Add CommonOpParams and MetaOpCode types

This patch adds the "meta" opcode type and the common op
params. Compatibility tests with Python are changed to pass Meta
opcodes.

Signed-off-by: Iustin Pop <iustin@google.com>
Reviewed-by: Guido Trotter <ultrotter@google.com>

diff --git a/htest/Test/Ganeti/OpCodes.hs b/htest/Test/Ganeti/OpCodes.hs
index 95657dc..3251ee2 100644 (file)
--- 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 520662c..6d93286 100644 (file)
--- 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