From edc1acde4621c2a9d1dc5220c09e3503a83f0ec1 Mon Sep 17 00:00:00 2001
From: Iustin Pop <iustin@google.com>
Date: Fri, 16 Nov 2012 14:32:53 +0100
Subject: [PATCH] Generalise the JSON "Container" type
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Currently, we have some types that we kept as dictionaries in the
objects representation (due to inconsistent behaviour, or other
technical reasons). This should be improved in the future, but in the
meantime we can improve the Container type by allowing its keys to be
non-strings; this is needed, for example, for better safe in
DiskParams type, where we don't want arbitrary strings as keys, but
only the actually defined types.
To implement this change, we generalise the type (Container β
GenericContainer), and in the process we introduce a type class for
"things that can be represented as strings". This is very similar to a
combination of Read and Show, but with custom string
representation. The new type class is needed because in JSON
representation, object keys must be strings, so we need to be able to
serialised/deserialise the generic keys to/from plain strings.
We also add the instance for DiskTemplate at the same time.
Signed-off-by: Iustin Pop <iustin@google.com>
Reviewed-by: Adeodato Simo <dato@google.com>
---
htest/Test/Ganeti/Objects.hs | 25 ++++++++++----------
htools/Ganeti/Config.hs | 2 +-
htools/Ganeti/JSON.hs | 46 ++++++++++++++++++++++++++++--------
htools/Ganeti/Types.hs | 5 ++++
4 files changed, 55 insertions(+), 23 deletions(-)
diff --git a/htest/Test/Ganeti/Objects.hs b/htest/Test/Ganeti/Objects.hs
index 6dc0af93c..de21d0c15 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 62582735c..c2c692905 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 1480140e8..113889834 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 a31cf62ad..99eceae14 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
--
GitLab