{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-imports #-}
+
+-- FIXME: should remove the no-warn-unused-imports option, once we get
+-- around to testing function from all modules; until then, we keep
+-- the (unused) imports here to generate correct coverage (0 for
+-- modules we don't use)
{-| Unittests for ganeti-htools.
, testTypes
, testCLI
, testJSON
- , testLUXI
+ , testLuxi
, testSsconf
+ , testRpc
+ , testQlang
) where
+import qualified Test.HUnit as HUnit
import Test.QuickCheck
+import Test.QuickCheck.Monadic (assert, monadicIO, run, stop)
import Text.Printf (printf)
-import Data.List (findIndex, intercalate, nub, isPrefixOf)
-import qualified Data.Set as Set
+import Data.List (intercalate, nub, isPrefixOf)
import Data.Maybe
+import qualified Data.Set as Set
import Control.Monad
import Control.Applicative
import qualified System.Console.GetOpt as GetOpt
import qualified Text.JSON as J
import qualified Data.Map
import qualified Data.IntMap as IntMap
-
-import qualified Ganeti.OpCodes as OpCodes
+import Control.Concurrent (forkIO)
+import Control.Exception (bracket, catchJust)
+import System.Directory (getTemporaryDirectory, removeFile)
+import System.Environment (getEnv)
+import System.Exit (ExitCode(..))
+import System.IO (hClose, openTempFile)
+import System.IO.Error (isEOFErrorType, ioeGetErrorType, isDoesNotExistError)
+import System.Process (readProcessWithExitCode)
+
+import qualified Ganeti.Confd as Confd
+import qualified Ganeti.Config as Config
+import qualified Ganeti.Daemon as Daemon
+import qualified Ganeti.Hash as Hash
+import qualified Ganeti.BasicTypes as BasicTypes
import qualified Ganeti.Jobs as Jobs
+import qualified Ganeti.Logging as Logging
import qualified Ganeti.Luxi as Luxi
+import qualified Ganeti.Objects as Objects
+import qualified Ganeti.OpCodes as OpCodes
+import qualified Ganeti.Qlang as Qlang
+import qualified Ganeti.Rpc as Rpc
+import qualified Ganeti.Runtime as Runtime
import qualified Ganeti.Ssconf as Ssconf
import qualified Ganeti.HTools.CLI as CLI
import qualified Ganeti.HTools.Cluster as Cluster
import qualified Ganeti.HTools.Container as Container
import qualified Ganeti.HTools.ExtLoader
+import qualified Ganeti.HTools.Group as Group
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 as HTools.Luxi
import qualified Ganeti.HTools.Node as Node
-import qualified Ganeti.HTools.Group as Group
import qualified Ganeti.HTools.PeerMap as PeerMap
import qualified Ganeti.HTools.Rapi
import qualified Ganeti.HTools.Simu as Simu
allDiskTemplates = [minBound..maxBound]
-- | Null iPolicy, and by null we mean very liberal.
+nullIPolicy :: Types.IPolicy
nullIPolicy = Types.IPolicy
{ Types.iPolicyMinSpec = Types.ISpec { Types.iSpecMemorySize = 0
, Types.iSpecCpuCount = 0
failTest :: String -> Property
failTest msg = printTestCase msg False
+-- | Return the python binary to use. If the PYTHON environment
+-- variable is defined, use its value, otherwise use just \"python\".
+pythonCmd :: IO String
+pythonCmd = catchJust (guard . isDoesNotExistError)
+ (getEnv "PYTHON") (const (return "python"))
+
+-- | Run Python with an expression, returning the exit code, standard
+-- output and error.
+runPython :: String -> String -> IO (ExitCode, String, String)
+runPython expr stdin = do
+ py_binary <- pythonCmd
+ readProcessWithExitCode py_binary ["-c", expr] stdin
+
+-- | Check python exit code, and fail via HUnit assertions if
+-- non-zero. Otherwise, return the standard output.
+checkPythonResult :: (ExitCode, String, String) -> IO String
+checkPythonResult (py_code, py_stdout, py_stderr) = do
+ HUnit.assertEqual ("python exited with error: " ++ py_stderr)
+ ExitSuccess py_code
+ return py_stdout
+
-- | Update an instance to be smaller than a node.
+setInstanceSmallerThanNode :: Node.Node
+ -> Instance.Instance -> Instance.Instance
setInstanceSmallerThanNode node inst =
inst { Instance.mem = Node.availMem node `div` 2
, Instance.dsk = Node.availDisk node `div` 2
}
-- | Create an instance given its spec.
+createInstance :: Int -> Int -> Int -> Instance.Instance
createInstance mem dsk vcpus =
Instance.create "inst-unnamed" mem dsk vcpus Types.Running [] True (-1) (-1)
Types.DTDrbd8 1
x <- elements (['a'..'z'] ++ ['0'..'9'] ++ "_-")
return (DNSChar x)
+instance Show DNSChar where
+ show = show . dnsGetChar
+
-- | Generates a single name component.
getName :: Gen String
getName = do
instance Arbitrary OpCodes.OpCode where
arbitrary = do
- op_id <- elements [ "OP_TEST_DELAY"
- , "OP_INSTANCE_REPLACE_DISKS"
- , "OP_INSTANCE_FAILOVER"
- , "OP_INSTANCE_MIGRATE"
- ]
+ op_id <- elements OpCodes.allOpIDs
case op_id of
"OP_TEST_DELAY" ->
OpCodes.OpTestDelay <$> arbitrary <*> arbitrary
, Types.iPolicySpindleRatio = spindle_ratio
}
+instance Arbitrary Objects.Hypervisor where
+ arbitrary = elements [minBound..maxBound]
+
+instance Arbitrary Objects.PartialNDParams where
+ arbitrary = Objects.PartialNDParams <$> arbitrary <*> arbitrary
+
+instance Arbitrary Objects.Node where
+ arbitrary = Objects.Node <$> getFQDN <*> getFQDN <*> getFQDN
+ <*> arbitrary <*> arbitrary <*> arbitrary <*> getFQDN
+ <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
+ <*> arbitrary <*> arbitrary <*> getFQDN <*> arbitrary
+ <*> (Set.fromList <$> genTags)
+
+instance Arbitrary Rpc.RpcCallAllInstancesInfo where
+ arbitrary = Rpc.RpcCallAllInstancesInfo <$> arbitrary
+
+instance Arbitrary Rpc.RpcCallInstanceList where
+ arbitrary = Rpc.RpcCallInstanceList <$> arbitrary
+
+instance Arbitrary Rpc.RpcCallNodeInfo where
+ arbitrary = Rpc.RpcCallNodeInfo <$> arbitrary <*> arbitrary
+
+-- | Custom 'Qlang.Filter' generator (top-level), which enforces a
+-- (sane) limit on the depth of the generated filters.
+genFilter :: Gen Qlang.Filter
+genFilter = choose (0, 10) >>= genFilter'
+
+-- | Custom generator for filters that correctly halves the state of
+-- the generators at each recursive step, per the QuickCheck
+-- documentation, in order not to run out of memory.
+genFilter' :: Int -> Gen Qlang.Filter
+genFilter' 0 =
+ oneof [ return Qlang.EmptyFilter
+ , Qlang.TrueFilter <$> getName
+ , Qlang.EQFilter <$> getName <*> value
+ , Qlang.LTFilter <$> getName <*> value
+ , Qlang.GTFilter <$> getName <*> value
+ , Qlang.LEFilter <$> getName <*> value
+ , Qlang.GEFilter <$> getName <*> value
+ , Qlang.RegexpFilter <$> getName <*> getName
+ , Qlang.ContainsFilter <$> getName <*> value
+ ]
+ where value = oneof [ Qlang.QuotedString <$> getName
+ , Qlang.NumericValue <$> arbitrary
+ ]
+genFilter' n = do
+ oneof [ Qlang.AndFilter <$> vectorOf n'' (genFilter' n')
+ , Qlang.OrFilter <$> vectorOf n'' (genFilter' n')
+ , Qlang.NotFilter <$> genFilter' n'
+ ]
+ where n' = n `div` 2 -- sub-filter generator size
+ n'' = max n' 2 -- but we don't want empty or 1-element lists,
+ -- so use this for and/or filter list length
+
+instance Arbitrary Qlang.ItemType where
+ arbitrary = elements [minBound..maxBound]
+
-- * Actual tests
-- ** Utils tests
-- | Helper to generate a small string that doesn't contain commas.
+genNonCommaString :: Gen [Char]
genNonCommaString = do
size <- choose (0, 20) -- arbitrary max size
vectorOf size (arbitrary `suchThat` ((/=) ','))
-- | If the list is not just an empty element, and if the elements do
-- not contain commas, then join+split should be idempotent.
+prop_Utils_commaJoinSplit :: Property
prop_Utils_commaJoinSplit =
forAll (choose (0, 20)) $ \llen ->
forAll (vectorOf llen genNonCommaString `suchThat` ((/=) [""])) $ \lst ->
Utils.sepSplit ',' (Utils.commaJoin lst) ==? lst
-- | Split and join should always be idempotent.
+prop_Utils_commaSplitJoin :: [Char] -> Property
prop_Utils_commaSplitJoin s =
Utils.commaJoin (Utils.sepSplit ',' s) ==? s
-- | fromObjWithDefault, we test using the Maybe monad and an integer
-- value.
+prop_Utils_fromObjWithDefault :: Integer -> String -> Bool
prop_Utils_fromObjWithDefault def_value random_key =
-- a missing key will be returned with the default
JSON.fromObjWithDefault [] random_key def_value == Just def_value &&
-- a found key will be returned as is, not with default
JSON.fromObjWithDefault [(random_key, J.showJSON def_value)]
random_key (def_value+1) == Just def_value
- where _types = def_value :: Integer
-- | Test that functional if' behaves like the syntactic sugar if.
prop_Utils_if'if :: Bool -> Int -> Int -> Gen Prop
tlist = zip (repeat True) lst2
cndlist = flist ++ tlist ++ [undefined]
+prop_Utils_parseUnit :: NonNegative Int -> Property
prop_Utils_parseUnit (NonNegative n) =
Utils.parseUnit (show n) ==? Types.Ok n .&&.
Utils.parseUnit (show n ++ "m") ==? Types.Ok n .&&.
printTestCase "Internal error/overflow?"
(n_mb >=0 && n_gb >= 0 && n_tb >= 0) .&&.
property (Types.isBad (Utils.parseUnit (show n ++ "x")::Types.Result Int))
- where _types = (n::Int)
- n_mb = (fromIntegral n::Rational) * 1000 * 1000 / 1024 / 1024
+ where n_mb = (fromIntegral n::Rational) * 1000 * 1000 / 1024 / 1024
n_gb = n_mb * 1000
n_tb = n_gb * 1000
-- ** PeerMap tests
-- | Make sure add is idempotent.
+prop_PeerMap_addIdempotent :: PeerMap.PeerMap
+ -> PeerMap.Key -> PeerMap.Elem -> Property
prop_PeerMap_addIdempotent pmap key em =
fn puniq ==? fn (fn puniq)
- where _types = (pmap::PeerMap.PeerMap,
- key::PeerMap.Key, em::PeerMap.Elem)
- fn = PeerMap.add key em
+ where fn = PeerMap.add key em
puniq = PeerMap.accumArray const pmap
-- | Make sure remove is idempotent.
+prop_PeerMap_removeIdempotent :: PeerMap.PeerMap -> PeerMap.Key -> Property
prop_PeerMap_removeIdempotent pmap key =
fn puniq ==? fn (fn puniq)
- where _types = (pmap::PeerMap.PeerMap, key::PeerMap.Key)
- fn = PeerMap.remove key
+ where fn = PeerMap.remove key
puniq = PeerMap.accumArray const pmap
-- | Make sure a missing item returns 0.
+prop_PeerMap_findMissing :: PeerMap.PeerMap -> PeerMap.Key -> Property
prop_PeerMap_findMissing pmap key =
PeerMap.find key (PeerMap.remove key puniq) ==? 0
- where _types = (pmap::PeerMap.PeerMap, key::PeerMap.Key)
- puniq = PeerMap.accumArray const pmap
+ where puniq = PeerMap.accumArray const pmap
-- | Make sure an added item is found.
+prop_PeerMap_addFind :: PeerMap.PeerMap
+ -> PeerMap.Key -> PeerMap.Elem -> Property
prop_PeerMap_addFind pmap key em =
PeerMap.find key (PeerMap.add key em puniq) ==? em
- where _types = (pmap::PeerMap.PeerMap,
- key::PeerMap.Key, em::PeerMap.Elem)
- puniq = PeerMap.accumArray const pmap
+ where puniq = PeerMap.accumArray const pmap
-- | Manual check that maxElem returns the maximum indeed, or 0 for null.
+prop_PeerMap_maxElem :: PeerMap.PeerMap -> Property
prop_PeerMap_maxElem pmap =
PeerMap.maxElem puniq ==? if null puniq then 0
else (maximum . snd . unzip) puniq
- where _types = pmap::PeerMap.PeerMap
- puniq = PeerMap.accumArray const pmap
+ where puniq = PeerMap.accumArray const pmap
-- | List of tests for the PeerMap module.
testSuite "PeerMap"
-- we silence the following due to hlint bug fixed in later versions
{-# ANN prop_Container_addTwo "HLint: ignore Avoid lambda" #-}
+prop_Container_addTwo :: [Container.Key] -> Int -> Int -> Bool
prop_Container_addTwo cdata i1 i2 =
fn i1 i2 cont == fn i2 i1 cont &&
fn i1 i2 cont == fn i1 i2 (fn i1 i2 cont)
- where _types = (cdata::[Int],
- i1::Int, i2::Int)
- cont = foldl (\c x -> Container.add x x c) Container.empty cdata
+ where cont = foldl (\c x -> Container.add x x c) Container.empty cdata
fn x1 x2 = Container.addTwo x1 x1 x2 x2
+prop_Container_nameOf :: Node.Node -> Property
prop_Container_nameOf node =
let nl = makeSmallCluster node 1
fnode = head (Container.elems nl)
-- | We test that in a cluster, given a random node, we can find it by
-- its name and alias, as long as all names and aliases are unique,
-- and that we fail to find a non-existing name.
-prop_Container_findByName node =
+prop_Container_findByName :: Property
+prop_Container_findByName =
+ forAll (genNode (Just 1) Nothing) $ \node ->
forAll (choose (1, 20)) $ \ cnt ->
forAll (choose (0, cnt - 1)) $ \ fidx ->
forAll (genUniquesList (cnt * 2)) $ \ allnames ->
$ zip names nodes
nl' = Container.fromList nodes'
target = snd (nodes' !! fidx)
- in Container.findByName nl' (Node.name target) == Just target &&
- Container.findByName nl' (Node.alias target) == Just target &&
- isNothing (Container.findByName nl' othername)
+ in Container.findByName nl' (Node.name target) ==? Just target .&&.
+ Container.findByName nl' (Node.alias target) ==? Just target .&&.
+ printTestCase "Found non-existing name"
+ (isNothing (Container.findByName nl' othername))
testSuite "Container"
[ 'prop_Container_addTwo
-- Simple instance tests, we only have setter/getters
+prop_Instance_creat :: Instance.Instance -> Property
prop_Instance_creat inst =
Instance.name inst ==? Instance.alias inst
+prop_Instance_setIdx :: Instance.Instance -> Types.Idx -> Property
prop_Instance_setIdx inst idx =
Instance.idx (Instance.setIdx inst idx) ==? idx
- where _types = (inst::Instance.Instance, idx::Types.Idx)
+prop_Instance_setName :: Instance.Instance -> String -> Bool
prop_Instance_setName inst name =
Instance.name newinst == name &&
Instance.alias newinst == name
- where _types = (inst::Instance.Instance, name::String)
- newinst = Instance.setName inst name
+ where newinst = Instance.setName inst name
+prop_Instance_setAlias :: Instance.Instance -> String -> Bool
prop_Instance_setAlias inst name =
Instance.name newinst == Instance.name inst &&
Instance.alias newinst == name
- where _types = (inst::Instance.Instance, name::String)
- newinst = Instance.setAlias inst name
+ where newinst = Instance.setAlias inst name
+prop_Instance_setPri :: Instance.Instance -> Types.Ndx -> Property
prop_Instance_setPri inst pdx =
Instance.pNode (Instance.setPri inst pdx) ==? pdx
- where _types = (inst::Instance.Instance, pdx::Types.Ndx)
+prop_Instance_setSec :: Instance.Instance -> Types.Ndx -> Property
prop_Instance_setSec inst sdx =
Instance.sNode (Instance.setSec inst sdx) ==? sdx
- where _types = (inst::Instance.Instance, sdx::Types.Ndx)
+prop_Instance_setBoth :: Instance.Instance -> Types.Ndx -> Types.Ndx -> Bool
prop_Instance_setBoth inst pdx sdx =
Instance.pNode si == pdx && Instance.sNode si == sdx
- where _types = (inst::Instance.Instance, pdx::Types.Ndx, sdx::Types.Ndx)
- si = Instance.setBoth inst pdx sdx
+ where si = Instance.setBoth inst pdx sdx
+prop_Instance_shrinkMG :: Instance.Instance -> Property
prop_Instance_shrinkMG inst =
Instance.mem inst >= 2 * Types.unitMem ==>
case Instance.shrinkByType inst Types.FailMem of
Types.Ok inst' -> Instance.mem inst' == Instance.mem inst - Types.unitMem
_ -> False
+prop_Instance_shrinkMF :: Instance.Instance -> Property
prop_Instance_shrinkMF inst =
forAll (choose (0, 2 * Types.unitMem - 1)) $ \mem ->
let inst' = inst { Instance.mem = mem}
in Types.isBad $ Instance.shrinkByType inst' Types.FailMem
+prop_Instance_shrinkCG :: Instance.Instance -> Property
prop_Instance_shrinkCG inst =
Instance.vcpus inst >= 2 * Types.unitCpu ==>
case Instance.shrinkByType inst Types.FailCPU of
Instance.vcpus inst' == Instance.vcpus inst - Types.unitCpu
_ -> False
+prop_Instance_shrinkCF :: Instance.Instance -> Property
prop_Instance_shrinkCF inst =
forAll (choose (0, 2 * Types.unitCpu - 1)) $ \vcpus ->
let inst' = inst { Instance.vcpus = vcpus }
in Types.isBad $ Instance.shrinkByType inst' Types.FailCPU
+prop_Instance_shrinkDG :: Instance.Instance -> Property
prop_Instance_shrinkDG inst =
Instance.dsk inst >= 2 * Types.unitDsk ==>
case Instance.shrinkByType inst Types.FailDisk of
Instance.dsk inst' == Instance.dsk inst - Types.unitDsk
_ -> False
+prop_Instance_shrinkDF :: Instance.Instance -> Property
prop_Instance_shrinkDF inst =
forAll (choose (0, 2 * Types.unitDsk - 1)) $ \dsk ->
let inst' = inst { Instance.dsk = dsk }
in Types.isBad $ Instance.shrinkByType inst' Types.FailDisk
+prop_Instance_setMovable :: Instance.Instance -> Bool -> Property
prop_Instance_setMovable inst m =
Instance.movable inst' ==? m
where inst' = Instance.setMovable inst m
-- Instance text loader tests
+prop_Text_Load_Instance :: String -> Int -> Int -> Int -> Types.InstanceStatus
+ -> NonEmptyList Char -> [Char]
+ -> NonNegative Int -> NonNegative Int -> Bool
+ -> Types.DiskTemplate -> Int -> Property
prop_Text_Load_Instance name mem dsk vcpus status
(NonEmpty pnode) snode
(NonNegative pdx) (NonNegative sdx) autobal dt su =
fail1 = Text.loadInst nl
[name, mem_s, dsk_s, vcpus_s, status_s,
sbal, pnode, pnode, tags]
- _types = ( name::String, mem::Int, dsk::Int
- , vcpus::Int, status::Types.InstanceStatus
- , snode::String
- , autobal::Bool)
in case inst of
Types.Bad msg -> failTest $ "Failed to load instance: " ++ msg
Types.Ok (_, i) -> printTestCase "Mismatch in some field while\
Instance.spindleUse i == su &&
Types.isBad fail1
+prop_Text_Load_InstanceFail :: [(String, Int)] -> [String] -> Property
prop_Text_Load_InstanceFail ktn fields =
length fields /= 10 && length fields /= 11 ==>
case Text.loadInst nl fields of
"Invalid/incomplete instance data: '" `isPrefixOf` msg
where nl = Data.Map.fromList ktn
+prop_Text_Load_Node :: String -> Int -> Int -> Int -> Int -> Int
+ -> Int -> Bool -> Bool
prop_Text_Load_Node name tm nm fm td fd tc fo =
let conv v = if v < 0
then "?"
Node.fDsk node == fd &&
Node.tCpu node == fromIntegral tc
+prop_Text_Load_NodeFail :: [String] -> Property
prop_Text_Load_NodeFail fields =
length fields /= 8 ==> isNothing $ Text.loadNode Data.Map.empty fields
-prop_Text_NodeLSIdempotent node =
- (Text.loadNode defGroupAssoc.
- Utils.sepSplit '|' . Text.serializeNode defGroupList) n ==?
- Just (Node.name n, n)
- -- override failN1 to what loadNode returns by default
- where n = Node.setPolicy Types.defIPolicy $
- node { Node.failN1 = True, Node.offline = False }
-
+prop_Text_NodeLSIdempotent :: Property
+prop_Text_NodeLSIdempotent =
+ forAll (genNode (Just 1) Nothing) $ \node ->
+ -- override failN1 to what loadNode returns by default
+ let n = Node.setPolicy Types.defIPolicy $
+ node { Node.failN1 = True, Node.offline = False }
+ in
+ (Text.loadNode defGroupAssoc.
+ Utils.sepSplit '|' . Text.serializeNode defGroupList) n ==?
+ Just (Node.name n, n)
+
+prop_Text_ISpecIdempotent :: Types.ISpec -> Property
prop_Text_ISpecIdempotent ispec =
case Text.loadISpec "dummy" . Utils.sepSplit ',' .
Text.serializeISpec $ ispec of
Types.Bad msg -> failTest $ "Failed to load ispec: " ++ msg
Types.Ok ispec' -> ispec ==? ispec'
+prop_Text_IPolicyIdempotent :: Types.IPolicy -> Property
prop_Text_IPolicyIdempotent ipol =
case Text.loadIPolicy . Utils.sepSplit '|' $
Text.serializeIPolicy owner ipol of
-- allocations, not for the business logic). As such, it's a quite
-- complex and slow test, and that's the reason we restrict it to
-- small cluster sizes.
+prop_Text_CreateSerialise :: Property
prop_Text_CreateSerialise =
forAll genTags $ \ctags ->
forAll (choose (1, 20)) $ \maxiter ->
-- | Checks that given a set of corrects specs, we can load them
-- successfully, and that at high-level the values look right.
-prop_SimuLoad =
+prop_Simu_Load :: Property
+prop_Simu_Load =
forAll (choose (0, 10)) $ \ngroups ->
forAll (replicateM ngroups genSimuSpec) $ \specs ->
let strspecs = map (\(p, n, d, m, c) -> printf "%s,%d,%d,%d,%d"
mdc_in = concatMap (\(_, n, d, m, c) ->
replicate n (fromIntegral m, fromIntegral d,
fromIntegral c,
- fromIntegral m, fromIntegral d)) specs
+ fromIntegral m, fromIntegral d))
+ specs :: [(Double, Double, Double, Int, Int)]
in case Simu.parseData strspecs of
Types.Bad msg -> failTest $ "Failed to load specs: " ++ msg
Types.Ok (Loader.ClusterData gl nl il tags ipol) ->
replicate ngroups Types.defIPolicy
testSuite "Simu"
- [ 'prop_SimuLoad
+ [ 'prop_Simu_Load
]
-- ** Node tests
+prop_Node_setAlias :: Node.Node -> String -> Bool
prop_Node_setAlias node name =
Node.name newnode == Node.name node &&
Node.alias newnode == name
- where _types = (node::Node.Node, name::String)
- newnode = Node.setAlias node name
+ where newnode = Node.setAlias node name
+prop_Node_setOffline :: Node.Node -> Bool -> Property
prop_Node_setOffline node status =
Node.offline newnode ==? status
where newnode = Node.setOffline node status
+prop_Node_setXmem :: Node.Node -> Int -> Property
prop_Node_setXmem node xm =
Node.xMem newnode ==? xm
where newnode = Node.setXmem node xm
+prop_Node_setMcpu :: Node.Node -> Double -> Property
prop_Node_setMcpu node mc =
Types.iPolicyVcpuRatio (Node.iPolicy newnode) ==? mc
where newnode = Node.setMcpu node mc
-- | Check that an instance add with too high memory or disk will be
-- rejected.
+prop_Node_addPriFM :: Node.Node -> Instance.Instance -> Property
prop_Node_addPriFM node inst =
Instance.mem inst >= Node.fMem node && not (Node.failN1 node) &&
not (Instance.isOffline inst) ==>
case Node.addPri node inst'' of
Types.OpFail Types.FailMem -> True
_ -> False
- where _types = (node::Node.Node, inst::Instance.Instance)
- inst' = setInstanceSmallerThanNode node inst
+ where inst' = setInstanceSmallerThanNode node inst
inst'' = inst' { Instance.mem = Instance.mem inst }
-- | Check that adding a primary instance with too much disk fails
-- with type FailDisk.
+prop_Node_addPriFD :: Node.Node -> Instance.Instance -> Property
prop_Node_addPriFD node inst =
forAll (elements Instance.localStorageTemplates) $ \dt ->
Instance.dsk inst >= Node.fDsk node && not (Node.failN1 node) ==>
-- | Check that adding a primary instance with too many VCPUs fails
-- with type FailCPU.
+prop_Node_addPriFC :: Property
prop_Node_addPriFC =
forAll (choose (1, maxCpu)) $ \extra ->
forAll genOnlineNode $ \node ->
-- | Check that an instance add with too high memory or disk will be
-- rejected.
+prop_Node_addSec :: Node.Node -> Instance.Instance -> Int -> Property
prop_Node_addSec node inst pdx =
((Instance.mem inst >= (Node.fMem node - Node.rMem node) &&
not (Instance.isOffline inst)) ||
Instance.dsk inst >= Node.fDsk node) &&
not (Node.failN1 node) ==>
isFailure (Node.addSec node inst pdx)
- where _types = (node::Node.Node, inst::Instance.Instance, pdx::Int)
-- | Check that an offline instance with reasonable disk size but
-- extra mem/cpu can always be added.
+prop_Node_addOfflinePri :: NonNegative Int -> NonNegative Int -> Property
prop_Node_addOfflinePri (NonNegative extra_mem) (NonNegative extra_cpu) =
forAll genOnlineNode $ \node ->
forAll (genInstanceSmallerThanNode node) $ \inst ->
-- | Check that an offline instance with reasonable disk size but
-- extra mem/cpu can always be added.
+prop_Node_addOfflineSec :: NonNegative Int -> NonNegative Int
+ -> Types.Ndx -> Property
prop_Node_addOfflineSec (NonNegative extra_mem) (NonNegative extra_cpu) pdx =
forAll genOnlineNode $ \node ->
forAll (genInstanceSmallerThanNode node) $ \inst ->
v -> failTest $ "Expected OpGood/OpGood, but got: " ++ show v
-- | Checks for memory reservation changes.
+prop_Node_rMem :: Instance.Instance -> Property
prop_Node_rMem inst =
not (Instance.isOffline inst) ==>
forAll (genOnlineNode `suchThat` ((> Types.unitMem) . Node.fMem)) $ \node ->
x -> failTest $ "Failed to add/remove instances: " ++ show x
-- | Check mdsk setting.
+prop_Node_setMdsk :: Node.Node -> SmallRatio -> Bool
prop_Node_setMdsk node mx =
Node.loDsk node' >= 0 &&
fromIntegral (Node.loDsk node') <= Node.tDsk node &&
Node.availDisk node' <= Node.fDsk node' &&
fromIntegral (Node.availDisk node') <= Node.tDsk node' &&
Node.mDsk node' == mx'
- where _types = (node::Node.Node, mx::SmallRatio)
- node' = Node.setMdsk node mx'
+ where node' = Node.setMdsk node mx'
SmallRatio mx' = mx
-- Check tag maps
+prop_Node_tagMaps_idempotent :: Property
prop_Node_tagMaps_idempotent =
forAll genTags $ \tags ->
Node.delTags (Node.addTags m tags) tags ==? m
where m = Data.Map.empty
+prop_Node_tagMaps_reject :: Property
prop_Node_tagMaps_reject =
forAll (genTags `suchThat` (not . null)) $ \tags ->
let m = Node.addTags Data.Map.empty tags
in all (\t -> Node.rejectAddTags m [t]) tags
+prop_Node_showField :: Node.Node -> Property
prop_Node_showField node =
forAll (elements Node.defaultFields) $ \ field ->
fst (Node.showHeader field) /= Types.unknownField &&
Node.showField node field /= Types.unknownField
+prop_Node_computeGroups :: [Node.Node] -> Bool
prop_Node_computeGroups nodes =
let ng = Node.computeGroups nodes
onlyuuid = map fst ng
(null nodes || not (null ng))
-- Check idempotence of add/remove operations
+prop_Node_addPri_idempotent :: Property
prop_Node_addPri_idempotent =
forAll genOnlineNode $ \node ->
forAll (genInstanceSmallerThanNode node) $ \inst ->
Types.OpGood node' -> Node.removePri node' inst ==? node
_ -> failTest "Can't add instance"
+prop_Node_addSec_idempotent :: Property
prop_Node_addSec_idempotent =
forAll genOnlineNode $ \node ->
forAll (genInstanceSmallerThanNode node) $ \inst ->
-- | Check that the cluster score is close to zero for a homogeneous
-- cluster.
-prop_Score_Zero node =
+prop_Cluster_Score_Zero :: Node.Node -> Property
+prop_Cluster_Score_Zero node =
forAll (choose (1, 1024)) $ \count ->
(not (Node.offline node) && not (Node.failN1 node) && (count > 0) &&
(Node.tDsk node > 0) && (Node.tMem node > 0)) ==>
in score <= 1e-12
-- | Check that cluster stats are sane.
-prop_CStats_sane =
+prop_Cluster_CStats_sane :: Property
+prop_Cluster_CStats_sane =
forAll (choose (1, 1024)) $ \count ->
forAll genOnlineNode $ \node ->
let fn = Node.buildPeers node Container.empty
-- | Check that one instance is allocated correctly, without
-- rebalances needed.
-prop_ClusterAlloc_sane inst =
+prop_Cluster_Alloc_sane :: Instance.Instance -> Property
+prop_Cluster_Alloc_sane inst =
forAll (choose (5, 20)) $ \count ->
forAll genOnlineNode $ \node ->
let (nl, il, inst') = makeSmallEmptyCluster node count inst
-- instance spec via tiered allocation (whatever the original instance
-- spec), on either one or two nodes. Furthermore, we test that
-- computed allocation statistics are correct.
-prop_ClusterCanTieredAlloc inst =
+prop_Cluster_CanTieredAlloc :: Instance.Instance -> Property
+prop_Cluster_CanTieredAlloc inst =
forAll (choose (2, 5)) $ \count ->
forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
let nl = makeSmallCluster node count
-- | Helper function to create a cluster with the given range of nodes
-- and allocate an instance on it.
+genClusterAlloc :: Int -> Node.Node -> Instance.Instance
+ -> Types.Result (Node.List, Instance.List, Instance.Instance)
genClusterAlloc count node inst =
let nl = makeSmallCluster node count
reqnodes = Instance.requiredNodes $ Instance.diskTemplate inst
-- | Checks that on a 4-8 node cluster, once we allocate an instance,
-- we can also relocate it.
-prop_ClusterAllocRelocate =
+prop_Cluster_AllocRelocate :: Property
+prop_Cluster_AllocRelocate =
forAll (choose (4, 8)) $ \count ->
forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
forAll (genInstanceSmallerThanNode node `suchThat` isMirrored) $ \inst ->
-- | Helper property checker for the result of a nodeEvac or
-- changeGroup operation.
+check_EvacMode :: Group.Group -> Instance.Instance
+ -> Types.Result (Node.List, Instance.List, Cluster.EvacSolution)
+ -> Property
check_EvacMode grp inst result =
case result of
Types.Bad msg -> failTest $ "Couldn't evacuate/change group:" ++ msg
failmsg "wrong target group"
(gdx == Group.idx grp)
v -> failmsg ("invalid solution: " ++ show v) False
- where failmsg = \msg -> printTestCase ("Failed to evacuate: " ++ msg)
+ where failmsg :: String -> Bool -> Property
+ failmsg = \msg -> printTestCase ("Failed to evacuate: " ++ msg)
idx = Instance.idx inst
-- | Checks that on a 4-8 node cluster, once we allocate an instance,
-- we can also node-evacuate it.
-prop_ClusterAllocEvacuate =
+prop_Cluster_AllocEvacuate :: Property
+prop_Cluster_AllocEvacuate =
forAll (choose (4, 8)) $ \count ->
forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
forAll (genInstanceSmallerThanNode node `suchThat` isMirrored) $ \inst ->
case genClusterAlloc count node inst of
Types.Bad msg -> failTest msg
Types.Ok (nl, il, inst') ->
- conjoin $ map (\mode -> check_EvacMode defGroup inst' $
+ conjoin . map (\mode -> check_EvacMode defGroup inst' $
Cluster.tryNodeEvac defGroupList nl il mode
[Instance.idx inst']) .
evacModeOptions .
-- | Checks that on a 4-8 node cluster with two node groups, once we
-- allocate an instance on the first node group, we can also change
-- its group.
-prop_ClusterAllocChangeGroup =
+prop_Cluster_AllocChangeGroup :: Property
+prop_Cluster_AllocChangeGroup =
forAll (choose (4, 8)) $ \count ->
forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
forAll (genInstanceSmallerThanNode node `suchThat` isMirrored) $ \inst ->
-- | Check that allocating multiple instances on a cluster, then
-- adding an empty node, results in a valid rebalance.
-prop_ClusterAllocBalance =
+prop_Cluster_AllocBalance :: Property
+prop_Cluster_AllocBalance =
forAll (genNode (Just 5) (Just 128)) $ \node ->
forAll (choose (3, 5)) $ \count ->
not (Node.offline node) && not (Node.failN1 node) ==>
canBalance tbl True True False
-- | Checks consistency.
-prop_ClusterCheckConsistency node inst =
+prop_Cluster_CheckConsistency :: Node.Node -> Instance.Instance -> Bool
+prop_Cluster_CheckConsistency node inst =
let nl = makeSmallCluster node 3
[node1, node2, node3] = Container.elems nl
node3' = node3 { Node.group = 1 }
(not . null $ ccheck [(0, inst3)])
-- | For now, we only test that we don't lose instances during the split.
-prop_ClusterSplitCluster node inst =
+prop_Cluster_SplitCluster :: Node.Node -> Instance.Instance -> Property
+prop_Cluster_SplitCluster node inst =
forAll (choose (0, 100)) $ \icnt ->
let nl = makeSmallCluster node 2
(nl', il') = foldl (\(ns, is) _ -> assignInstance ns is inst 0 1)
Just _ -> True
-- | Checks that allocation obeys minimum and maximum instance
--- policies. The unittest generates a random node, duplicates it count
+-- policies. The unittest generates a random node, duplicates it /count/
-- times, and generates a random instance that can be allocated on
-- this mini-cluster; it then checks that after applying a policy that
-- the instance doesn't fits, the allocation fails.
-prop_ClusterAllocPolicy node =
+prop_Cluster_AllocPolicy :: Node.Node -> Property
+prop_Cluster_AllocPolicy node =
-- rqn is the required nodes (1 or 2)
forAll (choose (1, 2)) $ \rqn ->
forAll (choose (5, 20)) $ \count ->
in not $ canAllocOn nl rqn inst
testSuite "Cluster"
- [ 'prop_Score_Zero
- , 'prop_CStats_sane
- , 'prop_ClusterAlloc_sane
- , 'prop_ClusterCanTieredAlloc
- , 'prop_ClusterAllocRelocate
- , 'prop_ClusterAllocEvacuate
- , 'prop_ClusterAllocChangeGroup
- , 'prop_ClusterAllocBalance
- , 'prop_ClusterCheckConsistency
- , 'prop_ClusterSplitCluster
- , 'prop_ClusterAllocPolicy
+ [ 'prop_Cluster_Score_Zero
+ , 'prop_Cluster_CStats_sane
+ , 'prop_Cluster_Alloc_sane
+ , 'prop_Cluster_CanTieredAlloc
+ , 'prop_Cluster_AllocRelocate
+ , 'prop_Cluster_AllocEvacuate
+ , 'prop_Cluster_AllocChangeGroup
+ , 'prop_Cluster_AllocBalance
+ , 'prop_Cluster_CheckConsistency
+ , 'prop_Cluster_SplitCluster
+ , 'prop_Cluster_AllocPolicy
]
-- ** OpCodes tests
-- | Check that opcode serialization is idempotent.
+prop_OpCodes_serialization :: OpCodes.OpCode -> Property
prop_OpCodes_serialization op =
case J.readJSON (J.showJSON op) of
J.Error e -> failTest $ "Cannot deserialise: " ++ e
J.Ok op' -> op ==? op'
- where _types = op::OpCodes.OpCode
testSuite "OpCodes"
[ 'prop_OpCodes_serialization ]
-- ** Jobs tests
-- | Check that (queued) job\/opcode status serialization is idempotent.
-prop_OpStatus_serialization os =
+prop_Jobs_OpStatus_serialization :: Jobs.OpStatus -> Property
+prop_Jobs_OpStatus_serialization os =
case J.readJSON (J.showJSON os) of
J.Error e -> failTest $ "Cannot deserialise: " ++ e
J.Ok os' -> os ==? os'
- where _types = os::Jobs.OpStatus
-prop_JobStatus_serialization js =
+prop_Jobs_JobStatus_serialization :: Jobs.JobStatus -> Property
+prop_Jobs_JobStatus_serialization js =
case J.readJSON (J.showJSON js) of
J.Error e -> failTest $ "Cannot deserialise: " ++ e
J.Ok js' -> js ==? js'
- where _types = js::Jobs.JobStatus
testSuite "Jobs"
- [ 'prop_OpStatus_serialization
- , 'prop_JobStatus_serialization
+ [ 'prop_Jobs_OpStatus_serialization
+ , 'prop_Jobs_JobStatus_serialization
]
-- ** Loader tests
+prop_Loader_lookupNode :: [(String, Int)] -> String -> String -> Property
prop_Loader_lookupNode ktn inst node =
Loader.lookupNode nl inst node ==? Data.Map.lookup node nl
where nl = Data.Map.fromList ktn
+prop_Loader_lookupInstance :: [(String, Int)] -> String -> Property
prop_Loader_lookupInstance kti inst =
Loader.lookupInstance il inst ==? Data.Map.lookup inst il
where il = Data.Map.fromList kti
+prop_Loader_assignIndices :: Property
prop_Loader_assignIndices =
-- generate nodes with unique names
forAll (arbitrary `suchThat`
-- | Checks that the number of primary instances recorded on the nodes
-- is zero.
+prop_Loader_mergeData :: [Node.Node] -> Bool
prop_Loader_mergeData ns =
let na = Container.fromList $ map (\n -> (Node.idx n, n)) ns
in case Loader.mergeData [] [] [] []
-- | Check that compareNameComponent on equal strings works.
prop_Loader_compareNameComponent_equal :: String -> Bool
prop_Loader_compareNameComponent_equal s =
- Loader.compareNameComponent s s ==
- Loader.LookupResult Loader.ExactMatch s
+ BasicTypes.compareNameComponent s s ==
+ BasicTypes.LookupResult BasicTypes.ExactMatch s
-- | Check that compareNameComponent on prefix strings works.
prop_Loader_compareNameComponent_prefix :: NonEmptyList Char -> String -> Bool
prop_Loader_compareNameComponent_prefix (NonEmpty s1) s2 =
- Loader.compareNameComponent (s1 ++ "." ++ s2) s1 ==
- Loader.LookupResult Loader.PartialMatch s1
+ BasicTypes.compareNameComponent (s1 ++ "." ++ s2) s1 ==
+ BasicTypes.LookupResult BasicTypes.PartialMatch s1
testSuite "Loader"
[ 'prop_Loader_lookupNode
-- ** Types tests
+prop_Types_AllocPolicy_serialisation :: Types.AllocPolicy -> Property
prop_Types_AllocPolicy_serialisation apol =
case J.readJSON (J.showJSON apol) of
J.Ok p -> p ==? apol
J.Error s -> failTest $ "Failed to deserialise: " ++ s
- where _types = apol::Types.AllocPolicy
+prop_Types_DiskTemplate_serialisation :: Types.DiskTemplate -> Property
prop_Types_DiskTemplate_serialisation dt =
case J.readJSON (J.showJSON dt) of
J.Ok p -> p ==? dt
J.Error s -> failTest $ "Failed to deserialise: " ++ s
- where _types = dt::Types.DiskTemplate
+prop_Types_ISpec_serialisation :: Types.ISpec -> Property
prop_Types_ISpec_serialisation ispec =
case J.readJSON (J.showJSON ispec) of
J.Ok p -> p ==? ispec
J.Error s -> failTest $ "Failed to deserialise: " ++ s
- where _types = ispec::Types.ISpec
+prop_Types_IPolicy_serialisation :: Types.IPolicy -> Property
prop_Types_IPolicy_serialisation ipol =
case J.readJSON (J.showJSON ipol) of
J.Ok p -> p ==? ipol
J.Error s -> failTest $ "Failed to deserialise: " ++ s
- where _types = ipol::Types.IPolicy
+prop_Types_EvacMode_serialisation :: Types.EvacMode -> Property
prop_Types_EvacMode_serialisation em =
case J.readJSON (J.showJSON em) of
J.Ok p -> p ==? em
J.Error s -> failTest $ "Failed to deserialise: " ++ s
- where _types = em::Types.EvacMode
+prop_Types_opToResult :: Types.OpResult Int -> Bool
prop_Types_opToResult op =
case op of
Types.OpFail _ -> Types.isBad r
Types.Bad _ -> False
Types.Ok v' -> v == v'
where r = Types.opToResult op
- _types = op::Types.OpResult Int
+prop_Types_eitherToResult :: Either String Int -> Bool
prop_Types_eitherToResult ei =
case ei of
Left _ -> Types.isBad r
Types.Bad _ -> False
Types.Ok v' -> v == v'
where r = Types.eitherToResult ei
- _types = ei::Either String Int
testSuite "Types"
[ 'prop_Types_AllocPolicy_serialisation
-- ** CLI tests
-- | Test correct parsing.
+prop_CLI_parseISpec :: String -> Int -> Int -> Int -> Property
prop_CLI_parseISpec descr dsk mem cpu =
- let str = printf "%d,%d,%d" dsk mem cpu
+ let str = printf "%d,%d,%d" dsk mem cpu::String
in CLI.parseISpecString descr str ==? Types.Ok (Types.RSpec cpu mem dsk)
-- | Test parsing failure due to wrong section count.
+prop_CLI_parseISpecFail :: String -> Property
prop_CLI_parseISpecFail descr =
forAll (choose (0,100) `suchThat` ((/=) 3)) $ \nelems ->
forAll (replicateM nelems arbitrary) $ \values ->
_ -> property True
-- | Test parseYesNo.
+prop_CLI_parseYesNo :: Bool -> Bool -> [Char] -> Property
prop_CLI_parseYesNo def testval val =
forAll (elements [val, "yes", "no"]) $ \actual_val ->
if testval
else property $ Types.isBad result
-- | Helper to check for correct parsing of string arg.
+checkStringArg :: [Char]
+ -> (GetOpt.OptDescr (CLI.Options -> Types.Result CLI.Options),
+ CLI.Options -> Maybe [Char])
+ -> Property
checkStringArg val (opt, fn) =
let GetOpt.Option _ longs _ _ = opt
in case longs of
Right (options, _) -> fn options ==? Just val
-- | Test a few string arguments.
+prop_CLI_StringArg :: [Char] -> Property
prop_CLI_StringArg argument =
let args = [ (CLI.oDataFile, CLI.optDataFile)
, (CLI.oDynuFile, CLI.optDynuFile)
in conjoin $ map (checkStringArg argument) args
-- | Helper to test that a given option is accepted OK with quick exit.
+checkEarlyExit :: String -> [CLI.OptType] -> String -> Property
checkEarlyExit name options param =
case CLI.parseOptsInner [param] name options of
Left (code, _) -> if code == 0
-- | Test that all binaries support some common options. There is
-- nothing actually random about this test...
+prop_CLI_stdopts :: Property
prop_CLI_stdopts =
let params = ["-h", "--help", "-V", "--version"]
opts = map (\(name, (_, o)) -> (name, o)) Program.personalities
-- * Luxi tests
-instance Arbitrary Luxi.LuxiReq where
+instance Arbitrary Luxi.TagObject where
arbitrary = elements [minBound..maxBound]
-instance Arbitrary Luxi.QrViaLuxi where
+instance Arbitrary Luxi.LuxiReq 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.ReqQuery -> Luxi.Query <$> arbitrary <*> getFields <*> genFilter
Luxi.ReqQueryNodes -> Luxi.QueryNodes <$> (listOf getFQDN) <*>
getFields <*> arbitrary
Luxi.ReqQueryGroups -> Luxi.QueryGroups <$> arbitrary <*>
(listOf getFQDN) <*> arbitrary
Luxi.ReqQueryConfigValues -> Luxi.QueryConfigValues <$> getFields
Luxi.ReqQueryClusterInfo -> pure Luxi.QueryClusterInfo
- Luxi.ReqQueryTags -> Luxi.QueryTags <$> getName <*> getFQDN
+ Luxi.ReqQueryTags -> Luxi.QueryTags <$> arbitrary <*> getFQDN
Luxi.ReqSubmitJob -> Luxi.SubmitJob <$> (resize maxOpCodes arbitrary)
Luxi.ReqSubmitManyJobs -> Luxi.SubmitManyJobs <$>
(resize maxOpCodes arbitrary)
prop_Luxi_CallEncoding op =
(Luxi.validateCall (Luxi.buildCall op) >>= Luxi.decodeCall) ==? Types.Ok op
-testSuite "LUXI"
+-- | Helper to a get a temporary file name.
+getTempFileName :: IO FilePath
+getTempFileName = do
+ tempdir <- getTemporaryDirectory
+ (fpath, handle) <- openTempFile tempdir "luxitest"
+ _ <- hClose handle
+ removeFile fpath
+ return fpath
+
+-- | Server ping-pong helper.
+luxiServerPong :: Luxi.Client -> IO ()
+luxiServerPong c = do
+ msg <- Luxi.recvMsgExt c
+ case msg of
+ Luxi.RecvOk m -> Luxi.sendMsg c m >> luxiServerPong c
+ _ -> return ()
+
+-- | Client ping-pong helper.
+luxiClientPong :: Luxi.Client -> [String] -> IO [String]
+luxiClientPong c =
+ mapM (\m -> Luxi.sendMsg c m >> Luxi.recvMsg c)
+
+-- | Monadic check that, given a server socket, we can connect via a
+-- client to it, and that we can send a list of arbitrary messages and
+-- get back what we sent.
+prop_Luxi_ClientServer :: [[DNSChar]] -> Property
+prop_Luxi_ClientServer dnschars = monadicIO $ do
+ let msgs = map (map dnsGetChar) dnschars
+ fpath <- run $ getTempFileName
+ -- we need to create the server first, otherwise (if we do it in the
+ -- forked thread) the client could try to connect to it before it's
+ -- ready
+ server <- run $ Luxi.getServer fpath
+ -- fork the server responder
+ _ <- run . forkIO $
+ bracket
+ (Luxi.acceptClient server)
+ (\c -> Luxi.closeClient c >> Luxi.closeServer fpath server)
+ luxiServerPong
+ replies <- run $
+ bracket
+ (Luxi.getClient fpath)
+ Luxi.closeClient
+ (\c -> luxiClientPong c msgs)
+ assert $ replies == msgs
+
+testSuite "Luxi"
[ 'prop_Luxi_CallEncoding
+ , 'prop_Luxi_ClientServer
]
-- * Ssconf tests
instance Arbitrary Ssconf.SSKey where
arbitrary = elements [minBound..maxBound]
+prop_Ssconf_filename :: Ssconf.SSKey -> Property
prop_Ssconf_filename key =
printTestCase "Key doesn't start with correct prefix" $
Ssconf.sSFilePrefix `isPrefixOf` Ssconf.keyToFilename (Just "") key
testSuite "Ssconf"
[ 'prop_Ssconf_filename
]
+
+-- * Rpc tests
+
+-- | Monadic check that, for an offline node and a call that does not
+-- offline nodes, we get a OfflineNodeError response.
+-- FIXME: We need a way of generalizing this, running it for
+-- every call manually will soon get problematic
+prop_Rpc_noffl_request_allinstinfo :: Rpc.RpcCallAllInstancesInfo -> Property
+prop_Rpc_noffl_request_allinstinfo call =
+ forAll (arbitrary `suchThat` Objects.nodeOffline) $ \node -> monadicIO $ do
+ res <- run $ Rpc.executeRpcCall [node] call
+ stop $ res ==? [(node, Left (Rpc.OfflineNodeError node))]
+
+prop_Rpc_noffl_request_instlist :: Rpc.RpcCallInstanceList -> Property
+prop_Rpc_noffl_request_instlist call =
+ forAll (arbitrary `suchThat` Objects.nodeOffline) $ \node -> monadicIO $ do
+ res <- run $ Rpc.executeRpcCall [node] call
+ stop $ res ==? [(node, Left (Rpc.OfflineNodeError node))]
+
+prop_Rpc_noffl_request_nodeinfo :: Rpc.RpcCallNodeInfo -> Property
+prop_Rpc_noffl_request_nodeinfo call =
+ forAll (arbitrary `suchThat` Objects.nodeOffline) $ \node -> monadicIO $ do
+ res <- run $ Rpc.executeRpcCall [node] call
+ stop $ res ==? [(node, Left (Rpc.OfflineNodeError node))]
+
+testSuite "Rpc"
+ [ 'prop_Rpc_noffl_request_allinstinfo
+ , 'prop_Rpc_noffl_request_instlist
+ , 'prop_Rpc_noffl_request_nodeinfo
+ ]
+
+-- * Qlang tests
+
+-- | Tests that serialisation/deserialisation of filters is
+-- idempotent.
+prop_Qlang_Serialisation :: Property
+prop_Qlang_Serialisation =
+ forAll genFilter $ \flt ->
+ J.readJSON (J.showJSON flt) ==? J.Ok flt
+
+testSuite "Qlang"
+ [ 'prop_Qlang_Serialisation
+ ]
projects / ganeti-local / blobdiff