diff --git a/htest/Test/Ganeti/Objects.hs b/htest/Test/Ganeti/Objects.hs
index 6dc0af93cffb22cfb7b45c388f41e1c946728ff7..de21d0c15d4450186493465c41231dd6eaa3a624 100644
--- a/htest/Test/Ganeti/Objects.hs
+++ b/htest/Test/Ganeti/Objects.hs
@@ -102,9 +102,9 @@ instance Arbitrary Instance where
<$> getFQDN <*> getFQDN <*> getFQDN -- OS name, but...
<*> arbitrary
-- FIXME: add non-empty hvparams when they're a proper type
- <*> pure (Container Map.empty) <*> arbitrary
+ <*> pure (GenericContainer Map.empty) <*> arbitrary
-- ... and for OSParams
- <*> pure (Container Map.empty) <*> arbitrary <*> arbitrary
+ <*> pure (GenericContainer Map.empty) <*> arbitrary <*> arbitrary
<*> arbitrary <*> arbitrary <*> arbitrary
-- ts
<*> arbitrary <*> arbitrary
@@ -127,7 +127,7 @@ $(genArbitrary ''PartialIPolicy)
-- validation rules.
instance Arbitrary NodeGroup where
arbitrary = NodeGroup <$> getFQDN <*> pure [] <*> arbitrary <*> arbitrary
- <*> arbitrary <*> pure (Container Map.empty)
+ <*> arbitrary <*> pure (GenericContainer Map.empty)
-- ts
<*> arbitrary <*> arbitrary
-- uuid
@@ -146,23 +146,23 @@ $(genArbitrary ''FilledBeParams)
-- | No real arbitrary instance for 'ClusterHvParams' yet.
instance Arbitrary ClusterHvParams where
- arbitrary = return $ Container Map.empty
+ arbitrary = return $ GenericContainer Map.empty
-- | No real arbitrary instance for 'OsHvParams' yet.
instance Arbitrary OsHvParams where
- arbitrary = return $ Container Map.empty
+ arbitrary = return $ GenericContainer Map.empty
instance Arbitrary ClusterNicParams where
- arbitrary = (Container . Map.singleton C.ppDefault) <$> arbitrary
+ arbitrary = (GenericContainer . Map.singleton C.ppDefault) <$> arbitrary
instance Arbitrary OsParams where
- arbitrary = (Container . Map.fromList) <$> arbitrary
+ arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
instance Arbitrary ClusterOsParams where
- arbitrary = (Container . Map.fromList) <$> arbitrary
+ arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
instance Arbitrary ClusterBeParams where
- arbitrary = (Container . Map.fromList) <$> arbitrary
+ arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
instance Arbitrary TagSet where
arbitrary = Set.fromList <$> genTags
@@ -179,10 +179,11 @@ genEmptyCluster ncount = do
nodes' = zipWith (\n idx -> n { nodeGroup = guuid,
nodeName = nodeName n ++ show idx })
nodes [(1::Int)..]
- contnodes = Container . Map.fromList $ map (\n -> (nodeName n, n)) nodes'
- continsts = Container Map.empty
+ contnodes = GenericContainer . Map.fromList $
+ map (\n -> (nodeName n, n)) nodes'
+ continsts = GenericContainer Map.empty
grp <- arbitrary
- let contgroups = Container $ Map.singleton guuid grp
+ let contgroups = GenericContainer $ Map.singleton guuid grp
serial <- arbitrary
cluster <- resize 8 arbitrary
let c = ConfigData version cluster contnodes contgroups continsts serial
diff --git a/htools/Ganeti/Config.hs b/htools/Ganeti/Config.hs
index 62582735c453f6b033fa386adb011ff596f1486a..c2c6929057513839c0aac7330511960834c0bddd 100644
--- a/htools/Ganeti/Config.hs
+++ b/htools/Ganeti/Config.hs
@@ -192,7 +192,7 @@ getGroupIpolicy cfg ng =
-- | Computes a group\'s (merged) disk params.
getGroupDiskParams :: ConfigData -> NodeGroup -> DiskParams
getGroupDiskParams cfg ng =
- Container $
+ GenericContainer $
fillDict (fromContainer . clusterDiskparams $ configCluster cfg)
(fromContainer $ groupDiskparams ng) []
diff --git a/htools/Ganeti/JSON.hs b/htools/Ganeti/JSON.hs
index 1480140e8b552ebdd1c960e89d116eb0510cb7c4..1138898344a64c5d4d94407b3f2dce784146f421 100644
--- a/htools/Ganeti/JSON.hs
+++ b/htools/Ganeti/JSON.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
{-| JSON utility functions. -}
{-
@@ -37,11 +38,12 @@ module Ganeti.JSON
, asObjectList
, tryFromObj
, toArray
- , Container(..)
+ , HasStringRepr(..)
+ , GenericContainer(..)
+ , Container
)
where
-import Control.Arrow (second)
import Control.Monad (liftM)
import Data.Maybe (fromMaybe)
import qualified Data.Map as Map
@@ -167,24 +169,48 @@ toArray o =
-- * Container type (special type for JSON serialisation)
+-- | Class of types that can be converted from Strings. This is
+-- similar to the 'Read' class, but it's using a different
+-- serialisation format, so we have to define a separate class. Mostly
+-- useful for custom key types in JSON dictionaries, which have to be
+-- backed by strings.
+class HasStringRepr a where
+ fromStringRepr :: (Monad m) => String -> m a
+ toStringRepr :: a -> String
+
+-- | Trivial instance 'HasStringRepr' for 'String'.
+instance HasStringRepr String where
+ fromStringRepr = return
+ toStringRepr = id
+
-- | The container type, a wrapper over Data.Map
-newtype Container a = Container { fromContainer :: Map.Map String a }
+newtype GenericContainer a b =
+ GenericContainer { fromContainer :: Map.Map a b }
deriving (Show, Read, Eq)
+-- | Type alias for string keys.
+type Container = GenericContainer String
+
-- | Container loader.
-readContainer :: (Monad m, J.JSON a) =>
- J.JSObject J.JSValue -> m (Container a)
+readContainer :: (Monad m, HasStringRepr a, Ord a, J.JSON b) =>
+ J.JSObject J.JSValue -> m (GenericContainer a b)
readContainer obj = do
let kjvlist = J.fromJSObject obj
- kalist <- mapM (\(k, v) -> fromKeyValue k v >>= \a -> return (k, a)) kjvlist
- return $ Container (Map.fromList kalist)
+ kalist <- mapM (\(k, v) -> do
+ k' <- fromStringRepr k
+ v' <- fromKeyValue k v
+ return (k', v')) kjvlist
+ return $ GenericContainer (Map.fromList kalist)
-- | Container dumper.
-showContainer :: (J.JSON a) => Container a -> J.JSValue
+showContainer :: (HasStringRepr a, J.JSON b) =>
+ GenericContainer a b -> J.JSValue
showContainer =
- J.makeObj . map (second J.showJSON) . Map.toList . fromContainer
+ J.makeObj . map (\(k, v) -> (toStringRepr k, J.showJSON v)) .
+ Map.toList . fromContainer
-instance (J.JSON a) => J.JSON (Container a) where
+instance (HasStringRepr a, Ord a, J.JSON b) =>
+ J.JSON (GenericContainer a b) where
showJSON = showContainer
readJSON (J.JSObject o) = readContainer o
readJSON v = fail $ "Failed to load container, expected object but got "
diff --git a/htools/Ganeti/Types.hs b/htools/Ganeti/Types.hs
index a31cf62ade9f9d71286c7223d780d8926c14819a..99eceae14c7f02d56ebfaed7790f4c17bdd08be9 100644
--- a/htools/Ganeti/Types.hs
+++ b/htools/Ganeti/Types.hs
@@ -60,6 +60,7 @@ import qualified Text.JSON as JSON
import qualified Ganeti.Constants as C
import qualified Ganeti.THH as THH
+import Ganeti.JSON
-- * Generic types
@@ -118,6 +119,10 @@ $(THH.declareSADT "DiskTemplate"
])
$(THH.makeJSONInstance ''DiskTemplate)
+instance HasStringRepr DiskTemplate where
+ fromStringRepr = diskTemplateFromRaw
+ toStringRepr = diskTemplateToRaw
+
-- | The Group allocation policy type.
--
-- Note that the order of constructors is important as the automatic