code.grnet.gr Git - ganeti-local/blob - htools/Ganeti/HTools/QC.hs

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