diff --git a/htest/Test/Ganeti/OpCodes.hs b/htest/Test/Ganeti/OpCodes.hs index 95657dccca99724f558666c807fc514d35586410..3251ee228b29625c8a9d98edb27a4b3c8d4a1a94 100644 --- a/htest/Test/Ganeti/OpCodes.hs +++ b/htest/Test/Ganeti/OpCodes.hs @@ -337,6 +337,10 @@ instance Arbitrary OpCodes.OpCode where genNameNE _ -> fail $ "Undefined arbitrary for opcode " ++ op_id +instance Arbitrary OpCodes.CommonOpParams where + arbitrary = OpCodes.CommonOpParams <$> arbitrary <*> arbitrary <*> + arbitrary <*> resize 5 arbitrary <*> genMaybe genName + -- * Helper functions -- | Empty JSObject. @@ -403,6 +407,9 @@ genMacPrefix = do octets <- vectorOf 3 $ choose (0::Int, 255) mkNonEmpty . intercalate ":" $ map (printf "%02x") octets +-- | Arbitrary instance for MetaOpCode, defined here due to TH ordering. +$(genArbitrary ''OpCodes.MetaOpCode) + -- * Test cases -- | Check that opcode serialization is idempotent. @@ -441,7 +448,7 @@ case_py_compat_types :: HUnit.Assertion case_py_compat_types = do let num_opcodes = length OpCodes.allOpIDs * 100 sample_opcodes <- sample' (vectorOf num_opcodes - (arbitrary::Gen OpCodes.OpCode)) + (arbitrary::Gen OpCodes.MetaOpCode)) let opcodes = head sample_opcodes serialized = J.encode opcodes -- check for non-ASCII fields, usually due to 'arbitrary :: String' @@ -460,7 +467,7 @@ case_py_compat_types = do \encoded = [op.__getstate__() for op in decoded]\n\ \print serializer.Dump(encoded)" serialized >>= checkPythonResult - let deserialised = J.decode py_stdout::J.Result [OpCodes.OpCode] + let deserialised = J.decode py_stdout::J.Result [OpCodes.MetaOpCode] decoded <- case deserialised of J.Ok ops -> return ops J.Error msg -> @@ -506,9 +513,16 @@ case_py_compat_fields = do py_flds hs_flds ) $ zip py_fields hs_fields +-- | Checks that setOpComment works correctly. +prop_setOpComment :: OpCodes.MetaOpCode -> String -> Property +prop_setOpComment op comment = + let (OpCodes.MetaOpCode common _) = OpCodes.setOpComment comment op + in OpCodes.opComment common ==? Just comment + testSuite "OpCodes" [ 'prop_serialization , 'case_AllDefined , 'case_py_compat_types , 'case_py_compat_fields + , 'prop_setOpComment ] diff --git a/htools/Ganeti/OpCodes.hs b/htools/Ganeti/OpCodes.hs index 520662c62e181a02ead06d96c32bc1cec9fc4bf0..6d93286a28caaeaa06a352954bc291fa51b33b57 100644 --- a/htools/Ganeti/OpCodes.hs +++ b/htools/Ganeti/OpCodes.hs @@ -38,13 +38,20 @@ module Ganeti.OpCodes , opID , allOpIDs , allOpFields + , CommonOpParams(..) + , defOpParams + , MetaOpCode(..) + , wrapOpCode + , setOpComment ) where -import Text.JSON (readJSON, showJSON, JSON()) +import Text.JSON (readJSON, showJSON, JSON, JSValue, makeObj) +import qualified Text.JSON import Ganeti.THH import Ganeti.OpParams +import Ganeti.Types (OpSubmitPriority(..)) -- | OpCode representation. -- @@ -538,3 +545,54 @@ $(genAllOpIDs ''OpCode "allOpIDs") instance JSON OpCode where readJSON = loadOpCode showJSON = saveOpCode + +-- | Generic\/common opcode parameters. +$(buildObject "CommonOpParams" "op" + [ pDryRun + , pDebugLevel + , pOpPriority + , pDependencies + , pComment + ]) + +-- | Default common parameter values. +defOpParams :: CommonOpParams +defOpParams = + CommonOpParams { opDryRun = Nothing + , opDebugLevel = Nothing + , opPriority = OpPrioNormal + , opDepends = Nothing + , opComment = Nothing + } + +-- | The top-level opcode type. +data MetaOpCode = MetaOpCode CommonOpParams OpCode + deriving (Show, Eq) + +-- | JSON serialisation for 'MetaOpCode'. +showMeta :: MetaOpCode -> JSValue +showMeta (MetaOpCode params op) = + let objparams = toDictCommonOpParams params + objop = toDictOpCode op + in makeObj (objparams ++ objop) + +-- | JSON deserialisation for 'MetaOpCode' +readMeta :: JSValue -> Text.JSON.Result MetaOpCode +readMeta v = do + meta <- readJSON v + op <- readJSON v + return $ MetaOpCode meta op + +instance JSON MetaOpCode where + showJSON = showMeta + readJSON = readMeta + +-- | Wraps an 'OpCode' with the default parameters to build a +-- 'MetaOpCode'. +wrapOpCode :: OpCode -> MetaOpCode +wrapOpCode = MetaOpCode defOpParams + +-- | Sets the comment on a meta opcode. +setOpComment :: String -> MetaOpCode -> MetaOpCode +setOpComment comment (MetaOpCode common op) = + MetaOpCode (common { opComment = Just comment}) op