1 {-# LANGUAGE TemplateHaskell #-}
2 {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-imports #-}
4 -- FIXME: should remove the no-warn-unused-imports option, once we get
5 -- around to testing function from all modules; until then, we keep
6 -- the (unused) imports here to generate correct coverage (0 for
7 -- modules we don't use)
9 {-| Unittests for ganeti-htools.
15 Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
17 This program is free software; you can redistribute it and/or modify
18 it under the terms of the GNU General Public License as published by
19 the Free Software Foundation; either version 2 of the License, or
20 (at your option) any later version.
22 This program is distributed in the hope that it will be useful, but
23 WITHOUT ANY WARRANTY; without even the implied warranty of
24 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
25 General Public License for more details.
27 You should have received a copy of the GNU General Public License
28 along with this program; if not, write to the Free Software
29 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
34 module Ganeti.HTools.QC
53 import Test.QuickCheck
54 import Test.QuickCheck.Monadic (assert, monadicIO, run)
55 import Text.Printf (printf)
56 import Data.List (intercalate, nub, isPrefixOf)
59 import Control.Applicative
60 import qualified System.Console.GetOpt as GetOpt
61 import qualified Text.JSON as J
62 import qualified Data.Map
63 import qualified Data.IntMap as IntMap
64 import Control.Concurrent (forkIO)
65 import Control.Exception (bracket, catchJust)
66 import System.Directory (getTemporaryDirectory, removeFile)
67 import System.IO (hClose, openTempFile)
68 import System.IO.Error (isEOFErrorType, ioeGetErrorType)
70 import qualified Ganeti.Confd as Confd
71 import qualified Ganeti.Config as Config
72 import qualified Ganeti.Daemon as Daemon
73 import qualified Ganeti.Hash as Hash
74 import qualified Ganeti.BasicTypes as BasicTypes
75 import qualified Ganeti.Jobs as Jobs
76 import qualified Ganeti.Logging as Logging
77 import qualified Ganeti.Luxi as Luxi
78 import qualified Ganeti.Objects as Objects
79 import qualified Ganeti.OpCodes as OpCodes
80 import qualified Ganeti.Query2 as Query2
81 import qualified Ganeti.Runtime as Runtime
82 import qualified Ganeti.Ssconf as Ssconf
83 import qualified Ganeti.HTools.CLI as CLI
84 import qualified Ganeti.HTools.Cluster as Cluster
85 import qualified Ganeti.HTools.Container as Container
86 import qualified Ganeti.HTools.ExtLoader
87 import qualified Ganeti.HTools.Group as Group
88 import qualified Ganeti.HTools.IAlloc as IAlloc
89 import qualified Ganeti.HTools.Instance as Instance
90 import qualified Ganeti.HTools.JSON as JSON
91 import qualified Ganeti.HTools.Loader as Loader
92 import qualified Ganeti.HTools.Luxi as HTools.Luxi
93 import qualified Ganeti.HTools.Node as Node
94 import qualified Ganeti.HTools.PeerMap as PeerMap
95 import qualified Ganeti.HTools.Rapi
96 import qualified Ganeti.HTools.Simu as Simu
97 import qualified Ganeti.HTools.Text as Text
98 import qualified Ganeti.HTools.Types as Types
99 import qualified Ganeti.HTools.Utils as Utils
100 import qualified Ganeti.HTools.Version
101 import qualified Ganeti.Constants as C
103 import qualified Ganeti.HTools.Program as Program
104 import qualified Ganeti.HTools.Program.Hail
105 import qualified Ganeti.HTools.Program.Hbal
106 import qualified Ganeti.HTools.Program.Hscan
107 import qualified Ganeti.HTools.Program.Hspace
109 import Ganeti.HTools.QCHelper (testSuite)
113 -- | Maximum memory (1TiB, somewhat random value).
117 -- | Maximum disk (8TiB, somewhat random value).
119 maxDsk = 1024 * 1024 * 8
121 -- | Max CPUs (1024, somewhat random value).
125 -- | Max vcpu ratio (random value).
126 maxVcpuRatio :: Double
127 maxVcpuRatio = 1024.0
129 -- | Max spindle ratio (random value).
130 maxSpindleRatio :: Double
131 maxSpindleRatio = 1024.0
133 -- | Max nodes, used just to limit arbitrary instances for smaller
134 -- opcode definitions (e.g. list of nodes in OpTestDelay).
138 -- | Max opcodes or jobs in a submit job and submit many jobs.
142 -- | All disk templates (used later)
143 allDiskTemplates :: [Types.DiskTemplate]
144 allDiskTemplates = [minBound..maxBound]
146 -- | Null iPolicy, and by null we mean very liberal.
147 nullIPolicy :: Types.IPolicy
148 nullIPolicy = Types.IPolicy
149 { Types.iPolicyMinSpec = Types.ISpec { Types.iSpecMemorySize = 0
150 , Types.iSpecCpuCount = 0
151 , Types.iSpecDiskSize = 0
152 , Types.iSpecDiskCount = 0
153 , Types.iSpecNicCount = 0
154 , Types.iSpecSpindleUse = 0
156 , Types.iPolicyMaxSpec = Types.ISpec { Types.iSpecMemorySize = maxBound
157 , Types.iSpecCpuCount = maxBound
158 , Types.iSpecDiskSize = maxBound
159 , Types.iSpecDiskCount = C.maxDisks
160 , Types.iSpecNicCount = C.maxNics
161 , Types.iSpecSpindleUse = maxBound
163 , Types.iPolicyStdSpec = Types.ISpec { Types.iSpecMemorySize = Types.unitMem
164 , Types.iSpecCpuCount = Types.unitCpu
165 , Types.iSpecDiskSize = Types.unitDsk
166 , Types.iSpecDiskCount = 1
167 , Types.iSpecNicCount = 1
168 , Types.iSpecSpindleUse = 1
170 , Types.iPolicyDiskTemplates = [minBound..maxBound]
171 , Types.iPolicyVcpuRatio = maxVcpuRatio -- somewhat random value, high
172 -- enough to not impact us
173 , Types.iPolicySpindleRatio = maxSpindleRatio
177 defGroup :: Group.Group
178 defGroup = flip Group.setIdx 0 $
179 Group.create "default" Types.defaultGroupID Types.AllocPreferred
182 defGroupList :: Group.List
183 defGroupList = Container.fromList [(Group.idx defGroup, defGroup)]
185 defGroupAssoc :: Data.Map.Map String Types.Gdx
186 defGroupAssoc = Data.Map.singleton (Group.uuid defGroup) (Group.idx defGroup)
188 -- * Helper functions
190 -- | Simple checker for whether OpResult is fail or pass.
191 isFailure :: Types.OpResult a -> Bool
192 isFailure (Types.OpFail _) = True
195 -- | Checks for equality with proper annotation.
196 (==?) :: (Show a, Eq a) => a -> a -> Property
197 (==?) x y = printTestCase
198 ("Expected equality, but '" ++
199 show x ++ "' /= '" ++ show y ++ "'") (x == y)
202 -- | Show a message and fail the test.
203 failTest :: String -> Property
204 failTest msg = printTestCase msg False
206 -- | Update an instance to be smaller than a node.
207 setInstanceSmallerThanNode :: Node.Node
208 -> Instance.Instance -> Instance.Instance
209 setInstanceSmallerThanNode node inst =
210 inst { Instance.mem = Node.availMem node `div` 2
211 , Instance.dsk = Node.availDisk node `div` 2
212 , Instance.vcpus = Node.availCpu node `div` 2
215 -- | Create an instance given its spec.
216 createInstance :: Int -> Int -> Int -> Instance.Instance
217 createInstance mem dsk vcpus =
218 Instance.create "inst-unnamed" mem dsk vcpus Types.Running [] True (-1) (-1)
221 -- | Create a small cluster by repeating a node spec.
222 makeSmallCluster :: Node.Node -> Int -> Node.List
223 makeSmallCluster node count =
224 let origname = Node.name node
225 origalias = Node.alias node
226 nodes = map (\idx -> node { Node.name = origname ++ "-" ++ show idx
227 , Node.alias = origalias ++ "-" ++ show idx })
229 fn = flip Node.buildPeers Container.empty
230 namelst = map (\n -> (Node.name n, fn n)) nodes
231 (_, nlst) = Loader.assignIndices namelst
234 -- | Make a small cluster, both nodes and instances.
235 makeSmallEmptyCluster :: Node.Node -> Int -> Instance.Instance
236 -> (Node.List, Instance.List, Instance.Instance)
237 makeSmallEmptyCluster node count inst =
238 (makeSmallCluster node count, Container.empty,
239 setInstanceSmallerThanNode node inst)
241 -- | Checks if a node is "big" enough.
242 isNodeBig :: Int -> Node.Node -> Bool
243 isNodeBig size node = Node.availDisk node > size * Types.unitDsk
244 && Node.availMem node > size * Types.unitMem
245 && Node.availCpu node > size * Types.unitCpu
247 canBalance :: Cluster.Table -> Bool -> Bool -> Bool -> Bool
248 canBalance tbl dm im evac = isJust $ Cluster.tryBalance tbl dm im evac 0 0
250 -- | Assigns a new fresh instance to a cluster; this is not
251 -- allocation, so no resource checks are done.
252 assignInstance :: Node.List -> Instance.List -> Instance.Instance ->
253 Types.Idx -> Types.Idx ->
254 (Node.List, Instance.List)
255 assignInstance nl il inst pdx sdx =
256 let pnode = Container.find pdx nl
257 snode = Container.find sdx nl
258 maxiidx = if Container.null il
260 else fst (Container.findMax il) + 1
261 inst' = inst { Instance.idx = maxiidx,
262 Instance.pNode = pdx, Instance.sNode = sdx }
263 pnode' = Node.setPri pnode inst'
264 snode' = Node.setSec snode inst'
265 nl' = Container.addTwo pdx pnode' sdx snode' nl
266 il' = Container.add maxiidx inst' il
269 -- | Generates a list of a given size with non-duplicate elements.
270 genUniquesList :: (Eq a, Arbitrary a) => Int -> Gen [a]
273 newelem <- arbitrary `suchThat` (`notElem` lst)
274 return (newelem:lst)) [] [1..cnt]
276 -- | Checks if an instance is mirrored.
277 isMirrored :: Instance.Instance -> Bool
278 isMirrored = (/= Types.MirrorNone) . Instance.mirrorType
280 -- | Returns the possible change node types for a disk template.
281 evacModeOptions :: Types.MirrorType -> [Types.EvacMode]
282 evacModeOptions Types.MirrorNone = []
283 evacModeOptions Types.MirrorInternal = [minBound..maxBound] -- DRBD can do all
284 evacModeOptions Types.MirrorExternal = [Types.ChangePrimary, Types.ChangeAll]
286 -- * Arbitrary instances
288 -- | Defines a DNS name.
289 newtype DNSChar = DNSChar { dnsGetChar::Char }
291 instance Arbitrary DNSChar where
293 x <- elements (['a'..'z'] ++ ['0'..'9'] ++ "_-")
296 instance Show DNSChar where
297 show = show . dnsGetChar
299 -- | Generates a single name component.
300 getName :: Gen String
304 return (map dnsGetChar dn)
306 -- | Generates an entire FQDN.
307 getFQDN :: Gen String
309 ncomps <- choose (1, 4)
310 names <- vectorOf ncomps getName
311 return $ intercalate "." names
313 -- | Combinator that generates a 'Maybe' using a sub-combinator.
314 getMaybe :: Gen a -> Gen (Maybe a)
321 -- | Generates a fields list. This uses the same character set as a
322 -- DNS name (just for simplicity).
323 getFields :: Gen [String]
328 -- | Defines a tag type.
329 newtype TagChar = TagChar { tagGetChar :: Char }
331 -- | All valid tag chars. This doesn't need to match _exactly_
332 -- Ganeti's own tag regex, just enough for it to be close.
334 tagChar = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ".+*/:@-"
336 instance Arbitrary TagChar where
338 c <- elements tagChar
342 genTag :: Gen [TagChar]
344 -- the correct value would be C.maxTagLen, but that's way too
345 -- verbose in unittests, and at the moment I don't see any possible
346 -- bugs with longer tags and the way we use tags in htools
350 -- | Generates a list of tags (correctly upper bounded).
351 genTags :: Gen [String]
353 -- the correct value would be C.maxTagsPerObj, but per the comment
354 -- in genTag, we don't use tags enough in htools to warrant testing
356 n <- choose (0, 10::Int)
357 tags <- mapM (const genTag) [1..n]
358 return $ map (map tagGetChar) tags
360 instance Arbitrary Types.InstanceStatus where
361 arbitrary = elements [minBound..maxBound]
363 -- | Generates a random instance with maximum disk/mem/cpu values.
364 genInstanceSmallerThan :: Int -> Int -> Int -> Gen Instance.Instance
365 genInstanceSmallerThan lim_mem lim_dsk lim_cpu = do
367 mem <- choose (0, lim_mem)
368 dsk <- choose (0, lim_dsk)
372 vcpus <- choose (0, lim_cpu)
374 return $ Instance.create name mem dsk vcpus run_st [] True pn sn dt 1
376 -- | Generates an instance smaller than a node.
377 genInstanceSmallerThanNode :: Node.Node -> Gen Instance.Instance
378 genInstanceSmallerThanNode node =
379 genInstanceSmallerThan (Node.availMem node `div` 2)
380 (Node.availDisk node `div` 2)
381 (Node.availCpu node `div` 2)
383 -- let's generate a random instance
384 instance Arbitrary Instance.Instance where
385 arbitrary = genInstanceSmallerThan maxMem maxDsk maxCpu
387 -- | Generas an arbitrary node based on sizing information.
388 genNode :: Maybe Int -- ^ Minimum node size in terms of units
389 -> Maybe Int -- ^ Maximum node size (when Nothing, bounded
390 -- just by the max... constants)
392 genNode min_multiplier max_multiplier = do
393 let (base_mem, base_dsk, base_cpu) =
394 case min_multiplier of
395 Just mm -> (mm * Types.unitMem,
399 (top_mem, top_dsk, top_cpu) =
400 case max_multiplier of
401 Just mm -> (mm * Types.unitMem,
404 Nothing -> (maxMem, maxDsk, maxCpu)
406 mem_t <- choose (base_mem, top_mem)
407 mem_f <- choose (base_mem, mem_t)
408 mem_n <- choose (0, mem_t - mem_f)
409 dsk_t <- choose (base_dsk, top_dsk)
410 dsk_f <- choose (base_dsk, dsk_t)
411 cpu_t <- choose (base_cpu, top_cpu)
413 let n = Node.create name (fromIntegral mem_t) mem_n mem_f
414 (fromIntegral dsk_t) dsk_f (fromIntegral cpu_t) offl 1 0
415 n' = Node.setPolicy nullIPolicy n
416 return $ Node.buildPeers n' Container.empty
418 -- | Helper function to generate a sane node.
419 genOnlineNode :: Gen Node.Node
421 arbitrary `suchThat` (\n -> not (Node.offline n) &&
422 not (Node.failN1 n) &&
423 Node.availDisk n > 0 &&
424 Node.availMem n > 0 &&
428 instance Arbitrary Node.Node where
429 arbitrary = genNode Nothing Nothing
432 instance Arbitrary OpCodes.ReplaceDisksMode where
433 arbitrary = elements [minBound..maxBound]
435 instance Arbitrary OpCodes.OpCode where
437 op_id <- elements [ "OP_TEST_DELAY"
438 , "OP_INSTANCE_REPLACE_DISKS"
439 , "OP_INSTANCE_FAILOVER"
440 , "OP_INSTANCE_MIGRATE"
444 OpCodes.OpTestDelay <$> arbitrary <*> arbitrary
445 <*> resize maxNodes (listOf getFQDN)
446 "OP_INSTANCE_REPLACE_DISKS" ->
447 OpCodes.OpInstanceReplaceDisks <$> getFQDN <*> getMaybe getFQDN <*>
448 arbitrary <*> resize C.maxDisks arbitrary <*> getMaybe getName
449 "OP_INSTANCE_FAILOVER" ->
450 OpCodes.OpInstanceFailover <$> getFQDN <*> arbitrary <*>
452 "OP_INSTANCE_MIGRATE" ->
453 OpCodes.OpInstanceMigrate <$> getFQDN <*> arbitrary <*>
454 arbitrary <*> arbitrary <*> getMaybe getFQDN
455 _ -> fail "Wrong opcode"
457 instance Arbitrary Jobs.OpStatus where
458 arbitrary = elements [minBound..maxBound]
460 instance Arbitrary Jobs.JobStatus where
461 arbitrary = elements [minBound..maxBound]
463 newtype SmallRatio = SmallRatio Double deriving Show
464 instance Arbitrary SmallRatio where
467 return $ SmallRatio v
469 instance Arbitrary Types.AllocPolicy where
470 arbitrary = elements [minBound..maxBound]
472 instance Arbitrary Types.DiskTemplate where
473 arbitrary = elements [minBound..maxBound]
475 instance Arbitrary Types.FailMode where
476 arbitrary = elements [minBound..maxBound]
478 instance Arbitrary Types.EvacMode where
479 arbitrary = elements [minBound..maxBound]
481 instance Arbitrary a => Arbitrary (Types.OpResult a) where
482 arbitrary = arbitrary >>= \c ->
484 then Types.OpGood <$> arbitrary
485 else Types.OpFail <$> arbitrary
487 instance Arbitrary Types.ISpec where
489 mem_s <- arbitrary::Gen (NonNegative Int)
490 dsk_c <- arbitrary::Gen (NonNegative Int)
491 dsk_s <- arbitrary::Gen (NonNegative Int)
492 cpu_c <- arbitrary::Gen (NonNegative Int)
493 nic_c <- arbitrary::Gen (NonNegative Int)
494 su <- arbitrary::Gen (NonNegative Int)
495 return Types.ISpec { Types.iSpecMemorySize = fromIntegral mem_s
496 , Types.iSpecCpuCount = fromIntegral cpu_c
497 , Types.iSpecDiskSize = fromIntegral dsk_s
498 , Types.iSpecDiskCount = fromIntegral dsk_c
499 , Types.iSpecNicCount = fromIntegral nic_c
500 , Types.iSpecSpindleUse = fromIntegral su
503 -- | Generates an ispec bigger than the given one.
504 genBiggerISpec :: Types.ISpec -> Gen Types.ISpec
505 genBiggerISpec imin = do
506 mem_s <- choose (Types.iSpecMemorySize imin, maxBound)
507 dsk_c <- choose (Types.iSpecDiskCount imin, maxBound)
508 dsk_s <- choose (Types.iSpecDiskSize imin, maxBound)
509 cpu_c <- choose (Types.iSpecCpuCount imin, maxBound)
510 nic_c <- choose (Types.iSpecNicCount imin, maxBound)
511 su <- choose (Types.iSpecSpindleUse imin, maxBound)
512 return Types.ISpec { Types.iSpecMemorySize = fromIntegral mem_s
513 , Types.iSpecCpuCount = fromIntegral cpu_c
514 , Types.iSpecDiskSize = fromIntegral dsk_s
515 , Types.iSpecDiskCount = fromIntegral dsk_c
516 , Types.iSpecNicCount = fromIntegral nic_c
517 , Types.iSpecSpindleUse = fromIntegral su
520 instance Arbitrary Types.IPolicy where
523 istd <- genBiggerISpec imin
524 imax <- genBiggerISpec istd
525 num_tmpl <- choose (0, length allDiskTemplates)
526 dts <- genUniquesList num_tmpl
527 vcpu_ratio <- choose (1.0, maxVcpuRatio)
528 spindle_ratio <- choose (1.0, maxSpindleRatio)
529 return Types.IPolicy { Types.iPolicyMinSpec = imin
530 , Types.iPolicyStdSpec = istd
531 , Types.iPolicyMaxSpec = imax
532 , Types.iPolicyDiskTemplates = dts
533 , Types.iPolicyVcpuRatio = vcpu_ratio
534 , Types.iPolicySpindleRatio = spindle_ratio
541 -- | Helper to generate a small string that doesn't contain commas.
542 genNonCommaString :: Gen [Char]
543 genNonCommaString = do
544 size <- choose (0, 20) -- arbitrary max size
545 vectorOf size (arbitrary `suchThat` ((/=) ','))
547 -- | If the list is not just an empty element, and if the elements do
548 -- not contain commas, then join+split should be idempotent.
549 prop_Utils_commaJoinSplit :: Property
550 prop_Utils_commaJoinSplit =
551 forAll (choose (0, 20)) $ \llen ->
552 forAll (vectorOf llen genNonCommaString `suchThat` ((/=) [""])) $ \lst ->
553 Utils.sepSplit ',' (Utils.commaJoin lst) ==? lst
555 -- | Split and join should always be idempotent.
556 prop_Utils_commaSplitJoin :: [Char] -> Property
557 prop_Utils_commaSplitJoin s =
558 Utils.commaJoin (Utils.sepSplit ',' s) ==? s
560 -- | fromObjWithDefault, we test using the Maybe monad and an integer
562 prop_Utils_fromObjWithDefault :: Integer -> String -> Bool
563 prop_Utils_fromObjWithDefault def_value random_key =
564 -- a missing key will be returned with the default
565 JSON.fromObjWithDefault [] random_key def_value == Just def_value &&
566 -- a found key will be returned as is, not with default
567 JSON.fromObjWithDefault [(random_key, J.showJSON def_value)]
568 random_key (def_value+1) == Just def_value
570 -- | Test that functional if' behaves like the syntactic sugar if.
571 prop_Utils_if'if :: Bool -> Int -> Int -> Gen Prop
572 prop_Utils_if'if cnd a b =
573 Utils.if' cnd a b ==? if cnd then a else b
575 -- | Test basic select functionality
576 prop_Utils_select :: Int -- ^ Default result
577 -> [Int] -- ^ List of False values
578 -> [Int] -- ^ List of True values
579 -> Gen Prop -- ^ Test result
580 prop_Utils_select def lst1 lst2 =
581 Utils.select def (flist ++ tlist) ==? expectedresult
582 where expectedresult = Utils.if' (null lst2) def (head lst2)
583 flist = zip (repeat False) lst1
584 tlist = zip (repeat True) lst2
586 -- | Test basic select functionality with undefined default
587 prop_Utils_select_undefd :: [Int] -- ^ List of False values
588 -> NonEmptyList Int -- ^ List of True values
589 -> Gen Prop -- ^ Test result
590 prop_Utils_select_undefd lst1 (NonEmpty lst2) =
591 Utils.select undefined (flist ++ tlist) ==? head lst2
592 where flist = zip (repeat False) lst1
593 tlist = zip (repeat True) lst2
595 -- | Test basic select functionality with undefined list values
596 prop_Utils_select_undefv :: [Int] -- ^ List of False values
597 -> NonEmptyList Int -- ^ List of True values
598 -> Gen Prop -- ^ Test result
599 prop_Utils_select_undefv lst1 (NonEmpty lst2) =
600 Utils.select undefined cndlist ==? head lst2
601 where flist = zip (repeat False) lst1
602 tlist = zip (repeat True) lst2
603 cndlist = flist ++ tlist ++ [undefined]
605 prop_Utils_parseUnit :: NonNegative Int -> Property
606 prop_Utils_parseUnit (NonNegative n) =
607 Utils.parseUnit (show n) ==? Types.Ok n .&&.
608 Utils.parseUnit (show n ++ "m") ==? Types.Ok n .&&.
609 Utils.parseUnit (show n ++ "M") ==? Types.Ok (truncate n_mb::Int) .&&.
610 Utils.parseUnit (show n ++ "g") ==? Types.Ok (n*1024) .&&.
611 Utils.parseUnit (show n ++ "G") ==? Types.Ok (truncate n_gb::Int) .&&.
612 Utils.parseUnit (show n ++ "t") ==? Types.Ok (n*1048576) .&&.
613 Utils.parseUnit (show n ++ "T") ==? Types.Ok (truncate n_tb::Int) .&&.
614 printTestCase "Internal error/overflow?"
615 (n_mb >=0 && n_gb >= 0 && n_tb >= 0) .&&.
616 property (Types.isBad (Utils.parseUnit (show n ++ "x")::Types.Result Int))
617 where n_mb = (fromIntegral n::Rational) * 1000 * 1000 / 1024 / 1024
621 -- | Test list for the Utils module.
623 [ 'prop_Utils_commaJoinSplit
624 , 'prop_Utils_commaSplitJoin
625 , 'prop_Utils_fromObjWithDefault
628 , 'prop_Utils_select_undefd
629 , 'prop_Utils_select_undefv
630 , 'prop_Utils_parseUnit
635 -- | Make sure add is idempotent.
636 prop_PeerMap_addIdempotent :: PeerMap.PeerMap
637 -> PeerMap.Key -> PeerMap.Elem -> Property
638 prop_PeerMap_addIdempotent pmap key em =
639 fn puniq ==? fn (fn puniq)
640 where fn = PeerMap.add key em
641 puniq = PeerMap.accumArray const pmap
643 -- | Make sure remove is idempotent.
644 prop_PeerMap_removeIdempotent :: PeerMap.PeerMap -> PeerMap.Key -> Property
645 prop_PeerMap_removeIdempotent pmap key =
646 fn puniq ==? fn (fn puniq)
647 where fn = PeerMap.remove key
648 puniq = PeerMap.accumArray const pmap
650 -- | Make sure a missing item returns 0.
651 prop_PeerMap_findMissing :: PeerMap.PeerMap -> PeerMap.Key -> Property
652 prop_PeerMap_findMissing pmap key =
653 PeerMap.find key (PeerMap.remove key puniq) ==? 0
654 where puniq = PeerMap.accumArray const pmap
656 -- | Make sure an added item is found.
657 prop_PeerMap_addFind :: PeerMap.PeerMap
658 -> PeerMap.Key -> PeerMap.Elem -> Property
659 prop_PeerMap_addFind pmap key em =
660 PeerMap.find key (PeerMap.add key em puniq) ==? em
661 where puniq = PeerMap.accumArray const pmap
663 -- | Manual check that maxElem returns the maximum indeed, or 0 for null.
664 prop_PeerMap_maxElem :: PeerMap.PeerMap -> Property
665 prop_PeerMap_maxElem pmap =
666 PeerMap.maxElem puniq ==? if null puniq then 0
667 else (maximum . snd . unzip) puniq
668 where puniq = PeerMap.accumArray const pmap
670 -- | List of tests for the PeerMap module.
672 [ 'prop_PeerMap_addIdempotent
673 , 'prop_PeerMap_removeIdempotent
674 , 'prop_PeerMap_maxElem
675 , 'prop_PeerMap_addFind
676 , 'prop_PeerMap_findMissing
679 -- ** Container tests
681 -- we silence the following due to hlint bug fixed in later versions
682 {-# ANN prop_Container_addTwo "HLint: ignore Avoid lambda" #-}
683 prop_Container_addTwo :: [Container.Key] -> Int -> Int -> Bool
684 prop_Container_addTwo cdata i1 i2 =
685 fn i1 i2 cont == fn i2 i1 cont &&
686 fn i1 i2 cont == fn i1 i2 (fn i1 i2 cont)
687 where cont = foldl (\c x -> Container.add x x c) Container.empty cdata
688 fn x1 x2 = Container.addTwo x1 x1 x2 x2
690 prop_Container_nameOf :: Node.Node -> Property
691 prop_Container_nameOf node =
692 let nl = makeSmallCluster node 1
693 fnode = head (Container.elems nl)
694 in Container.nameOf nl (Node.idx fnode) ==? Node.name fnode
696 -- | We test that in a cluster, given a random node, we can find it by
697 -- its name and alias, as long as all names and aliases are unique,
698 -- and that we fail to find a non-existing name.
699 prop_Container_findByName :: Property
700 prop_Container_findByName =
701 forAll (genNode (Just 1) Nothing) $ \node ->
702 forAll (choose (1, 20)) $ \ cnt ->
703 forAll (choose (0, cnt - 1)) $ \ fidx ->
704 forAll (genUniquesList (cnt * 2)) $ \ allnames ->
705 forAll (arbitrary `suchThat` (`notElem` allnames)) $ \ othername ->
706 let names = zip (take cnt allnames) (drop cnt allnames)
707 nl = makeSmallCluster node cnt
708 nodes = Container.elems nl
709 nodes' = map (\((name, alias), nn) -> (Node.idx nn,
710 nn { Node.name = name,
711 Node.alias = alias }))
713 nl' = Container.fromList nodes'
714 target = snd (nodes' !! fidx)
715 in Container.findByName nl' (Node.name target) ==? Just target .&&.
716 Container.findByName nl' (Node.alias target) ==? Just target .&&.
717 printTestCase "Found non-existing name"
718 (isNothing (Container.findByName nl' othername))
720 testSuite "Container"
721 [ 'prop_Container_addTwo
722 , 'prop_Container_nameOf
723 , 'prop_Container_findByName
728 -- Simple instance tests, we only have setter/getters
730 prop_Instance_creat :: Instance.Instance -> Property
731 prop_Instance_creat inst =
732 Instance.name inst ==? Instance.alias inst
734 prop_Instance_setIdx :: Instance.Instance -> Types.Idx -> Property
735 prop_Instance_setIdx inst idx =
736 Instance.idx (Instance.setIdx inst idx) ==? idx
738 prop_Instance_setName :: Instance.Instance -> String -> Bool
739 prop_Instance_setName inst name =
740 Instance.name newinst == name &&
741 Instance.alias newinst == name
742 where newinst = Instance.setName inst name
744 prop_Instance_setAlias :: Instance.Instance -> String -> Bool
745 prop_Instance_setAlias inst name =
746 Instance.name newinst == Instance.name inst &&
747 Instance.alias newinst == name
748 where newinst = Instance.setAlias inst name
750 prop_Instance_setPri :: Instance.Instance -> Types.Ndx -> Property
751 prop_Instance_setPri inst pdx =
752 Instance.pNode (Instance.setPri inst pdx) ==? pdx
754 prop_Instance_setSec :: Instance.Instance -> Types.Ndx -> Property
755 prop_Instance_setSec inst sdx =
756 Instance.sNode (Instance.setSec inst sdx) ==? sdx
758 prop_Instance_setBoth :: Instance.Instance -> Types.Ndx -> Types.Ndx -> Bool
759 prop_Instance_setBoth inst pdx sdx =
760 Instance.pNode si == pdx && Instance.sNode si == sdx
761 where si = Instance.setBoth inst pdx sdx
763 prop_Instance_shrinkMG :: Instance.Instance -> Property
764 prop_Instance_shrinkMG inst =
765 Instance.mem inst >= 2 * Types.unitMem ==>
766 case Instance.shrinkByType inst Types.FailMem of
767 Types.Ok inst' -> Instance.mem inst' == Instance.mem inst - Types.unitMem
770 prop_Instance_shrinkMF :: Instance.Instance -> Property
771 prop_Instance_shrinkMF inst =
772 forAll (choose (0, 2 * Types.unitMem - 1)) $ \mem ->
773 let inst' = inst { Instance.mem = mem}
774 in Types.isBad $ Instance.shrinkByType inst' Types.FailMem
776 prop_Instance_shrinkCG :: Instance.Instance -> Property
777 prop_Instance_shrinkCG inst =
778 Instance.vcpus inst >= 2 * Types.unitCpu ==>
779 case Instance.shrinkByType inst Types.FailCPU of
781 Instance.vcpus inst' == Instance.vcpus inst - Types.unitCpu
784 prop_Instance_shrinkCF :: Instance.Instance -> Property
785 prop_Instance_shrinkCF inst =
786 forAll (choose (0, 2 * Types.unitCpu - 1)) $ \vcpus ->
787 let inst' = inst { Instance.vcpus = vcpus }
788 in Types.isBad $ Instance.shrinkByType inst' Types.FailCPU
790 prop_Instance_shrinkDG :: Instance.Instance -> Property
791 prop_Instance_shrinkDG inst =
792 Instance.dsk inst >= 2 * Types.unitDsk ==>
793 case Instance.shrinkByType inst Types.FailDisk of
795 Instance.dsk inst' == Instance.dsk inst - Types.unitDsk
798 prop_Instance_shrinkDF :: Instance.Instance -> Property
799 prop_Instance_shrinkDF inst =
800 forAll (choose (0, 2 * Types.unitDsk - 1)) $ \dsk ->
801 let inst' = inst { Instance.dsk = dsk }
802 in Types.isBad $ Instance.shrinkByType inst' Types.FailDisk
804 prop_Instance_setMovable :: Instance.Instance -> Bool -> Property
805 prop_Instance_setMovable inst m =
806 Instance.movable inst' ==? m
807 where inst' = Instance.setMovable inst m
810 [ 'prop_Instance_creat
811 , 'prop_Instance_setIdx
812 , 'prop_Instance_setName
813 , 'prop_Instance_setAlias
814 , 'prop_Instance_setPri
815 , 'prop_Instance_setSec
816 , 'prop_Instance_setBoth
817 , 'prop_Instance_shrinkMG
818 , 'prop_Instance_shrinkMF
819 , 'prop_Instance_shrinkCG
820 , 'prop_Instance_shrinkCF
821 , 'prop_Instance_shrinkDG
822 , 'prop_Instance_shrinkDF
823 , 'prop_Instance_setMovable
828 -- *** Text backend tests
830 -- Instance text loader tests
832 prop_Text_Load_Instance :: String -> Int -> Int -> Int -> Types.InstanceStatus
833 -> NonEmptyList Char -> [Char]
834 -> NonNegative Int -> NonNegative Int -> Bool
835 -> Types.DiskTemplate -> Int -> Property
836 prop_Text_Load_Instance name mem dsk vcpus status
837 (NonEmpty pnode) snode
838 (NonNegative pdx) (NonNegative sdx) autobal dt su =
839 pnode /= snode && pdx /= sdx ==>
840 let vcpus_s = show vcpus
844 status_s = Types.instanceStatusToRaw status
847 else [(pnode, pdx), (snode, sdx)]
848 nl = Data.Map.fromList ndx
850 sbal = if autobal then "Y" else "N"
851 sdt = Types.diskTemplateToRaw dt
852 inst = Text.loadInst nl
853 [name, mem_s, dsk_s, vcpus_s, status_s,
854 sbal, pnode, snode, sdt, tags, su_s]
855 fail1 = Text.loadInst nl
856 [name, mem_s, dsk_s, vcpus_s, status_s,
857 sbal, pnode, pnode, tags]
859 Types.Bad msg -> failTest $ "Failed to load instance: " ++ msg
860 Types.Ok (_, i) -> printTestCase "Mismatch in some field while\
861 \ loading the instance" $
862 Instance.name i == name &&
863 Instance.vcpus i == vcpus &&
864 Instance.mem i == mem &&
865 Instance.pNode i == pdx &&
866 Instance.sNode i == (if null snode
867 then Node.noSecondary
869 Instance.autoBalance i == autobal &&
870 Instance.spindleUse i == su &&
873 prop_Text_Load_InstanceFail :: [(String, Int)] -> [String] -> Property
874 prop_Text_Load_InstanceFail ktn fields =
875 length fields /= 10 && length fields /= 11 ==>
876 case Text.loadInst nl fields of
877 Types.Ok _ -> failTest "Managed to load instance from invalid data"
878 Types.Bad msg -> printTestCase ("Unrecognised error message: " ++ msg) $
879 "Invalid/incomplete instance data: '" `isPrefixOf` msg
880 where nl = Data.Map.fromList ktn
882 prop_Text_Load_Node :: String -> Int -> Int -> Int -> Int -> Int
883 -> Int -> Bool -> Bool
884 prop_Text_Load_Node name tm nm fm td fd tc fo =
885 let conv v = if v < 0
897 any_broken = any (< 0) [tm, nm, fm, td, fd, tc]
898 gid = Group.uuid defGroup
899 in case Text.loadNode defGroupAssoc
900 [name, tm_s, nm_s, fm_s, td_s, fd_s, tc_s, fo_s, gid] of
902 Just (name', node) ->
904 then Node.offline node
905 else Node.name node == name' && name' == name &&
906 Node.alias node == name &&
907 Node.tMem node == fromIntegral tm &&
908 Node.nMem node == nm &&
909 Node.fMem node == fm &&
910 Node.tDsk node == fromIntegral td &&
911 Node.fDsk node == fd &&
912 Node.tCpu node == fromIntegral tc
914 prop_Text_Load_NodeFail :: [String] -> Property
915 prop_Text_Load_NodeFail fields =
916 length fields /= 8 ==> isNothing $ Text.loadNode Data.Map.empty fields
918 prop_Text_NodeLSIdempotent :: Property
919 prop_Text_NodeLSIdempotent =
920 forAll (genNode (Just 1) Nothing) $ \node ->
921 -- override failN1 to what loadNode returns by default
922 let n = Node.setPolicy Types.defIPolicy $
923 node { Node.failN1 = True, Node.offline = False }
925 (Text.loadNode defGroupAssoc.
926 Utils.sepSplit '|' . Text.serializeNode defGroupList) n ==?
927 Just (Node.name n, n)
929 prop_Text_ISpecIdempotent :: Types.ISpec -> Property
930 prop_Text_ISpecIdempotent ispec =
931 case Text.loadISpec "dummy" . Utils.sepSplit ',' .
932 Text.serializeISpec $ ispec of
933 Types.Bad msg -> failTest $ "Failed to load ispec: " ++ msg
934 Types.Ok ispec' -> ispec ==? ispec'
936 prop_Text_IPolicyIdempotent :: Types.IPolicy -> Property
937 prop_Text_IPolicyIdempotent ipol =
938 case Text.loadIPolicy . Utils.sepSplit '|' $
939 Text.serializeIPolicy owner ipol of
940 Types.Bad msg -> failTest $ "Failed to load ispec: " ++ msg
941 Types.Ok res -> (owner, ipol) ==? res
942 where owner = "dummy"
944 -- | This property, while being in the text tests, does more than just
945 -- test end-to-end the serialisation and loading back workflow; it
946 -- also tests the Loader.mergeData and the actuall
947 -- Cluster.iterateAlloc (for well-behaving w.r.t. instance
948 -- allocations, not for the business logic). As such, it's a quite
949 -- complex and slow test, and that's the reason we restrict it to
950 -- small cluster sizes.
951 prop_Text_CreateSerialise :: Property
952 prop_Text_CreateSerialise =
953 forAll genTags $ \ctags ->
954 forAll (choose (1, 20)) $ \maxiter ->
955 forAll (choose (2, 10)) $ \count ->
956 forAll genOnlineNode $ \node ->
957 forAll (genInstanceSmallerThanNode node) $ \inst ->
958 let nl = makeSmallCluster node count
959 reqnodes = Instance.requiredNodes $ Instance.diskTemplate inst
960 in case Cluster.genAllocNodes defGroupList nl reqnodes True >>= \allocn ->
961 Cluster.iterateAlloc nl Container.empty (Just maxiter) inst allocn [] []
963 Types.Bad msg -> failTest $ "Failed to allocate: " ++ msg
964 Types.Ok (_, _, _, [], _) -> printTestCase
965 "Failed to allocate: no allocations" False
966 Types.Ok (_, nl', il', _, _) ->
967 let cdata = Loader.ClusterData defGroupList nl' il' ctags
969 saved = Text.serializeCluster cdata
970 in case Text.parseData saved >>= Loader.mergeData [] [] [] [] of
971 Types.Bad msg -> failTest $ "Failed to load/merge: " ++ msg
972 Types.Ok (Loader.ClusterData gl2 nl2 il2 ctags2 cpol2) ->
973 ctags ==? ctags2 .&&.
974 Types.defIPolicy ==? cpol2 .&&.
976 defGroupList ==? gl2 .&&.
980 [ 'prop_Text_Load_Instance
981 , 'prop_Text_Load_InstanceFail
982 , 'prop_Text_Load_Node
983 , 'prop_Text_Load_NodeFail
984 , 'prop_Text_NodeLSIdempotent
985 , 'prop_Text_ISpecIdempotent
986 , 'prop_Text_IPolicyIdempotent
987 , 'prop_Text_CreateSerialise
992 -- | Generates a tuple of specs for simulation.
993 genSimuSpec :: Gen (String, Int, Int, Int, Int)
995 pol <- elements [C.allocPolicyPreferred,
996 C.allocPolicyLastResort, C.allocPolicyUnallocable,
998 -- should be reasonable (nodes/group), bigger values only complicate
999 -- the display of failed tests, and we don't care (in this particular
1000 -- test) about big node groups
1001 nodes <- choose (0, 20)
1002 dsk <- choose (0, maxDsk)
1003 mem <- choose (0, maxMem)
1004 cpu <- choose (0, maxCpu)
1005 return (pol, nodes, dsk, mem, cpu)
1007 -- | Checks that given a set of corrects specs, we can load them
1008 -- successfully, and that at high-level the values look right.
1009 prop_SimuLoad :: Property
1011 forAll (choose (0, 10)) $ \ngroups ->
1012 forAll (replicateM ngroups genSimuSpec) $ \specs ->
1013 let strspecs = map (\(p, n, d, m, c) -> printf "%s,%d,%d,%d,%d"
1014 p n d m c::String) specs
1015 totnodes = sum $ map (\(_, n, _, _, _) -> n) specs
1016 mdc_in = concatMap (\(_, n, d, m, c) ->
1017 replicate n (fromIntegral m, fromIntegral d,
1019 fromIntegral m, fromIntegral d))
1020 specs :: [(Double, Double, Double, Int, Int)]
1021 in case Simu.parseData strspecs of
1022 Types.Bad msg -> failTest $ "Failed to load specs: " ++ msg
1023 Types.Ok (Loader.ClusterData gl nl il tags ipol) ->
1024 let nodes = map snd $ IntMap.toAscList nl
1025 nidx = map Node.idx nodes
1026 mdc_out = map (\n -> (Node.tMem n, Node.tDsk n, Node.tCpu n,
1027 Node.fMem n, Node.fDsk n)) nodes
1029 Container.size gl ==? ngroups .&&.
1030 Container.size nl ==? totnodes .&&.
1031 Container.size il ==? 0 .&&.
1032 length tags ==? 0 .&&.
1033 ipol ==? Types.defIPolicy .&&.
1034 nidx ==? [1..totnodes] .&&.
1035 mdc_in ==? mdc_out .&&.
1036 map Group.iPolicy (Container.elems gl) ==?
1037 replicate ngroups Types.defIPolicy
1045 prop_Node_setAlias :: Node.Node -> String -> Bool
1046 prop_Node_setAlias node name =
1047 Node.name newnode == Node.name node &&
1048 Node.alias newnode == name
1049 where newnode = Node.setAlias node name
1051 prop_Node_setOffline :: Node.Node -> Bool -> Property
1052 prop_Node_setOffline node status =
1053 Node.offline newnode ==? status
1054 where newnode = Node.setOffline node status
1056 prop_Node_setXmem :: Node.Node -> Int -> Property
1057 prop_Node_setXmem node xm =
1058 Node.xMem newnode ==? xm
1059 where newnode = Node.setXmem node xm
1061 prop_Node_setMcpu :: Node.Node -> Double -> Property
1062 prop_Node_setMcpu node mc =
1063 Types.iPolicyVcpuRatio (Node.iPolicy newnode) ==? mc
1064 where newnode = Node.setMcpu node mc
1066 -- | Check that an instance add with too high memory or disk will be
1068 prop_Node_addPriFM :: Node.Node -> Instance.Instance -> Property
1069 prop_Node_addPriFM node inst =
1070 Instance.mem inst >= Node.fMem node && not (Node.failN1 node) &&
1071 not (Instance.isOffline inst) ==>
1072 case Node.addPri node inst'' of
1073 Types.OpFail Types.FailMem -> True
1075 where inst' = setInstanceSmallerThanNode node inst
1076 inst'' = inst' { Instance.mem = Instance.mem inst }
1078 -- | Check that adding a primary instance with too much disk fails
1079 -- with type FailDisk.
1080 prop_Node_addPriFD :: Node.Node -> Instance.Instance -> Property
1081 prop_Node_addPriFD node inst =
1082 forAll (elements Instance.localStorageTemplates) $ \dt ->
1083 Instance.dsk inst >= Node.fDsk node && not (Node.failN1 node) ==>
1084 let inst' = setInstanceSmallerThanNode node inst
1085 inst'' = inst' { Instance.dsk = Instance.dsk inst
1086 , Instance.diskTemplate = dt }
1087 in case Node.addPri node inst'' of
1088 Types.OpFail Types.FailDisk -> True
1091 -- | Check that adding a primary instance with too many VCPUs fails
1092 -- with type FailCPU.
1093 prop_Node_addPriFC :: Property
1094 prop_Node_addPriFC =
1095 forAll (choose (1, maxCpu)) $ \extra ->
1096 forAll genOnlineNode $ \node ->
1097 forAll (arbitrary `suchThat` Instance.notOffline) $ \inst ->
1098 let inst' = setInstanceSmallerThanNode node inst
1099 inst'' = inst' { Instance.vcpus = Node.availCpu node + extra }
1100 in case Node.addPri node inst'' of
1101 Types.OpFail Types.FailCPU -> property True
1102 v -> failTest $ "Expected OpFail FailCPU, but got " ++ show v
1104 -- | Check that an instance add with too high memory or disk will be
1106 prop_Node_addSec :: Node.Node -> Instance.Instance -> Int -> Property
1107 prop_Node_addSec node inst pdx =
1108 ((Instance.mem inst >= (Node.fMem node - Node.rMem node) &&
1109 not (Instance.isOffline inst)) ||
1110 Instance.dsk inst >= Node.fDsk node) &&
1111 not (Node.failN1 node) ==>
1112 isFailure (Node.addSec node inst pdx)
1114 -- | Check that an offline instance with reasonable disk size but
1115 -- extra mem/cpu can always be added.
1116 prop_Node_addOfflinePri :: NonNegative Int -> NonNegative Int -> Property
1117 prop_Node_addOfflinePri (NonNegative extra_mem) (NonNegative extra_cpu) =
1118 forAll genOnlineNode $ \node ->
1119 forAll (genInstanceSmallerThanNode node) $ \inst ->
1120 let inst' = inst { Instance.runSt = Types.AdminOffline
1121 , Instance.mem = Node.availMem node + extra_mem
1122 , Instance.vcpus = Node.availCpu node + extra_cpu }
1123 in case Node.addPri node inst' of
1124 Types.OpGood _ -> property True
1125 v -> failTest $ "Expected OpGood, but got: " ++ show v
1127 -- | Check that an offline instance with reasonable disk size but
1128 -- extra mem/cpu can always be added.
1129 prop_Node_addOfflineSec :: NonNegative Int -> NonNegative Int
1130 -> Types.Ndx -> Property
1131 prop_Node_addOfflineSec (NonNegative extra_mem) (NonNegative extra_cpu) pdx =
1132 forAll genOnlineNode $ \node ->
1133 forAll (genInstanceSmallerThanNode node) $ \inst ->
1134 let inst' = inst { Instance.runSt = Types.AdminOffline
1135 , Instance.mem = Node.availMem node + extra_mem
1136 , Instance.vcpus = Node.availCpu node + extra_cpu
1137 , Instance.diskTemplate = Types.DTDrbd8 }
1138 in case Node.addSec node inst' pdx of
1139 Types.OpGood _ -> property True
1140 v -> failTest $ "Expected OpGood/OpGood, but got: " ++ show v
1142 -- | Checks for memory reservation changes.
1143 prop_Node_rMem :: Instance.Instance -> Property
1144 prop_Node_rMem inst =
1145 not (Instance.isOffline inst) ==>
1146 forAll (genOnlineNode `suchThat` ((> Types.unitMem) . Node.fMem)) $ \node ->
1147 -- ab = auto_balance, nb = non-auto_balance
1148 -- we use -1 as the primary node of the instance
1149 let inst' = inst { Instance.pNode = -1, Instance.autoBalance = True
1150 , Instance.diskTemplate = Types.DTDrbd8 }
1151 inst_ab = setInstanceSmallerThanNode node inst'
1152 inst_nb = inst_ab { Instance.autoBalance = False }
1153 -- now we have the two instances, identical except the
1154 -- autoBalance attribute
1155 orig_rmem = Node.rMem node
1156 inst_idx = Instance.idx inst_ab
1157 node_add_ab = Node.addSec node inst_ab (-1)
1158 node_add_nb = Node.addSec node inst_nb (-1)
1159 node_del_ab = liftM (`Node.removeSec` inst_ab) node_add_ab
1160 node_del_nb = liftM (`Node.removeSec` inst_nb) node_add_nb
1161 in case (node_add_ab, node_add_nb, node_del_ab, node_del_nb) of
1162 (Types.OpGood a_ab, Types.OpGood a_nb,
1163 Types.OpGood d_ab, Types.OpGood d_nb) ->
1164 printTestCase "Consistency checks failed" $
1165 Node.rMem a_ab > orig_rmem &&
1166 Node.rMem a_ab - orig_rmem == Instance.mem inst_ab &&
1167 Node.rMem a_nb == orig_rmem &&
1168 Node.rMem d_ab == orig_rmem &&
1169 Node.rMem d_nb == orig_rmem &&
1170 -- this is not related to rMem, but as good a place to
1172 inst_idx `elem` Node.sList a_ab &&
1173 inst_idx `notElem` Node.sList d_ab
1174 x -> failTest $ "Failed to add/remove instances: " ++ show x
1176 -- | Check mdsk setting.
1177 prop_Node_setMdsk :: Node.Node -> SmallRatio -> Bool
1178 prop_Node_setMdsk node mx =
1179 Node.loDsk node' >= 0 &&
1180 fromIntegral (Node.loDsk node') <= Node.tDsk node &&
1181 Node.availDisk node' >= 0 &&
1182 Node.availDisk node' <= Node.fDsk node' &&
1183 fromIntegral (Node.availDisk node') <= Node.tDsk node' &&
1184 Node.mDsk node' == mx'
1185 where node' = Node.setMdsk node mx'
1189 prop_Node_tagMaps_idempotent :: Property
1190 prop_Node_tagMaps_idempotent =
1191 forAll genTags $ \tags ->
1192 Node.delTags (Node.addTags m tags) tags ==? m
1193 where m = Data.Map.empty
1195 prop_Node_tagMaps_reject :: Property
1196 prop_Node_tagMaps_reject =
1197 forAll (genTags `suchThat` (not . null)) $ \tags ->
1198 let m = Node.addTags Data.Map.empty tags
1199 in all (\t -> Node.rejectAddTags m [t]) tags
1201 prop_Node_showField :: Node.Node -> Property
1202 prop_Node_showField node =
1203 forAll (elements Node.defaultFields) $ \ field ->
1204 fst (Node.showHeader field) /= Types.unknownField &&
1205 Node.showField node field /= Types.unknownField
1207 prop_Node_computeGroups :: [Node.Node] -> Bool
1208 prop_Node_computeGroups nodes =
1209 let ng = Node.computeGroups nodes
1210 onlyuuid = map fst ng
1211 in length nodes == sum (map (length . snd) ng) &&
1212 all (\(guuid, ns) -> all ((== guuid) . Node.group) ns) ng &&
1213 length (nub onlyuuid) == length onlyuuid &&
1214 (null nodes || not (null ng))
1216 -- Check idempotence of add/remove operations
1217 prop_Node_addPri_idempotent :: Property
1218 prop_Node_addPri_idempotent =
1219 forAll genOnlineNode $ \node ->
1220 forAll (genInstanceSmallerThanNode node) $ \inst ->
1221 case Node.addPri node inst of
1222 Types.OpGood node' -> Node.removePri node' inst ==? node
1223 _ -> failTest "Can't add instance"
1225 prop_Node_addSec_idempotent :: Property
1226 prop_Node_addSec_idempotent =
1227 forAll genOnlineNode $ \node ->
1228 forAll (genInstanceSmallerThanNode node) $ \inst ->
1229 let pdx = Node.idx node + 1
1230 inst' = Instance.setPri inst pdx
1231 inst'' = inst' { Instance.diskTemplate = Types.DTDrbd8 }
1232 in case Node.addSec node inst'' pdx of
1233 Types.OpGood node' -> Node.removeSec node' inst'' ==? node
1234 _ -> failTest "Can't add instance"
1237 [ 'prop_Node_setAlias
1238 , 'prop_Node_setOffline
1239 , 'prop_Node_setMcpu
1240 , 'prop_Node_setXmem
1241 , 'prop_Node_addPriFM
1242 , 'prop_Node_addPriFD
1243 , 'prop_Node_addPriFC
1245 , 'prop_Node_addOfflinePri
1246 , 'prop_Node_addOfflineSec
1248 , 'prop_Node_setMdsk
1249 , 'prop_Node_tagMaps_idempotent
1250 , 'prop_Node_tagMaps_reject
1251 , 'prop_Node_showField
1252 , 'prop_Node_computeGroups
1253 , 'prop_Node_addPri_idempotent
1254 , 'prop_Node_addSec_idempotent
1259 -- | Check that the cluster score is close to zero for a homogeneous
1261 prop_Score_Zero :: Node.Node -> Property
1262 prop_Score_Zero node =
1263 forAll (choose (1, 1024)) $ \count ->
1264 (not (Node.offline node) && not (Node.failN1 node) && (count > 0) &&
1265 (Node.tDsk node > 0) && (Node.tMem node > 0)) ==>
1266 let fn = Node.buildPeers node Container.empty
1267 nlst = replicate count fn
1268 score = Cluster.compCVNodes nlst
1269 -- we can't say == 0 here as the floating point errors accumulate;
1270 -- this should be much lower than the default score in CLI.hs
1273 -- | Check that cluster stats are sane.
1274 prop_CStats_sane :: Property
1276 forAll (choose (1, 1024)) $ \count ->
1277 forAll genOnlineNode $ \node ->
1278 let fn = Node.buildPeers node Container.empty
1279 nlst = zip [1..] $ replicate count fn::[(Types.Ndx, Node.Node)]
1280 nl = Container.fromList nlst
1281 cstats = Cluster.totalResources nl
1282 in Cluster.csAdsk cstats >= 0 &&
1283 Cluster.csAdsk cstats <= Cluster.csFdsk cstats
1285 -- | Check that one instance is allocated correctly, without
1286 -- rebalances needed.
1287 prop_ClusterAlloc_sane :: Instance.Instance -> Property
1288 prop_ClusterAlloc_sane inst =
1289 forAll (choose (5, 20)) $ \count ->
1290 forAll genOnlineNode $ \node ->
1291 let (nl, il, inst') = makeSmallEmptyCluster node count inst
1292 reqnodes = Instance.requiredNodes $ Instance.diskTemplate inst
1293 in case Cluster.genAllocNodes defGroupList nl reqnodes True >>=
1294 Cluster.tryAlloc nl il inst' of
1295 Types.Bad _ -> False
1297 case Cluster.asSolution as of
1299 Just (xnl, xi, _, cv) ->
1300 let il' = Container.add (Instance.idx xi) xi il
1301 tbl = Cluster.Table xnl il' cv []
1302 in not (canBalance tbl True True False)
1304 -- | Checks that on a 2-5 node cluster, we can allocate a random
1305 -- instance spec via tiered allocation (whatever the original instance
1306 -- spec), on either one or two nodes. Furthermore, we test that
1307 -- computed allocation statistics are correct.
1308 prop_ClusterCanTieredAlloc :: Instance.Instance -> Property
1309 prop_ClusterCanTieredAlloc inst =
1310 forAll (choose (2, 5)) $ \count ->
1311 forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
1312 let nl = makeSmallCluster node count
1313 il = Container.empty
1314 rqnodes = Instance.requiredNodes $ Instance.diskTemplate inst
1315 allocnodes = Cluster.genAllocNodes defGroupList nl rqnodes True
1316 in case allocnodes >>= \allocnodes' ->
1317 Cluster.tieredAlloc nl il (Just 1) inst allocnodes' [] [] of
1318 Types.Bad msg -> failTest $ "Failed to tiered alloc: " ++ msg
1319 Types.Ok (_, nl', il', ixes, cstats) ->
1320 let (ai_alloc, ai_pool, ai_unav) =
1321 Cluster.computeAllocationDelta
1322 (Cluster.totalResources nl)
1323 (Cluster.totalResources nl')
1324 all_nodes = Container.elems nl
1325 in property (not (null ixes)) .&&.
1326 IntMap.size il' ==? length ixes .&&.
1327 length ixes ==? length cstats .&&.
1328 sum (map Types.allocInfoVCpus [ai_alloc, ai_pool, ai_unav]) ==?
1329 sum (map Node.hiCpu all_nodes) .&&.
1330 sum (map Types.allocInfoNCpus [ai_alloc, ai_pool, ai_unav]) ==?
1331 sum (map Node.tCpu all_nodes) .&&.
1332 sum (map Types.allocInfoMem [ai_alloc, ai_pool, ai_unav]) ==?
1333 truncate (sum (map Node.tMem all_nodes)) .&&.
1334 sum (map Types.allocInfoDisk [ai_alloc, ai_pool, ai_unav]) ==?
1335 truncate (sum (map Node.tDsk all_nodes))
1337 -- | Helper function to create a cluster with the given range of nodes
1338 -- and allocate an instance on it.
1339 genClusterAlloc :: Int -> Node.Node -> Instance.Instance
1340 -> Types.Result (Node.List, Instance.List, Instance.Instance)
1341 genClusterAlloc count node inst =
1342 let nl = makeSmallCluster node count
1343 reqnodes = Instance.requiredNodes $ Instance.diskTemplate inst
1344 in case Cluster.genAllocNodes defGroupList nl reqnodes True >>=
1345 Cluster.tryAlloc nl Container.empty inst of
1346 Types.Bad _ -> Types.Bad "Can't allocate"
1348 case Cluster.asSolution as of
1349 Nothing -> Types.Bad "Empty solution?"
1350 Just (xnl, xi, _, _) ->
1351 let xil = Container.add (Instance.idx xi) xi Container.empty
1352 in Types.Ok (xnl, xil, xi)
1354 -- | Checks that on a 4-8 node cluster, once we allocate an instance,
1355 -- we can also relocate it.
1356 prop_ClusterAllocRelocate :: Property
1357 prop_ClusterAllocRelocate =
1358 forAll (choose (4, 8)) $ \count ->
1359 forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
1360 forAll (genInstanceSmallerThanNode node `suchThat` isMirrored) $ \inst ->
1361 case genClusterAlloc count node inst of
1362 Types.Bad msg -> failTest msg
1363 Types.Ok (nl, il, inst') ->
1364 case IAlloc.processRelocate defGroupList nl il
1365 (Instance.idx inst) 1
1366 [(if Instance.diskTemplate inst' == Types.DTDrbd8
1368 else Instance.pNode) inst'] of
1369 Types.Ok _ -> property True
1370 Types.Bad msg -> failTest $ "Failed to relocate: " ++ msg
1372 -- | Helper property checker for the result of a nodeEvac or
1373 -- changeGroup operation.
1374 check_EvacMode :: Group.Group -> Instance.Instance
1375 -> Types.Result (Node.List, Instance.List, Cluster.EvacSolution)
1377 check_EvacMode grp inst result =
1379 Types.Bad msg -> failTest $ "Couldn't evacuate/change group:" ++ msg
1380 Types.Ok (_, _, es) ->
1381 let moved = Cluster.esMoved es
1382 failed = Cluster.esFailed es
1383 opcodes = not . null $ Cluster.esOpCodes es
1384 in failmsg ("'failed' not empty: " ++ show failed) (null failed) .&&.
1385 failmsg "'opcodes' is null" opcodes .&&.
1387 [(idx', gdx, _)] -> failmsg "invalid instance moved" (idx == idx')
1389 failmsg "wrong target group"
1390 (gdx == Group.idx grp)
1391 v -> failmsg ("invalid solution: " ++ show v) False
1392 where failmsg :: String -> Bool -> Property
1393 failmsg = \msg -> printTestCase ("Failed to evacuate: " ++ msg)
1394 idx = Instance.idx inst
1396 -- | Checks that on a 4-8 node cluster, once we allocate an instance,
1397 -- we can also node-evacuate it.
1398 prop_ClusterAllocEvacuate :: Property
1399 prop_ClusterAllocEvacuate =
1400 forAll (choose (4, 8)) $ \count ->
1401 forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
1402 forAll (genInstanceSmallerThanNode node `suchThat` isMirrored) $ \inst ->
1403 case genClusterAlloc count node inst of
1404 Types.Bad msg -> failTest msg
1405 Types.Ok (nl, il, inst') ->
1406 conjoin $ map (\mode -> check_EvacMode defGroup inst' $
1407 Cluster.tryNodeEvac defGroupList nl il mode
1408 [Instance.idx inst']) .
1410 Instance.mirrorType $ inst'
1412 -- | Checks that on a 4-8 node cluster with two node groups, once we
1413 -- allocate an instance on the first node group, we can also change
1415 prop_ClusterAllocChangeGroup :: Property
1416 prop_ClusterAllocChangeGroup =
1417 forAll (choose (4, 8)) $ \count ->
1418 forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
1419 forAll (genInstanceSmallerThanNode node `suchThat` isMirrored) $ \inst ->
1420 case genClusterAlloc count node inst of
1421 Types.Bad msg -> failTest msg
1422 Types.Ok (nl, il, inst') ->
1423 -- we need to add a second node group and nodes to the cluster
1424 let nl2 = Container.elems $ makeSmallCluster node count
1425 grp2 = Group.setIdx defGroup (Group.idx defGroup + 1)
1426 maxndx = maximum . map Node.idx $ nl2
1427 nl3 = map (\n -> n { Node.group = Group.idx grp2
1428 , Node.idx = Node.idx n + maxndx }) nl2
1429 nl4 = Container.fromList . map (\n -> (Node.idx n, n)) $ nl3
1430 gl' = Container.add (Group.idx grp2) grp2 defGroupList
1431 nl' = IntMap.union nl nl4
1432 in check_EvacMode grp2 inst' $
1433 Cluster.tryChangeGroup gl' nl' il [] [Instance.idx inst']
1435 -- | Check that allocating multiple instances on a cluster, then
1436 -- adding an empty node, results in a valid rebalance.
1437 prop_ClusterAllocBalance :: Property
1438 prop_ClusterAllocBalance =
1439 forAll (genNode (Just 5) (Just 128)) $ \node ->
1440 forAll (choose (3, 5)) $ \count ->
1441 not (Node.offline node) && not (Node.failN1 node) ==>
1442 let nl = makeSmallCluster node count
1443 (hnode, nl') = IntMap.deleteFindMax nl
1444 il = Container.empty
1445 allocnodes = Cluster.genAllocNodes defGroupList nl' 2 True
1446 i_templ = createInstance Types.unitMem Types.unitDsk Types.unitCpu
1447 in case allocnodes >>= \allocnodes' ->
1448 Cluster.iterateAlloc nl' il (Just 5) i_templ allocnodes' [] [] of
1449 Types.Bad msg -> failTest $ "Failed to allocate: " ++ msg
1450 Types.Ok (_, _, _, [], _) -> failTest "Failed to allocate: no instances"
1451 Types.Ok (_, xnl, il', _, _) ->
1452 let ynl = Container.add (Node.idx hnode) hnode xnl
1453 cv = Cluster.compCV ynl
1454 tbl = Cluster.Table ynl il' cv []
1455 in printTestCase "Failed to rebalance" $
1456 canBalance tbl True True False
1458 -- | Checks consistency.
1459 prop_ClusterCheckConsistency :: Node.Node -> Instance.Instance -> Bool
1460 prop_ClusterCheckConsistency node inst =
1461 let nl = makeSmallCluster node 3
1462 [node1, node2, node3] = Container.elems nl
1463 node3' = node3 { Node.group = 1 }
1464 nl' = Container.add (Node.idx node3') node3' nl
1465 inst1 = Instance.setBoth inst (Node.idx node1) (Node.idx node2)
1466 inst2 = Instance.setBoth inst (Node.idx node1) Node.noSecondary
1467 inst3 = Instance.setBoth inst (Node.idx node1) (Node.idx node3)
1468 ccheck = Cluster.findSplitInstances nl' . Container.fromList
1469 in null (ccheck [(0, inst1)]) &&
1470 null (ccheck [(0, inst2)]) &&
1471 (not . null $ ccheck [(0, inst3)])
1473 -- | For now, we only test that we don't lose instances during the split.
1474 prop_ClusterSplitCluster :: Node.Node -> Instance.Instance -> Property
1475 prop_ClusterSplitCluster node inst =
1476 forAll (choose (0, 100)) $ \icnt ->
1477 let nl = makeSmallCluster node 2
1478 (nl', il') = foldl (\(ns, is) _ -> assignInstance ns is inst 0 1)
1479 (nl, Container.empty) [1..icnt]
1480 gni = Cluster.splitCluster nl' il'
1481 in sum (map (Container.size . snd . snd) gni) == icnt &&
1482 all (\(guuid, (nl'', _)) -> all ((== guuid) . Node.group)
1483 (Container.elems nl'')) gni
1485 -- | Helper function to check if we can allocate an instance on a
1487 canAllocOn :: Node.List -> Int -> Instance.Instance -> Bool
1488 canAllocOn nl reqnodes inst =
1489 case Cluster.genAllocNodes defGroupList nl reqnodes True >>=
1490 Cluster.tryAlloc nl (Container.empty) inst of
1491 Types.Bad _ -> False
1493 case Cluster.asSolution as of
1497 -- | Checks that allocation obeys minimum and maximum instance
1498 -- policies. The unittest generates a random node, duplicates it /count/
1499 -- times, and generates a random instance that can be allocated on
1500 -- this mini-cluster; it then checks that after applying a policy that
1501 -- the instance doesn't fits, the allocation fails.
1502 prop_ClusterAllocPolicy :: Node.Node -> Property
1503 prop_ClusterAllocPolicy node =
1504 -- rqn is the required nodes (1 or 2)
1505 forAll (choose (1, 2)) $ \rqn ->
1506 forAll (choose (5, 20)) $ \count ->
1507 forAll (arbitrary `suchThat` (canAllocOn (makeSmallCluster node count) rqn))
1509 forAll (arbitrary `suchThat` (isFailure .
1510 Instance.instMatchesPolicy inst)) $ \ipol ->
1511 let node' = Node.setPolicy ipol node
1512 nl = makeSmallCluster node' count
1513 in not $ canAllocOn nl rqn inst
1518 , 'prop_ClusterAlloc_sane
1519 , 'prop_ClusterCanTieredAlloc
1520 , 'prop_ClusterAllocRelocate
1521 , 'prop_ClusterAllocEvacuate
1522 , 'prop_ClusterAllocChangeGroup
1523 , 'prop_ClusterAllocBalance
1524 , 'prop_ClusterCheckConsistency
1525 , 'prop_ClusterSplitCluster
1526 , 'prop_ClusterAllocPolicy
1531 -- | Check that opcode serialization is idempotent.
1532 prop_OpCodes_serialization :: OpCodes.OpCode -> Property
1533 prop_OpCodes_serialization op =
1534 case J.readJSON (J.showJSON op) of
1535 J.Error e -> failTest $ "Cannot deserialise: " ++ e
1536 J.Ok op' -> op ==? op'
1539 [ 'prop_OpCodes_serialization ]
1543 -- | Check that (queued) job\/opcode status serialization is idempotent.
1544 prop_OpStatus_serialization :: Jobs.OpStatus -> Property
1545 prop_OpStatus_serialization os =
1546 case J.readJSON (J.showJSON os) of
1547 J.Error e -> failTest $ "Cannot deserialise: " ++ e
1548 J.Ok os' -> os ==? os'
1550 prop_JobStatus_serialization :: Jobs.JobStatus -> Property
1551 prop_JobStatus_serialization js =
1552 case J.readJSON (J.showJSON js) of
1553 J.Error e -> failTest $ "Cannot deserialise: " ++ e
1554 J.Ok js' -> js ==? js'
1557 [ 'prop_OpStatus_serialization
1558 , 'prop_JobStatus_serialization
1563 prop_Loader_lookupNode :: [(String, Int)] -> String -> String -> Property
1564 prop_Loader_lookupNode ktn inst node =
1565 Loader.lookupNode nl inst node ==? Data.Map.lookup node nl
1566 where nl = Data.Map.fromList ktn
1568 prop_Loader_lookupInstance :: [(String, Int)] -> String -> Property
1569 prop_Loader_lookupInstance kti inst =
1570 Loader.lookupInstance il inst ==? Data.Map.lookup inst il
1571 where il = Data.Map.fromList kti
1573 prop_Loader_assignIndices :: Property
1574 prop_Loader_assignIndices =
1575 -- generate nodes with unique names
1576 forAll (arbitrary `suchThat`
1578 let names = map Node.name nodes
1579 in length names == length (nub names))) $ \nodes ->
1581 Loader.assignIndices (map (\n -> (Node.name n, n)) nodes)
1582 in Data.Map.size nassoc == length nodes &&
1583 Container.size kt == length nodes &&
1585 then maximum (IntMap.keys kt) == length nodes - 1
1588 -- | Checks that the number of primary instances recorded on the nodes
1590 prop_Loader_mergeData :: [Node.Node] -> Bool
1591 prop_Loader_mergeData ns =
1592 let na = Container.fromList $ map (\n -> (Node.idx n, n)) ns
1593 in case Loader.mergeData [] [] [] []
1594 (Loader.emptyCluster {Loader.cdNodes = na}) of
1595 Types.Bad _ -> False
1596 Types.Ok (Loader.ClusterData _ nl il _ _) ->
1597 let nodes = Container.elems nl
1598 instances = Container.elems il
1599 in (sum . map (length . Node.pList)) nodes == 0 &&
1602 -- | Check that compareNameComponent on equal strings works.
1603 prop_Loader_compareNameComponent_equal :: String -> Bool
1604 prop_Loader_compareNameComponent_equal s =
1605 BasicTypes.compareNameComponent s s ==
1606 BasicTypes.LookupResult BasicTypes.ExactMatch s
1608 -- | Check that compareNameComponent on prefix strings works.
1609 prop_Loader_compareNameComponent_prefix :: NonEmptyList Char -> String -> Bool
1610 prop_Loader_compareNameComponent_prefix (NonEmpty s1) s2 =
1611 BasicTypes.compareNameComponent (s1 ++ "." ++ s2) s1 ==
1612 BasicTypes.LookupResult BasicTypes.PartialMatch s1
1615 [ 'prop_Loader_lookupNode
1616 , 'prop_Loader_lookupInstance
1617 , 'prop_Loader_assignIndices
1618 , 'prop_Loader_mergeData
1619 , 'prop_Loader_compareNameComponent_equal
1620 , 'prop_Loader_compareNameComponent_prefix
1625 prop_Types_AllocPolicy_serialisation :: Types.AllocPolicy -> Property
1626 prop_Types_AllocPolicy_serialisation apol =
1627 case J.readJSON (J.showJSON apol) of
1628 J.Ok p -> p ==? apol
1629 J.Error s -> failTest $ "Failed to deserialise: " ++ s
1631 prop_Types_DiskTemplate_serialisation :: Types.DiskTemplate -> Property
1632 prop_Types_DiskTemplate_serialisation dt =
1633 case J.readJSON (J.showJSON dt) of
1635 J.Error s -> failTest $ "Failed to deserialise: " ++ s
1637 prop_Types_ISpec_serialisation :: Types.ISpec -> Property
1638 prop_Types_ISpec_serialisation ispec =
1639 case J.readJSON (J.showJSON ispec) of
1640 J.Ok p -> p ==? ispec
1641 J.Error s -> failTest $ "Failed to deserialise: " ++ s
1643 prop_Types_IPolicy_serialisation :: Types.IPolicy -> Property
1644 prop_Types_IPolicy_serialisation ipol =
1645 case J.readJSON (J.showJSON ipol) of
1646 J.Ok p -> p ==? ipol
1647 J.Error s -> failTest $ "Failed to deserialise: " ++ s
1649 prop_Types_EvacMode_serialisation :: Types.EvacMode -> Property
1650 prop_Types_EvacMode_serialisation em =
1651 case J.readJSON (J.showJSON em) of
1653 J.Error s -> failTest $ "Failed to deserialise: " ++ s
1655 prop_Types_opToResult :: Types.OpResult Int -> Bool
1656 prop_Types_opToResult op =
1658 Types.OpFail _ -> Types.isBad r
1659 Types.OpGood v -> case r of
1660 Types.Bad _ -> False
1661 Types.Ok v' -> v == v'
1662 where r = Types.opToResult op
1664 prop_Types_eitherToResult :: Either String Int -> Bool
1665 prop_Types_eitherToResult ei =
1667 Left _ -> Types.isBad r
1668 Right v -> case r of
1669 Types.Bad _ -> False
1670 Types.Ok v' -> v == v'
1671 where r = Types.eitherToResult ei
1674 [ 'prop_Types_AllocPolicy_serialisation
1675 , 'prop_Types_DiskTemplate_serialisation
1676 , 'prop_Types_ISpec_serialisation
1677 , 'prop_Types_IPolicy_serialisation
1678 , 'prop_Types_EvacMode_serialisation
1679 , 'prop_Types_opToResult
1680 , 'prop_Types_eitherToResult
1685 -- | Test correct parsing.
1686 prop_CLI_parseISpec :: String -> Int -> Int -> Int -> Property
1687 prop_CLI_parseISpec descr dsk mem cpu =
1688 let str = printf "%d,%d,%d" dsk mem cpu::String
1689 in CLI.parseISpecString descr str ==? Types.Ok (Types.RSpec cpu mem dsk)
1691 -- | Test parsing failure due to wrong section count.
1692 prop_CLI_parseISpecFail :: String -> Property
1693 prop_CLI_parseISpecFail descr =
1694 forAll (choose (0,100) `suchThat` ((/=) 3)) $ \nelems ->
1695 forAll (replicateM nelems arbitrary) $ \values ->
1696 let str = intercalate "," $ map show (values::[Int])
1697 in case CLI.parseISpecString descr str of
1698 Types.Ok v -> failTest $ "Expected failure, got " ++ show v
1701 -- | Test parseYesNo.
1702 prop_CLI_parseYesNo :: Bool -> Bool -> [Char] -> Property
1703 prop_CLI_parseYesNo def testval val =
1704 forAll (elements [val, "yes", "no"]) $ \actual_val ->
1706 then CLI.parseYesNo def Nothing ==? Types.Ok def
1707 else let result = CLI.parseYesNo def (Just actual_val)
1708 in if actual_val `elem` ["yes", "no"]
1709 then result ==? Types.Ok (actual_val == "yes")
1710 else property $ Types.isBad result
1712 -- | Helper to check for correct parsing of string arg.
1713 checkStringArg :: [Char]
1714 -> (GetOpt.OptDescr (CLI.Options -> Types.Result CLI.Options),
1715 CLI.Options -> Maybe [Char])
1717 checkStringArg val (opt, fn) =
1718 let GetOpt.Option _ longs _ _ = opt
1720 [] -> failTest "no long options?"
1722 case CLI.parseOptsInner ["--" ++ cmdarg ++ "=" ++ val] "prog" [opt] of
1723 Left e -> failTest $ "Failed to parse option: " ++ show e
1724 Right (options, _) -> fn options ==? Just val
1726 -- | Test a few string arguments.
1727 prop_CLI_StringArg :: [Char] -> Property
1728 prop_CLI_StringArg argument =
1729 let args = [ (CLI.oDataFile, CLI.optDataFile)
1730 , (CLI.oDynuFile, CLI.optDynuFile)
1731 , (CLI.oSaveCluster, CLI.optSaveCluster)
1732 , (CLI.oReplay, CLI.optReplay)
1733 , (CLI.oPrintCommands, CLI.optShowCmds)
1734 , (CLI.oLuxiSocket, CLI.optLuxi)
1736 in conjoin $ map (checkStringArg argument) args
1738 -- | Helper to test that a given option is accepted OK with quick exit.
1739 checkEarlyExit :: String -> [CLI.OptType] -> String -> Property
1740 checkEarlyExit name options param =
1741 case CLI.parseOptsInner [param] name options of
1742 Left (code, _) -> if code == 0
1744 else failTest $ "Program " ++ name ++
1745 " returns invalid code " ++ show code ++
1746 " for option " ++ param
1747 _ -> failTest $ "Program " ++ name ++ " doesn't consider option " ++
1748 param ++ " as early exit one"
1750 -- | Test that all binaries support some common options. There is
1751 -- nothing actually random about this test...
1752 prop_CLI_stdopts :: Property
1754 let params = ["-h", "--help", "-V", "--version"]
1755 opts = map (\(name, (_, o)) -> (name, o)) Program.personalities
1756 -- apply checkEarlyExit across the cartesian product of params and opts
1757 in conjoin [checkEarlyExit n o p | p <- params, (n, o) <- opts]
1760 [ 'prop_CLI_parseISpec
1761 , 'prop_CLI_parseISpecFail
1762 , 'prop_CLI_parseYesNo
1763 , 'prop_CLI_StringArg
1769 prop_JSON_toArray :: [Int] -> Property
1770 prop_JSON_toArray intarr =
1771 let arr = map J.showJSON intarr in
1772 case JSON.toArray (J.JSArray arr) of
1773 Types.Ok arr' -> arr ==? arr'
1774 Types.Bad err -> failTest $ "Failed to parse array: " ++ err
1776 prop_JSON_toArrayFail :: Int -> String -> Bool -> Property
1777 prop_JSON_toArrayFail i s b =
1778 -- poor man's instance Arbitrary JSValue
1779 forAll (elements [J.showJSON i, J.showJSON s, J.showJSON b]) $ \item ->
1780 case JSON.toArray item of
1781 Types.Bad _ -> property True
1782 Types.Ok result -> failTest $ "Unexpected parse, got " ++ show result
1785 [ 'prop_JSON_toArray
1786 , 'prop_JSON_toArrayFail
1791 instance Arbitrary Luxi.LuxiReq where
1792 arbitrary = elements [minBound..maxBound]
1794 instance Arbitrary Luxi.QrViaLuxi where
1795 arbitrary = elements [minBound..maxBound]
1797 instance Arbitrary Luxi.LuxiOp where
1801 Luxi.ReqQuery -> Luxi.Query <$> arbitrary <*> getFields <*> arbitrary
1802 Luxi.ReqQueryNodes -> Luxi.QueryNodes <$> (listOf getFQDN) <*>
1803 getFields <*> arbitrary
1804 Luxi.ReqQueryGroups -> Luxi.QueryGroups <$> arbitrary <*>
1805 arbitrary <*> arbitrary
1806 Luxi.ReqQueryInstances -> Luxi.QueryInstances <$> (listOf getFQDN) <*>
1807 getFields <*> arbitrary
1808 Luxi.ReqQueryJobs -> Luxi.QueryJobs <$> arbitrary <*> getFields
1809 Luxi.ReqQueryExports -> Luxi.QueryExports <$>
1810 (listOf getFQDN) <*> arbitrary
1811 Luxi.ReqQueryConfigValues -> Luxi.QueryConfigValues <$> getFields
1812 Luxi.ReqQueryClusterInfo -> pure Luxi.QueryClusterInfo
1813 Luxi.ReqQueryTags -> Luxi.QueryTags <$> getName <*> getFQDN
1814 Luxi.ReqSubmitJob -> Luxi.SubmitJob <$> (resize maxOpCodes arbitrary)
1815 Luxi.ReqSubmitManyJobs -> Luxi.SubmitManyJobs <$>
1816 (resize maxOpCodes arbitrary)
1817 Luxi.ReqWaitForJobChange -> Luxi.WaitForJobChange <$> arbitrary <*>
1818 getFields <*> pure J.JSNull <*>
1819 pure J.JSNull <*> arbitrary
1820 Luxi.ReqArchiveJob -> Luxi.ArchiveJob <$> arbitrary
1821 Luxi.ReqAutoArchiveJobs -> Luxi.AutoArchiveJobs <$> arbitrary <*>
1823 Luxi.ReqCancelJob -> Luxi.CancelJob <$> arbitrary
1824 Luxi.ReqSetDrainFlag -> Luxi.SetDrainFlag <$> arbitrary
1825 Luxi.ReqSetWatcherPause -> Luxi.SetWatcherPause <$> arbitrary
1827 -- | Simple check that encoding/decoding of LuxiOp works.
1828 prop_Luxi_CallEncoding :: Luxi.LuxiOp -> Property
1829 prop_Luxi_CallEncoding op =
1830 (Luxi.validateCall (Luxi.buildCall op) >>= Luxi.decodeCall) ==? Types.Ok op
1832 -- | Helper to a get a temporary file name.
1833 getTempFileName :: IO FilePath
1834 getTempFileName = do
1835 tempdir <- getTemporaryDirectory
1836 (fpath, handle) <- openTempFile tempdir "luxitest"
1841 -- | Helper to execute recvMsg but return Nothing if we reach EOF.
1842 handleEOF :: (IO a) -> IO (Maybe a)
1845 (\e -> if isEOFErrorType (ioeGetErrorType e) then Just () else Nothing)
1847 (\_ -> return Nothing)
1849 -- | Server ping-pong helper.
1850 luxiServerPong :: Luxi.Client -> IO ()
1851 luxiServerPong c = do
1852 msg <- handleEOF (Luxi.recvMsg c)
1854 Nothing -> return ()
1855 Just m -> Luxi.sendMsg c m >> luxiServerPong c
1857 -- | Client ping-pong helper.
1858 luxiClientPong :: Luxi.Client -> [String] -> IO [String]
1860 mapM (\m -> Luxi.sendMsg c m >> Luxi.recvMsg c)
1862 -- | Monadic check that, given a server socket, we can connect via a
1863 -- client to it, and that we can send a list of arbitrary messages and
1864 -- get back what we sent.
1865 prop_Luxi_ClientServer :: [[DNSChar]] -> Property
1866 prop_Luxi_ClientServer dnschars = monadicIO $ do
1867 let msgs = map (map dnsGetChar) dnschars
1868 fpath <- run $ getTempFileName
1869 -- we need to create the server first, otherwise (if we do it in the
1870 -- forked thread) the client could try to connect to it before it's
1872 server <- run $ Luxi.getServer fpath
1873 -- fork the server responder
1876 (Luxi.acceptClient server)
1877 (\c -> Luxi.closeClient c >> removeFile fpath)
1881 (Luxi.getClient fpath)
1883 (\c -> luxiClientPong c msgs)
1884 assert $ replies == msgs
1887 [ 'prop_Luxi_CallEncoding
1888 , 'prop_Luxi_ClientServer
1893 instance Arbitrary Ssconf.SSKey where
1894 arbitrary = elements [minBound..maxBound]
1896 prop_Ssconf_filename :: Ssconf.SSKey -> Property
1897 prop_Ssconf_filename key =
1898 printTestCase "Key doesn't start with correct prefix" $
1899 Ssconf.sSFilePrefix `isPrefixOf` Ssconf.keyToFilename (Just "") key
1902 [ 'prop_Ssconf_filename