Revision 4a826364
| b/htest/Test/Ganeti/OpCodes.hs | ||
|---|---|---|
| 337 | 337 |
genNameNE |
| 338 | 338 |
_ -> fail $ "Undefined arbitrary for opcode " ++ op_id |
| 339 | 339 |
|
| 340 |
instance Arbitrary OpCodes.CommonOpParams where |
|
| 341 |
arbitrary = OpCodes.CommonOpParams <$> arbitrary <*> arbitrary <*> |
|
| 342 |
arbitrary <*> resize 5 arbitrary <*> genMaybe genName |
|
| 343 |
|
|
| 340 | 344 |
-- * Helper functions |
| 341 | 345 |
|
| 342 | 346 |
-- | Empty JSObject. |
| ... | ... | |
| 403 | 407 |
octets <- vectorOf 3 $ choose (0::Int, 255) |
| 404 | 408 |
mkNonEmpty . intercalate ":" $ map (printf "%02x") octets |
| 405 | 409 |
|
| 410 |
-- | Arbitrary instance for MetaOpCode, defined here due to TH ordering. |
|
| 411 |
$(genArbitrary ''OpCodes.MetaOpCode) |
|
| 412 |
|
|
| 406 | 413 |
-- * Test cases |
| 407 | 414 |
|
| 408 | 415 |
-- | Check that opcode serialization is idempotent. |
| ... | ... | |
| 441 | 448 |
case_py_compat_types = do |
| 442 | 449 |
let num_opcodes = length OpCodes.allOpIDs * 100 |
| 443 | 450 |
sample_opcodes <- sample' (vectorOf num_opcodes |
| 444 |
(arbitrary::Gen OpCodes.OpCode)) |
|
| 451 |
(arbitrary::Gen OpCodes.MetaOpCode))
|
|
| 445 | 452 |
let opcodes = head sample_opcodes |
| 446 | 453 |
serialized = J.encode opcodes |
| 447 | 454 |
-- check for non-ASCII fields, usually due to 'arbitrary :: String' |
| ... | ... | |
| 460 | 467 |
\encoded = [op.__getstate__() for op in decoded]\n\ |
| 461 | 468 |
\print serializer.Dump(encoded)" serialized |
| 462 | 469 |
>>= checkPythonResult |
| 463 |
let deserialised = J.decode py_stdout::J.Result [OpCodes.OpCode] |
|
| 470 |
let deserialised = J.decode py_stdout::J.Result [OpCodes.MetaOpCode]
|
|
| 464 | 471 |
decoded <- case deserialised of |
| 465 | 472 |
J.Ok ops -> return ops |
| 466 | 473 |
J.Error msg -> |
| ... | ... | |
| 506 | 513 |
py_flds hs_flds |
| 507 | 514 |
) $ zip py_fields hs_fields |
| 508 | 515 |
|
| 516 |
-- | Checks that setOpComment works correctly. |
|
| 517 |
prop_setOpComment :: OpCodes.MetaOpCode -> String -> Property |
|
| 518 |
prop_setOpComment op comment = |
|
| 519 |
let (OpCodes.MetaOpCode common _) = OpCodes.setOpComment comment op |
|
| 520 |
in OpCodes.opComment common ==? Just comment |
|
| 521 |
|
|
| 509 | 522 |
testSuite "OpCodes" |
| 510 | 523 |
[ 'prop_serialization |
| 511 | 524 |
, 'case_AllDefined |
| 512 | 525 |
, 'case_py_compat_types |
| 513 | 526 |
, 'case_py_compat_fields |
| 527 |
, 'prop_setOpComment |
|
| 514 | 528 |
] |
| b/htools/Ganeti/OpCodes.hs | ||
|---|---|---|
| 38 | 38 |
, opID |
| 39 | 39 |
, allOpIDs |
| 40 | 40 |
, allOpFields |
| 41 |
, CommonOpParams(..) |
|
| 42 |
, defOpParams |
|
| 43 |
, MetaOpCode(..) |
|
| 44 |
, wrapOpCode |
|
| 45 |
, setOpComment |
|
| 41 | 46 |
) where |
| 42 | 47 |
|
| 43 |
import Text.JSON (readJSON, showJSON, JSON()) |
|
| 48 |
import Text.JSON (readJSON, showJSON, JSON, JSValue, makeObj) |
|
| 49 |
import qualified Text.JSON |
|
| 44 | 50 |
|
| 45 | 51 |
import Ganeti.THH |
| 46 | 52 |
|
| 47 | 53 |
import Ganeti.OpParams |
| 54 |
import Ganeti.Types (OpSubmitPriority(..)) |
|
| 48 | 55 |
|
| 49 | 56 |
-- | OpCode representation. |
| 50 | 57 |
-- |
| ... | ... | |
| 538 | 545 |
instance JSON OpCode where |
| 539 | 546 |
readJSON = loadOpCode |
| 540 | 547 |
showJSON = saveOpCode |
| 548 |
|
|
| 549 |
-- | Generic\/common opcode parameters. |
|
| 550 |
$(buildObject "CommonOpParams" "op" |
|
| 551 |
[ pDryRun |
|
| 552 |
, pDebugLevel |
|
| 553 |
, pOpPriority |
|
| 554 |
, pDependencies |
|
| 555 |
, pComment |
|
| 556 |
]) |
|
| 557 |
|
|
| 558 |
-- | Default common parameter values. |
|
| 559 |
defOpParams :: CommonOpParams |
|
| 560 |
defOpParams = |
|
| 561 |
CommonOpParams { opDryRun = Nothing
|
|
| 562 |
, opDebugLevel = Nothing |
|
| 563 |
, opPriority = OpPrioNormal |
|
| 564 |
, opDepends = Nothing |
|
| 565 |
, opComment = Nothing |
|
| 566 |
} |
|
| 567 |
|
|
| 568 |
-- | The top-level opcode type. |
|
| 569 |
data MetaOpCode = MetaOpCode CommonOpParams OpCode |
|
| 570 |
deriving (Show, Eq) |
|
| 571 |
|
|
| 572 |
-- | JSON serialisation for 'MetaOpCode'. |
|
| 573 |
showMeta :: MetaOpCode -> JSValue |
|
| 574 |
showMeta (MetaOpCode params op) = |
|
| 575 |
let objparams = toDictCommonOpParams params |
|
| 576 |
objop = toDictOpCode op |
|
| 577 |
in makeObj (objparams ++ objop) |
|
| 578 |
|
|
| 579 |
-- | JSON deserialisation for 'MetaOpCode' |
|
| 580 |
readMeta :: JSValue -> Text.JSON.Result MetaOpCode |
|
| 581 |
readMeta v = do |
|
| 582 |
meta <- readJSON v |
|
| 583 |
op <- readJSON v |
|
| 584 |
return $ MetaOpCode meta op |
|
| 585 |
|
|
| 586 |
instance JSON MetaOpCode where |
|
| 587 |
showJSON = showMeta |
|
| 588 |
readJSON = readMeta |
|
| 589 |
|
|
| 590 |
-- | Wraps an 'OpCode' with the default parameters to build a |
|
| 591 |
-- 'MetaOpCode'. |
|
| 592 |
wrapOpCode :: OpCode -> MetaOpCode |
|
| 593 |
wrapOpCode = MetaOpCode defOpParams |
|
| 594 |
|
|
| 595 |
-- | Sets the comment on a meta opcode. |
|
| 596 |
setOpComment :: String -> MetaOpCode -> MetaOpCode |
|
| 597 |
setOpComment comment (MetaOpCode common op) = |
|
| 598 |
MetaOpCode (common { opComment = Just comment}) op
|
|
Also available in: Unified diff