1 {-# LANGUAGE TemplateHaskell #-}
3 {-| Unittests for ganeti-htools.
9 Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
11 This program is free software; you can redistribute it and/or modify
12 it under the terms of the GNU General Public License as published by
13 the Free Software Foundation; either version 2 of the License, or
14 (at your option) any later version.
16 This program is distributed in the hope that it will be useful, but
17 WITHOUT ANY WARRANTY; without even the implied warranty of
18 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19 General Public License for more details.
21 You should have received a copy of the GNU General Public License
22 along with this program; if not, write to the Free Software
23 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
28 module Ganeti.HTools.QC
44 import Test.QuickCheck
45 import Text.Printf (printf)
46 import Data.List (findIndex, intercalate, nub, isPrefixOf)
47 import qualified Data.Set as Set
50 import qualified System.Console.GetOpt as GetOpt
51 import qualified Text.JSON as J
52 import qualified Data.Map
53 import qualified Data.IntMap as IntMap
55 import qualified Ganeti.OpCodes as OpCodes
56 import qualified Ganeti.Jobs as Jobs
57 import qualified Ganeti.Luxi
58 import qualified Ganeti.HTools.CLI as CLI
59 import qualified Ganeti.HTools.Cluster as Cluster
60 import qualified Ganeti.HTools.Container as Container
61 import qualified Ganeti.HTools.ExtLoader
62 import qualified Ganeti.HTools.IAlloc as IAlloc
63 import qualified Ganeti.HTools.Instance as Instance
64 import qualified Ganeti.HTools.JSON as JSON
65 import qualified Ganeti.HTools.Loader as Loader
66 import qualified Ganeti.HTools.Luxi
67 import qualified Ganeti.HTools.Node as Node
68 import qualified Ganeti.HTools.Group as Group
69 import qualified Ganeti.HTools.PeerMap as PeerMap
70 import qualified Ganeti.HTools.Rapi
71 import qualified Ganeti.HTools.Simu as Simu
72 import qualified Ganeti.HTools.Text as Text
73 import qualified Ganeti.HTools.Types as Types
74 import qualified Ganeti.HTools.Utils as Utils
75 import qualified Ganeti.HTools.Version
76 import qualified Ganeti.Constants as C
78 import qualified Ganeti.HTools.Program as Program
79 import qualified Ganeti.HTools.Program.Hail
80 import qualified Ganeti.HTools.Program.Hbal
81 import qualified Ganeti.HTools.Program.Hscan
82 import qualified Ganeti.HTools.Program.Hspace
84 import Ganeti.HTools.QCHelper (testSuite)
88 -- | Maximum memory (1TiB, somewhat random value).
92 -- | Maximum disk (8TiB, somewhat random value).
94 maxDsk = 1024 * 1024 * 8
96 -- | Max CPUs (1024, somewhat random value).
100 -- | Max vcpu ratio (random value).
101 maxVcpuRatio :: Double
102 maxVcpuRatio = 1024.0
104 -- | Max spindle ratio (random value).
105 maxSpindleRatio :: Double
106 maxSpindleRatio = 1024.0
108 -- | All disk templates (used later)
109 allDiskTemplates :: [Types.DiskTemplate]
110 allDiskTemplates = [minBound..maxBound]
112 -- | Null iPolicy, and by null we mean very liberal.
113 nullIPolicy = Types.IPolicy
114 { Types.iPolicyMinSpec = Types.ISpec { Types.iSpecMemorySize = 0
115 , Types.iSpecCpuCount = 0
116 , Types.iSpecDiskSize = 0
117 , Types.iSpecDiskCount = 0
118 , Types.iSpecNicCount = 0
120 , Types.iPolicyMaxSpec = Types.ISpec { Types.iSpecMemorySize = maxBound
121 , Types.iSpecCpuCount = maxBound
122 , Types.iSpecDiskSize = maxBound
123 , Types.iSpecDiskCount = C.maxDisks
124 , Types.iSpecNicCount = C.maxNics
126 , Types.iPolicyStdSpec = Types.ISpec { Types.iSpecMemorySize = Types.unitMem
127 , Types.iSpecCpuCount = Types.unitCpu
128 , Types.iSpecDiskSize = Types.unitDsk
129 , Types.iSpecDiskCount = 1
130 , Types.iSpecNicCount = 1
132 , Types.iPolicyDiskTemplates = [Types.DTDrbd8, Types.DTPlain]
133 , Types.iPolicyVcpuRatio = maxVcpuRatio -- somewhat random value, high
134 -- enough to not impact us
135 , Types.iPolicySpindleRatio = maxSpindleRatio
139 defGroup :: Group.Group
140 defGroup = flip Group.setIdx 0 $
141 Group.create "default" Types.defaultGroupID Types.AllocPreferred
144 defGroupList :: Group.List
145 defGroupList = Container.fromList [(Group.idx defGroup, defGroup)]
147 defGroupAssoc :: Data.Map.Map String Types.Gdx
148 defGroupAssoc = Data.Map.singleton (Group.uuid defGroup) (Group.idx defGroup)
150 -- * Helper functions
152 -- | Simple checker for whether OpResult is fail or pass.
153 isFailure :: Types.OpResult a -> Bool
154 isFailure (Types.OpFail _) = True
157 -- | Checks for equality with proper annotation.
158 (==?) :: (Show a, Eq a) => a -> a -> Property
159 (==?) x y = printTestCase
160 ("Expected equality, but '" ++
161 show x ++ "' /= '" ++ show y ++ "'") (x == y)
164 -- | Show a message and fail the test.
165 failTest :: String -> Property
166 failTest msg = printTestCase msg False
168 -- | Update an instance to be smaller than a node.
169 setInstanceSmallerThanNode node inst =
170 inst { Instance.mem = Node.availMem node `div` 2
171 , Instance.dsk = Node.availDisk node `div` 2
172 , Instance.vcpus = Node.availCpu node `div` 2
175 -- | Create an instance given its spec.
176 createInstance mem dsk vcpus =
177 Instance.create "inst-unnamed" mem dsk vcpus Types.Running [] True (-1) (-1)
180 -- | Create a small cluster by repeating a node spec.
181 makeSmallCluster :: Node.Node -> Int -> Node.List
182 makeSmallCluster node count =
183 let origname = Node.name node
184 origalias = Node.alias node
185 nodes = map (\idx -> node { Node.name = origname ++ "-" ++ show idx
186 , Node.alias = origalias ++ "-" ++ show idx })
188 fn = flip Node.buildPeers Container.empty
189 namelst = map (\n -> (Node.name n, fn n)) nodes
190 (_, nlst) = Loader.assignIndices namelst
193 -- | Make a small cluster, both nodes and instances.
194 makeSmallEmptyCluster :: Node.Node -> Int -> Instance.Instance
195 -> (Node.List, Instance.List, Instance.Instance)
196 makeSmallEmptyCluster node count inst =
197 (makeSmallCluster node count, Container.empty,
198 setInstanceSmallerThanNode node inst)
200 -- | Checks if a node is "big" enough.
201 isNodeBig :: Int -> Node.Node -> Bool
202 isNodeBig size node = Node.availDisk node > size * Types.unitDsk
203 && Node.availMem node > size * Types.unitMem
204 && Node.availCpu node > size * Types.unitCpu
206 canBalance :: Cluster.Table -> Bool -> Bool -> Bool -> Bool
207 canBalance tbl dm im evac = isJust $ Cluster.tryBalance tbl dm im evac 0 0
209 -- | Assigns a new fresh instance to a cluster; this is not
210 -- allocation, so no resource checks are done.
211 assignInstance :: Node.List -> Instance.List -> Instance.Instance ->
212 Types.Idx -> Types.Idx ->
213 (Node.List, Instance.List)
214 assignInstance nl il inst pdx sdx =
215 let pnode = Container.find pdx nl
216 snode = Container.find sdx nl
217 maxiidx = if Container.null il
219 else fst (Container.findMax il) + 1
220 inst' = inst { Instance.idx = maxiidx,
221 Instance.pNode = pdx, Instance.sNode = sdx }
222 pnode' = Node.setPri pnode inst'
223 snode' = Node.setSec snode inst'
224 nl' = Container.addTwo pdx pnode' sdx snode' nl
225 il' = Container.add maxiidx inst' il
228 -- | Generates a list of a given size with non-duplicate elements.
229 genUniquesList :: (Eq a, Arbitrary a) => Int -> Gen [a]
232 newelem <- arbitrary `suchThat` (`notElem` lst)
233 return (newelem:lst)) [] [1..cnt]
235 -- * Arbitrary instances
237 -- | Defines a DNS name.
238 newtype DNSChar = DNSChar { dnsGetChar::Char }
240 instance Arbitrary DNSChar where
242 x <- elements (['a'..'z'] ++ ['0'..'9'] ++ "_-")
245 -- | Generates a single name component.
246 getName :: Gen String
249 dn <- vector n::Gen [DNSChar]
250 return (map dnsGetChar dn)
252 -- | Generates an entire FQDN.
253 getFQDN :: Gen String
255 ncomps <- choose (1, 4)
256 names <- mapM (const getName) [1..ncomps::Int]
257 return $ intercalate "." names
259 -- | Defines a tag type.
260 newtype TagChar = TagChar { tagGetChar :: Char }
262 -- | All valid tag chars. This doesn't need to match _exactly_
263 -- Ganeti's own tag regex, just enough for it to be close.
265 tagChar = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ".+*/:@-"
267 instance Arbitrary TagChar where
269 c <- elements tagChar
273 genTag :: Gen [TagChar]
275 -- the correct value would be C.maxTagLen, but that's way too
276 -- verbose in unittests, and at the moment I don't see any possible
277 -- bugs with longer tags and the way we use tags in htools
281 -- | Generates a list of tags (correctly upper bounded).
282 genTags :: Gen [String]
284 -- the correct value would be C.maxTagsPerObj, but per the comment
285 -- in genTag, we don't use tags enough in htools to warrant testing
287 n <- choose (0, 10::Int)
288 tags <- mapM (const genTag) [1..n]
289 return $ map (map tagGetChar) tags
291 instance Arbitrary Types.InstanceStatus where
292 arbitrary = elements [minBound..maxBound]
294 -- | Generates a random instance with maximum disk/mem/cpu values.
295 genInstanceSmallerThan :: Int -> Int -> Int -> Gen Instance.Instance
296 genInstanceSmallerThan lim_mem lim_dsk lim_cpu = do
298 mem <- choose (0, lim_mem)
299 dsk <- choose (0, lim_dsk)
303 vcpus <- choose (0, lim_cpu)
304 return $ Instance.create name mem dsk vcpus run_st [] True pn sn
307 -- | Generates an instance smaller than a node.
308 genInstanceSmallerThanNode :: Node.Node -> Gen Instance.Instance
309 genInstanceSmallerThanNode node =
310 genInstanceSmallerThan (Node.availMem node `div` 2)
311 (Node.availDisk node `div` 2)
312 (Node.availCpu node `div` 2)
314 -- let's generate a random instance
315 instance Arbitrary Instance.Instance where
316 arbitrary = genInstanceSmallerThan maxMem maxDsk maxCpu
318 -- | Generas an arbitrary node based on sizing information.
319 genNode :: Maybe Int -- ^ Minimum node size in terms of units
320 -> Maybe Int -- ^ Maximum node size (when Nothing, bounded
321 -- just by the max... constants)
323 genNode min_multiplier max_multiplier = do
324 let (base_mem, base_dsk, base_cpu) =
325 case min_multiplier of
326 Just mm -> (mm * Types.unitMem,
330 (top_mem, top_dsk, top_cpu) =
331 case max_multiplier of
332 Just mm -> (mm * Types.unitMem,
335 Nothing -> (maxMem, maxDsk, maxCpu)
337 mem_t <- choose (base_mem, top_mem)
338 mem_f <- choose (base_mem, mem_t)
339 mem_n <- choose (0, mem_t - mem_f)
340 dsk_t <- choose (base_dsk, top_dsk)
341 dsk_f <- choose (base_dsk, dsk_t)
342 cpu_t <- choose (base_cpu, top_cpu)
344 let n = Node.create name (fromIntegral mem_t) mem_n mem_f
345 (fromIntegral dsk_t) dsk_f (fromIntegral cpu_t) offl 1 0
346 n' = Node.setPolicy nullIPolicy n
347 return $ Node.buildPeers n' Container.empty
349 -- | Helper function to generate a sane node.
350 genOnlineNode :: Gen Node.Node
352 arbitrary `suchThat` (\n -> not (Node.offline n) &&
353 not (Node.failN1 n) &&
354 Node.availDisk n > 0 &&
355 Node.availMem n > 0 &&
359 instance Arbitrary Node.Node where
360 arbitrary = genNode Nothing Nothing
363 instance Arbitrary OpCodes.ReplaceDisksMode where
364 arbitrary = elements [minBound..maxBound]
366 instance Arbitrary OpCodes.OpCode where
368 op_id <- elements [ "OP_TEST_DELAY"
369 , "OP_INSTANCE_REPLACE_DISKS"
370 , "OP_INSTANCE_FAILOVER"
371 , "OP_INSTANCE_MIGRATE"
375 liftM3 OpCodes.OpTestDelay arbitrary arbitrary arbitrary
376 "OP_INSTANCE_REPLACE_DISKS" ->
377 liftM5 OpCodes.OpInstanceReplaceDisks arbitrary arbitrary
378 arbitrary arbitrary arbitrary
379 "OP_INSTANCE_FAILOVER" ->
380 liftM3 OpCodes.OpInstanceFailover arbitrary arbitrary
382 "OP_INSTANCE_MIGRATE" ->
383 liftM5 OpCodes.OpInstanceMigrate arbitrary arbitrary
384 arbitrary arbitrary arbitrary
385 _ -> fail "Wrong opcode"
387 instance Arbitrary Jobs.OpStatus where
388 arbitrary = elements [minBound..maxBound]
390 instance Arbitrary Jobs.JobStatus where
391 arbitrary = elements [minBound..maxBound]
393 newtype SmallRatio = SmallRatio Double deriving Show
394 instance Arbitrary SmallRatio where
397 return $ SmallRatio v
399 instance Arbitrary Types.AllocPolicy where
400 arbitrary = elements [minBound..maxBound]
402 instance Arbitrary Types.DiskTemplate where
403 arbitrary = elements [minBound..maxBound]
405 instance Arbitrary Types.FailMode where
406 arbitrary = elements [minBound..maxBound]
408 instance Arbitrary Types.EvacMode where
409 arbitrary = elements [minBound..maxBound]
411 instance Arbitrary a => Arbitrary (Types.OpResult a) where
412 arbitrary = arbitrary >>= \c ->
414 then liftM Types.OpGood arbitrary
415 else liftM Types.OpFail arbitrary
417 instance Arbitrary Types.ISpec where
419 mem_s <- arbitrary::Gen (NonNegative Int)
420 dsk_c <- arbitrary::Gen (NonNegative Int)
421 dsk_s <- arbitrary::Gen (NonNegative Int)
422 cpu_c <- arbitrary::Gen (NonNegative Int)
423 nic_c <- arbitrary::Gen (NonNegative Int)
424 return Types.ISpec { Types.iSpecMemorySize = fromIntegral mem_s
425 , Types.iSpecCpuCount = fromIntegral cpu_c
426 , Types.iSpecDiskSize = fromIntegral dsk_s
427 , Types.iSpecDiskCount = fromIntegral dsk_c
428 , Types.iSpecNicCount = fromIntegral nic_c
431 -- | Generates an ispec bigger than the given one.
432 genBiggerISpec :: Types.ISpec -> Gen Types.ISpec
433 genBiggerISpec imin = do
434 mem_s <- choose (Types.iSpecMemorySize imin, maxBound)
435 dsk_c <- choose (Types.iSpecDiskCount imin, maxBound)
436 dsk_s <- choose (Types.iSpecDiskSize imin, maxBound)
437 cpu_c <- choose (Types.iSpecCpuCount imin, maxBound)
438 nic_c <- choose (Types.iSpecNicCount imin, maxBound)
439 return Types.ISpec { Types.iSpecMemorySize = fromIntegral mem_s
440 , Types.iSpecCpuCount = fromIntegral cpu_c
441 , Types.iSpecDiskSize = fromIntegral dsk_s
442 , Types.iSpecDiskCount = fromIntegral dsk_c
443 , Types.iSpecNicCount = fromIntegral nic_c
446 instance Arbitrary Types.IPolicy where
449 istd <- genBiggerISpec imin
450 imax <- genBiggerISpec istd
451 num_tmpl <- choose (0, length allDiskTemplates)
452 dts <- genUniquesList num_tmpl
453 vcpu_ratio <- choose (1.0, maxVcpuRatio)
454 spindle_ratio <- choose (1.0, maxSpindleRatio)
455 return Types.IPolicy { Types.iPolicyMinSpec = imin
456 , Types.iPolicyStdSpec = istd
457 , Types.iPolicyMaxSpec = imax
458 , Types.iPolicyDiskTemplates = dts
459 , Types.iPolicyVcpuRatio = vcpu_ratio
460 , Types.iPolicySpindleRatio = spindle_ratio
467 -- | Helper to generate a small string that doesn't contain commas.
468 genNonCommaString = do
469 size <- choose (0, 20) -- arbitrary max size
470 vectorOf size (arbitrary `suchThat` ((/=) ','))
472 -- | If the list is not just an empty element, and if the elements do
473 -- not contain commas, then join+split should be idempotent.
474 prop_Utils_commaJoinSplit =
475 forAll (choose (0, 20)) $ \llen ->
476 forAll (vectorOf llen genNonCommaString `suchThat` ((/=) [""])) $ \lst ->
477 Utils.sepSplit ',' (Utils.commaJoin lst) ==? lst
479 -- | Split and join should always be idempotent.
480 prop_Utils_commaSplitJoin s =
481 Utils.commaJoin (Utils.sepSplit ',' s) ==? s
483 -- | fromObjWithDefault, we test using the Maybe monad and an integer
485 prop_Utils_fromObjWithDefault def_value random_key =
486 -- a missing key will be returned with the default
487 JSON.fromObjWithDefault [] random_key def_value == Just def_value &&
488 -- a found key will be returned as is, not with default
489 JSON.fromObjWithDefault [(random_key, J.showJSON def_value)]
490 random_key (def_value+1) == Just def_value
491 where _types = def_value :: Integer
493 -- | Test that functional if' behaves like the syntactic sugar if.
494 prop_Utils_if'if :: Bool -> Int -> Int -> Gen Prop
495 prop_Utils_if'if cnd a b =
496 Utils.if' cnd a b ==? if cnd then a else b
498 -- | Test basic select functionality
499 prop_Utils_select :: Int -- ^ Default result
500 -> [Int] -- ^ List of False values
501 -> [Int] -- ^ List of True values
502 -> Gen Prop -- ^ Test result
503 prop_Utils_select def lst1 lst2 =
504 Utils.select def (flist ++ tlist) ==? expectedresult
505 where expectedresult = Utils.if' (null lst2) def (head lst2)
506 flist = zip (repeat False) lst1
507 tlist = zip (repeat True) lst2
509 -- | Test basic select functionality with undefined default
510 prop_Utils_select_undefd :: [Int] -- ^ List of False values
511 -> NonEmptyList Int -- ^ List of True values
512 -> Gen Prop -- ^ Test result
513 prop_Utils_select_undefd lst1 (NonEmpty lst2) =
514 Utils.select undefined (flist ++ tlist) ==? head lst2
515 where flist = zip (repeat False) lst1
516 tlist = zip (repeat True) lst2
518 -- | Test basic select functionality with undefined list values
519 prop_Utils_select_undefv :: [Int] -- ^ List of False values
520 -> NonEmptyList Int -- ^ List of True values
521 -> Gen Prop -- ^ Test result
522 prop_Utils_select_undefv lst1 (NonEmpty lst2) =
523 Utils.select undefined cndlist ==? head lst2
524 where flist = zip (repeat False) lst1
525 tlist = zip (repeat True) lst2
526 cndlist = flist ++ tlist ++ [undefined]
528 prop_Utils_parseUnit (NonNegative n) =
529 Utils.parseUnit (show n) == Types.Ok n &&
530 Utils.parseUnit (show n ++ "m") == Types.Ok n &&
531 (case Utils.parseUnit (show n ++ "M") of
532 Types.Ok m -> if n > 0
533 then m < n -- for positive values, X MB is < than X MiB
534 else m == 0 -- but for 0, 0 MB == 0 MiB
535 Types.Bad _ -> False) &&
536 Utils.parseUnit (show n ++ "g") == Types.Ok (n*1024) &&
537 Utils.parseUnit (show n ++ "t") == Types.Ok (n*1048576) &&
538 Types.isBad (Utils.parseUnit (show n ++ "x")::Types.Result Int)
539 where _types = n::Int
541 -- | Test list for the Utils module.
543 [ 'prop_Utils_commaJoinSplit
544 , 'prop_Utils_commaSplitJoin
545 , 'prop_Utils_fromObjWithDefault
548 , 'prop_Utils_select_undefd
549 , 'prop_Utils_select_undefv
550 , 'prop_Utils_parseUnit
555 -- | Make sure add is idempotent.
556 prop_PeerMap_addIdempotent pmap key em =
557 fn puniq ==? fn (fn puniq)
558 where _types = (pmap::PeerMap.PeerMap,
559 key::PeerMap.Key, em::PeerMap.Elem)
560 fn = PeerMap.add key em
561 puniq = PeerMap.accumArray const pmap
563 -- | Make sure remove is idempotent.
564 prop_PeerMap_removeIdempotent pmap key =
565 fn puniq ==? fn (fn puniq)
566 where _types = (pmap::PeerMap.PeerMap, key::PeerMap.Key)
567 fn = PeerMap.remove key
568 puniq = PeerMap.accumArray const pmap
570 -- | Make sure a missing item returns 0.
571 prop_PeerMap_findMissing pmap key =
572 PeerMap.find key (PeerMap.remove key puniq) ==? 0
573 where _types = (pmap::PeerMap.PeerMap, key::PeerMap.Key)
574 puniq = PeerMap.accumArray const pmap
576 -- | Make sure an added item is found.
577 prop_PeerMap_addFind pmap key em =
578 PeerMap.find key (PeerMap.add key em puniq) ==? em
579 where _types = (pmap::PeerMap.PeerMap,
580 key::PeerMap.Key, em::PeerMap.Elem)
581 puniq = PeerMap.accumArray const pmap
583 -- | Manual check that maxElem returns the maximum indeed, or 0 for null.
584 prop_PeerMap_maxElem pmap =
585 PeerMap.maxElem puniq ==? if null puniq then 0
586 else (maximum . snd . unzip) puniq
587 where _types = pmap::PeerMap.PeerMap
588 puniq = PeerMap.accumArray const pmap
590 -- | List of tests for the PeerMap module.
592 [ 'prop_PeerMap_addIdempotent
593 , 'prop_PeerMap_removeIdempotent
594 , 'prop_PeerMap_maxElem
595 , 'prop_PeerMap_addFind
596 , 'prop_PeerMap_findMissing
599 -- ** Container tests
601 -- we silence the following due to hlint bug fixed in later versions
602 {-# ANN prop_Container_addTwo "HLint: ignore Avoid lambda" #-}
603 prop_Container_addTwo cdata i1 i2 =
604 fn i1 i2 cont == fn i2 i1 cont &&
605 fn i1 i2 cont == fn i1 i2 (fn i1 i2 cont)
606 where _types = (cdata::[Int],
608 cont = foldl (\c x -> Container.add x x c) Container.empty cdata
609 fn x1 x2 = Container.addTwo x1 x1 x2 x2
611 prop_Container_nameOf node =
612 let nl = makeSmallCluster node 1
613 fnode = head (Container.elems nl)
614 in Container.nameOf nl (Node.idx fnode) ==? Node.name fnode
616 -- | We test that in a cluster, given a random node, we can find it by
617 -- its name and alias, as long as all names and aliases are unique,
618 -- and that we fail to find a non-existing name.
619 prop_Container_findByName node =
620 forAll (choose (1, 20)) $ \ cnt ->
621 forAll (choose (0, cnt - 1)) $ \ fidx ->
622 forAll (genUniquesList (cnt * 2)) $ \ allnames ->
623 forAll (arbitrary `suchThat` (`notElem` allnames)) $ \ othername ->
624 let names = zip (take cnt allnames) (drop cnt allnames)
625 nl = makeSmallCluster node cnt
626 nodes = Container.elems nl
627 nodes' = map (\((name, alias), nn) -> (Node.idx nn,
628 nn { Node.name = name,
629 Node.alias = alias }))
631 nl' = Container.fromList nodes'
632 target = snd (nodes' !! fidx)
633 in Container.findByName nl' (Node.name target) == Just target &&
634 Container.findByName nl' (Node.alias target) == Just target &&
635 isNothing (Container.findByName nl' othername)
637 testSuite "Container"
638 [ 'prop_Container_addTwo
639 , 'prop_Container_nameOf
640 , 'prop_Container_findByName
645 -- Simple instance tests, we only have setter/getters
647 prop_Instance_creat inst =
648 Instance.name inst ==? Instance.alias inst
650 prop_Instance_setIdx inst idx =
651 Instance.idx (Instance.setIdx inst idx) ==? idx
652 where _types = (inst::Instance.Instance, idx::Types.Idx)
654 prop_Instance_setName inst name =
655 Instance.name newinst == name &&
656 Instance.alias newinst == name
657 where _types = (inst::Instance.Instance, name::String)
658 newinst = Instance.setName inst name
660 prop_Instance_setAlias inst name =
661 Instance.name newinst == Instance.name inst &&
662 Instance.alias newinst == name
663 where _types = (inst::Instance.Instance, name::String)
664 newinst = Instance.setAlias inst name
666 prop_Instance_setPri inst pdx =
667 Instance.pNode (Instance.setPri inst pdx) ==? pdx
668 where _types = (inst::Instance.Instance, pdx::Types.Ndx)
670 prop_Instance_setSec inst sdx =
671 Instance.sNode (Instance.setSec inst sdx) ==? sdx
672 where _types = (inst::Instance.Instance, sdx::Types.Ndx)
674 prop_Instance_setBoth inst pdx sdx =
675 Instance.pNode si == pdx && Instance.sNode si == sdx
676 where _types = (inst::Instance.Instance, pdx::Types.Ndx, sdx::Types.Ndx)
677 si = Instance.setBoth inst pdx sdx
679 prop_Instance_shrinkMG inst =
680 Instance.mem inst >= 2 * Types.unitMem ==>
681 case Instance.shrinkByType inst Types.FailMem of
682 Types.Ok inst' -> Instance.mem inst' == Instance.mem inst - Types.unitMem
685 prop_Instance_shrinkMF inst =
686 forAll (choose (0, 2 * Types.unitMem - 1)) $ \mem ->
687 let inst' = inst { Instance.mem = mem}
688 in Types.isBad $ Instance.shrinkByType inst' Types.FailMem
690 prop_Instance_shrinkCG inst =
691 Instance.vcpus inst >= 2 * Types.unitCpu ==>
692 case Instance.shrinkByType inst Types.FailCPU of
694 Instance.vcpus inst' == Instance.vcpus inst - Types.unitCpu
697 prop_Instance_shrinkCF inst =
698 forAll (choose (0, 2 * Types.unitCpu - 1)) $ \vcpus ->
699 let inst' = inst { Instance.vcpus = vcpus }
700 in Types.isBad $ Instance.shrinkByType inst' Types.FailCPU
702 prop_Instance_shrinkDG inst =
703 Instance.dsk inst >= 2 * Types.unitDsk ==>
704 case Instance.shrinkByType inst Types.FailDisk of
706 Instance.dsk inst' == Instance.dsk inst - Types.unitDsk
709 prop_Instance_shrinkDF inst =
710 forAll (choose (0, 2 * Types.unitDsk - 1)) $ \dsk ->
711 let inst' = inst { Instance.dsk = dsk }
712 in Types.isBad $ Instance.shrinkByType inst' Types.FailDisk
714 prop_Instance_setMovable inst m =
715 Instance.movable inst' ==? m
716 where inst' = Instance.setMovable inst m
719 [ 'prop_Instance_creat
720 , 'prop_Instance_setIdx
721 , 'prop_Instance_setName
722 , 'prop_Instance_setAlias
723 , 'prop_Instance_setPri
724 , 'prop_Instance_setSec
725 , 'prop_Instance_setBoth
726 , 'prop_Instance_shrinkMG
727 , 'prop_Instance_shrinkMF
728 , 'prop_Instance_shrinkCG
729 , 'prop_Instance_shrinkCF
730 , 'prop_Instance_shrinkDG
731 , 'prop_Instance_shrinkDF
732 , 'prop_Instance_setMovable
737 -- *** Text backend tests
739 -- Instance text loader tests
741 prop_Text_Load_Instance name mem dsk vcpus status
742 (NonEmpty pnode) snode
743 (NonNegative pdx) (NonNegative sdx) autobal dt =
744 pnode /= snode && pdx /= sdx ==>
745 let vcpus_s = show vcpus
748 status_s = Types.instanceStatusToRaw status
751 else [(pnode, pdx), (snode, sdx)]
752 nl = Data.Map.fromList ndx
754 sbal = if autobal then "Y" else "N"
755 sdt = Types.diskTemplateToRaw dt
756 inst = Text.loadInst nl
757 [name, mem_s, dsk_s, vcpus_s, status_s,
758 sbal, pnode, snode, sdt, tags]
759 fail1 = Text.loadInst nl
760 [name, mem_s, dsk_s, vcpus_s, status_s,
761 sbal, pnode, pnode, tags]
762 _types = ( name::String, mem::Int, dsk::Int
763 , vcpus::Int, status::Types.InstanceStatus
767 Types.Bad msg -> failTest $ "Failed to load instance: " ++ msg
768 Types.Ok (_, i) -> printTestCase "Mismatch in some field while\
769 \ loading the instance" $
770 Instance.name i == name &&
771 Instance.vcpus i == vcpus &&
772 Instance.mem i == mem &&
773 Instance.pNode i == pdx &&
774 Instance.sNode i == (if null snode
775 then Node.noSecondary
777 Instance.autoBalance i == autobal &&
780 prop_Text_Load_InstanceFail ktn fields =
781 length fields /= 10 ==>
782 case Text.loadInst nl fields of
783 Types.Ok _ -> failTest "Managed to load instance from invalid data"
784 Types.Bad msg -> printTestCase ("Unrecognised error message: " ++ msg) $
785 "Invalid/incomplete instance data: '" `isPrefixOf` msg
786 where nl = Data.Map.fromList ktn
788 prop_Text_Load_Node name tm nm fm td fd tc fo =
789 let conv v = if v < 0
801 any_broken = any (< 0) [tm, nm, fm, td, fd, tc]
802 gid = Group.uuid defGroup
803 in case Text.loadNode defGroupAssoc
804 [name, tm_s, nm_s, fm_s, td_s, fd_s, tc_s, fo_s, gid] of
806 Just (name', node) ->
808 then Node.offline node
809 else Node.name node == name' && name' == name &&
810 Node.alias node == name &&
811 Node.tMem node == fromIntegral tm &&
812 Node.nMem node == nm &&
813 Node.fMem node == fm &&
814 Node.tDsk node == fromIntegral td &&
815 Node.fDsk node == fd &&
816 Node.tCpu node == fromIntegral tc
818 prop_Text_Load_NodeFail fields =
819 length fields /= 8 ==> isNothing $ Text.loadNode Data.Map.empty fields
821 prop_Text_NodeLSIdempotent node =
822 (Text.loadNode defGroupAssoc.
823 Utils.sepSplit '|' . Text.serializeNode defGroupList) n ==?
824 Just (Node.name n, n)
825 -- override failN1 to what loadNode returns by default
826 where n = Node.setPolicy Types.defIPolicy $
827 node { Node.failN1 = True, Node.offline = False }
829 prop_Text_ISpecIdempotent ispec =
830 case Text.loadISpec "dummy" . Utils.sepSplit ',' .
831 Text.serializeISpec $ ispec of
832 Types.Bad msg -> failTest $ "Failed to load ispec: " ++ msg
833 Types.Ok ispec' -> ispec ==? ispec'
835 prop_Text_IPolicyIdempotent ipol =
836 case Text.loadIPolicy . Utils.sepSplit '|' $
837 Text.serializeIPolicy owner ipol of
838 Types.Bad msg -> failTest $ "Failed to load ispec: " ++ msg
839 Types.Ok res -> (owner, ipol) ==? res
840 where owner = "dummy"
842 -- | This property, while being in the text tests, does more than just
843 -- test end-to-end the serialisation and loading back workflow; it
844 -- also tests the Loader.mergeData and the actuall
845 -- Cluster.iterateAlloc (for well-behaving w.r.t. instance
846 -- allocations, not for the business logic). As such, it's a quite
847 -- complex and slow test, and that's the reason we restrict it to
848 -- small cluster sizes.
849 prop_Text_CreateSerialise =
850 forAll genTags $ \ctags ->
851 forAll (choose (1, 2)) $ \reqnodes ->
852 forAll (choose (1, 20)) $ \maxiter ->
853 forAll (choose (2, 10)) $ \count ->
854 forAll genOnlineNode $ \node ->
855 forAll (genInstanceSmallerThanNode node) $ \inst ->
856 let inst' = Instance.setMovable inst (reqnodes == 2)
857 nl = makeSmallCluster node count
858 in case Cluster.genAllocNodes defGroupList nl reqnodes True >>= \allocn ->
859 Cluster.iterateAlloc nl Container.empty (Just maxiter) inst' allocn [] []
861 Types.Bad msg -> failTest $ "Failed to allocate: " ++ msg
862 Types.Ok (_, _, _, [], _) -> printTestCase
863 "Failed to allocate: no allocations" False
864 Types.Ok (_, nl', il', _, _) ->
865 let cdata = Loader.ClusterData defGroupList nl' il' ctags
867 saved = Text.serializeCluster cdata
868 in case Text.parseData saved >>= Loader.mergeData [] [] [] [] of
869 Types.Bad msg -> failTest $ "Failed to load/merge: " ++ msg
870 Types.Ok (Loader.ClusterData gl2 nl2 il2 ctags2 cpol2) ->
871 ctags ==? ctags2 .&&.
872 Types.defIPolicy ==? cpol2 .&&.
874 defGroupList ==? gl2 .&&.
878 [ 'prop_Text_Load_Instance
879 , 'prop_Text_Load_InstanceFail
880 , 'prop_Text_Load_Node
881 , 'prop_Text_Load_NodeFail
882 , 'prop_Text_NodeLSIdempotent
883 , 'prop_Text_ISpecIdempotent
884 , 'prop_Text_IPolicyIdempotent
885 , 'prop_Text_CreateSerialise
890 -- | Generates a tuple of specs for simulation.
891 genSimuSpec :: Gen (String, Int, Int, Int, Int)
893 pol <- elements [C.allocPolicyPreferred,
894 C.allocPolicyLastResort, C.allocPolicyUnallocable,
896 -- should be reasonable (nodes/group), bigger values only complicate
897 -- the display of failed tests, and we don't care (in this particular
898 -- test) about big node groups
899 nodes <- choose (0, 20)
900 dsk <- choose (0, maxDsk)
901 mem <- choose (0, maxMem)
902 cpu <- choose (0, maxCpu)
903 return (pol, nodes, dsk, mem, cpu)
905 -- | Checks that given a set of corrects specs, we can load them
906 -- successfully, and that at high-level the values look right.
908 forAll (choose (0, 10)) $ \ngroups ->
909 forAll (replicateM ngroups genSimuSpec) $ \specs ->
910 let strspecs = map (\(p, n, d, m, c) -> printf "%s,%d,%d,%d,%d"
911 p n d m c::String) specs
912 totnodes = sum $ map (\(_, n, _, _, _) -> n) specs
913 mdc_in = concatMap (\(_, n, d, m, c) ->
914 replicate n (fromIntegral m, fromIntegral d,
916 fromIntegral m, fromIntegral d)) specs
917 in case Simu.parseData strspecs of
918 Types.Bad msg -> failTest $ "Failed to load specs: " ++ msg
919 Types.Ok (Loader.ClusterData gl nl il tags ipol) ->
920 let nodes = map snd $ IntMap.toAscList nl
921 nidx = map Node.idx nodes
922 mdc_out = map (\n -> (Node.tMem n, Node.tDsk n, Node.tCpu n,
923 Node.fMem n, Node.fDsk n)) nodes
925 Container.size gl ==? ngroups .&&.
926 Container.size nl ==? totnodes .&&.
927 Container.size il ==? 0 .&&.
928 length tags ==? 0 .&&.
929 ipol ==? Types.defIPolicy .&&.
930 nidx ==? [1..totnodes] .&&.
931 mdc_in ==? mdc_out .&&.
932 map Group.iPolicy (Container.elems gl) ==?
933 replicate ngroups Types.defIPolicy
941 prop_Node_setAlias node name =
942 Node.name newnode == Node.name node &&
943 Node.alias newnode == name
944 where _types = (node::Node.Node, name::String)
945 newnode = Node.setAlias node name
947 prop_Node_setOffline node status =
948 Node.offline newnode ==? status
949 where newnode = Node.setOffline node status
951 prop_Node_setXmem node xm =
952 Node.xMem newnode ==? xm
953 where newnode = Node.setXmem node xm
955 prop_Node_setMcpu node mc =
956 Types.iPolicyVcpuRatio (Node.iPolicy newnode) ==? mc
957 where newnode = Node.setMcpu node mc
959 -- | Check that an instance add with too high memory or disk will be
961 prop_Node_addPriFM node inst =
962 Instance.mem inst >= Node.fMem node && not (Node.failN1 node) &&
963 not (Instance.instanceOffline inst) ==>
964 case Node.addPri node inst'' of
965 Types.OpFail Types.FailMem -> True
967 where _types = (node::Node.Node, inst::Instance.Instance)
968 inst' = setInstanceSmallerThanNode node inst
969 inst'' = inst' { Instance.mem = Instance.mem inst }
971 prop_Node_addPriFD node inst =
972 Instance.dsk inst >= Node.fDsk node && not (Node.failN1 node) ==>
973 case Node.addPri node inst'' of
974 Types.OpFail Types.FailDisk -> True
976 where _types = (node::Node.Node, inst::Instance.Instance)
977 inst' = setInstanceSmallerThanNode node inst
978 inst'' = inst' { Instance.dsk = Instance.dsk inst }
981 forAll (choose (1, maxCpu)) $ \extra ->
982 forAll genOnlineNode $ \node ->
983 forAll (arbitrary `suchThat` Instance.instanceNotOffline) $ \inst ->
984 let inst' = setInstanceSmallerThanNode node inst
985 inst'' = inst' { Instance.vcpus = Node.availCpu node + extra }
986 in case Node.addPri node inst'' of
987 Types.OpFail Types.FailCPU -> property True
988 v -> failTest $ "Expected OpFail FailCPU, but got " ++ show v
990 -- | Check that an instance add with too high memory or disk will be
992 prop_Node_addSec node inst pdx =
993 ((Instance.mem inst >= (Node.fMem node - Node.rMem node) &&
994 not (Instance.instanceOffline inst)) ||
995 Instance.dsk inst >= Node.fDsk node) &&
996 not (Node.failN1 node) ==>
997 isFailure (Node.addSec node inst pdx)
998 where _types = (node::Node.Node, inst::Instance.Instance, pdx::Int)
1000 -- | Check that an offline instance with reasonable disk size but
1001 -- extra mem/cpu can always be added.
1002 prop_Node_addOffline (NonNegative extra_mem) (NonNegative extra_cpu) pdx =
1003 forAll genOnlineNode $ \node ->
1004 forAll (genInstanceSmallerThanNode node) $ \inst ->
1005 let inst' = inst { Instance.runSt = Types.AdminOffline
1006 , Instance.mem = Node.availMem node + extra_mem
1007 , Instance.vcpus = Node.availCpu node + extra_cpu }
1008 in case (Node.addPri node inst', Node.addSec node inst' pdx) of
1009 (Types.OpGood _, Types.OpGood _) -> property True
1010 v -> failTest $ "Expected OpGood/OpGood, but got: " ++ show v
1012 -- | Checks for memory reservation changes.
1013 prop_Node_rMem inst =
1014 not (Instance.instanceOffline inst) ==>
1015 forAll (arbitrary `suchThat` ((> Types.unitMem) . Node.fMem)) $ \node ->
1016 -- ab = auto_balance, nb = non-auto_balance
1017 -- we use -1 as the primary node of the instance
1018 let inst' = inst { Instance.pNode = -1, Instance.autoBalance = True }
1019 inst_ab = setInstanceSmallerThanNode node inst'
1020 inst_nb = inst_ab { Instance.autoBalance = False }
1021 -- now we have the two instances, identical except the
1022 -- autoBalance attribute
1023 orig_rmem = Node.rMem node
1024 inst_idx = Instance.idx inst_ab
1025 node_add_ab = Node.addSec node inst_ab (-1)
1026 node_add_nb = Node.addSec node inst_nb (-1)
1027 node_del_ab = liftM (`Node.removeSec` inst_ab) node_add_ab
1028 node_del_nb = liftM (`Node.removeSec` inst_nb) node_add_nb
1029 in case (node_add_ab, node_add_nb, node_del_ab, node_del_nb) of
1030 (Types.OpGood a_ab, Types.OpGood a_nb,
1031 Types.OpGood d_ab, Types.OpGood d_nb) ->
1032 printTestCase "Consistency checks failed" $
1033 Node.rMem a_ab > orig_rmem &&
1034 Node.rMem a_ab - orig_rmem == Instance.mem inst_ab &&
1035 Node.rMem a_nb == orig_rmem &&
1036 Node.rMem d_ab == orig_rmem &&
1037 Node.rMem d_nb == orig_rmem &&
1038 -- this is not related to rMem, but as good a place to
1040 inst_idx `elem` Node.sList a_ab &&
1041 inst_idx `notElem` Node.sList d_ab
1042 x -> failTest $ "Failed to add/remove instances: " ++ show x
1044 -- | Check mdsk setting.
1045 prop_Node_setMdsk node mx =
1046 Node.loDsk node' >= 0 &&
1047 fromIntegral (Node.loDsk node') <= Node.tDsk node &&
1048 Node.availDisk node' >= 0 &&
1049 Node.availDisk node' <= Node.fDsk node' &&
1050 fromIntegral (Node.availDisk node') <= Node.tDsk node' &&
1051 Node.mDsk node' == mx'
1052 where _types = (node::Node.Node, mx::SmallRatio)
1053 node' = Node.setMdsk node mx'
1057 prop_Node_tagMaps_idempotent =
1058 forAll genTags $ \tags ->
1059 Node.delTags (Node.addTags m tags) tags ==? m
1060 where m = Data.Map.empty
1062 prop_Node_tagMaps_reject =
1063 forAll (genTags `suchThat` (not . null)) $ \tags ->
1064 let m = Node.addTags Data.Map.empty tags
1065 in all (\t -> Node.rejectAddTags m [t]) tags
1067 prop_Node_showField node =
1068 forAll (elements Node.defaultFields) $ \ field ->
1069 fst (Node.showHeader field) /= Types.unknownField &&
1070 Node.showField node field /= Types.unknownField
1072 prop_Node_computeGroups nodes =
1073 let ng = Node.computeGroups nodes
1074 onlyuuid = map fst ng
1075 in length nodes == sum (map (length . snd) ng) &&
1076 all (\(guuid, ns) -> all ((== guuid) . Node.group) ns) ng &&
1077 length (nub onlyuuid) == length onlyuuid &&
1078 (null nodes || not (null ng))
1081 [ 'prop_Node_setAlias
1082 , 'prop_Node_setOffline
1083 , 'prop_Node_setMcpu
1084 , 'prop_Node_setXmem
1085 , 'prop_Node_addPriFM
1086 , 'prop_Node_addPriFD
1087 , 'prop_Node_addPriFC
1089 , 'prop_Node_addOffline
1091 , 'prop_Node_setMdsk
1092 , 'prop_Node_tagMaps_idempotent
1093 , 'prop_Node_tagMaps_reject
1094 , 'prop_Node_showField
1095 , 'prop_Node_computeGroups
1100 -- | Check that the cluster score is close to zero for a homogeneous
1102 prop_Score_Zero node =
1103 forAll (choose (1, 1024)) $ \count ->
1104 (not (Node.offline node) && not (Node.failN1 node) && (count > 0) &&
1105 (Node.tDsk node > 0) && (Node.tMem node > 0)) ==>
1106 let fn = Node.buildPeers node Container.empty
1107 nlst = replicate count fn
1108 score = Cluster.compCVNodes nlst
1109 -- we can't say == 0 here as the floating point errors accumulate;
1110 -- this should be much lower than the default score in CLI.hs
1113 -- | Check that cluster stats are sane.
1115 forAll (choose (1, 1024)) $ \count ->
1116 forAll genOnlineNode $ \node ->
1117 let fn = Node.buildPeers node Container.empty
1118 nlst = zip [1..] $ replicate count fn::[(Types.Ndx, Node.Node)]
1119 nl = Container.fromList nlst
1120 cstats = Cluster.totalResources nl
1121 in Cluster.csAdsk cstats >= 0 &&
1122 Cluster.csAdsk cstats <= Cluster.csFdsk cstats
1124 -- | Check that one instance is allocated correctly, without
1125 -- rebalances needed.
1126 prop_ClusterAlloc_sane inst =
1127 forAll (choose (5, 20)) $ \count ->
1128 forAll genOnlineNode $ \node ->
1129 let (nl, il, inst') = makeSmallEmptyCluster node count inst
1130 in case Cluster.genAllocNodes defGroupList nl 2 True >>=
1131 Cluster.tryAlloc nl il inst' of
1132 Types.Bad _ -> False
1134 case Cluster.asSolution as of
1136 Just (xnl, xi, _, cv) ->
1137 let il' = Container.add (Instance.idx xi) xi il
1138 tbl = Cluster.Table xnl il' cv []
1139 in not (canBalance tbl True True False)
1141 -- | Checks that on a 2-5 node cluster, we can allocate a random
1142 -- instance spec via tiered allocation (whatever the original instance
1143 -- spec), on either one or two nodes. Furthermore, we test that
1144 -- computed allocation statistics are correct.
1145 prop_ClusterCanTieredAlloc inst =
1146 forAll (choose (2, 5)) $ \count ->
1147 forAll (choose (1, 2)) $ \rqnodes ->
1148 forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
1149 let nl = makeSmallCluster node count
1150 il = Container.empty
1151 allocnodes = Cluster.genAllocNodes defGroupList nl rqnodes True
1152 in case allocnodes >>= \allocnodes' ->
1153 Cluster.tieredAlloc nl il (Just 1) inst allocnodes' [] [] of
1154 Types.Bad msg -> failTest $ "Failed to tiered alloc: " ++ msg
1155 Types.Ok (_, nl', il', ixes, cstats) ->
1156 let (ai_alloc, ai_pool, ai_unav) =
1157 Cluster.computeAllocationDelta
1158 (Cluster.totalResources nl)
1159 (Cluster.totalResources nl')
1160 all_nodes = Container.elems nl
1161 in property (not (null ixes)) .&&.
1162 IntMap.size il' ==? length ixes .&&.
1163 length ixes ==? length cstats .&&.
1164 sum (map Types.allocInfoVCpus [ai_alloc, ai_pool, ai_unav]) ==?
1165 sum (map Node.hiCpu all_nodes) .&&.
1166 sum (map Types.allocInfoNCpus [ai_alloc, ai_pool, ai_unav]) ==?
1167 sum (map Node.tCpu all_nodes) .&&.
1168 sum (map Types.allocInfoMem [ai_alloc, ai_pool, ai_unav]) ==?
1169 truncate (sum (map Node.tMem all_nodes)) .&&.
1170 sum (map Types.allocInfoDisk [ai_alloc, ai_pool, ai_unav]) ==?
1171 truncate (sum (map Node.tDsk all_nodes))
1173 -- | Helper function to create a cluster with the given range of nodes
1174 -- and allocate an instance on it.
1175 genClusterAlloc count node inst =
1176 let nl = makeSmallCluster node count
1177 in case Cluster.genAllocNodes defGroupList nl 2 True >>=
1178 Cluster.tryAlloc nl Container.empty inst of
1179 Types.Bad _ -> Types.Bad "Can't allocate"
1181 case Cluster.asSolution as of
1182 Nothing -> Types.Bad "Empty solution?"
1183 Just (xnl, xi, _, _) ->
1184 let xil = Container.add (Instance.idx xi) xi Container.empty
1185 in Types.Ok (xnl, xil, xi)
1187 -- | Checks that on a 4-8 node cluster, once we allocate an instance,
1188 -- we can also relocate it.
1189 prop_ClusterAllocRelocate =
1190 forAll (choose (4, 8)) $ \count ->
1191 forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
1192 forAll (genInstanceSmallerThanNode node) $ \inst ->
1193 case genClusterAlloc count node inst of
1194 Types.Bad msg -> failTest msg
1195 Types.Ok (nl, il, inst') ->
1196 case IAlloc.processRelocate defGroupList nl il
1197 (Instance.idx inst) 1 [Instance.sNode inst'] of
1198 Types.Ok _ -> printTestCase "??" True -- huh, how to make
1200 Types.Bad msg -> failTest $ "Failed to relocate: " ++ msg
1202 -- | Helper property checker for the result of a nodeEvac or
1203 -- changeGroup operation.
1204 check_EvacMode grp inst result =
1206 Types.Bad msg -> failTest $ "Couldn't evacuate/change group:" ++ msg
1207 Types.Ok (_, _, es) ->
1208 let moved = Cluster.esMoved es
1209 failed = Cluster.esFailed es
1210 opcodes = not . null $ Cluster.esOpCodes es
1211 in failmsg ("'failed' not empty: " ++ show failed) (null failed) .&&.
1212 failmsg "'opcodes' is null" opcodes .&&.
1214 [(idx', gdx, _)] -> failmsg "invalid instance moved" (idx == idx')
1216 failmsg "wrong target group"
1217 (gdx == Group.idx grp)
1218 v -> failmsg ("invalid solution: " ++ show v) False
1219 where failmsg = \msg -> printTestCase ("Failed to evacuate: " ++ msg)
1220 idx = Instance.idx inst
1222 -- | Checks that on a 4-8 node cluster, once we allocate an instance,
1223 -- we can also node-evacuate it.
1224 prop_ClusterAllocEvacuate =
1225 forAll (choose (4, 8)) $ \count ->
1226 forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
1227 forAll (genInstanceSmallerThanNode node) $ \inst ->
1228 case genClusterAlloc count node inst of
1229 Types.Bad msg -> failTest msg
1230 Types.Ok (nl, il, inst') ->
1231 conjoin $ map (\mode -> check_EvacMode defGroup inst' $
1232 Cluster.tryNodeEvac defGroupList nl il mode
1233 [Instance.idx inst']) [minBound..maxBound]
1235 -- | Checks that on a 4-8 node cluster with two node groups, once we
1236 -- allocate an instance on the first node group, we can also change
1238 prop_ClusterAllocChangeGroup =
1239 forAll (choose (4, 8)) $ \count ->
1240 forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
1241 forAll (genInstanceSmallerThanNode node) $ \inst ->
1242 case genClusterAlloc count node inst of
1243 Types.Bad msg -> failTest msg
1244 Types.Ok (nl, il, inst') ->
1245 -- we need to add a second node group and nodes to the cluster
1246 let nl2 = Container.elems $ makeSmallCluster node count
1247 grp2 = Group.setIdx defGroup (Group.idx defGroup + 1)
1248 maxndx = maximum . map Node.idx $ nl2
1249 nl3 = map (\n -> n { Node.group = Group.idx grp2
1250 , Node.idx = Node.idx n + maxndx }) nl2
1251 nl4 = Container.fromList . map (\n -> (Node.idx n, n)) $ nl3
1252 gl' = Container.add (Group.idx grp2) grp2 defGroupList
1253 nl' = IntMap.union nl nl4
1254 in check_EvacMode grp2 inst' $
1255 Cluster.tryChangeGroup gl' nl' il [] [Instance.idx inst']
1257 -- | Check that allocating multiple instances on a cluster, then
1258 -- adding an empty node, results in a valid rebalance.
1259 prop_ClusterAllocBalance =
1260 forAll (genNode (Just 5) (Just 128)) $ \node ->
1261 forAll (choose (3, 5)) $ \count ->
1262 not (Node.offline node) && not (Node.failN1 node) ==>
1263 let nl = makeSmallCluster node count
1264 (hnode, nl') = IntMap.deleteFindMax nl
1265 il = Container.empty
1266 allocnodes = Cluster.genAllocNodes defGroupList nl' 2 True
1267 i_templ = createInstance Types.unitMem Types.unitDsk Types.unitCpu
1268 in case allocnodes >>= \allocnodes' ->
1269 Cluster.iterateAlloc nl' il (Just 5) i_templ allocnodes' [] [] of
1270 Types.Bad msg -> failTest $ "Failed to allocate: " ++ msg
1271 Types.Ok (_, _, _, [], _) -> failTest "Failed to allocate: no instances"
1272 Types.Ok (_, xnl, il', _, _) ->
1273 let ynl = Container.add (Node.idx hnode) hnode xnl
1274 cv = Cluster.compCV ynl
1275 tbl = Cluster.Table ynl il' cv []
1276 in printTestCase "Failed to rebalance" $
1277 canBalance tbl True True False
1279 -- | Checks consistency.
1280 prop_ClusterCheckConsistency node inst =
1281 let nl = makeSmallCluster node 3
1282 [node1, node2, node3] = Container.elems nl
1283 node3' = node3 { Node.group = 1 }
1284 nl' = Container.add (Node.idx node3') node3' nl
1285 inst1 = Instance.setBoth inst (Node.idx node1) (Node.idx node2)
1286 inst2 = Instance.setBoth inst (Node.idx node1) Node.noSecondary
1287 inst3 = Instance.setBoth inst (Node.idx node1) (Node.idx node3)
1288 ccheck = Cluster.findSplitInstances nl' . Container.fromList
1289 in null (ccheck [(0, inst1)]) &&
1290 null (ccheck [(0, inst2)]) &&
1291 (not . null $ ccheck [(0, inst3)])
1293 -- | For now, we only test that we don't lose instances during the split.
1294 prop_ClusterSplitCluster node inst =
1295 forAll (choose (0, 100)) $ \icnt ->
1296 let nl = makeSmallCluster node 2
1297 (nl', il') = foldl (\(ns, is) _ -> assignInstance ns is inst 0 1)
1298 (nl, Container.empty) [1..icnt]
1299 gni = Cluster.splitCluster nl' il'
1300 in sum (map (Container.size . snd . snd) gni) == icnt &&
1301 all (\(guuid, (nl'', _)) -> all ((== guuid) . Node.group)
1302 (Container.elems nl'')) gni
1304 -- | Helper function to check if we can allocate an instance on a
1306 canAllocOn :: Node.List -> Int -> Instance.Instance -> Bool
1307 canAllocOn nl reqnodes inst =
1308 case Cluster.genAllocNodes defGroupList nl reqnodes True >>=
1309 Cluster.tryAlloc nl (Container.empty) inst of
1310 Types.Bad _ -> False
1312 case Cluster.asSolution as of
1316 -- | Checks that allocation obeys minimum and maximum instance
1317 -- policies. The unittest generates a random node, duplicates it count
1318 -- times, and generates a random instance that can be allocated on
1319 -- this mini-cluster; it then checks that after applying a policy that
1320 -- the instance doesn't fits, the allocation fails.
1321 prop_ClusterAllocPolicy node =
1322 -- rqn is the required nodes (1 or 2)
1323 forAll (choose (1, 2)) $ \rqn ->
1324 forAll (choose (5, 20)) $ \count ->
1325 forAll (arbitrary `suchThat` (canAllocOn (makeSmallCluster node count) rqn))
1327 forAll (arbitrary `suchThat` (isFailure .
1328 Instance.instMatchesPolicy inst)) $ \ipol ->
1329 let node' = Node.setPolicy ipol node
1330 nl = makeSmallCluster node' count
1331 in not $ canAllocOn nl rqn inst
1336 , 'prop_ClusterAlloc_sane
1337 , 'prop_ClusterCanTieredAlloc
1338 , 'prop_ClusterAllocRelocate
1339 , 'prop_ClusterAllocEvacuate
1340 , 'prop_ClusterAllocChangeGroup
1341 , 'prop_ClusterAllocBalance
1342 , 'prop_ClusterCheckConsistency
1343 , 'prop_ClusterSplitCluster
1344 , 'prop_ClusterAllocPolicy
1349 -- | Check that opcode serialization is idempotent.
1350 prop_OpCodes_serialization op =
1351 case J.readJSON (J.showJSON op) of
1352 J.Error e -> failTest $ "Cannot deserialise: " ++ e
1353 J.Ok op' -> op ==? op'
1354 where _types = op::OpCodes.OpCode
1357 [ 'prop_OpCodes_serialization ]
1361 -- | Check that (queued) job\/opcode status serialization is idempotent.
1362 prop_OpStatus_serialization os =
1363 case J.readJSON (J.showJSON os) of
1364 J.Error e -> failTest $ "Cannot deserialise: " ++ e
1365 J.Ok os' -> os ==? os'
1366 where _types = os::Jobs.OpStatus
1368 prop_JobStatus_serialization js =
1369 case J.readJSON (J.showJSON js) of
1370 J.Error e -> failTest $ "Cannot deserialise: " ++ e
1371 J.Ok js' -> js ==? js'
1372 where _types = js::Jobs.JobStatus
1375 [ 'prop_OpStatus_serialization
1376 , 'prop_JobStatus_serialization
1381 prop_Loader_lookupNode ktn inst node =
1382 Loader.lookupNode nl inst node ==? Data.Map.lookup node nl
1383 where nl = Data.Map.fromList ktn
1385 prop_Loader_lookupInstance kti inst =
1386 Loader.lookupInstance il inst ==? Data.Map.lookup inst il
1387 where il = Data.Map.fromList kti
1389 prop_Loader_assignIndices =
1390 -- generate nodes with unique names
1391 forAll (arbitrary `suchThat`
1393 let names = map Node.name nodes
1394 in length names == length (nub names))) $ \nodes ->
1396 Loader.assignIndices (map (\n -> (Node.name n, n)) nodes)
1397 in Data.Map.size nassoc == length nodes &&
1398 Container.size kt == length nodes &&
1400 then maximum (IntMap.keys kt) == length nodes - 1
1403 -- | Checks that the number of primary instances recorded on the nodes
1405 prop_Loader_mergeData ns =
1406 let na = Container.fromList $ map (\n -> (Node.idx n, n)) ns
1407 in case Loader.mergeData [] [] [] []
1408 (Loader.emptyCluster {Loader.cdNodes = na}) of
1409 Types.Bad _ -> False
1410 Types.Ok (Loader.ClusterData _ nl il _ _) ->
1411 let nodes = Container.elems nl
1412 instances = Container.elems il
1413 in (sum . map (length . Node.pList)) nodes == 0 &&
1416 -- | Check that compareNameComponent on equal strings works.
1417 prop_Loader_compareNameComponent_equal :: String -> Bool
1418 prop_Loader_compareNameComponent_equal s =
1419 Loader.compareNameComponent s s ==
1420 Loader.LookupResult Loader.ExactMatch s
1422 -- | Check that compareNameComponent on prefix strings works.
1423 prop_Loader_compareNameComponent_prefix :: NonEmptyList Char -> String -> Bool
1424 prop_Loader_compareNameComponent_prefix (NonEmpty s1) s2 =
1425 Loader.compareNameComponent (s1 ++ "." ++ s2) s1 ==
1426 Loader.LookupResult Loader.PartialMatch s1
1429 [ 'prop_Loader_lookupNode
1430 , 'prop_Loader_lookupInstance
1431 , 'prop_Loader_assignIndices
1432 , 'prop_Loader_mergeData
1433 , 'prop_Loader_compareNameComponent_equal
1434 , 'prop_Loader_compareNameComponent_prefix
1439 prop_Types_AllocPolicy_serialisation apol =
1440 case J.readJSON (J.showJSON apol) of
1441 J.Ok p -> p ==? apol
1442 J.Error s -> failTest $ "Failed to deserialise: " ++ s
1443 where _types = apol::Types.AllocPolicy
1445 prop_Types_DiskTemplate_serialisation dt =
1446 case J.readJSON (J.showJSON dt) of
1448 J.Error s -> failTest $ "Failed to deserialise: " ++ s
1449 where _types = dt::Types.DiskTemplate
1451 prop_Types_ISpec_serialisation ispec =
1452 case J.readJSON (J.showJSON ispec) of
1453 J.Ok p -> p ==? ispec
1454 J.Error s -> failTest $ "Failed to deserialise: " ++ s
1455 where _types = ispec::Types.ISpec
1457 prop_Types_IPolicy_serialisation ipol =
1458 case J.readJSON (J.showJSON ipol) of
1459 J.Ok p -> p ==? ipol
1460 J.Error s -> failTest $ "Failed to deserialise: " ++ s
1461 where _types = ipol::Types.IPolicy
1463 prop_Types_EvacMode_serialisation em =
1464 case J.readJSON (J.showJSON em) of
1466 J.Error s -> failTest $ "Failed to deserialise: " ++ s
1467 where _types = em::Types.EvacMode
1469 prop_Types_opToResult op =
1471 Types.OpFail _ -> Types.isBad r
1472 Types.OpGood v -> case r of
1473 Types.Bad _ -> False
1474 Types.Ok v' -> v == v'
1475 where r = Types.opToResult op
1476 _types = op::Types.OpResult Int
1478 prop_Types_eitherToResult ei =
1480 Left _ -> Types.isBad r
1481 Right v -> case r of
1482 Types.Bad _ -> False
1483 Types.Ok v' -> v == v'
1484 where r = Types.eitherToResult ei
1485 _types = ei::Either String Int
1488 [ 'prop_Types_AllocPolicy_serialisation
1489 , 'prop_Types_DiskTemplate_serialisation
1490 , 'prop_Types_ISpec_serialisation
1491 , 'prop_Types_IPolicy_serialisation
1492 , 'prop_Types_EvacMode_serialisation
1493 , 'prop_Types_opToResult
1494 , 'prop_Types_eitherToResult
1499 -- | Test correct parsing.
1500 prop_CLI_parseISpec descr dsk mem cpu =
1501 let str = printf "%d,%d,%d" dsk mem cpu
1502 in CLI.parseISpecString descr str ==? Types.Ok (Types.RSpec cpu mem dsk)
1504 -- | Test parsing failure due to wrong section count.
1505 prop_CLI_parseISpecFail descr =
1506 forAll (choose (0,100) `suchThat` ((/=) 3)) $ \nelems ->
1507 forAll (replicateM nelems arbitrary) $ \values ->
1508 let str = intercalate "," $ map show (values::[Int])
1509 in case CLI.parseISpecString descr str of
1510 Types.Ok v -> failTest $ "Expected failure, got " ++ show v
1513 -- | Test parseYesNo.
1514 prop_CLI_parseYesNo def testval val =
1515 forAll (elements [val, "yes", "no"]) $ \actual_val ->
1517 then CLI.parseYesNo def Nothing ==? Types.Ok def
1518 else let result = CLI.parseYesNo def (Just actual_val)
1519 in if actual_val `elem` ["yes", "no"]
1520 then result ==? Types.Ok (actual_val == "yes")
1521 else property $ Types.isBad result
1523 -- | Helper to check for correct parsing of string arg.
1524 checkStringArg val (opt, fn) =
1525 let GetOpt.Option _ longs _ _ = opt
1527 [] -> failTest "no long options?"
1529 case CLI.parseOptsInner ["--" ++ cmdarg ++ "=" ++ val] "prog" [opt] of
1530 Left e -> failTest $ "Failed to parse option: " ++ show e
1531 Right (options, _) -> fn options ==? Just val
1533 -- | Test a few string arguments.
1534 prop_CLI_StringArg argument =
1535 let args = [ (CLI.oDataFile, CLI.optDataFile)
1536 , (CLI.oDynuFile, CLI.optDynuFile)
1537 , (CLI.oSaveCluster, CLI.optSaveCluster)
1538 , (CLI.oReplay, CLI.optReplay)
1539 , (CLI.oPrintCommands, CLI.optShowCmds)
1540 , (CLI.oLuxiSocket, CLI.optLuxi)
1542 in conjoin $ map (checkStringArg argument) args
1544 -- | Helper to test that a given option is accepted OK with quick exit.
1545 checkEarlyExit name options param =
1546 case CLI.parseOptsInner [param] name options of
1547 Left (code, _) -> if code == 0
1549 else failTest $ "Program " ++ name ++
1550 " returns invalid code " ++ show code ++
1551 " for option " ++ param
1552 _ -> failTest $ "Program " ++ name ++ " doesn't consider option " ++
1553 param ++ " as early exit one"
1555 -- | Test that all binaries support some common options. There is
1556 -- nothing actually random about this test...
1558 let params = ["-h", "--help", "-V", "--version"]
1559 opts = map (\(name, (_, o)) -> (name, o)) Program.personalities
1560 -- apply checkEarlyExit across the cartesian product of params and opts
1561 in conjoin [checkEarlyExit n o p | p <- params, (n, o) <- opts]
1564 [ 'prop_CLI_parseISpec
1565 , 'prop_CLI_parseISpecFail
1566 , 'prop_CLI_parseYesNo
1567 , 'prop_CLI_StringArg