diff --git a/htools/Ganeti/Luxi.hs b/htools/Ganeti/Luxi.hs index f475245a8963674cc54b8ddb40fedc2510433565..4b3c12adcab72862edd9fb18e446912c7257bc67 100644 --- a/htools/Ganeti/Luxi.hs +++ b/htools/Ganeti/Luxi.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + {-| Implementation of the Ganeti LUXI interface. -} @@ -46,6 +48,7 @@ import Ganeti.HTools.Types import Ganeti.Jobs (JobStatus) import Ganeti.OpCodes (OpCode) +import Ganeti.THH -- * Utility functions @@ -59,43 +62,82 @@ withTimeout secs descr action = do -- * Generic protocol functionality --- | Currently supported Luxi operations. -data LuxiOp = QueryInstances [String] [String] Bool - | QueryNodes [String] [String] Bool - | QueryGroups [String] [String] Bool - | QueryJobs [Int] [String] - | QueryExports [String] Bool - | QueryConfigValues [String] - | QueryClusterInfo - | QueryTags String String - | SubmitJob [OpCode] - | SubmitManyJobs [[OpCode]] - | WaitForJobChange Int [String] JSValue JSValue Int - | ArchiveJob Int - | AutoArchiveJobs Int Int - | CancelJob Int - | SetDrainFlag Bool - | SetWatcherPause Double - deriving (Show, Read) +-- | Currently supported Luxi operations and JSON serialization. +$(genLuxiOp "LuxiOp" + [ ("QueryNodes", + [ ("names", [t| [String] |], [| id |]) + , ("fields", [t| [String] |], [| id |]) + , ("lock", [t| Bool |], [| id |]) + ], + [| J.showJSON |]) + , ("QueryGroups", + [ ("names", [t| [String] |], [| id |]) + , ("fields", [t| [String] |], [| id |]) + , ("lock", [t| Bool |], [| id |]) + ], + [| J.showJSON |]) + , ("QueryInstances", + [ ("names", [t| [String] |], [| id |]) + , ("fields", [t| [String] |], [| id |]) + , ("lock", [t| Bool |], [| id |]) + ], + [| J.showJSON |]) + , ("QueryJobs", + [ ("ids", [t| [Int] |], [| map show |]) + , ("fields", [t| [String] |], [| id |]) + ], + [| J.showJSON |]) + , ("QueryExports", + [ ("nodes", [t| [String] |], [| id |]) + , ("lock", [t| Bool |], [| id |]) + ], + [| J.showJSON |]) + , ("QueryConfigValues", + [ ("fields", [t| [String] |], [| id |]) ], + [| J.showJSON |]) + , ("QueryClusterInfo", + [], + [| J.showJSON |]) + , ("QueryTags", + [ ("kind", [t| String |], [| id |]) + , ("name", [t| String |], [| id |]) + ], + [| J.showJSON |]) + , ("SubmitJob", + [ ("job", [t| [OpCode] |], [| id |]) ], + [| J.showJSON |]) + , ("SubmitManyJobs", + [ ("ops", [t| [[OpCode]] |], [| id |]) ], + [| J.showJSON |]) + , ("WaitForJobChange", + [ ("job", [t| Int |], [| J.showJSON |]) + , ("fields", [t| [String]|], [| J.showJSON |]) + , ("prev_job", [t| JSValue |], [| J.showJSON |]) + , ("prev_log", [t| JSValue |], [| J.showJSON |]) + , ("tmout", [t| Int |], [| J.showJSON |]) + ], + [| \(j, f, pj, pl, t) -> JSArray [j, f, pj, pl, t] |]) + , ("ArchiveJob", + [ ("job", [t| Int |], [| show |]) ], + [| J.showJSON |]) + , ("AutoArchiveJobs", + [ ("age", [t| Int |], [| id |]) + , ("tmout", [t| Int |], [| id |]) + ], + [| J.showJSON |]) + , ("CancelJob", + [("job", [t| Int |], [| show |]) ], + [| J.showJSON |]) + , ("SetDrainFlag", + [ ("flag", [t| Bool |], [| id |]) ], + [| J.showJSON |]) + , ("SetWatcherPause", + [ ("duration", [t| Double |], [| \x -> [x] |]) ], + [| J.showJSON |]) + ]) -- | The serialisation of LuxiOps into strings in messages. -strOfOp :: LuxiOp -> String -strOfOp QueryNodes {} = "QueryNodes" -strOfOp QueryGroups {} = "QueryGroups" -strOfOp QueryInstances {} = "QueryInstances" -strOfOp QueryJobs {} = "QueryJobs" -strOfOp QueryExports {} = "QueryExports" -strOfOp QueryConfigValues {} = "QueryConfigValues" -strOfOp QueryClusterInfo {} = "QueryClusterInfo" -strOfOp QueryTags {} = "QueryTags" -strOfOp SubmitManyJobs {} = "SubmitManyJobs" -strOfOp WaitForJobChange {} = "WaitForJobChange" -strOfOp SubmitJob {} = "SubmitJob" -strOfOp ArchiveJob {} = "ArchiveJob" -strOfOp AutoArchiveJobs {} = "AutoArchiveJobs" -strOfOp CancelJob {} = "CancelJob" -strOfOp SetDrainFlag {} = "SetDrainFlag" -strOfOp SetWatcherPause {} = "SetWatcherPause" +$(genStrOfOp ''LuxiOp "strOfOp") -- | The end-of-message separator. eOM :: Char @@ -108,11 +150,7 @@ data MsgKeys = Method | Result -- | The serialisation of MsgKeys into strings in messages. -strOfKey :: MsgKeys -> String -strOfKey Method = "method" -strOfKey Args = "args" -strOfKey Success = "success" -strOfKey Result = "result" +$(genStrOfKey ''MsgKeys "strOfKey") -- | Luxi client encapsulation. data Client = Client { socket :: S.Socket -- ^ The socket of the client @@ -161,29 +199,6 @@ recvMsg s = do writeIORef (rbuf s) nbuf return msg --- | Compute the serialized form of a Luxi operation. -opToArgs :: LuxiOp -> JSValue -opToArgs (QueryNodes names fields lock) = J.showJSON (names, fields, lock) -opToArgs (QueryGroups names fields lock) = J.showJSON (names, fields, lock) -opToArgs (QueryInstances names fields lock) = J.showJSON (names, fields, lock) -opToArgs (QueryJobs ids fields) = J.showJSON (map show ids, fields) -opToArgs (QueryExports nodes lock) = J.showJSON (nodes, lock) -opToArgs (QueryConfigValues fields) = J.showJSON fields -opToArgs (QueryClusterInfo) = J.showJSON () -opToArgs (QueryTags kind name) = J.showJSON (kind, name) -opToArgs (SubmitJob j) = J.showJSON j -opToArgs (SubmitManyJobs ops) = J.showJSON ops --- This is special, since the JSON library doesn't export an instance --- of a 5-tuple -opToArgs (WaitForJobChange a b c d e) = - JSArray [ J.showJSON a, J.showJSON b, J.showJSON c - , J.showJSON d, J.showJSON e] -opToArgs (ArchiveJob a) = J.showJSON (show a) -opToArgs (AutoArchiveJobs a b) = J.showJSON (a, b) -opToArgs (CancelJob a) = J.showJSON (show a) -opToArgs (SetDrainFlag flag) = J.showJSON flag -opToArgs (SetWatcherPause duration) = J.showJSON [duration] - -- | Serialize a request to String. buildCall :: LuxiOp -- ^ The method -> String -- ^ The serialized form diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs index dd479600eee1f2a2c1c55127d3b4142f4640cf4c..2505f6f333a5c75b0b48abb04389e034bbe5b213 100644 --- a/htools/Ganeti/THH.hs +++ b/htools/Ganeti/THH.hs @@ -34,6 +34,9 @@ module Ganeti.THH ( declareSADT , genOpID , genOpCode , noDefault + , genStrOfOp + , genStrOfKey + , genLuxiOp ) where import Control.Monad (liftM) @@ -222,24 +225,27 @@ constructorName (NormalC name _) = return name constructorName (RecC name _) = return name constructorName x = fail $ "Unhandled constructor " ++ show x --- | Builds the constructor-to-string function. +-- | Builds the generic constructor-to-string function. -- -- This generates a simple function of the following form: -- -- @ --- fname (ConStructorOne {}) = "CON_STRUCTOR_ONE" --- fname (ConStructorTwo {}) = "CON_STRUCTOR_TWO" +-- fname (ConStructorOne {}) = trans_fun("ConStructorOne") +-- fname (ConStructorTwo {}) = trans_fun("ConStructorTwo") -- @ -- -- This builds a custom list of name/string pairs and then uses -- 'genToString' to actually generate the function -genOpID :: Name -> String -> Q [Dec] -genOpID name fname = do +genConstrToStr :: (String -> String) -> Name -> String -> Q [Dec] +genConstrToStr trans_fun name fname = do TyConI (DataD _ _ _ cons _) <- reify name cnames <- mapM (liftM nameBase . constructorName) cons - let svalues = map (Left . deCamelCase) cnames + let svalues = map (Left . trans_fun) cnames genToString (mkName fname) name $ zip cnames svalues +-- | Constructor-to-string for OpCode. +genOpID :: Name -> String -> Q [Dec] +genOpID = genConstrToStr deCamelCase -- | OpCode parameter (field) type type OpParam = (String, Q Type, Q Exp) @@ -400,3 +406,63 @@ genLoadOpCode opdefs = do -- | No default type. noDefault :: Q Exp noDefault = conE 'Nothing + +-- * Template code for luxi + +-- | Constructor-to-string for LuxiOp. +genStrOfOp :: Name -> String -> Q [Dec] +genStrOfOp = genConstrToStr id + +-- | Constructor-to-string for MsgKeys. +genStrOfKey :: Name -> String -> Q [Dec] +genStrOfKey = genConstrToStr ensureLower + +-- | LuxiOp parameter type. +type LuxiParam = (String, Q Type, Q Exp) + +-- | Generates the LuxiOp data type. +-- +-- This takes a Luxi operation definition and builds both the +-- datatype and the function trnasforming the arguments to JSON. +-- We can't use anything less generic, because the way different +-- operations are serialized differs on both parameter- and top-level. +-- +-- There are three things to be defined for each parameter: +-- +-- * name +-- +-- * type +-- +-- * operation; this is the operation performed on the parameter before +-- serialization +-- +genLuxiOp :: String -> [(String, [LuxiParam], Q Exp)] -> Q [Dec] +genLuxiOp name cons = do + decl_d <- mapM (\(cname, fields, _) -> do + fields' <- mapM (\(_, qt, _) -> + qt >>= \t -> return (NotStrict, t)) + fields + return $ NormalC (mkName cname) fields') + cons + let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read] + (savesig, savefn) <- genSaveLuxiOp cons + return [declD, savesig, savefn] + +-- | Generates the \"save\" clause for entire LuxiOp constructor. +saveLuxiConstructor :: (String, [LuxiParam], Q Exp) -> Q Clause +saveLuxiConstructor (sname, fields, finfn) = + let cname = mkName sname + fnames = map (\(nm, _, _) -> mkName nm) fields + pat = conP cname (map varP fnames) + flist = map (\(nm, _, fn) -> appE fn $ varNameE nm) fields + finval = appE finfn (tupE flist) + in + clause [pat] (normalB finval) [] + +-- | Generates the main save LuxiOp function. +genSaveLuxiOp :: [(String, [LuxiParam], Q Exp)] -> Q (Dec, Dec) +genSaveLuxiOp opdefs = do + sigt <- [t| $(conT (mkName "LuxiOp")) -> JSON.JSValue |] + let fname = mkName "opToArgs" + cclauses <- mapM saveLuxiConstructor opdefs + return $ (SigD fname sigt, FunD fname cclauses)