From cdd495ae22f69fed19dbfe1a573784979002fceb Mon Sep 17 00:00:00 2001
From: Iustin Pop <iustin@google.com>
Date: Mon, 7 May 2012 12:56:32 +0200
Subject: [PATCH] Add decoding of Luxi calls and unittests for LuxiOp
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
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>
---
htools/Ganeti/HTools/QC.hs | 52 ++++++++++++++++++++-
htools/Ganeti/Luxi.hs | 96 +++++++++++++++++++++++++++++++++++++-
htools/Ganeti/THH.hs | 2 +-
htools/test.hs | 1 +
4 files changed, 147 insertions(+), 4 deletions(-)
diff --git a/htools/Ganeti/HTools/QC.hs b/htools/Ganeti/HTools/QC.hs
index 2c2996800..0c1ff5adb 100644
--- 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 3afd41ffb..4c0daedee 100644
--- 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 cc41388c3..1dc5533ad 100644
--- 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 2167e0ea5..eedefd35b 100644
--- a/htools/test.hs
+++ b/htools/test.hs
@@ -124,6 +124,7 @@ allTests =
, (fast, testTypes)
, (fast, testCLI)
, (fast, testJSON)
+ , (fast, testLUXI)
, (slow, testCluster)
]
--
GitLab