Commit edc1acde authored by Iustin Pop's avatar Iustin Pop
Browse files

Generalise the JSON "Container" type



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: default avatarIustin Pop <iustin@google.com>
Reviewed-by: default avatarAdeodato Simo <dato@google.com>
parent d696bbef
......@@ -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
......
......@@ -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) []
......
{-# 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 "
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment