Revision b20cbf06
| b/htools/Ganeti/HTools/Luxi.hs | ||
|---|---|---|
| 95 | 95 |
queryNodesMsg = |
| 96 | 96 |
L.Query L.QRNode ["name", "mtotal", "mnode", "mfree", "dtotal", "dfree", |
| 97 | 97 |
"ctotal", "offline", "drained", "vm_capable", |
| 98 |
"group.uuid"] Nothing
|
|
| 98 |
"group.uuid"] ()
|
|
| 99 | 99 |
|
| 100 | 100 |
-- | The input data for instance query. |
| 101 | 101 |
queryInstancesMsg :: L.LuxiOp |
| 102 | 102 |
queryInstancesMsg = |
| 103 | 103 |
L.Query L.QRInstance ["name", "disk_usage", "be/memory", "be/vcpus", |
| 104 | 104 |
"status", "pnode", "snodes", "tags", "oper_ram", |
| 105 |
"be/auto_balance", "disk_template"] Nothing
|
|
| 105 |
"be/auto_balance", "disk_template"] ()
|
|
| 106 | 106 |
|
| 107 | 107 |
-- | The input data for cluster query. |
| 108 | 108 |
queryClusterInfoMsg :: L.LuxiOp |
| ... | ... | |
| 111 | 111 |
-- | The input data for node group query. |
| 112 | 112 |
queryGroupsMsg :: L.LuxiOp |
| 113 | 113 |
queryGroupsMsg = |
| 114 |
L.Query L.QRGroup ["uuid", "name", "alloc_policy"] Nothing
|
|
| 114 |
L.Query L.QRGroup ["uuid", "name", "alloc_policy"] ()
|
|
| 115 | 115 |
|
| 116 | 116 |
-- | Wraper over 'callMethod' doing node query. |
| 117 | 117 |
queryNodes :: L.Client -> IO (Result JSValue) |
| b/htools/Ganeti/Luxi.hs | ||
|---|---|---|
| 76 | 76 |
-- | Currently supported Luxi operations and JSON serialization. |
| 77 | 77 |
$(genLuxiOp "LuxiOp" |
| 78 | 78 |
[("Query" ,
|
| 79 |
[ ("what", [t| QrViaLuxi |], [| id |])
|
|
| 80 |
, ("fields", [t| [String] |], [| id |])
|
|
| 81 |
, ("qfilter", [t| Maybe (String, [[String]]) |], [| id |])
|
|
| 82 |
], SDict)
|
|
| 79 |
[ ("what", [t| QrViaLuxi |], [| id |])
|
|
| 80 |
, ("fields", [t| [String] |], [| id |])
|
|
| 81 |
, ("qfilter", [t| () |], [| const JSNull |])
|
|
| 82 |
]) |
|
| 83 | 83 |
, ("QueryNodes",
|
| 84 | 84 |
[ ("names", [t| [String] |], [| id |])
|
| 85 | 85 |
, ("fields", [t| [String] |], [| id |])
|
| 86 | 86 |
, ("lock", [t| Bool |], [| id |])
|
| 87 |
], SList)
|
|
| 87 |
]) |
|
| 88 | 88 |
, ("QueryGroups",
|
| 89 | 89 |
[ ("names", [t| [String] |], [| id |])
|
| 90 | 90 |
, ("fields", [t| [String] |], [| id |])
|
| 91 | 91 |
, ("lock", [t| Bool |], [| id |])
|
| 92 |
], SList)
|
|
| 92 |
]) |
|
| 93 | 93 |
, ("QueryInstances",
|
| 94 | 94 |
[ ("names", [t| [String] |], [| id |])
|
| 95 | 95 |
, ("fields", [t| [String] |], [| id |])
|
| 96 | 96 |
, ("lock", [t| Bool |], [| id |])
|
| 97 |
], SList)
|
|
| 97 |
]) |
|
| 98 | 98 |
, ("QueryJobs",
|
| 99 | 99 |
[ ("ids", [t| [Int] |], [| map show |])
|
| 100 | 100 |
, ("fields", [t| [String] |], [| id |])
|
| 101 |
], SList)
|
|
| 101 |
]) |
|
| 102 | 102 |
, ("QueryExports",
|
| 103 | 103 |
[ ("nodes", [t| [String] |], [| id |])
|
| 104 | 104 |
, ("lock", [t| Bool |], [| id |])
|
| 105 |
], SList)
|
|
| 105 |
]) |
|
| 106 | 106 |
, ("QueryConfigValues",
|
| 107 |
[ ("fields", [t| [String] |], [| id |]) ],
|
|
| 108 |
SList)
|
|
| 109 |
, ("QueryClusterInfo", [], SList)
|
|
| 107 |
[ ("fields", [t| [String] |], [| id |]) ]
|
|
| 108 |
) |
|
| 109 |
, ("QueryClusterInfo", [])
|
|
| 110 | 110 |
, ("QueryTags",
|
| 111 | 111 |
[ ("kind", [t| String |], [| id |])
|
| 112 | 112 |
, ("name", [t| String |], [| id |])
|
| 113 |
], SList)
|
|
| 113 |
]) |
|
| 114 | 114 |
, ("SubmitJob",
|
| 115 |
[ ("job", [t| [OpCode] |], [| id |]) ],
|
|
| 116 |
SList)
|
|
| 115 |
[ ("job", [t| [OpCode] |], [| id |]) ]
|
|
| 116 |
) |
|
| 117 | 117 |
, ("SubmitManyJobs",
|
| 118 |
[ ("ops", [t| [[OpCode]] |], [| id |]) ],
|
|
| 119 |
SList)
|
|
| 118 |
[ ("ops", [t| [[OpCode]] |], [| id |]) ]
|
|
| 119 |
) |
|
| 120 | 120 |
, ("WaitForJobChange",
|
| 121 | 121 |
[ ("job", [t| Int |], [| id |])
|
| 122 | 122 |
, ("fields", [t| [String]|], [| id |])
|
| 123 | 123 |
, ("prev_job", [t| JSValue |], [| id |])
|
| 124 | 124 |
, ("prev_log", [t| JSValue |], [| id |])
|
| 125 | 125 |
, ("tmout", [t| Int |], [| id |])
|
| 126 |
], SList)
|
|
| 126 |
]) |
|
| 127 | 127 |
, ("ArchiveJob",
|
| 128 |
[ ("job", [t| Int |], [| show |]) ],
|
|
| 129 |
SList)
|
|
| 128 |
[ ("job", [t| Int |], [| show |]) ]
|
|
| 129 |
) |
|
| 130 | 130 |
, ("AutoArchiveJobs",
|
| 131 | 131 |
[ ("age", [t| Int |], [| id |])
|
| 132 | 132 |
, ("tmout", [t| Int |], [| id |])
|
| 133 |
], SList)
|
|
| 133 |
]) |
|
| 134 | 134 |
, ("CancelJob",
|
| 135 |
[("job", [t| Int |], [| show |]) ],
|
|
| 136 |
SList)
|
|
| 135 |
[ ("job", [t| Int |], [| show |]) ]
|
|
| 136 |
) |
|
| 137 | 137 |
, ("SetDrainFlag",
|
| 138 |
[ ("flag", [t| Bool |], [| id |]) ],
|
|
| 139 |
SList)
|
|
| 138 |
[ ("flag", [t| Bool |], [| id |]) ]
|
|
| 139 |
) |
|
| 140 | 140 |
, ("SetWatcherPause",
|
| 141 |
[ ("duration", [t| Double |], [| (: []) |]) ],
|
|
| 142 |
SList)
|
|
| 141 |
[ ("duration", [t| Double |], [| id |]) ]
|
|
| 142 |
) |
|
| 143 | 143 |
]) |
| 144 | 144 |
|
| 145 | 145 |
-- | The serialisation of LuxiOps into strings in messages. |
| b/htools/Ganeti/THH.hs | ||
|---|---|---|
| 29 | 29 |
|
| 30 | 30 |
-} |
| 31 | 31 |
|
| 32 |
module Ganeti.THH ( Store(..) |
|
| 33 |
, declareSADT |
|
| 32 |
module Ganeti.THH ( declareSADT |
|
| 34 | 33 |
, makeJSONInstance |
| 35 | 34 |
, genOpID |
| 36 | 35 |
, genOpCode |
| ... | ... | |
| 429 | 428 |
-- | LuxiOp parameter type. |
| 430 | 429 |
type LuxiParam = (String, Q Type, Q Exp) |
| 431 | 430 |
|
| 432 |
-- | Storage options for JSON. |
|
| 433 |
data Store = SList | SDict |
|
| 434 |
|
|
| 435 | 431 |
-- | Generates the LuxiOp data type. |
| 436 | 432 |
-- |
| 437 | 433 |
-- This takes a Luxi operation definition and builds both the |
| ... | ... | |
| 448 | 444 |
-- * operation; this is the operation performed on the parameter before |
| 449 | 445 |
-- serialization |
| 450 | 446 |
-- |
| 451 |
genLuxiOp :: String -> [(String, [LuxiParam], Store)] -> Q [Dec]
|
|
| 447 |
genLuxiOp :: String -> [(String, [LuxiParam])] -> Q [Dec] |
|
| 452 | 448 |
genLuxiOp name cons = do |
| 453 |
decl_d <- mapM (\(cname, fields, _) -> do
|
|
| 449 |
decl_d <- mapM (\(cname, fields) -> do |
|
| 454 | 450 |
fields' <- mapM (\(_, qt, _) -> |
| 455 | 451 |
qt >>= \t -> return (NotStrict, t)) |
| 456 | 452 |
fields |
| ... | ... | |
| 460 | 456 |
(savesig, savefn) <- genSaveLuxiOp cons |
| 461 | 457 |
return [declD, savesig, savefn] |
| 462 | 458 |
|
| 463 |
-- | Generates a Q Exp for an element, depending of the JSON return type. |
|
| 464 |
helperLuxiField :: Store -> String -> Q Exp -> Q Exp |
|
| 465 |
helperLuxiField SList name val = [| [ JSON.showJSON $val ] |] |
|
| 466 |
helperLuxiField SDict name val = [| [(name, JSON.showJSON $val)] |] |
|
| 467 |
|
|
| 468 | 459 |
-- | Generates the \"save\" expression for a single luxi parameter. |
| 469 |
saveLuxiField :: Store -> Name -> LuxiParam -> Q Exp |
|
| 470 |
saveLuxiField store fvar (fname, qt, fn) = do |
|
| 471 |
t <- qt |
|
| 472 |
let fvare = varE fvar |
|
| 473 |
(if isOptional t |
|
| 474 |
then [| case $fvare of |
|
| 475 |
Just v' -> |
|
| 476 |
$(helperLuxiField store fname $ liftM2 appFn fn [| v' |]) |
|
| 477 |
Nothing -> [] |
|
| 478 |
|] |
|
| 479 |
else helperLuxiField store fname $ liftM2 appFn fn fvare) |
|
| 480 |
|
|
| 481 |
-- | Generates final JSON Q Exp for constructor. |
|
| 482 |
helperLuxiConstructor :: Store -> Q Exp -> Q Exp |
|
| 483 |
helperLuxiConstructor SDict val = [| JSON.showJSON $ JSON.makeObj $val |] |
|
| 484 |
helperLuxiConstructor SList val = [| JSON.JSArray $val |] |
|
| 460 |
saveLuxiField :: Name -> LuxiParam -> Q Exp |
|
| 461 |
saveLuxiField fvar (_, qt, fn) = |
|
| 462 |
[| JSON.showJSON ( $(liftM2 appFn fn $ varE fvar) ) |] |
|
| 485 | 463 |
|
| 486 | 464 |
-- | Generates the \"save\" clause for entire LuxiOp constructor. |
| 487 |
saveLuxiConstructor :: (String, [LuxiParam], Store) -> Q Clause
|
|
| 488 |
saveLuxiConstructor (sname, fields, store) = do
|
|
| 465 |
saveLuxiConstructor :: (String, [LuxiParam]) -> Q Clause |
|
| 466 |
saveLuxiConstructor (sname, fields) = do |
|
| 489 | 467 |
let cname = mkName sname |
| 490 | 468 |
fnames = map (\(nm, _, _) -> mkName nm) fields |
| 491 | 469 |
pat = conP cname (map varP fnames) |
| 492 |
flist = map (uncurry $ saveLuxiField store) (zip fnames fields) |
|
| 493 |
flist' = appE [| concat |] (listE flist) |
|
| 494 |
finval = helperLuxiConstructor store flist' |
|
| 470 |
flist = map (uncurry saveLuxiField) (zip fnames fields) |
|
| 471 |
finval = if null flist |
|
| 472 |
then [| JSON.showJSON () |] |
|
| 473 |
else [| JSON.showJSON $(listE flist) |] |
|
| 495 | 474 |
clause [pat] (normalB finval) [] |
| 496 | 475 |
|
| 497 | 476 |
-- | Generates the main save LuxiOp function. |
| 498 |
genSaveLuxiOp :: [(String, [LuxiParam], Store)]-> Q (Dec, Dec)
|
|
| 477 |
genSaveLuxiOp :: [(String, [LuxiParam])]-> Q (Dec, Dec) |
|
| 499 | 478 |
genSaveLuxiOp opdefs = do |
| 500 | 479 |
sigt <- [t| $(conT (mkName "LuxiOp")) -> JSON.JSValue |] |
| 501 | 480 |
let fname = mkName "opToArgs" |
Also available in: Unified diff