Commit 12c19659 authored by Iustin Pop's avatar Iustin Pop
Browse files

Use TemplateHaskell to generate opcode serialisation



This replaces the hand-coded opcode serialisation code with
auto-generation based on TemplateHaskell.
Signed-off-by: default avatarIustin Pop <iustin@google.com>
Reviewed-by: default avatarAgata Murawska <agatamurawska@google.com>
parent 6111e296
......@@ -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
......
......@@ -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
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