Commit a0090487 authored by Agata Murawska's avatar Agata Murawska
Browse files

Use TemplateHaskell to create LUXI operations


Signed-off-by: default avatarAgata Murawska <agatamurawska@google.com>
Reviewed-by: default avatarIustin Pop <iustin@google.com>
parent a17deeab
{-# 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
......
......@@ -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)
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