Commit cdd495ae authored by Iustin Pop's avatar Iustin Pop

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: default avatarIustin Pop <iustin@google.com>
Reviewed-by: default avatarRené Nussbaumer <rn@google.com>
parent 5cefb2b2
......@@ -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
]
......@@ -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
......
......@@ -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))) $
......
......@@ -124,6 +124,7 @@ allTests =
, (fast, testTypes)
, (fast, testCLI)
, (fast, testJSON)
, (fast, testLUXI)
, (slow, testCluster)
]
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment