From 12c19659f588c5a7ca586aaa4dcf5e9c4ad24732 Mon Sep 17 00:00:00 2001 From: Iustin Pop Date: Wed, 21 Sep 2011 18:23:04 +0900 Subject: [PATCH] Use TemplateHaskell to generate opcode serialisation This replaces the hand-coded opcode serialisation code with auto-generation based on TemplateHaskell. Signed-off-by: Iustin Pop Reviewed-by: Agata Murawska --- htools/Ganeti/OpCodes.hs | 121 +++++++++------------------------- htools/Ganeti/THH.hs | 165 ++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 196 insertions(+), 90 deletions(-) diff --git a/htools/Ganeti/OpCodes.hs b/htools/Ganeti/OpCodes.hs index af973f1..187af13 100644 --- a/htools/Ganeti/OpCodes.hs +++ b/htools/Ganeti/OpCodes.hs @@ -31,114 +31,55 @@ module Ganeti.OpCodes , opID ) where -import Control.Monad import Text.JSON (readJSON, showJSON, makeObj, JSON) import qualified Text.JSON as J -import Text.JSON.Types import qualified Ganeti.Constants as C -import qualified Ganeti.THH as THH +import Ganeti.THH import Ganeti.HTools.Utils -- | Replace disks type. -$(THH.declareSADT "ReplaceDisksMode" +$(declareSADT "ReplaceDisksMode" [ ("ReplaceOnPrimary", 'C.replaceDiskPri) , ("ReplaceOnSecondary", 'C.replaceDiskSec) , ("ReplaceNewSecondary", 'C.replaceDiskChg) , ("ReplaceAuto", 'C.replaceDiskAuto) ]) -$(THH.makeJSONInstance ''ReplaceDisksMode) +$(makeJSONInstance ''ReplaceDisksMode) -- | OpCode representation. -- -- We only implement a subset of Ganeti opcodes, but only what we -- actually use in the htools codebase. -data OpCode = OpTestDelay Double Bool [String] - | OpInstanceReplaceDisks String (Maybe String) ReplaceDisksMode - [Int] (Maybe String) - | OpInstanceFailover String Bool (Maybe String) - | OpInstanceMigrate String Bool Bool Bool (Maybe String) - deriving (Show, Read, Eq) - - -$(THH.genOpID ''OpCode "opID") - --- | Loads an OpCode from the JSON serialised form. -loadOpCode :: JSValue -> J.Result OpCode -loadOpCode v = do - o <- liftM J.fromJSObject (readJSON v) - let extract x = fromObj o x - op_id <- extract "OP_ID" - case op_id of - "OP_TEST_DELAY" -> do - on_nodes <- extract "on_nodes" - on_master <- extract "on_master" - duration <- extract "duration" - return $ OpTestDelay duration on_master on_nodes - "OP_INSTANCE_REPLACE_DISKS" -> do - inst <- extract "instance_name" - node <- maybeFromObj o "remote_node" - mode <- extract "mode" - disks <- extract "disks" - ialloc <- maybeFromObj o "iallocator" - return $ OpInstanceReplaceDisks inst node mode disks ialloc - "OP_INSTANCE_FAILOVER" -> do - inst <- extract "instance_name" - consist <- extract "ignore_consistency" - tnode <- maybeFromObj o "target_node" - return $ OpInstanceFailover inst consist tnode - "OP_INSTANCE_MIGRATE" -> do - inst <- extract "instance_name" - live <- extract "live" - cleanup <- extract "cleanup" - allow_failover <- fromObjWithDefault o "allow_failover" False - tnode <- maybeFromObj o "target_node" - return $ OpInstanceMigrate inst live cleanup - allow_failover tnode - _ -> J.Error $ "Unknown opcode " ++ op_id - --- | Serialises an opcode to JSON. -saveOpCode :: OpCode -> JSValue -saveOpCode op@(OpTestDelay duration on_master on_nodes) = - let ol = [ ("OP_ID", showJSON $ opID op) - , ("duration", showJSON duration) - , ("on_master", showJSON on_master) - , ("on_nodes", showJSON on_nodes) ] - in makeObj ol - -saveOpCode op@(OpInstanceReplaceDisks inst node mode disks iallocator) = - let ol = [ ("OP_ID", showJSON $ opID op) - , ("instance_name", showJSON inst) - , ("mode", showJSON mode) - , ("disks", showJSON disks)] - ol2 = case node of - Just n -> ("remote_node", showJSON n):ol - Nothing -> ol - ol3 = case iallocator of - Just i -> ("iallocator", showJSON i):ol2 - Nothing -> ol2 - in makeObj ol3 - -saveOpCode op@(OpInstanceFailover inst consist tnode) = - let ol = [ ("OP_ID", showJSON $ opID op) - , ("instance_name", showJSON inst) - , ("ignore_consistency", showJSON consist) ] - ol' = case tnode of - Nothing -> ol - Just node -> ("target_node", showJSON node):ol - in makeObj ol' - -saveOpCode op@(OpInstanceMigrate inst live cleanup allow_failover tnode) = - let ol = [ ("OP_ID", showJSON $ opID op) - , ("instance_name", showJSON inst) - , ("live", showJSON live) - , ("cleanup", showJSON cleanup) - , ("allow_failover", showJSON allow_failover) ] - ol' = case tnode of - Nothing -> ol - Just node -> ("target_node", showJSON node):ol - in makeObj ol' +$(genOpCode "OpCode" + [ ("OpTestDelay", + [ ("duration", [t| Double |], noDefault) + , ("on_master", [t| Bool |], noDefault) + , ("on_nodes", [t| [String] |], noDefault) + ]) + , ("OpInstanceReplaceDisks", + [ ("instance_name", [t| String |], noDefault) + , ("remote_node", [t| Maybe String |], noDefault) + , ("mode", [t| ReplaceDisksMode |], noDefault) + , ("disks", [t| [Int] |], noDefault) + , ("iallocator", [t| Maybe String |], noDefault) + ]) + , ("OpInstanceFailover", + [ ("instance_name", [t| String |], noDefault) + , ("ignore_consistency", [t| Bool |], noDefault) + , ("target_node", [t| Maybe String |], noDefault) + ]) + , ("OpInstanceMigrate", + [ ("instance_name", [t| String |], noDefault) + , ("live", [t| Bool |], noDefault) + , ("cleanup", [t| Bool |], noDefault) + , ("allow_failover", [t| Bool |], [| Just False |]) + , ("target_node", [t| Maybe String |], noDefault) + ]) + ]) + +$(genOpID ''OpCode "opID") instance JSON OpCode where readJSON = loadOpCode diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs index 808836f..7584a2b 100644 --- a/htools/Ganeti/THH.hs +++ b/htools/Ganeti/THH.hs @@ -32,6 +32,8 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA module Ganeti.THH ( declareSADT , makeJSONInstance , genOpID + , genOpCode + , noDefault ) where import Control.Monad (liftM) @@ -224,3 +226,166 @@ genOpID name fname = do cnames <- mapM (liftM nameBase . constructorName) cons let svalues = map (Left . deCamelCase) cnames genToString (mkName fname) name $ zip cnames svalues + + +-- | OpCode parameter (field) type +type OpParam = (String, Q Type, Q Exp) + +-- | Generates the OpCode data type. +-- +-- This takes an opcode logical definition, and builds both the +-- datatype and the JSON serialisation out of it. We can't use a +-- generic serialisation since we need to be compatible with Ganeti's +-- own, so we have a few quirks to work around. +-- +-- There are three things to be defined for each parameter: +-- +-- * name +-- +-- * type; if this is 'Maybe', will only be serialised if it's a +-- 'Just' value +-- +-- * default; if missing, won't raise an exception, but will instead +-- use the default +-- +genOpCode :: String -- ^ Type name to use + -> [(String, [OpParam])] -- ^ Constructor name and parameters + -> Q [Dec] +genOpCode name cons = do + decl_d <- mapM (\(cname, fields) -> do + -- we only need the type of the field, without Q + fields' <- mapM (\(_, qt, _) -> + qt >>= \t -> return (NotStrict, t)) + fields + return $ NormalC (mkName cname) fields') + cons + let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq] + + (savesig, savefn) <- genSaveOpCode cons + (loadsig, loadfn) <- genLoadOpCode cons + return [declD, loadsig, loadfn, savesig, savefn] + +-- | Checks whether a given parameter is options +-- +-- This requires that it's a 'Maybe'. +isOptional :: Type -> Bool +isOptional (AppT (ConT dt) _) | dt == ''Maybe = True +isOptional _ = False + +-- | Generates the \"save\" expression for a single opcode parameter. +-- +-- There is only one special handling mode: if the parameter is of +-- 'Maybe' type, then we only save it if it's a 'Just' value, +-- otherwise we skip it. +saveField :: Name -- ^ The name of variable that contains the value + -> OpParam -- ^ Parameter definition + -> Q Exp +saveField fvar (fname, qt, _) = do + t <- qt + let showJ = varE (mkName "showJSON") + fnexp = litE (stringL fname) + fvare = varE fvar + (if isOptional t + then [| case $fvare of + Just v' -> [( $fnexp, $showJ v')] + Nothing -> [] + |] + else [| [( $fnexp, $showJ $fvare )] |]) + +-- | Generates the \"save\" clause for an entire opcode constructor. +-- +-- This matches the opcode with variables named the same as the +-- constructor fields (just so that the spliced in code looks nicer), +-- and passes those name plus the parameter definition to 'saveField'. +saveConstructor :: String -- ^ The constructor name + -> [OpParam] -- ^ The parameter definitions for this + -- constructor + -> Q Clause -- ^ Resulting clause +saveConstructor sname fields = do + let cname = mkName sname + let fnames = map (\(n, _, _) -> mkName n) fields + let pat = conP cname (map varP fnames) + let felems = map (uncurry saveField) (zip fnames fields) + -- now build the OP_ID serialisation + opid = [| [( $(litE (stringL "OP_ID")), + $(varE (mkName "showJSON")) + $(litE . stringL . deCamelCase $ sname) )] |] + flist = listE (opid:felems) + -- and finally convert all this to a json object + flist' = [| $(varE (mkName "makeObj")) (concat $flist) |] + clause [pat] (normalB flist') [] + +-- | Generates the main save opcode function. +-- +-- This builds a per-constructor match clause that contains the +-- respective constructor-serialisation code. +genSaveOpCode :: [(String, [OpParam])] -> Q (Dec, Dec) +genSaveOpCode opdefs = do + cclauses <- mapM (uncurry saveConstructor) opdefs + let fname = mkName "saveOpCode" + sigt <- [t| $(conT (mkName "OpCode")) -> JSON.JSValue |] + return $ (SigD fname sigt, FunD fname cclauses) + +-- | Generates the \"load\" field for a single parameter. +-- +-- There is custom handling, depending on how the parameter is +-- specified. For a 'Maybe' type parameter, we allow that it is not +-- present (via 'Utils.maybeFromObj'). Otherwise, if there is a +-- default value, we allow the parameter to be abset, and finally if +-- there is no default value, we require its presence. +loadField :: OpParam -> Q (Name, Stmt) +loadField (fname, qt, qdefa) = do + let fvar = mkName fname + t <- qt + defa <- qdefa + -- these are used in all patterns below + let objvar = varE (mkName "o") + objfield = litE (StringL fname) + bexp <- if isOptional t + then [| $((varE (mkName "maybeFromObj"))) $objvar $objfield |] + else case defa of + AppE (ConE dt) defval | dt == 'Just -> + -- but has a default value + [| $(varE (mkName "fromObjWithDefault")) + $objvar $objfield $(return defval) |] + ConE dt | dt == 'Nothing -> + [| $(varE (mkName "fromObj")) $objvar $objfield |] + s -> fail $ "Invalid default value " ++ show s ++ + ", expecting either 'Nothing' or a 'Just defval'" + return (fvar, BindS (VarP fvar) bexp) + +loadConstructor :: String -> [OpParam] -> Q Exp +loadConstructor sname fields = do + let name = mkName sname + fbinds <- mapM loadField fields + let (fnames, fstmts) = unzip fbinds + let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames + fstmts' = fstmts ++ [NoBindS (AppE (VarE 'return) cval)] + return $ DoE fstmts' + +genLoadOpCode :: [(String, [OpParam])] -> Q (Dec, Dec) +genLoadOpCode opdefs = do + let fname = mkName "loadOpCode" + arg1 = mkName "v" + objname = mkName "o" + opid = mkName "op_id" + st1 <- bindS (varP objname) [| liftM JSON.fromJSObject + (JSON.readJSON $(varE arg1)) |] + st2 <- bindS (varP opid) [| $(varE (mkName "fromObj")) + $(varE objname) $(litE (stringL "OP_ID")) |] + -- the match results (per-constructor blocks) + mexps <- mapM (uncurry loadConstructor) opdefs + fails <- [| fail $ "Unknown opcode " ++ $(varE opid) |] + let mpats = map (\(me, c) -> + let mp = LitP . StringL . deCamelCase . fst $ c + in Match mp (NormalB me) [] + ) $ zip mexps opdefs + defmatch = Match WildP (NormalB fails) [] + cst = NoBindS $ CaseE (VarE opid) $ mpats++[defmatch] + body = DoE [st1, st2, cst] + sigt <- [t| JSON.JSValue -> JSON.Result $(conT (mkName "OpCode")) |] + return $ (SigD fname sigt, FunD fname [Clause [VarP arg1] (NormalB body) []]) + +-- | No default type. +noDefault :: Q Exp +noDefault = conE 'Nothing -- 1.7.10.4