Commit 84835174 authored by Iustin Pop's avatar Iustin Pop

Improve the TH 'Container' type

This is the first part of the changes related to the 'Container' type.

We currently handle this type as follows: it's a simple type alias
over the Data.Map type, which means:

- it's easy to use the Data.Map functions to change the type
- however, since Data.Map already has a JSON instance, we have to very
  carefully always use custom show/read routines to handle this type

The second point leads to potential bugs which are not caught by the
type system, so let's improve the situation by making it a proper
newtype, which can have its own JSON instance (with our desired
behaviour). Once we do this change, accessing the type requires an
extra function call, but it's as safe as before. On the positive side,
we can use the implicit read/show JSON, which means we can remove (in
the next patch) the "container" special casing.

The patch also moves the type to outside of THH, since not all users
of this will want to import that (as opposed to JSON.hs, which is
smaller).
Signed-off-by: default avatarIustin Pop <iustin@google.com>
Reviewed-by: default avatarAgata Murawska <agatamurawska@google.com>
parent d8cb8e13
......@@ -137,7 +137,7 @@ getClusterHmac = fmap B.unpack $ B.readFile C.confdHmacKey
nodeRole :: ConfigData -> String -> Result ConfdNodeRole
nodeRole cfg name =
let cmaster = clusterMasterNode . configCluster $ cfg
mnode = M.lookup name . configNodes $ cfg
mnode = M.lookup name . fromContainer . configNodes $ cfg
in case mnode of
Nothing -> Bad "Node not found"
Just node | cmaster == name -> Ok NodeRoleMaster
......@@ -194,7 +194,7 @@ buildResponse cdata (ConfdRequest { confdRqType = ReqNodePipList }) =
-- versions of the library
return (ReplyStatusOk, J.showJSON $
M.foldlWithKey (\accu _ n -> nodePrimaryIp n:accu) []
(configNodes (fst cdata)))
(fromContainer . configNodes . fst $ cdata))
buildResponse cdata (ConfdRequest { confdRqType = ReqMcPipList }) =
-- note: we use foldlWithKey because that's present accross more
......@@ -203,7 +203,7 @@ buildResponse cdata (ConfdRequest { confdRqType = ReqMcPipList }) =
M.foldlWithKey (\accu _ n -> if nodeMasterCandidate n
then nodePrimaryIp n:accu
else accu) []
(configNodes (fst cdata)))
(fromContainer . configNodes . fst $ cdata))
buildResponse (cfg, linkipmap)
req@(ConfdRequest { confdRqType = ReqInstIpsList }) = do
......@@ -234,7 +234,7 @@ buildResponse cdata req@(ConfdRequest { confdRqType = ReqNodeDrbd }) = do
_ -> fail $ "Invalid query type " ++ show (confdRqQuery req)
node <- getNode cfg node_name
let minors = concatMap (getInstMinorsForNode (nodeName node)) .
M.elems . configInstances $ cfg
M.elems . fromContainer . configInstances $ cfg
encoded = [J.JSArray [J.showJSON a, J.showJSON b, J.showJSON c,
J.showJSON d, J.showJSON e, J.showJSON f] |
(a, b, c, d, e, f) <- minors]
......
......@@ -92,7 +92,7 @@ instSecondaryNodes inst =
-- | Get instances of a given node.
getNodeInstances :: ConfigData -> String -> ([Instance], [Instance])
getNodeInstances cfg nname =
let all_inst = M.elems . configInstances $ cfg
let all_inst = M.elems . fromContainer . configInstances $ cfg
pri_inst = filter ((== nname) . instPrimaryNode) all_inst
sec_inst = filter ((nname `S.member`) . instSecondaryNodes) all_inst
in (pri_inst, sec_inst)
......@@ -100,7 +100,8 @@ getNodeInstances cfg nname =
-- | Returns the default cluster link.
getDefaultNicLink :: ConfigData -> String
getDefaultNicLink =
nicpLink . (M.! C.ppDefault) . clusterNicparams . configCluster
nicpLink . (M.! C.ppDefault) . fromContainer .
clusterNicparams . configCluster
-- | Returns instances of a given link.
getInstancesIpByLink :: LinkIpMap -> String -> [String]
......@@ -123,11 +124,12 @@ getItem kind name allitems = do
-- | Looks up a node.
getNode :: ConfigData -> String -> Result Node
getNode cfg name = getItem "Node" name (configNodes cfg)
getNode cfg name = getItem "Node" name (fromContainer $ configNodes cfg)
-- | Looks up an instance.
getInstance :: ConfigData -> String -> Result Instance
getInstance cfg name = getItem "Instance" name (configInstances cfg)
getInstance cfg name =
getItem "Instance" name (fromContainer $ configInstances cfg)
-- | Looks up an instance's primary node.
getInstPrimaryNode :: ConfigData -> String -> Result Node
......@@ -183,8 +185,8 @@ getInstMinorsForNode node inst =
buildLinkIpInstnameMap :: ConfigData -> LinkIpMap
buildLinkIpInstnameMap cfg =
let cluster = configCluster cfg
instances = M.elems . configInstances $ cfg
defparams = (M.!) (clusterNicparams cluster) C.ppDefault
instances = M.elems . fromContainer . configInstances $ cfg
defparams = (M.!) (fromContainer $ clusterNicparams cluster) C.ppDefault
nics = concatMap (\i -> [(instName i, nic) | nic <- instNics i])
instances
in foldl' (\accum (iname, nic) ->
......
......@@ -35,11 +35,14 @@ module Ganeti.HTools.JSON
, asObjectList
, tryFromObj
, toArray
, Container(..)
)
where
import Control.Arrow (second)
import Control.Monad (liftM)
import Data.Maybe (fromMaybe)
import qualified Data.Map as Map
import Text.Printf (printf)
import qualified Text.JSON as J
......@@ -132,3 +135,28 @@ tryFromObj t o = annotateResult t . fromObj o
toArray :: (Monad m) => J.JSValue -> m [J.JSValue]
toArray (J.JSArray arr) = return arr
toArray o = fail $ "Invalid input, expected array but got " ++ show o
-- * Container type (special type for JSON serialisation)
-- | The container type, a wrapper over Data.Map
newtype Container a = Container { fromContainer :: Map.Map String a }
deriving (Show, Read, Eq)
-- | Container loader.
readContainer :: (Monad m, J.JSON a) =>
J.JSObject J.JSValue -> m (Container a)
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)
-- | Container dumper.
showContainer :: (J.JSON a) => Container a -> J.JSValue
showContainer =
J.makeObj . map (second J.showJSON) . Map.toList . fromContainer
instance (J.JSON a) => J.JSON (Container a) where
showJSON = showContainer
readJSON (J.JSObject o) = readContainer o
readJSON v = fail $ "Failed to load container, expected object but got "
++ show v
......@@ -54,11 +54,9 @@ module Ganeti.THH ( declareSADT
, Container
) where
import Control.Arrow
import Control.Monad (liftM, liftM2)
import Data.Char
import Data.List
import qualified Data.Map as M
import qualified Data.Set as Set
import Language.Haskell.TH
......@@ -68,8 +66,6 @@ import Ganeti.HTools.JSON
-- * Exported types
type Container = M.Map String
-- | Serialised field data type.
data Field = Field { fieldName :: String
, fieldType :: Q Type
......@@ -155,7 +151,7 @@ loadFn :: Field -- ^ The field definition
-> Q Exp -- ^ The entire object in JSON object format
-> Q Exp -- ^ Resulting expression
loadFn (Field { fieldIsContainer = True }) expr _ =
[| $expr >>= readContainer |]
[| $expr |]
loadFn (Field { fieldRead = Just readfn }) expr o = [| $expr >>= $readfn $o |]
loadFn _ expr _ = expr
......@@ -225,18 +221,6 @@ appFn :: Exp -> Exp -> Exp
appFn f x | f == VarE 'id = x
| otherwise = AppE f x
-- | Container loader
readContainer :: (Monad m, JSON.JSON a) =>
JSON.JSObject JSON.JSValue -> m (Container a)
readContainer obj = do
let kjvlist = JSON.fromJSObject obj
kalist <- mapM (\(k, v) -> fromKeyValue k v >>= \a -> return (k, a)) kjvlist
return $ M.fromList kalist
-- | Container dumper
showContainer :: (JSON.JSON a) => Container a -> JSON.JSValue
showContainer = JSON.makeObj . map (second JSON.showJSON) . M.toList
-- * Template code for simple raw type-equivalent ADTs
-- | Generates a data type declaration.
......@@ -639,7 +623,7 @@ genSaveObject save_fn sname fields = do
saveObjectField :: Name -> Field -> Q Exp
saveObjectField fvar field
| isContainer = [| [( $nameE , JSON.showJSON . showContainer $ $fvarE)] |]
| isContainer = [| [( $nameE , JSON.showJSON $fvarE)] |]
| fisOptional = [| case $(varE fvar) of
Nothing -> []
Just v -> [( $nameE, JSON.showJSON v)]
......
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