Revision a0090487
| b/htools/Ganeti/Luxi.hs | ||
|---|---|---|
| 1 |
{-# LANGUAGE TemplateHaskell #-}
|
|
| 2 |
|
|
| 1 | 3 |
{-| Implementation of the Ganeti LUXI interface.
|
| 2 | 4 |
|
| 3 | 5 |
-} |
| ... | ... | |
| 46 | 48 |
|
| 47 | 49 |
import Ganeti.Jobs (JobStatus) |
| 48 | 50 |
import Ganeti.OpCodes (OpCode) |
| 51 |
import Ganeti.THH |
|
| 49 | 52 |
|
| 50 | 53 |
-- * Utility functions |
| 51 | 54 |
|
| ... | ... | |
| 59 | 62 |
|
| 60 | 63 |
-- * Generic protocol functionality |
| 61 | 64 |
|
| 62 |
-- | Currently supported Luxi operations. |
|
| 63 |
data LuxiOp = QueryInstances [String] [String] Bool |
|
| 64 |
| QueryNodes [String] [String] Bool |
|
| 65 |
| QueryGroups [String] [String] Bool |
|
| 66 |
| QueryJobs [Int] [String] |
|
| 67 |
| QueryExports [String] Bool |
|
| 68 |
| QueryConfigValues [String] |
|
| 69 |
| QueryClusterInfo |
|
| 70 |
| QueryTags String String |
|
| 71 |
| SubmitJob [OpCode] |
|
| 72 |
| SubmitManyJobs [[OpCode]] |
|
| 73 |
| WaitForJobChange Int [String] JSValue JSValue Int |
|
| 74 |
| ArchiveJob Int |
|
| 75 |
| AutoArchiveJobs Int Int |
|
| 76 |
| CancelJob Int |
|
| 77 |
| SetDrainFlag Bool |
|
| 78 |
| SetWatcherPause Double |
|
| 79 |
deriving (Show, Read) |
|
| 65 |
-- | Currently supported Luxi operations and JSON serialization. |
|
| 66 |
$(genLuxiOp "LuxiOp" |
|
| 67 |
[ ("QueryNodes",
|
|
| 68 |
[ ("names", [t| [String] |], [| id |])
|
|
| 69 |
, ("fields", [t| [String] |], [| id |])
|
|
| 70 |
, ("lock", [t| Bool |], [| id |])
|
|
| 71 |
], |
|
| 72 |
[| J.showJSON |]) |
|
| 73 |
, ("QueryGroups",
|
|
| 74 |
[ ("names", [t| [String] |], [| id |])
|
|
| 75 |
, ("fields", [t| [String] |], [| id |])
|
|
| 76 |
, ("lock", [t| Bool |], [| id |])
|
|
| 77 |
], |
|
| 78 |
[| J.showJSON |]) |
|
| 79 |
, ("QueryInstances",
|
|
| 80 |
[ ("names", [t| [String] |], [| id |])
|
|
| 81 |
, ("fields", [t| [String] |], [| id |])
|
|
| 82 |
, ("lock", [t| Bool |], [| id |])
|
|
| 83 |
], |
|
| 84 |
[| J.showJSON |]) |
|
| 85 |
, ("QueryJobs",
|
|
| 86 |
[ ("ids", [t| [Int] |], [| map show |])
|
|
| 87 |
, ("fields", [t| [String] |], [| id |])
|
|
| 88 |
], |
|
| 89 |
[| J.showJSON |]) |
|
| 90 |
, ("QueryExports",
|
|
| 91 |
[ ("nodes", [t| [String] |], [| id |])
|
|
| 92 |
, ("lock", [t| Bool |], [| id |])
|
|
| 93 |
], |
|
| 94 |
[| J.showJSON |]) |
|
| 95 |
, ("QueryConfigValues",
|
|
| 96 |
[ ("fields", [t| [String] |], [| id |]) ],
|
|
| 97 |
[| J.showJSON |]) |
|
| 98 |
, ("QueryClusterInfo",
|
|
| 99 |
[], |
|
| 100 |
[| J.showJSON |]) |
|
| 101 |
, ("QueryTags",
|
|
| 102 |
[ ("kind", [t| String |], [| id |])
|
|
| 103 |
, ("name", [t| String |], [| id |])
|
|
| 104 |
], |
|
| 105 |
[| J.showJSON |]) |
|
| 106 |
, ("SubmitJob",
|
|
| 107 |
[ ("job", [t| [OpCode] |], [| id |]) ],
|
|
| 108 |
[| J.showJSON |]) |
|
| 109 |
, ("SubmitManyJobs",
|
|
| 110 |
[ ("ops", [t| [[OpCode]] |], [| id |]) ],
|
|
| 111 |
[| J.showJSON |]) |
|
| 112 |
, ("WaitForJobChange",
|
|
| 113 |
[ ("job", [t| Int |], [| J.showJSON |])
|
|
| 114 |
, ("fields", [t| [String]|], [| J.showJSON |])
|
|
| 115 |
, ("prev_job", [t| JSValue |], [| J.showJSON |])
|
|
| 116 |
, ("prev_log", [t| JSValue |], [| J.showJSON |])
|
|
| 117 |
, ("tmout", [t| Int |], [| J.showJSON |])
|
|
| 118 |
], |
|
| 119 |
[| \(j, f, pj, pl, t) -> JSArray [j, f, pj, pl, t] |]) |
|
| 120 |
, ("ArchiveJob",
|
|
| 121 |
[ ("job", [t| Int |], [| show |]) ],
|
|
| 122 |
[| J.showJSON |]) |
|
| 123 |
, ("AutoArchiveJobs",
|
|
| 124 |
[ ("age", [t| Int |], [| id |])
|
|
| 125 |
, ("tmout", [t| Int |], [| id |])
|
|
| 126 |
], |
|
| 127 |
[| J.showJSON |]) |
|
| 128 |
, ("CancelJob",
|
|
| 129 |
[("job", [t| Int |], [| show |]) ],
|
|
| 130 |
[| J.showJSON |]) |
|
| 131 |
, ("SetDrainFlag",
|
|
| 132 |
[ ("flag", [t| Bool |], [| id |]) ],
|
|
| 133 |
[| J.showJSON |]) |
|
| 134 |
, ("SetWatcherPause",
|
|
| 135 |
[ ("duration", [t| Double |], [| \x -> [x] |]) ],
|
|
| 136 |
[| J.showJSON |]) |
|
| 137 |
]) |
|
| 80 | 138 |
|
| 81 | 139 |
-- | The serialisation of LuxiOps into strings in messages. |
| 82 |
strOfOp :: LuxiOp -> String |
|
| 83 |
strOfOp QueryNodes {} = "QueryNodes"
|
|
| 84 |
strOfOp QueryGroups {} = "QueryGroups"
|
|
| 85 |
strOfOp QueryInstances {} = "QueryInstances"
|
|
| 86 |
strOfOp QueryJobs {} = "QueryJobs"
|
|
| 87 |
strOfOp QueryExports {} = "QueryExports"
|
|
| 88 |
strOfOp QueryConfigValues {} = "QueryConfigValues"
|
|
| 89 |
strOfOp QueryClusterInfo {} = "QueryClusterInfo"
|
|
| 90 |
strOfOp QueryTags {} = "QueryTags"
|
|
| 91 |
strOfOp SubmitManyJobs {} = "SubmitManyJobs"
|
|
| 92 |
strOfOp WaitForJobChange {} = "WaitForJobChange"
|
|
| 93 |
strOfOp SubmitJob {} = "SubmitJob"
|
|
| 94 |
strOfOp ArchiveJob {} = "ArchiveJob"
|
|
| 95 |
strOfOp AutoArchiveJobs {} = "AutoArchiveJobs"
|
|
| 96 |
strOfOp CancelJob {} = "CancelJob"
|
|
| 97 |
strOfOp SetDrainFlag {} = "SetDrainFlag"
|
|
| 98 |
strOfOp SetWatcherPause {} = "SetWatcherPause"
|
|
| 140 |
$(genStrOfOp ''LuxiOp "strOfOp") |
|
| 99 | 141 |
|
| 100 | 142 |
-- | The end-of-message separator. |
| 101 | 143 |
eOM :: Char |
| ... | ... | |
| 108 | 150 |
| Result |
| 109 | 151 |
|
| 110 | 152 |
-- | The serialisation of MsgKeys into strings in messages. |
| 111 |
strOfKey :: MsgKeys -> String |
|
| 112 |
strOfKey Method = "method" |
|
| 113 |
strOfKey Args = "args" |
|
| 114 |
strOfKey Success = "success" |
|
| 115 |
strOfKey Result = "result" |
|
| 153 |
$(genStrOfKey ''MsgKeys "strOfKey") |
|
| 116 | 154 |
|
| 117 | 155 |
-- | Luxi client encapsulation. |
| 118 | 156 |
data Client = Client { socket :: S.Socket -- ^ The socket of the client
|
| ... | ... | |
| 161 | 199 |
writeIORef (rbuf s) nbuf |
| 162 | 200 |
return msg |
| 163 | 201 |
|
| 164 |
-- | Compute the serialized form of a Luxi operation. |
|
| 165 |
opToArgs :: LuxiOp -> JSValue |
|
| 166 |
opToArgs (QueryNodes names fields lock) = J.showJSON (names, fields, lock) |
|
| 167 |
opToArgs (QueryGroups names fields lock) = J.showJSON (names, fields, lock) |
|
| 168 |
opToArgs (QueryInstances names fields lock) = J.showJSON (names, fields, lock) |
|
| 169 |
opToArgs (QueryJobs ids fields) = J.showJSON (map show ids, fields) |
|
| 170 |
opToArgs (QueryExports nodes lock) = J.showJSON (nodes, lock) |
|
| 171 |
opToArgs (QueryConfigValues fields) = J.showJSON fields |
|
| 172 |
opToArgs (QueryClusterInfo) = J.showJSON () |
|
| 173 |
opToArgs (QueryTags kind name) = J.showJSON (kind, name) |
|
| 174 |
opToArgs (SubmitJob j) = J.showJSON j |
|
| 175 |
opToArgs (SubmitManyJobs ops) = J.showJSON ops |
|
| 176 |
-- This is special, since the JSON library doesn't export an instance |
|
| 177 |
-- of a 5-tuple |
|
| 178 |
opToArgs (WaitForJobChange a b c d e) = |
|
| 179 |
JSArray [ J.showJSON a, J.showJSON b, J.showJSON c |
|
| 180 |
, J.showJSON d, J.showJSON e] |
|
| 181 |
opToArgs (ArchiveJob a) = J.showJSON (show a) |
|
| 182 |
opToArgs (AutoArchiveJobs a b) = J.showJSON (a, b) |
|
| 183 |
opToArgs (CancelJob a) = J.showJSON (show a) |
|
| 184 |
opToArgs (SetDrainFlag flag) = J.showJSON flag |
|
| 185 |
opToArgs (SetWatcherPause duration) = J.showJSON [duration] |
|
| 186 |
|
|
| 187 | 202 |
-- | Serialize a request to String. |
| 188 | 203 |
buildCall :: LuxiOp -- ^ The method |
| 189 | 204 |
-> String -- ^ The serialized form |
| b/htools/Ganeti/THH.hs | ||
|---|---|---|
| 34 | 34 |
, genOpID |
| 35 | 35 |
, genOpCode |
| 36 | 36 |
, noDefault |
| 37 |
, genStrOfOp |
|
| 38 |
, genStrOfKey |
|
| 39 |
, genLuxiOp |
|
| 37 | 40 |
) where |
| 38 | 41 |
|
| 39 | 42 |
import Control.Monad (liftM) |
| ... | ... | |
| 222 | 225 |
constructorName (RecC name _) = return name |
| 223 | 226 |
constructorName x = fail $ "Unhandled constructor " ++ show x |
| 224 | 227 |
|
| 225 |
-- | Builds the constructor-to-string function. |
|
| 228 |
-- | Builds the generic constructor-to-string function.
|
|
| 226 | 229 |
-- |
| 227 | 230 |
-- This generates a simple function of the following form: |
| 228 | 231 |
-- |
| 229 | 232 |
-- @ |
| 230 |
-- fname (ConStructorOne {}) = "CON_STRUCTOR_ONE"
|
|
| 231 |
-- fname (ConStructorTwo {}) = "CON_STRUCTOR_TWO"
|
|
| 233 |
-- fname (ConStructorOne {}) = trans_fun("ConStructorOne")
|
|
| 234 |
-- fname (ConStructorTwo {}) = trans_fun("ConStructorTwo")
|
|
| 232 | 235 |
-- @ |
| 233 | 236 |
-- |
| 234 | 237 |
-- This builds a custom list of name/string pairs and then uses |
| 235 | 238 |
-- 'genToString' to actually generate the function |
| 236 |
genOpID :: Name -> String -> Q [Dec]
|
|
| 237 |
genOpID name fname = do
|
|
| 239 |
genConstrToStr :: (String -> String) -> Name -> String -> Q [Dec]
|
|
| 240 |
genConstrToStr trans_fun name fname = do
|
|
| 238 | 241 |
TyConI (DataD _ _ _ cons _) <- reify name |
| 239 | 242 |
cnames <- mapM (liftM nameBase . constructorName) cons |
| 240 |
let svalues = map (Left . deCamelCase) cnames
|
|
| 243 |
let svalues = map (Left . trans_fun) cnames
|
|
| 241 | 244 |
genToString (mkName fname) name $ zip cnames svalues |
| 242 | 245 |
|
| 246 |
-- | Constructor-to-string for OpCode. |
|
| 247 |
genOpID :: Name -> String -> Q [Dec] |
|
| 248 |
genOpID = genConstrToStr deCamelCase |
|
| 243 | 249 |
|
| 244 | 250 |
-- | OpCode parameter (field) type |
| 245 | 251 |
type OpParam = (String, Q Type, Q Exp) |
| ... | ... | |
| 400 | 406 |
-- | No default type. |
| 401 | 407 |
noDefault :: Q Exp |
| 402 | 408 |
noDefault = conE 'Nothing |
| 409 |
|
|
| 410 |
-- * Template code for luxi |
|
| 411 |
|
|
| 412 |
-- | Constructor-to-string for LuxiOp. |
|
| 413 |
genStrOfOp :: Name -> String -> Q [Dec] |
|
| 414 |
genStrOfOp = genConstrToStr id |
|
| 415 |
|
|
| 416 |
-- | Constructor-to-string for MsgKeys. |
|
| 417 |
genStrOfKey :: Name -> String -> Q [Dec] |
|
| 418 |
genStrOfKey = genConstrToStr ensureLower |
|
| 419 |
|
|
| 420 |
-- | LuxiOp parameter type. |
|
| 421 |
type LuxiParam = (String, Q Type, Q Exp) |
|
| 422 |
|
|
| 423 |
-- | Generates the LuxiOp data type. |
|
| 424 |
-- |
|
| 425 |
-- This takes a Luxi operation definition and builds both the |
|
| 426 |
-- datatype and the function trnasforming the arguments to JSON. |
|
| 427 |
-- We can't use anything less generic, because the way different |
|
| 428 |
-- operations are serialized differs on both parameter- and top-level. |
|
| 429 |
-- |
|
| 430 |
-- There are three things to be defined for each parameter: |
|
| 431 |
-- |
|
| 432 |
-- * name |
|
| 433 |
-- |
|
| 434 |
-- * type |
|
| 435 |
-- |
|
| 436 |
-- * operation; this is the operation performed on the parameter before |
|
| 437 |
-- serialization |
|
| 438 |
-- |
|
| 439 |
genLuxiOp :: String -> [(String, [LuxiParam], Q Exp)] -> Q [Dec] |
|
| 440 |
genLuxiOp name cons = do |
|
| 441 |
decl_d <- mapM (\(cname, fields, _) -> do |
|
| 442 |
fields' <- mapM (\(_, qt, _) -> |
|
| 443 |
qt >>= \t -> return (NotStrict, t)) |
|
| 444 |
fields |
|
| 445 |
return $ NormalC (mkName cname) fields') |
|
| 446 |
cons |
|
| 447 |
let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read] |
|
| 448 |
(savesig, savefn) <- genSaveLuxiOp cons |
|
| 449 |
return [declD, savesig, savefn] |
|
| 450 |
|
|
| 451 |
-- | Generates the \"save\" clause for entire LuxiOp constructor. |
|
| 452 |
saveLuxiConstructor :: (String, [LuxiParam], Q Exp) -> Q Clause |
|
| 453 |
saveLuxiConstructor (sname, fields, finfn) = |
|
| 454 |
let cname = mkName sname |
|
| 455 |
fnames = map (\(nm, _, _) -> mkName nm) fields |
|
| 456 |
pat = conP cname (map varP fnames) |
|
| 457 |
flist = map (\(nm, _, fn) -> appE fn $ varNameE nm) fields |
|
| 458 |
finval = appE finfn (tupE flist) |
|
| 459 |
in |
|
| 460 |
clause [pat] (normalB finval) [] |
|
| 461 |
|
|
| 462 |
-- | Generates the main save LuxiOp function. |
|
| 463 |
genSaveLuxiOp :: [(String, [LuxiParam], Q Exp)] -> Q (Dec, Dec) |
|
| 464 |
genSaveLuxiOp opdefs = do |
|
| 465 |
sigt <- [t| $(conT (mkName "LuxiOp")) -> JSON.JSValue |] |
|
| 466 |
let fname = mkName "opToArgs" |
|
| 467 |
cclauses <- mapM saveLuxiConstructor opdefs |
|
| 468 |
return $ (SigD fname sigt, FunD fname cclauses) |
|
Also available in: Unified diff