+{-# LANGUAGE TemplateHaskell #-}
+
{-| Unittests for ganeti-htools.
-}
import qualified Ganeti.HTools.Program.Hscan
import qualified Ganeti.HTools.Program.Hspace
-run :: Testable prop => prop -> Args -> IO Result
-run = flip quickCheckWithResult
+import Ganeti.HTools.QCHelper (testSuite)
-- * Constants
isFailure (Types.OpFail _) = True
isFailure _ = False
+-- | Checks for equality with proper annotation.
+(==?) :: (Show a, Eq a) => a -> a -> Property
+(==?) x y = printTestCase
+ ("Expected equality, but '" ++
+ show x ++ "' /= '" ++ show y ++ "'") (x == y)
+infix 3 ==?
+
-- | Update an instance to be smaller than a node.
setInstanceSmallerThanNode node inst =
inst { Instance.mem = Node.availMem node `div` 2
prop_Utils_commaJoinSplit =
forAll (arbitrary `suchThat`
(\l -> l /= [""] && all (not . elem ',') l )) $ \lst ->
- Utils.sepSplit ',' (Utils.commaJoin lst) == lst
+ Utils.sepSplit ',' (Utils.commaJoin lst) ==? lst
-- | Split and join should always be idempotent.
-prop_Utils_commaSplitJoin s = Utils.commaJoin (Utils.sepSplit ',' s) == s
+prop_Utils_commaSplitJoin s =
+ Utils.commaJoin (Utils.sepSplit ',' s) ==? s
-- | fromObjWithDefault, we test using the Maybe monad and an integer
-- value.
where _types = def_value :: Integer
-- | Test that functional if' behaves like the syntactic sugar if.
-prop_Utils_if'if :: Bool -> Int -> Int -> Bool
-prop_Utils_if'if cnd a b = Utils.if' cnd a b == if cnd then a else b
+prop_Utils_if'if :: Bool -> Int -> Int -> Gen Prop
+prop_Utils_if'if cnd a b =
+ Utils.if' cnd a b ==? if cnd then a else b
-- | Test basic select functionality
-prop_Utils_select :: Int -- ^ Default result
- -> [Int] -- ^ List of False values
- -> [Int] -- ^ List of True values
- -> Bool -- ^ Test result
+prop_Utils_select :: Int -- ^ Default result
+ -> [Int] -- ^ List of False values
+ -> [Int] -- ^ List of True values
+ -> Gen Prop -- ^ Test result
prop_Utils_select def lst1 lst2 =
- Utils.select def cndlist == expectedresult
+ Utils.select def cndlist ==? expectedresult
where expectedresult = Utils.if' (null lst2) def (head lst2)
flist = map (\e -> (False, e)) lst1
tlist = map (\e -> (True, e)) lst2
cndlist = flist ++ tlist
-- | Test basic select functionality with undefined default
-prop_Utils_select_undefd :: [Int] -- ^ List of False values
+prop_Utils_select_undefd :: [Int] -- ^ List of False values
-> NonEmptyList Int -- ^ List of True values
- -> Bool -- ^ Test result
+ -> Gen Prop -- ^ Test result
prop_Utils_select_undefd lst1 (NonEmpty lst2) =
- Utils.select undefined cndlist == head lst2
+ Utils.select undefined cndlist ==? head lst2
where flist = map (\e -> (False, e)) lst1
tlist = map (\e -> (True, e)) lst2
cndlist = flist ++ tlist
-- | Test basic select functionality with undefined list values
-prop_Utils_select_undefv :: [Int] -- ^ List of False values
+prop_Utils_select_undefv :: [Int] -- ^ List of False values
-> NonEmptyList Int -- ^ List of True values
- -> Bool -- ^ Test result
+ -> Gen Prop -- ^ Test result
prop_Utils_select_undefv lst1 (NonEmpty lst2) =
- Utils.select undefined cndlist == head lst2
+ Utils.select undefined cndlist ==? head lst2
where flist = map (\e -> (False, e)) lst1
tlist = map (\e -> (True, e)) lst2
cndlist = flist ++ tlist ++ [undefined]
where _types = n::Int
-- | Test list for the Utils module.
-testUtils =
- [ run prop_Utils_commaJoinSplit
- , run prop_Utils_commaSplitJoin
- , run prop_Utils_fromObjWithDefault
- , run prop_Utils_if'if
- , run prop_Utils_select
- , run prop_Utils_select_undefd
- , run prop_Utils_select_undefv
- , run prop_Utils_parseUnit
- ]
+testSuite "Utils"
+ [ 'prop_Utils_commaJoinSplit
+ , 'prop_Utils_commaSplitJoin
+ , 'prop_Utils_fromObjWithDefault
+ , 'prop_Utils_if'if
+ , 'prop_Utils_select
+ , 'prop_Utils_select_undefd
+ , 'prop_Utils_select_undefv
+ , 'prop_Utils_parseUnit
+ ]
-- ** PeerMap tests
-- | Make sure add is idempotent.
prop_PeerMap_addIdempotent pmap key em =
- fn puniq == fn (fn puniq)
+ fn puniq ==? fn (fn puniq)
where _types = (pmap::PeerMap.PeerMap,
key::PeerMap.Key, em::PeerMap.Elem)
fn = PeerMap.add key em
-- | Make sure remove is idempotent.
prop_PeerMap_removeIdempotent pmap key =
- fn puniq == fn (fn puniq)
+ fn puniq ==? fn (fn puniq)
where _types = (pmap::PeerMap.PeerMap, key::PeerMap.Key)
fn = PeerMap.remove key
puniq = PeerMap.accumArray const pmap
-- | Make sure a missing item returns 0.
prop_PeerMap_findMissing pmap key =
- PeerMap.find key (PeerMap.remove key puniq) == 0
+ PeerMap.find key (PeerMap.remove key puniq) ==? 0
where _types = (pmap::PeerMap.PeerMap, key::PeerMap.Key)
puniq = PeerMap.accumArray const pmap
-- | Make sure an added item is found.
prop_PeerMap_addFind pmap key em =
- PeerMap.find key (PeerMap.add key em puniq) == 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
-- | Manual check that maxElem returns the maximum indeed, or 0 for null.
prop_PeerMap_maxElem pmap =
- PeerMap.maxElem puniq == if null puniq then 0
- else (maximum . snd . unzip) puniq
+ PeerMap.maxElem puniq ==? if null puniq then 0
+ else (maximum . snd . unzip) puniq
where _types = pmap::PeerMap.PeerMap
puniq = PeerMap.accumArray const pmap
-- | List of tests for the PeerMap module.
-testPeerMap =
- [ run prop_PeerMap_addIdempotent
- , run prop_PeerMap_removeIdempotent
- , run prop_PeerMap_maxElem
- , run prop_PeerMap_addFind
- , run prop_PeerMap_findMissing
- ]
+testSuite "PeerMap"
+ [ 'prop_PeerMap_addIdempotent
+ , 'prop_PeerMap_removeIdempotent
+ , 'prop_PeerMap_maxElem
+ , 'prop_PeerMap_addFind
+ , 'prop_PeerMap_findMissing
+ ]
-- ** Container tests
prop_Container_nameOf node =
let nl = makeSmallCluster node 1
fnode = head (Container.elems nl)
- in Container.nameOf nl (Node.idx fnode) == Node.name fnode
+ in Container.nameOf nl (Node.idx fnode) ==? Node.name fnode
-- | 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,
Container.findByName nl' (Node.alias target) == Just target &&
Container.findByName nl' othername == Nothing
-testContainer =
- [ run prop_Container_addTwo
- , run prop_Container_nameOf
- , run prop_Container_findByName
- ]
+testSuite "Container"
+ [ 'prop_Container_addTwo
+ , 'prop_Container_nameOf
+ , 'prop_Container_findByName
+ ]
-- ** Instance tests
-- Simple instance tests, we only have setter/getters
prop_Instance_creat inst =
- Instance.name inst == Instance.alias inst
+ Instance.name inst ==? Instance.alias inst
prop_Instance_setIdx inst idx =
- Instance.idx (Instance.setIdx inst idx) == idx
+ Instance.idx (Instance.setIdx inst idx) ==? idx
where _types = (inst::Instance.Instance, idx::Types.Idx)
prop_Instance_setName inst name =
newinst = Instance.setAlias inst name
prop_Instance_setPri inst pdx =
- Instance.pNode (Instance.setPri inst pdx) == pdx
+ Instance.pNode (Instance.setPri inst pdx) ==? pdx
where _types = (inst::Instance.Instance, pdx::Types.Ndx)
prop_Instance_setSec inst sdx =
- Instance.sNode (Instance.setSec inst sdx) == sdx
+ Instance.sNode (Instance.setSec inst sdx) ==? sdx
where _types = (inst::Instance.Instance, sdx::Types.Ndx)
prop_Instance_setBoth inst pdx sdx =
in Types.isBad $ Instance.shrinkByType inst' Types.FailDisk
prop_Instance_setMovable inst m =
- Instance.movable inst' == m
+ Instance.movable inst' ==? m
where inst' = Instance.setMovable inst m
-testInstance =
- [ run prop_Instance_creat
- , run prop_Instance_setIdx
- , run prop_Instance_setName
- , run prop_Instance_setAlias
- , run prop_Instance_setPri
- , run prop_Instance_setSec
- , run prop_Instance_setBoth
- , run prop_Instance_runStatus_True
- , run prop_Instance_runStatus_False
- , run prop_Instance_shrinkMG
- , run prop_Instance_shrinkMF
- , run prop_Instance_shrinkCG
- , run prop_Instance_shrinkCF
- , run prop_Instance_shrinkDG
- , run prop_Instance_shrinkDF
- , run prop_Instance_setMovable
- ]
+testSuite "Instance"
+ [ 'prop_Instance_creat
+ , 'prop_Instance_setIdx
+ , 'prop_Instance_setName
+ , 'prop_Instance_setAlias
+ , 'prop_Instance_setPri
+ , 'prop_Instance_setSec
+ , 'prop_Instance_setBoth
+ , 'prop_Instance_runStatus_True
+ , 'prop_Instance_runStatus_False
+ , 'prop_Instance_shrinkMG
+ , 'prop_Instance_shrinkMF
+ , 'prop_Instance_shrinkCG
+ , 'prop_Instance_shrinkCF
+ , 'prop_Instance_shrinkDG
+ , 'prop_Instance_shrinkDF
+ , 'prop_Instance_setMovable
+ ]
-- ** Text backend tests
nl = Data.Map.fromList ndx
tags = ""
sbal = if autobal then "Y" else "N"
- sdt = Types.dtToString dt
+ sdt = Types.diskTemplateToString dt
inst = Text.loadInst nl
[name, mem_s, dsk_s, vcpus_s, status,
sbal, pnode, snode, sdt, tags]
-- override failN1 to what loadNode returns by default
where n = node { Node.failN1 = True, Node.offline = False }
-testText =
- [ run prop_Text_Load_Instance
- , run prop_Text_Load_InstanceFail
- , run prop_Text_Load_Node
- , run prop_Text_Load_NodeFail
- , run prop_Text_NodeLSIdempotent
- ]
+testSuite "Text"
+ [ 'prop_Text_Load_Instance
+ , 'prop_Text_Load_InstanceFail
+ , 'prop_Text_Load_Node
+ , 'prop_Text_Load_NodeFail
+ , 'prop_Text_NodeLSIdempotent
+ ]
-- ** Node tests
newnode = Node.setAlias node name
prop_Node_setOffline node status =
- Node.offline newnode == status
+ Node.offline newnode ==? status
where newnode = Node.setOffline node status
prop_Node_setXmem node xm =
- Node.xMem newnode == xm
+ Node.xMem newnode ==? xm
where newnode = Node.setXmem node xm
prop_Node_setMcpu node mc =
- Node.mCpu newnode == mc
+ Node.mCpu newnode ==? mc
where newnode = Node.setMcpu node mc
-- | Check that an instance add with too high memory or disk will be
-- Check tag maps
prop_Node_tagMaps_idempotent tags =
- Node.delTags (Node.addTags m tags) tags == m
+ Node.delTags (Node.addTags m tags) tags ==? m
where m = Data.Map.empty
prop_Node_tagMaps_reject tags =
not (null tags) ==>
- any (\t -> Node.rejectAddTags m [t]) tags
+ all (\t -> Node.rejectAddTags m [t]) tags
where m = Node.addTags Data.Map.empty tags
prop_Node_showField node =
fst (Node.showHeader field) /= Types.unknownField &&
Node.showField node field /= Types.unknownField
-
prop_Node_computeGroups nodes =
let ng = Node.computeGroups nodes
onlyuuid = map fst ng
length (nub onlyuuid) == length onlyuuid &&
(null nodes || not (null ng))
-testNode =
- [ run prop_Node_setAlias
- , run prop_Node_setOffline
- , run prop_Node_setMcpu
- , run prop_Node_setXmem
- , run prop_Node_addPriFM
- , run prop_Node_addPriFD
- , run prop_Node_addPriFC
- , run prop_Node_addSec
- , run prop_Node_rMem
- , run prop_Node_setMdsk
- , run prop_Node_tagMaps_idempotent
- , run prop_Node_tagMaps_reject
- , run prop_Node_showField
- , run prop_Node_computeGroups
- ]
-
+testSuite "Node"
+ [ 'prop_Node_setAlias
+ , 'prop_Node_setOffline
+ , 'prop_Node_setMcpu
+ , 'prop_Node_setXmem
+ , 'prop_Node_addPriFM
+ , 'prop_Node_addPriFD
+ , 'prop_Node_addPriFC
+ , 'prop_Node_addSec
+ , 'prop_Node_rMem
+ , 'prop_Node_setMdsk
+ , 'prop_Node_tagMaps_idempotent
+ , 'prop_Node_tagMaps_reject
+ , 'prop_Node_showField
+ , 'prop_Node_computeGroups
+ ]
-- ** Cluster tests
Cluster.tryAlloc nl il inst' of
Types.Bad _ -> False
Types.Ok as ->
- case Cluster.asSolutions as of
- [] -> False
- (xnl, xi, _, cv):[] ->
+ case Cluster.asSolution as of
+ Nothing -> False
+ Just (xnl, xi, _, cv) ->
let il' = Container.add (Instance.idx xi) xi il
tbl = Cluster.Table xnl il' cv []
in not (canBalance tbl True True False)
- _ -> False
-- | Checks that on a 2-5 node cluster, we can allocate a random
-- instance spec via tiered allocation (whatever the original instance
Cluster.tryAlloc nl il inst' of
Types.Bad _ -> False
Types.Ok as ->
- case Cluster.asSolutions as of
- [] -> False
- (xnl, xi, _, _):[] ->
+ case Cluster.asSolution as of
+ Nothing -> False
+ Just (xnl, xi, _, _) ->
let sdx = Instance.sNode xi
il' = Container.add (Instance.idx xi) xi il
in case IAlloc.processRelocate defGroupList xnl il'
(Instance.idx xi) 1 [sdx] of
Types.Ok _ -> True
_ -> False
- _ -> False
-- | Check that allocating multiple instances on a cluster, then
-- adding an empty node, results in a valid rebalance.
all (\(guuid, (nl'', _)) -> all ((== guuid) . Node.group)
(Container.elems nl'')) gni
-testCluster =
- [ run prop_Score_Zero
- , run prop_CStats_sane
- , run prop_ClusterAlloc_sane
- , run prop_ClusterCanTieredAlloc
- , run prop_ClusterAllocEvac
- , run prop_ClusterAllocBalance
- , run prop_ClusterCheckConsistency
- , run prop_ClusterSplitCluster
- ]
+testSuite "Cluster"
+ [ 'prop_Score_Zero
+ , 'prop_CStats_sane
+ , 'prop_ClusterAlloc_sane
+ , 'prop_ClusterCanTieredAlloc
+ , 'prop_ClusterAllocEvac
+ , 'prop_ClusterAllocBalance
+ , 'prop_ClusterCheckConsistency
+ , 'prop_ClusterSplitCluster
+ ]
-- ** OpCodes tests
-- | Check that opcode serialization is idempotent.
prop_OpCodes_serialization op =
case J.readJSON (J.showJSON op) of
- J.Error _ -> False
- J.Ok op' -> op == op'
+ J.Error e -> printTestCase ("Cannot deserialise: " ++ e) False
+ J.Ok op' -> op ==? op'
where _types = op::OpCodes.OpCode
-testOpCodes =
- [ run prop_OpCodes_serialization
- ]
+testSuite "OpCodes"
+ [ 'prop_OpCodes_serialization ]
-- ** Jobs tests
-- | Check that (queued) job\/opcode status serialization is idempotent.
prop_OpStatus_serialization os =
case J.readJSON (J.showJSON os) of
- J.Error _ -> False
- J.Ok os' -> os == os'
+ J.Error e -> printTestCase ("Cannot deserialise: " ++ e) False
+ J.Ok os' -> os ==? os'
where _types = os::Jobs.OpStatus
prop_JobStatus_serialization js =
case J.readJSON (J.showJSON js) of
- J.Error _ -> False
- J.Ok js' -> js == js'
+ J.Error e -> printTestCase ("Cannot deserialise: " ++ e) False
+ J.Ok js' -> js ==? js'
where _types = js::Jobs.JobStatus
-testJobs =
- [ run prop_OpStatus_serialization
- , run prop_JobStatus_serialization
- ]
+testSuite "Jobs"
+ [ 'prop_OpStatus_serialization
+ , 'prop_JobStatus_serialization
+ ]
-- ** Loader tests
prop_Loader_lookupNode ktn inst node =
- Loader.lookupNode nl inst node == Data.Map.lookup node nl
+ Loader.lookupNode nl inst node ==? Data.Map.lookup node nl
where nl = Data.Map.fromList ktn
prop_Loader_lookupInstance kti inst =
- Loader.lookupInstance il inst == Data.Map.lookup inst il
+ Loader.lookupInstance il inst ==? Data.Map.lookup inst il
where il = Data.Map.fromList kti
prop_Loader_assignIndices nodes =
Loader.compareNameComponent (s1 ++ "." ++ s2) s1 ==
Loader.LookupResult Loader.PartialMatch s1
-testLoader =
- [ run prop_Loader_lookupNode
- , run prop_Loader_lookupInstance
- , run prop_Loader_assignIndices
- , run prop_Loader_mergeData
- , run prop_Loader_compareNameComponent_equal
- , run prop_Loader_compareNameComponent_prefix
- ]
+testSuite "Loader"
+ [ 'prop_Loader_lookupNode
+ , 'prop_Loader_lookupInstance
+ , 'prop_Loader_assignIndices
+ , 'prop_Loader_mergeData
+ , 'prop_Loader_compareNameComponent_equal
+ , 'prop_Loader_compareNameComponent_prefix
+ ]
-- ** Types tests
where r = Types.eitherToResult ei
_types = ei::Either String Int
-testTypes =
- [ run prop_Types_AllocPolicy_serialisation
- , run prop_Types_DiskTemplate_serialisation
- , run prop_Types_opToResult
- , run prop_Types_eitherToResult
- ]
+testSuite "Types"
+ [ 'prop_Types_AllocPolicy_serialisation
+ , 'prop_Types_DiskTemplate_serialisation
+ , 'prop_Types_opToResult
+ , 'prop_Types_eitherToResult
+ ]
projects / ganeti-local / blobdiff