show x ++ "' /= '" ++ show y ++ "'") (x == y)
infix 3 ==?
+-- | Show a message and fail the test.
+failTest :: String -> Property
+failTest msg = printTestCase msg False
+
-- | Update an instance to be smaller than a node.
setInstanceSmallerThanNode node inst =
inst { Instance.mem = Node.availMem node `div` 2
, Instance.vcpus = Node.availCpu node `div` 2
}
+-- | Check if an instance is smaller than a node.
+isInstanceSmallerThanNode node inst =
+ Instance.mem inst <= Node.availMem node `div` 2 &&
+ Instance.dsk inst <= Node.availDisk node `div` 2 &&
+ Instance.vcpus inst <= Node.availCpu node `div` 2
+
-- | Create an instance given its spec.
createInstance mem dsk vcpus =
Instance.create "inst-unnamed" mem dsk vcpus Types.Running [] True (-1) (-1)
-- | Create a small cluster by repeating a node spec.
makeSmallCluster :: Node.Node -> Int -> Node.List
makeSmallCluster node count =
- let fn = Node.buildPeers node Container.empty
- namelst = map (\n -> (Node.name n, n)) (replicate count fn)
+ let origname = Node.name node
+ origalias = Node.alias node
+ nodes = map (\idx -> node { Node.name = origname ++ "-" ++ show idx
+ , Node.alias = origalias ++ "-" ++ show idx })
+ [1..count]
+ fn = flip Node.buildPeers Container.empty
+ namelst = map (\n -> (Node.name n, fn n)) nodes
(_, nlst) = Loader.assignIndices namelst
in nlst
setInstanceSmallerThanNode node inst)
-- | Checks if a node is "big" enough.
-isNodeBig :: Node.Node -> Int -> Bool
-isNodeBig node size = Node.availDisk node > size * Types.unitDsk
+isNodeBig :: Int -> Node.Node -> Bool
+isNodeBig size node = Node.availDisk node > size * Types.unitDsk
&& Node.availMem node > size * Types.unitMem
&& Node.availCpu node > size * Types.unitCpu
let frest' = map (map dnsGetChar) frest
return (felem ++ "." ++ intercalate "." frest')
+-- | Defines a tag type.
+newtype TagChar = TagChar { tagGetChar :: Char }
+
+-- | All valid tag chars. This doesn't need to match _exactly_
+-- Ganeti's own tag regex, just enough for it to be close.
+tagChar :: [Char]
+tagChar = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ".+*/:@-"
+
+instance Arbitrary TagChar where
+ arbitrary = do
+ c <- elements tagChar
+ return (TagChar c)
+
+-- | Generates a tag
+genTag :: Gen [TagChar]
+genTag = do
+ -- the correct value would be C.maxTagLen, but that's way too
+ -- verbose in unittests, and at the moment I don't see any possible
+ -- bugs with longer tags and the way we use tags in htools
+ n <- choose (1, 10)
+ vector n
+
+-- | Generates a list of tags (correctly upper bounded).
+genTags :: Gen [String]
+genTags = do
+ -- the correct value would be C.maxTagsPerObj, but per the comment
+ -- in genTag, we don't use tags enough in htools to warrant testing
+ -- such big values
+ n <- choose (0, 10::Int)
+ tags <- mapM (const genTag) [1..n]
+ return $ map (map tagGetChar) tags
+
instance Arbitrary Types.InstanceStatus where
arbitrary = elements [minBound..maxBound]
n' = Node.setPolicy nullIPolicy n
return $ Node.buildPeers n' Container.empty
+-- | Helper function to generate a sane node.
+genOnlineNode :: Gen Node.Node
+genOnlineNode = do
+ arbitrary `suchThat` (\n -> not (Node.offline n) &&
+ not (Node.failN1 n) &&
+ Node.availDisk n > 0 &&
+ Node.availMem n > 0 &&
+ Node.availCpu n > 0)
+
-- and a random node
instance Arbitrary Node.Node where
arbitrary = genNode Nothing Nothing
instance Arbitrary Types.FailMode where
arbitrary = elements [minBound..maxBound]
+instance Arbitrary Types.EvacMode where
+ arbitrary = elements [minBound..maxBound]
+
instance Arbitrary a => Arbitrary (Types.OpResult a) where
arbitrary = arbitrary >>= \c ->
if c
, snode::String
, autobal::Bool)
in case inst of
- Types.Bad msg -> printTestCase ("Failed to load instance: " ++ msg)
- False
+ Types.Bad msg -> failTest $ "Failed to load instance: " ++ msg
Types.Ok (_, i) -> printTestCase "Mismatch in some field while\
\ loading the instance" $
Instance.name i == name &&
prop_Text_Load_InstanceFail ktn fields =
length fields /= 10 ==>
case Text.loadInst nl fields of
- Types.Ok _ -> printTestCase "Managed to load instance from invalid\
- \ data" False
+ Types.Ok _ -> failTest "Managed to load instance from invalid data"
Types.Bad msg -> printTestCase ("Unrecognised error message: " ++ msg) $
"Invalid/incomplete instance data: '" `isPrefixOf` msg
where nl = Data.Map.fromList ktn
where n = node { Node.failN1 = True, Node.offline = False
, Node.iPolicy = Types.defIPolicy }
+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 ipol =
+ case Text.loadIPolicy . Utils.sepSplit '|' $
+ Text.serializeIPolicy owner ipol of
+ Types.Bad msg -> failTest $ "Failed to load ispec: " ++ msg
+ Types.Ok res -> (owner, ipol) ==? res
+ where owner = "dummy"
+
+-- | This property, while being in the text tests, does more than just
+-- test end-to-end the serialisation and loading back workflow; it
+-- also tests the Loader.mergeData and the actuall
+-- Cluster.iterateAlloc (for well-behaving w.r.t. instance
+-- 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 =
+ forAll genTags $ \ctags ->
+ forAll (choose (1, 2)) $ \reqnodes ->
+ forAll (choose (1, 20)) $ \maxiter ->
+ forAll (choose (2, 10)) $ \count ->
+ forAll genOnlineNode $ \node ->
+ forAll (arbitrary `suchThat` isInstanceSmallerThanNode node) $ \inst ->
+ let inst' = Instance.setMovable inst $ Utils.if' (reqnodes == 2) True False
+ nl = makeSmallCluster node count
+ in case Cluster.genAllocNodes defGroupList nl reqnodes True >>= \allocn ->
+ Cluster.iterateAlloc nl Container.empty (Just maxiter) inst' allocn [] []
+ of
+ Types.Bad msg -> failTest $ "Failed to allocate: " ++ msg
+ Types.Ok (_, _, _, [], _) -> printTestCase
+ "Failed to allocate: no allocations" False
+ Types.Ok (_, nl', il', _, _) ->
+ let cdata = Loader.ClusterData defGroupList nl' il' ctags
+ Types.defIPolicy
+ saved = Text.serializeCluster cdata
+ in case Text.parseData saved >>= Loader.mergeData [] [] [] [] of
+ Types.Bad msg -> failTest $ "Failed to load/merge: " ++ msg
+ Types.Ok (Loader.ClusterData gl2 nl2 il2 ctags2 cpol2) ->
+ ctags ==? ctags2 .&&.
+ Types.defIPolicy ==? cpol2 .&&.
+ il' ==? il2 .&&.
+ defGroupList ==? gl2 .&&.
+ nl' ==? nl2
+
testSuite "Text"
[ 'prop_Text_Load_Instance
, 'prop_Text_Load_InstanceFail
, 'prop_Text_Load_Node
, 'prop_Text_Load_NodeFail
, 'prop_Text_NodeLSIdempotent
+ , 'prop_Text_ISpecIdempotent
+ , 'prop_Text_IPolicyIdempotent
+ , 'prop_Text_CreateSerialise
]
-- ** Node tests
-- test as any
inst_idx `elem` Node.sList a_ab &&
inst_idx `notElem` Node.sList d_ab
- x -> printTestCase ("Failed to add/remove instances: " ++ show x) False
+ x -> failTest $ "Failed to add/remove instances: " ++ show x
-- | Check mdsk setting.
prop_Node_setMdsk node mx =
in score <= 1e-12
-- | Check that cluster stats are sane.
-prop_CStats_sane node =
+prop_CStats_sane =
forAll (choose (1, 1024)) $ \count ->
- (not (Node.offline node) && not (Node.failN1 node) &&
- (Node.availDisk node > 0) && (Node.availMem node > 0)) ==>
+ forAll genOnlineNode $ \node ->
let fn = Node.buildPeers node Container.empty
nlst = zip [1..] $ replicate count fn::[(Types.Ndx, Node.Node)]
nl = Container.fromList nlst
-- | Check that one instance is allocated correctly, without
-- rebalances needed.
-prop_ClusterAlloc_sane node inst =
+prop_ClusterAlloc_sane inst =
forAll (choose (5, 20)) $ \count ->
- not (Node.offline node)
- && not (Node.failN1 node)
- && Node.availDisk node > 0
- && Node.availMem node > 0
- ==>
+ forAll genOnlineNode $ \node ->
let (nl, il, inst') = makeSmallEmptyCluster node count inst
in case Cluster.genAllocNodes defGroupList nl 2 True >>=
Cluster.tryAlloc nl il inst' of
-- | Checks that on a 2-5 node cluster, we can allocate a random
-- instance spec via tiered allocation (whatever the original instance
-- spec), on either one or two nodes.
-prop_ClusterCanTieredAlloc node inst =
+prop_ClusterCanTieredAlloc inst =
forAll (choose (2, 5)) $ \count ->
forAll (choose (1, 2)) $ \rqnodes ->
- not (Node.offline node)
- && not (Node.failN1 node)
- && isNodeBig node 4
- ==>
+ forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
let nl = makeSmallCluster node count
il = Container.empty
allocnodes = Cluster.genAllocNodes defGroupList nl rqnodes True
-- | Checks that on a 4-8 node cluster, once we allocate an instance,
-- we can also evacuate it.
-prop_ClusterAllocEvac node inst =
+prop_ClusterAllocEvac inst =
forAll (choose (4, 8)) $ \count ->
- not (Node.offline node)
- && not (Node.failN1 node)
- && isNodeBig node 4
- ==>
+ forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
let (nl, il, inst') = makeSmallEmptyCluster node count inst
in case Cluster.genAllocNodes defGroupList nl 2 True >>=
Cluster.tryAlloc nl il inst' of
i_templ = createInstance Types.unitMem Types.unitDsk Types.unitCpu
in case allocnodes >>= \allocnodes' ->
Cluster.iterateAlloc nl' il (Just 5) i_templ allocnodes' [] [] of
- Types.Bad _ -> printTestCase "Failed to allocate" False
- Types.Ok (_, _, _, [], _) -> printTestCase "Failed to allocate" False
+ Types.Bad msg -> failTest $ "Failed to allocate: " ++ msg
+ Types.Ok (_, _, _, [], _) -> failTest "Failed to allocate: no instances"
Types.Ok (_, xnl, il', _, _) ->
let ynl = Container.add (Node.idx hnode) hnode xnl
cv = Cluster.compCV ynl
-- | Check that opcode serialization is idempotent.
prop_OpCodes_serialization op =
case J.readJSON (J.showJSON op) of
- J.Error e -> printTestCase ("Cannot deserialise: " ++ e) False
+ J.Error e -> failTest $ "Cannot deserialise: " ++ e
J.Ok op' -> op ==? op'
where _types = op::OpCodes.OpCode
-- | Check that (queued) job\/opcode status serialization is idempotent.
prop_OpStatus_serialization os =
case J.readJSON (J.showJSON os) of
- J.Error e -> printTestCase ("Cannot deserialise: " ++ e) False
+ J.Error e -> failTest $ "Cannot deserialise: " ++ e
J.Ok os' -> os ==? os'
where _types = os::Jobs.OpStatus
prop_JobStatus_serialization js =
case J.readJSON (J.showJSON js) of
- J.Error e -> printTestCase ("Cannot deserialise: " ++ e) False
+ J.Error e -> failTest $ "Cannot deserialise: " ++ e
J.Ok js' -> js ==? js'
where _types = js::Jobs.JobStatus
prop_Types_AllocPolicy_serialisation apol =
case J.readJSON (J.showJSON apol) of
- J.Ok p -> printTestCase ("invalid deserialisation " ++ show p) $
- p == apol
- J.Error s -> printTestCase ("failed to deserialise: " ++ s) False
+ J.Ok p -> p ==? apol
+ J.Error s -> failTest $ "Failed to deserialise: " ++ s
where _types = apol::Types.AllocPolicy
prop_Types_DiskTemplate_serialisation dt =
case J.readJSON (J.showJSON dt) of
- J.Ok p -> printTestCase ("invalid deserialisation " ++ show p) $
- p == dt
- J.Error s -> printTestCase ("failed to deserialise: " ++ s)
- False
+ J.Ok p -> p ==? dt
+ J.Error s -> failTest $ "Failed to deserialise: " ++ s
where _types = dt::Types.DiskTemplate
+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 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 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 op =
case op of
Types.OpFail _ -> Types.isBad r
testSuite "Types"
[ 'prop_Types_AllocPolicy_serialisation
, 'prop_Types_DiskTemplate_serialisation
+ , 'prop_Types_ISpec_serialisation
+ , 'prop_Types_IPolicy_serialisation
+ , 'prop_Types_EvacMode_serialisation
, 'prop_Types_opToResult
, 'prop_Types_eitherToResult
]
projects / ganeti-local / blobdiff