Add decoding of Luxi calls and unittests for LuxiOp

This patch adds a hand-coded decoder for LuxiCall arguments, as the
data-structure is not uniform enough for automated generation (even
for the serialisation, we had to add hints for some fields,
de-serialisation is even harder).

It also fixes a tiny issue with WaitForJobChange job ID encoding, and
adds unittests for the encoding/decoding of LuxiOp structures.

Signed-off-by: Iustin Pop <iustin@google.com>
Reviewed-by: René Nussbaumer <rn@google.com>

diff --git a/htools/Ganeti/HTools/QC.hs b/htools/Ganeti/HTools/QC.hs
index 2c29968..0c1ff5a 100644 (file)
--- a/htools/Ganeti/HTools/QC.hs
+++ b/htools/Ganeti/HTools/QC.hs
@@ -40,6 +40,7 @@ module Ganeti.HTools.QC
   , testTypes
   , testCLI
   , testJSON
+  , testLUXI
   ) where
 
 import Test.QuickCheck
@@ -56,7 +57,7 @@ import qualified Data.IntMap as IntMap
 
 import qualified Ganeti.OpCodes as OpCodes
 import qualified Ganeti.Jobs as Jobs
-import qualified Ganeti.Luxi
+import qualified Ganeti.Luxi as Luxi
 import qualified Ganeti.HTools.CLI as CLI
 import qualified Ganeti.HTools.Cluster as Cluster
 import qualified Ganeti.HTools.Container as Container
@@ -65,7 +66,7 @@ import qualified Ganeti.HTools.IAlloc as IAlloc
 import qualified Ganeti.HTools.Instance as Instance
 import qualified Ganeti.HTools.JSON as JSON
 import qualified Ganeti.HTools.Loader as Loader
-import qualified Ganeti.HTools.Luxi
+import qualified Ganeti.HTools.Luxi as HTools.Luxi
 import qualified Ganeti.HTools.Node as Node
 import qualified Ganeti.HTools.Group as Group
 import qualified Ganeti.HTools.PeerMap as PeerMap
@@ -1683,3 +1684,50 @@ testSuite "JSON"
           [ 'prop_JSON_toArray
           , 'prop_JSON_toArrayFail
           ]
+
+-- * Luxi tests
+
+instance Arbitrary Luxi.LuxiReq where
+  arbitrary = elements [minBound..maxBound]
+
+instance Arbitrary Luxi.QrViaLuxi where
+  arbitrary = elements [minBound..maxBound]
+
+instance Arbitrary Luxi.LuxiOp where
+  arbitrary = do
+    lreq <- arbitrary
+    case lreq of
+      Luxi.ReqQuery -> Luxi.Query <$> arbitrary <*> getFields <*> arbitrary
+      Luxi.ReqQueryNodes -> Luxi.QueryNodes <$> (listOf getFQDN) <*>
+                            getFields <*> arbitrary
+      Luxi.ReqQueryGroups -> Luxi.QueryGroups <$> arbitrary <*>
+                             arbitrary <*> arbitrary
+      Luxi.ReqQueryInstances -> Luxi.QueryInstances <$> (listOf getFQDN) <*>
+                                getFields <*> arbitrary
+      Luxi.ReqQueryJobs -> Luxi.QueryJobs <$> arbitrary <*> getFields
+      Luxi.ReqQueryExports -> Luxi.QueryExports <$>
+                              (listOf getFQDN) <*> arbitrary
+      Luxi.ReqQueryConfigValues -> Luxi.QueryConfigValues <$> getFields
+      Luxi.ReqQueryClusterInfo -> pure Luxi.QueryClusterInfo
+      Luxi.ReqQueryTags -> Luxi.QueryTags <$> getName <*> getFQDN
+      Luxi.ReqSubmitJob -> Luxi.SubmitJob <$> (resize maxOpCodes arbitrary)
+      Luxi.ReqSubmitManyJobs -> Luxi.SubmitManyJobs <$>
+                                (resize maxOpCodes arbitrary)
+      Luxi.ReqWaitForJobChange -> Luxi.WaitForJobChange <$> arbitrary <*>
+                                  getFields <*> pure J.JSNull <*>
+                                  pure J.JSNull <*> arbitrary
+      Luxi.ReqArchiveJob -> Luxi.ArchiveJob <$> arbitrary
+      Luxi.ReqAutoArchiveJobs -> Luxi.AutoArchiveJobs <$> arbitrary <*>
+                                 arbitrary
+      Luxi.ReqCancelJob -> Luxi.CancelJob <$> arbitrary
+      Luxi.ReqSetDrainFlag -> Luxi.SetDrainFlag <$> arbitrary
+      Luxi.ReqSetWatcherPause -> Luxi.SetWatcherPause <$> arbitrary
+
+-- | Simple check that encoding/decoding of LuxiOp works.
+prop_Luxi_CallEncoding :: Luxi.LuxiOp -> Property
+prop_Luxi_CallEncoding op =
+  (Luxi.validateCall (Luxi.buildCall op) >>= Luxi.decodeCall) ==? Types.Ok op
+
+testSuite "LUXI"
+          [ 'prop_Luxi_CallEncoding
+          ]

diff --git a/htools/Ganeti/Luxi.hs b/htools/Ganeti/Luxi.hs
index 3afd41f..4c0daed 100644 (file)
--- a/htools/Ganeti/Luxi.hs
+++ b/htools/Ganeti/Luxi.hs
@@ -37,6 +37,9 @@ module Ganeti.Luxi
   , callMethod
   , submitManyJobs
   , queryJobsStatus
+  , buildCall
+  , validateCall
+  , decodeCall
   ) where
 
 import Data.IORef
@@ -49,6 +52,7 @@ import qualified Network.Socket as S
 
 import Ganeti.HTools.JSON
 import Ganeti.HTools.Types
+import Ganeti.HTools.Utils
 
 import Ganeti.Constants
 import Ganeti.Jobs (JobStatus)
@@ -121,7 +125,7 @@ $(genLuxiOp "LuxiOp"
      [ ("ops", [t| [[OpCode]] |], [| id |]) ]
     )
   , (luxiReqWaitForJobChange,
-     [ ("job",      [t| Int     |], [| id |])
+     [ ("job",      [t| Int     |], [| show |])
      , ("fields",   [t| [String]|], [| id |])
      , ("prev_job", [t| JSValue |], [| id |])
      , ("prev_log", [t| JSValue |], [| id |])
@@ -160,6 +164,9 @@ $(declareIADT "ResultStatus"
 
 $(makeJSONInstance ''ResultStatus)
 
+-- | Type holding the initial (unparsed) Luxi call.
+data LuxiCall = LuxiCall LuxiReq JSValue
+
 -- | Check that ResultStatus is success or fail with descriptive message.
 checkRS :: (Monad m) => ResultStatus -> a -> m a
 checkRS RSNormal val    = return val
@@ -238,6 +245,93 @@ buildCall lo =
       jo = toJSObject ja
   in encodeStrict jo
 
+-- | Check that luxi request contains the required keys and parse it.
+validateCall :: String -> Result LuxiCall
+validateCall s = do
+  arr <- fromJResult "luxi call" $ decodeStrict s::Result (JSObject JSValue)
+  let aobj = fromJSObject arr
+  call <- fromObj aobj (strOfKey Method)::Result LuxiReq
+  args <- fromObj aobj (strOfKey Args)
+  return (LuxiCall call args)
+
+-- | Converts Luxi call arguments into a 'LuxiOp' data structure.
+--
+-- This is currently hand-coded until we make it more uniform so that
+-- it can be generated using TH.
+decodeCall :: LuxiCall -> Result LuxiOp
+decodeCall (LuxiCall call args) =
+  case call of
+    ReqQueryJobs -> do
+              (jid, jargs) <- fromJVal args
+              rid <- mapM (tryRead "parsing job ID" . fromJSString) jid
+              let rargs = map fromJSString jargs
+              return $ QueryJobs rid rargs
+    ReqQueryInstances -> do
+              (names, fields, locking) <- fromJVal args
+              return $ QueryInstances names fields locking
+    ReqQueryNodes -> do
+              (names, fields, locking) <- fromJVal args
+              return $ QueryNodes names fields locking
+    ReqQueryGroups -> do
+              (names, fields, locking) <- fromJVal args
+              return $ QueryGroups names fields locking
+    ReqQueryClusterInfo -> do
+              return QueryClusterInfo
+    ReqQuery -> do
+              (what, fields, _) <-
+                fromJVal args::Result (QrViaLuxi, [String], JSValue)
+              return $ Query what fields ()
+    ReqSubmitJob -> do
+              [ops1] <- fromJVal args
+              ops2 <- mapM (fromJResult (luxiReqToRaw call) . J.readJSON) ops1
+              return $ SubmitJob ops2
+    ReqSubmitManyJobs -> do
+              [ops1] <- fromJVal args
+              ops2 <- mapM (fromJResult (luxiReqToRaw call) . J.readJSON) ops1
+              return $ SubmitManyJobs ops2
+    ReqWaitForJobChange -> do
+              (jid, fields, pinfo, pidx, wtmout) <-
+                -- No instance for 5-tuple, code copied from the
+                -- json sources and adapted
+                fromJResult "Parsing WaitForJobChange message" $
+                case args of
+                  JSArray [a, b, c, d, e] ->
+                    (,,,,) `fmap`
+                    J.readJSON a `ap`
+                    J.readJSON b `ap`
+                    J.readJSON c `ap`
+                    J.readJSON d `ap`
+                    J.readJSON e
+                  _ -> J.Error "Not enough values"
+              rid <- tryRead "parsing job ID" jid
+              return $ WaitForJobChange rid fields pinfo pidx wtmout
+    ReqArchiveJob -> do
+              [jid] <- fromJVal args
+              rid <- tryRead "parsing job ID" jid
+              return $ ArchiveJob rid
+    ReqAutoArchiveJobs -> do
+              (age, tmout) <- fromJVal args
+              return $ AutoArchiveJobs age tmout
+    ReqQueryExports -> do
+              (nodes, lock) <- fromJVal args
+              return $ QueryExports nodes lock
+    ReqQueryConfigValues -> do
+              [fields] <- fromJVal args
+              return $ QueryConfigValues fields
+    ReqQueryTags -> do
+              (kind, name) <- fromJVal args
+              return $ QueryTags kind name
+    ReqCancelJob -> do
+              [job] <- fromJVal args
+              rid <- tryRead "parsing job ID" job
+              return $ CancelJob rid
+    ReqSetDrainFlag -> do
+              [flag] <- fromJVal args
+              return $ SetDrainFlag flag
+    ReqSetWatcherPause -> do
+              [duration] <- fromJVal args
+              return $ SetWatcherPause duration
+
 -- | Check that luxi responses contain the required keys and that the
 -- call was successful.
 validateResult :: String -> Result JSValue

diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs
index cc41388..1dc5533 100644 (file)
--- a/htools/Ganeti/THH.hs
+++ b/htools/Ganeti/THH.hs
@@ -541,7 +541,7 @@ genLuxiOp name cons = do
                                fields
                     return $ NormalC (mkName cname) fields')
             cons
-  let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read]
+  let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq]
   (savesig, savefn) <- genSaveLuxiOp cons
   req_defs <- declareSADT "LuxiReq" .
               map (\(str, _) -> ("Req" ++ str, mkName ("luxiReq" ++ str))) $

diff --git a/htools/test.hs b/htools/test.hs
index 2167e0e..eedefd3 100644 (file)
--- a/htools/test.hs
+++ b/htools/test.hs
@@ -124,6 +124,7 @@ allTests =
   , (fast, testTypes)
   , (fast, testCLI)
   , (fast, testJSON)
+  , (fast, testLUXI)
   , (slow, testCluster)
   ]