Synnefo » snf-ganeti

  , testLUXI

import qualified Ganeti.Luxi as Luxi

import qualified Ganeti.HTools.Luxi as HTools.Luxi

-- * 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

          ]

  , buildCall

  , validateCall

  , decodeCall

import Ganeti.HTools.Utils

     [ ("job",      [t| Int     |], [| show |])

-- | Type holding the initial (unparsed) Luxi call.

data LuxiCall = LuxiCall LuxiReq JSValue

-- | 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

  let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq]

  , (fast, testLUXI)