Revision 12c19659
b/htools/Ganeti/OpCodes.hs | ||
---|---|---|
31 | 31 |
, opID |
32 | 32 |
) where |
33 | 33 |
|
34 |
import Control.Monad |
|
35 | 34 |
import Text.JSON (readJSON, showJSON, makeObj, JSON) |
36 | 35 |
import qualified Text.JSON as J |
37 |
import Text.JSON.Types |
|
38 | 36 |
|
39 | 37 |
import qualified Ganeti.Constants as C |
40 |
import qualified Ganeti.THH as THH
|
|
38 |
import Ganeti.THH
|
|
41 | 39 |
|
42 | 40 |
import Ganeti.HTools.Utils |
43 | 41 |
|
44 | 42 |
-- | Replace disks type. |
45 |
$(THH.declareSADT "ReplaceDisksMode"
|
|
43 |
$(declareSADT "ReplaceDisksMode" |
|
46 | 44 |
[ ("ReplaceOnPrimary", 'C.replaceDiskPri) |
47 | 45 |
, ("ReplaceOnSecondary", 'C.replaceDiskSec) |
48 | 46 |
, ("ReplaceNewSecondary", 'C.replaceDiskChg) |
49 | 47 |
, ("ReplaceAuto", 'C.replaceDiskAuto) |
50 | 48 |
]) |
51 |
$(THH.makeJSONInstance ''ReplaceDisksMode)
|
|
49 |
$(makeJSONInstance ''ReplaceDisksMode) |
|
52 | 50 |
|
53 | 51 |
-- | OpCode representation. |
54 | 52 |
-- |
55 | 53 |
-- We only implement a subset of Ganeti opcodes, but only what we |
56 | 54 |
-- actually use in the htools codebase. |
57 |
data OpCode = OpTestDelay Double Bool [String] |
|
58 |
| OpInstanceReplaceDisks String (Maybe String) ReplaceDisksMode |
|
59 |
[Int] (Maybe String) |
|
60 |
| OpInstanceFailover String Bool (Maybe String) |
|
61 |
| OpInstanceMigrate String Bool Bool Bool (Maybe String) |
|
62 |
deriving (Show, Read, Eq) |
|
63 |
|
|
64 |
|
|
65 |
$(THH.genOpID ''OpCode "opID") |
|
66 |
|
|
67 |
-- | Loads an OpCode from the JSON serialised form. |
|
68 |
loadOpCode :: JSValue -> J.Result OpCode |
|
69 |
loadOpCode v = do |
|
70 |
o <- liftM J.fromJSObject (readJSON v) |
|
71 |
let extract x = fromObj o x |
|
72 |
op_id <- extract "OP_ID" |
|
73 |
case op_id of |
|
74 |
"OP_TEST_DELAY" -> do |
|
75 |
on_nodes <- extract "on_nodes" |
|
76 |
on_master <- extract "on_master" |
|
77 |
duration <- extract "duration" |
|
78 |
return $ OpTestDelay duration on_master on_nodes |
|
79 |
"OP_INSTANCE_REPLACE_DISKS" -> do |
|
80 |
inst <- extract "instance_name" |
|
81 |
node <- maybeFromObj o "remote_node" |
|
82 |
mode <- extract "mode" |
|
83 |
disks <- extract "disks" |
|
84 |
ialloc <- maybeFromObj o "iallocator" |
|
85 |
return $ OpInstanceReplaceDisks inst node mode disks ialloc |
|
86 |
"OP_INSTANCE_FAILOVER" -> do |
|
87 |
inst <- extract "instance_name" |
|
88 |
consist <- extract "ignore_consistency" |
|
89 |
tnode <- maybeFromObj o "target_node" |
|
90 |
return $ OpInstanceFailover inst consist tnode |
|
91 |
"OP_INSTANCE_MIGRATE" -> do |
|
92 |
inst <- extract "instance_name" |
|
93 |
live <- extract "live" |
|
94 |
cleanup <- extract "cleanup" |
|
95 |
allow_failover <- fromObjWithDefault o "allow_failover" False |
|
96 |
tnode <- maybeFromObj o "target_node" |
|
97 |
return $ OpInstanceMigrate inst live cleanup |
|
98 |
allow_failover tnode |
|
99 |
_ -> J.Error $ "Unknown opcode " ++ op_id |
|
100 |
|
|
101 |
-- | Serialises an opcode to JSON. |
|
102 |
saveOpCode :: OpCode -> JSValue |
|
103 |
saveOpCode op@(OpTestDelay duration on_master on_nodes) = |
|
104 |
let ol = [ ("OP_ID", showJSON $ opID op) |
|
105 |
, ("duration", showJSON duration) |
|
106 |
, ("on_master", showJSON on_master) |
|
107 |
, ("on_nodes", showJSON on_nodes) ] |
|
108 |
in makeObj ol |
|
109 |
|
|
110 |
saveOpCode op@(OpInstanceReplaceDisks inst node mode disks iallocator) = |
|
111 |
let ol = [ ("OP_ID", showJSON $ opID op) |
|
112 |
, ("instance_name", showJSON inst) |
|
113 |
, ("mode", showJSON mode) |
|
114 |
, ("disks", showJSON disks)] |
|
115 |
ol2 = case node of |
|
116 |
Just n -> ("remote_node", showJSON n):ol |
|
117 |
Nothing -> ol |
|
118 |
ol3 = case iallocator of |
|
119 |
Just i -> ("iallocator", showJSON i):ol2 |
|
120 |
Nothing -> ol2 |
|
121 |
in makeObj ol3 |
|
122 |
|
|
123 |
saveOpCode op@(OpInstanceFailover inst consist tnode) = |
|
124 |
let ol = [ ("OP_ID", showJSON $ opID op) |
|
125 |
, ("instance_name", showJSON inst) |
|
126 |
, ("ignore_consistency", showJSON consist) ] |
|
127 |
ol' = case tnode of |
|
128 |
Nothing -> ol |
|
129 |
Just node -> ("target_node", showJSON node):ol |
|
130 |
in makeObj ol' |
|
131 |
|
|
132 |
saveOpCode op@(OpInstanceMigrate inst live cleanup allow_failover tnode) = |
|
133 |
let ol = [ ("OP_ID", showJSON $ opID op) |
|
134 |
, ("instance_name", showJSON inst) |
|
135 |
, ("live", showJSON live) |
|
136 |
, ("cleanup", showJSON cleanup) |
|
137 |
, ("allow_failover", showJSON allow_failover) ] |
|
138 |
ol' = case tnode of |
|
139 |
Nothing -> ol |
|
140 |
Just node -> ("target_node", showJSON node):ol |
|
141 |
in makeObj ol' |
|
55 |
$(genOpCode "OpCode" |
|
56 |
[ ("OpTestDelay", |
|
57 |
[ ("duration", [t| Double |], noDefault) |
|
58 |
, ("on_master", [t| Bool |], noDefault) |
|
59 |
, ("on_nodes", [t| [String] |], noDefault) |
|
60 |
]) |
|
61 |
, ("OpInstanceReplaceDisks", |
|
62 |
[ ("instance_name", [t| String |], noDefault) |
|
63 |
, ("remote_node", [t| Maybe String |], noDefault) |
|
64 |
, ("mode", [t| ReplaceDisksMode |], noDefault) |
|
65 |
, ("disks", [t| [Int] |], noDefault) |
|
66 |
, ("iallocator", [t| Maybe String |], noDefault) |
|
67 |
]) |
|
68 |
, ("OpInstanceFailover", |
|
69 |
[ ("instance_name", [t| String |], noDefault) |
|
70 |
, ("ignore_consistency", [t| Bool |], noDefault) |
|
71 |
, ("target_node", [t| Maybe String |], noDefault) |
|
72 |
]) |
|
73 |
, ("OpInstanceMigrate", |
|
74 |
[ ("instance_name", [t| String |], noDefault) |
|
75 |
, ("live", [t| Bool |], noDefault) |
|
76 |
, ("cleanup", [t| Bool |], noDefault) |
|
77 |
, ("allow_failover", [t| Bool |], [| Just False |]) |
|
78 |
, ("target_node", [t| Maybe String |], noDefault) |
|
79 |
]) |
|
80 |
]) |
|
81 |
|
|
82 |
$(genOpID ''OpCode "opID") |
|
142 | 83 |
|
143 | 84 |
instance JSON OpCode where |
144 | 85 |
readJSON = loadOpCode |
b/htools/Ganeti/THH.hs | ||
---|---|---|
32 | 32 |
module Ganeti.THH ( declareSADT |
33 | 33 |
, makeJSONInstance |
34 | 34 |
, genOpID |
35 |
, genOpCode |
|
36 |
, noDefault |
|
35 | 37 |
) where |
36 | 38 |
|
37 | 39 |
import Control.Monad (liftM) |
... | ... | |
224 | 226 |
cnames <- mapM (liftM nameBase . constructorName) cons |
225 | 227 |
let svalues = map (Left . deCamelCase) cnames |
226 | 228 |
genToString (mkName fname) name $ zip cnames svalues |
229 |
|
|
230 |
|
|
231 |
-- | OpCode parameter (field) type |
|
232 |
type OpParam = (String, Q Type, Q Exp) |
|
233 |
|
|
234 |
-- | Generates the OpCode data type. |
|
235 |
-- |
|
236 |
-- This takes an opcode logical definition, and builds both the |
|
237 |
-- datatype and the JSON serialisation out of it. We can't use a |
|
238 |
-- generic serialisation since we need to be compatible with Ganeti's |
|
239 |
-- own, so we have a few quirks to work around. |
|
240 |
-- |
|
241 |
-- There are three things to be defined for each parameter: |
|
242 |
-- |
|
243 |
-- * name |
|
244 |
-- |
|
245 |
-- * type; if this is 'Maybe', will only be serialised if it's a |
|
246 |
-- 'Just' value |
|
247 |
-- |
|
248 |
-- * default; if missing, won't raise an exception, but will instead |
|
249 |
-- use the default |
|
250 |
-- |
|
251 |
genOpCode :: String -- ^ Type name to use |
|
252 |
-> [(String, [OpParam])] -- ^ Constructor name and parameters |
|
253 |
-> Q [Dec] |
|
254 |
genOpCode name cons = do |
|
255 |
decl_d <- mapM (\(cname, fields) -> do |
|
256 |
-- we only need the type of the field, without Q |
|
257 |
fields' <- mapM (\(_, qt, _) -> |
|
258 |
qt >>= \t -> return (NotStrict, t)) |
|
259 |
fields |
|
260 |
return $ NormalC (mkName cname) fields') |
|
261 |
cons |
|
262 |
let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq] |
|
263 |
|
|
264 |
(savesig, savefn) <- genSaveOpCode cons |
|
265 |
(loadsig, loadfn) <- genLoadOpCode cons |
|
266 |
return [declD, loadsig, loadfn, savesig, savefn] |
|
267 |
|
|
268 |
-- | Checks whether a given parameter is options |
|
269 |
-- |
|
270 |
-- This requires that it's a 'Maybe'. |
|
271 |
isOptional :: Type -> Bool |
|
272 |
isOptional (AppT (ConT dt) _) | dt == ''Maybe = True |
|
273 |
isOptional _ = False |
|
274 |
|
|
275 |
-- | Generates the \"save\" expression for a single opcode parameter. |
|
276 |
-- |
|
277 |
-- There is only one special handling mode: if the parameter is of |
|
278 |
-- 'Maybe' type, then we only save it if it's a 'Just' value, |
|
279 |
-- otherwise we skip it. |
|
280 |
saveField :: Name -- ^ The name of variable that contains the value |
|
281 |
-> OpParam -- ^ Parameter definition |
|
282 |
-> Q Exp |
|
283 |
saveField fvar (fname, qt, _) = do |
|
284 |
t <- qt |
|
285 |
let showJ = varE (mkName "showJSON") |
|
286 |
fnexp = litE (stringL fname) |
|
287 |
fvare = varE fvar |
|
288 |
(if isOptional t |
|
289 |
then [| case $fvare of |
|
290 |
Just v' -> [( $fnexp, $showJ v')] |
|
291 |
Nothing -> [] |
|
292 |
|] |
|
293 |
else [| [( $fnexp, $showJ $fvare )] |]) |
|
294 |
|
|
295 |
-- | Generates the \"save\" clause for an entire opcode constructor. |
|
296 |
-- |
|
297 |
-- This matches the opcode with variables named the same as the |
|
298 |
-- constructor fields (just so that the spliced in code looks nicer), |
|
299 |
-- and passes those name plus the parameter definition to 'saveField'. |
|
300 |
saveConstructor :: String -- ^ The constructor name |
|
301 |
-> [OpParam] -- ^ The parameter definitions for this |
|
302 |
-- constructor |
|
303 |
-> Q Clause -- ^ Resulting clause |
|
304 |
saveConstructor sname fields = do |
|
305 |
let cname = mkName sname |
|
306 |
let fnames = map (\(n, _, _) -> mkName n) fields |
|
307 |
let pat = conP cname (map varP fnames) |
|
308 |
let felems = map (uncurry saveField) (zip fnames fields) |
|
309 |
-- now build the OP_ID serialisation |
|
310 |
opid = [| [( $(litE (stringL "OP_ID")), |
|
311 |
$(varE (mkName "showJSON")) |
|
312 |
$(litE . stringL . deCamelCase $ sname) )] |] |
|
313 |
flist = listE (opid:felems) |
|
314 |
-- and finally convert all this to a json object |
|
315 |
flist' = [| $(varE (mkName "makeObj")) (concat $flist) |] |
|
316 |
clause [pat] (normalB flist') [] |
|
317 |
|
|
318 |
-- | Generates the main save opcode function. |
|
319 |
-- |
|
320 |
-- This builds a per-constructor match clause that contains the |
|
321 |
-- respective constructor-serialisation code. |
|
322 |
genSaveOpCode :: [(String, [OpParam])] -> Q (Dec, Dec) |
|
323 |
genSaveOpCode opdefs = do |
|
324 |
cclauses <- mapM (uncurry saveConstructor) opdefs |
|
325 |
let fname = mkName "saveOpCode" |
|
326 |
sigt <- [t| $(conT (mkName "OpCode")) -> JSON.JSValue |] |
|
327 |
return $ (SigD fname sigt, FunD fname cclauses) |
|
328 |
|
|
329 |
-- | Generates the \"load\" field for a single parameter. |
|
330 |
-- |
|
331 |
-- There is custom handling, depending on how the parameter is |
|
332 |
-- specified. For a 'Maybe' type parameter, we allow that it is not |
|
333 |
-- present (via 'Utils.maybeFromObj'). Otherwise, if there is a |
|
334 |
-- default value, we allow the parameter to be abset, and finally if |
|
335 |
-- there is no default value, we require its presence. |
|
336 |
loadField :: OpParam -> Q (Name, Stmt) |
|
337 |
loadField (fname, qt, qdefa) = do |
|
338 |
let fvar = mkName fname |
|
339 |
t <- qt |
|
340 |
defa <- qdefa |
|
341 |
-- these are used in all patterns below |
|
342 |
let objvar = varE (mkName "o") |
|
343 |
objfield = litE (StringL fname) |
|
344 |
bexp <- if isOptional t |
|
345 |
then [| $((varE (mkName "maybeFromObj"))) $objvar $objfield |] |
|
346 |
else case defa of |
|
347 |
AppE (ConE dt) defval | dt == 'Just -> |
|
348 |
-- but has a default value |
|
349 |
[| $(varE (mkName "fromObjWithDefault")) |
|
350 |
$objvar $objfield $(return defval) |] |
|
351 |
ConE dt | dt == 'Nothing -> |
|
352 |
[| $(varE (mkName "fromObj")) $objvar $objfield |] |
|
353 |
s -> fail $ "Invalid default value " ++ show s ++ |
|
354 |
", expecting either 'Nothing' or a 'Just defval'" |
|
355 |
return (fvar, BindS (VarP fvar) bexp) |
|
356 |
|
|
357 |
loadConstructor :: String -> [OpParam] -> Q Exp |
|
358 |
loadConstructor sname fields = do |
|
359 |
let name = mkName sname |
|
360 |
fbinds <- mapM loadField fields |
|
361 |
let (fnames, fstmts) = unzip fbinds |
|
362 |
let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames |
|
363 |
fstmts' = fstmts ++ [NoBindS (AppE (VarE 'return) cval)] |
|
364 |
return $ DoE fstmts' |
|
365 |
|
|
366 |
genLoadOpCode :: [(String, [OpParam])] -> Q (Dec, Dec) |
|
367 |
genLoadOpCode opdefs = do |
|
368 |
let fname = mkName "loadOpCode" |
|
369 |
arg1 = mkName "v" |
|
370 |
objname = mkName "o" |
|
371 |
opid = mkName "op_id" |
|
372 |
st1 <- bindS (varP objname) [| liftM JSON.fromJSObject |
|
373 |
(JSON.readJSON $(varE arg1)) |] |
|
374 |
st2 <- bindS (varP opid) [| $(varE (mkName "fromObj")) |
|
375 |
$(varE objname) $(litE (stringL "OP_ID")) |] |
|
376 |
-- the match results (per-constructor blocks) |
|
377 |
mexps <- mapM (uncurry loadConstructor) opdefs |
|
378 |
fails <- [| fail $ "Unknown opcode " ++ $(varE opid) |] |
|
379 |
let mpats = map (\(me, c) -> |
|
380 |
let mp = LitP . StringL . deCamelCase . fst $ c |
|
381 |
in Match mp (NormalB me) [] |
|
382 |
) $ zip mexps opdefs |
|
383 |
defmatch = Match WildP (NormalB fails) [] |
|
384 |
cst = NoBindS $ CaseE (VarE opid) $ mpats++[defmatch] |
|
385 |
body = DoE [st1, st2, cst] |
|
386 |
sigt <- [t| JSON.JSValue -> JSON.Result $(conT (mkName "OpCode")) |] |
|
387 |
return $ (SigD fname sigt, FunD fname [Clause [VarP arg1] (NormalB body) []]) |
|
388 |
|
|
389 |
-- | No default type. |
|
390 |
noDefault :: Q Exp |
|
391 |
noDefault = conE 'Nothing |
Also available in: Unified diff