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 (Positive extra) =
 970   forAll genOnlineNode $ \node ->
 971   forAll (arbitrary `suchThat` Instance.instanceNotOffline) $ \inst ->
 972   let inst' = setInstanceSmallerThanNode node inst
 973       inst'' = inst' { Instance.vcpus = Node.availCpu node + extra }
 974   in case Node.addPri node inst'' of
 975        Types.OpFail Types.FailCPU -> property True
 976        v -> failTest $ "Expected OpFail FailCPU, but got " ++ show v
 977
 978 -- | Check that an instance add with too high memory or disk will be
 979 -- rejected.
 980 prop_Node_addSec node inst pdx =
 981   ((Instance.mem inst >= (Node.fMem node - Node.rMem node) &&
 982     not (Instance.instanceOffline inst)) ||
 983    Instance.dsk inst >= Node.fDsk node) &&
 984   not (Node.failN1 node) ==>
 985       isFailure (Node.addSec node inst pdx)
 986         where _types = (node::Node.Node, inst::Instance.Instance, pdx::Int)
 987
 988 -- | Check that an offline instance with reasonable disk size but
 989 -- extra mem/cpu can always be added.
 990 prop_Node_addOffline (NonNegative extra_mem) (NonNegative extra_cpu) pdx =
 991   forAll genOnlineNode $ \node ->
 992   forAll (genInstanceSmallerThanNode node) $ \inst ->
 993   let inst' = inst { Instance.runSt = Types.AdminOffline
 994                    , Instance.mem = Node.availMem node + extra_mem
 995                    , Instance.vcpus = Node.availCpu node + extra_cpu }
 996   in case (Node.addPri node inst', Node.addSec node inst' pdx) of
 997        (Types.OpGood _, Types.OpGood _) -> property True
 998        v -> failTest $ "Expected OpGood/OpGood, but got: " ++ show v
 999
1000 -- | Checks for memory reservation changes.
1001 prop_Node_rMem inst =
1002   not (Instance.instanceOffline inst) ==>
1003   forAll (arbitrary `suchThat` ((> Types.unitMem) . Node.fMem)) $ \node ->
1004   -- ab = auto_balance, nb = non-auto_balance
1005   -- we use -1 as the primary node of the instance
1006   let inst' = inst { Instance.pNode = -1, Instance.autoBalance = True }
1007       inst_ab = setInstanceSmallerThanNode node inst'
1008       inst_nb = inst_ab { Instance.autoBalance = False }
1009       -- now we have the two instances, identical except the
1010       -- autoBalance attribute
1011       orig_rmem = Node.rMem node
1012       inst_idx = Instance.idx inst_ab
1013       node_add_ab = Node.addSec node inst_ab (-1)
1014       node_add_nb = Node.addSec node inst_nb (-1)
1015       node_del_ab = liftM (`Node.removeSec` inst_ab) node_add_ab
1016       node_del_nb = liftM (`Node.removeSec` inst_nb) node_add_nb
1017   in case (node_add_ab, node_add_nb, node_del_ab, node_del_nb) of
1018        (Types.OpGood a_ab, Types.OpGood a_nb,
1019         Types.OpGood d_ab, Types.OpGood d_nb) ->
1020          printTestCase "Consistency checks failed" $
1021            Node.rMem a_ab >  orig_rmem &&
1022            Node.rMem a_ab - orig_rmem == Instance.mem inst_ab &&
1023            Node.rMem a_nb == orig_rmem &&
1024            Node.rMem d_ab == orig_rmem &&
1025            Node.rMem d_nb == orig_rmem &&
1026            -- this is not related to rMem, but as good a place to
1027            -- test as any
1028            inst_idx `elem` Node.sList a_ab &&
1029            inst_idx `notElem` Node.sList d_ab
1030        x -> failTest $ "Failed to add/remove instances: " ++ show x
1031
1032 -- | Check mdsk setting.
1033 prop_Node_setMdsk node mx =
1034   Node.loDsk node' >= 0 &&
1035   fromIntegral (Node.loDsk node') <= Node.tDsk node &&
1036   Node.availDisk node' >= 0 &&
1037   Node.availDisk node' <= Node.fDsk node' &&
1038   fromIntegral (Node.availDisk node') <= Node.tDsk node' &&
1039   Node.mDsk node' == mx'
1040     where _types = (node::Node.Node, mx::SmallRatio)
1041           node' = Node.setMdsk node mx'
1042           SmallRatio mx' = mx
1043
1044 -- Check tag maps
1045 prop_Node_tagMaps_idempotent =
1046   forAll genTags $ \tags ->
1047   Node.delTags (Node.addTags m tags) tags ==? m
1048     where m = Data.Map.empty
1049
1050 prop_Node_tagMaps_reject =
1051   forAll (genTags `suchThat` (not . null)) $ \tags ->
1052   let m = Node.addTags Data.Map.empty tags
1053   in all (\t -> Node.rejectAddTags m [t]) tags
1054
1055 prop_Node_showField node =
1056   forAll (elements Node.defaultFields) $ \ field ->
1057   fst (Node.showHeader field) /= Types.unknownField &&
1058   Node.showField node field /= Types.unknownField
1059
1060 prop_Node_computeGroups nodes =
1061   let ng = Node.computeGroups nodes
1062       onlyuuid = map fst ng
1063   in length nodes == sum (map (length . snd) ng) &&
1064      all (\(guuid, ns) -> all ((== guuid) . Node.group) ns) ng &&
1065      length (nub onlyuuid) == length onlyuuid &&
1066      (null nodes || not (null ng))
1067
1068 testSuite "Node"
1069             [ 'prop_Node_setAlias
1070             , 'prop_Node_setOffline
1071             , 'prop_Node_setMcpu
1072             , 'prop_Node_setXmem
1073             , 'prop_Node_addPriFM
1074             , 'prop_Node_addPriFD
1075             , 'prop_Node_addPriFC
1076             , 'prop_Node_addSec
1077             , 'prop_Node_addOffline
1078             , 'prop_Node_rMem
1079             , 'prop_Node_setMdsk
1080             , 'prop_Node_tagMaps_idempotent
1081             , 'prop_Node_tagMaps_reject
1082             , 'prop_Node_showField
1083             , 'prop_Node_computeGroups
1084             ]
1085
1086 -- ** Cluster tests
1087
1088 -- | Check that the cluster score is close to zero for a homogeneous
1089 -- cluster.
1090 prop_Score_Zero node =
1091   forAll (choose (1, 1024)) $ \count ->
1092     (not (Node.offline node) && not (Node.failN1 node) && (count > 0) &&
1093      (Node.tDsk node > 0) && (Node.tMem node > 0)) ==>
1094   let fn = Node.buildPeers node Container.empty
1095       nlst = replicate count fn
1096       score = Cluster.compCVNodes nlst
1097   -- we can't say == 0 here as the floating point errors accumulate;
1098   -- this should be much lower than the default score in CLI.hs
1099   in score <= 1e-12
1100
1101 -- | Check that cluster stats are sane.
1102 prop_CStats_sane =
1103   forAll (choose (1, 1024)) $ \count ->
1104   forAll genOnlineNode $ \node ->
1105   let fn = Node.buildPeers node Container.empty
1106       nlst = zip [1..] $ replicate count fn::[(Types.Ndx, Node.Node)]
1107       nl = Container.fromList nlst
1108       cstats = Cluster.totalResources nl
1109   in Cluster.csAdsk cstats >= 0 &&
1110      Cluster.csAdsk cstats <= Cluster.csFdsk cstats
1111
1112 -- | Check that one instance is allocated correctly, without
1113 -- rebalances needed.
1114 prop_ClusterAlloc_sane inst =
1115   forAll (choose (5, 20)) $ \count ->
1116   forAll genOnlineNode $ \node ->
1117   let (nl, il, inst') = makeSmallEmptyCluster node count inst
1118   in case Cluster.genAllocNodes defGroupList nl 2 True >>=
1119      Cluster.tryAlloc nl il inst' of
1120        Types.Bad _ -> False
1121        Types.Ok as ->
1122          case Cluster.asSolution as of
1123            Nothing -> False
1124            Just (xnl, xi, _, cv) ->
1125              let il' = Container.add (Instance.idx xi) xi il
1126                  tbl = Cluster.Table xnl il' cv []
1127              in not (canBalance tbl True True False)
1128
1129 -- | Checks that on a 2-5 node cluster, we can allocate a random
1130 -- instance spec via tiered allocation (whatever the original instance
1131 -- spec), on either one or two nodes. Furthermore, we test that
1132 -- computed allocation statistics are correct.
1133 prop_ClusterCanTieredAlloc inst =
1134   forAll (choose (2, 5)) $ \count ->
1135   forAll (choose (1, 2)) $ \rqnodes ->
1136   forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
1137   let nl = makeSmallCluster node count
1138       il = Container.empty
1139       allocnodes = Cluster.genAllocNodes defGroupList nl rqnodes True
1140   in case allocnodes >>= \allocnodes' ->
1141     Cluster.tieredAlloc nl il (Just 1) inst allocnodes' [] [] of
1142        Types.Bad msg -> failTest $ "Failed to tiered alloc: " ++ msg
1143        Types.Ok (_, nl', il', ixes, cstats) ->
1144          let (ai_alloc, ai_pool, ai_unav) =
1145                Cluster.computeAllocationDelta
1146                 (Cluster.totalResources nl)
1147                 (Cluster.totalResources nl')
1148              all_nodes = Container.elems nl
1149          in property (not (null ixes)) .&&.
1150             IntMap.size il' ==? length ixes .&&.
1151             length ixes ==? length cstats .&&.
1152             sum (map Types.allocInfoVCpus [ai_alloc, ai_pool, ai_unav]) ==?
1153               sum (map Node.hiCpu all_nodes) .&&.
1154             sum (map Types.allocInfoNCpus [ai_alloc, ai_pool, ai_unav]) ==?
1155               sum (map Node.tCpu all_nodes) .&&.
1156             sum (map Types.allocInfoMem [ai_alloc, ai_pool, ai_unav]) ==?
1157               truncate (sum (map Node.tMem all_nodes)) .&&.
1158             sum (map Types.allocInfoDisk [ai_alloc, ai_pool, ai_unav]) ==?
1159               truncate (sum (map Node.tDsk all_nodes))
1160
1161 -- | Helper function to create a cluster with the given range of nodes
1162 -- and allocate an instance on it.
1163 genClusterAlloc count node inst =
1164   let nl = makeSmallCluster node count
1165   in case Cluster.genAllocNodes defGroupList nl 2 True >>=
1166      Cluster.tryAlloc nl Container.empty inst of
1167        Types.Bad _ -> Types.Bad "Can't allocate"
1168        Types.Ok as ->
1169          case Cluster.asSolution as of
1170            Nothing -> Types.Bad "Empty solution?"
1171            Just (xnl, xi, _, _) ->
1172              let xil = Container.add (Instance.idx xi) xi Container.empty
1173              in Types.Ok (xnl, xil, xi)
1174
1175 -- | Checks that on a 4-8 node cluster, once we allocate an instance,
1176 -- we can also relocate it.
1177 prop_ClusterAllocRelocate =
1178   forAll (choose (4, 8)) $ \count ->
1179   forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
1180   forAll (genInstanceSmallerThanNode node) $ \inst ->
1181   case genClusterAlloc count node inst of
1182     Types.Bad msg -> failTest msg
1183     Types.Ok (nl, il, inst') ->
1184       case IAlloc.processRelocate defGroupList nl il
1185              (Instance.idx inst) 1 [Instance.sNode inst'] of
1186         Types.Ok _ -> printTestCase "??" True  -- huh, how to make
1187                                                -- this nicer...
1188         Types.Bad msg -> failTest $ "Failed to relocate: " ++ msg
1189
1190 -- | Helper property checker for the result of a nodeEvac or
1191 -- changeGroup operation.
1192 check_EvacMode grp inst result =
1193   case result of
1194     Types.Bad msg -> failTest $ "Couldn't evacuate/change group:" ++ msg
1195     Types.Ok (_, _, es) ->
1196       let moved = Cluster.esMoved es
1197           failed = Cluster.esFailed es
1198           opcodes = not . null $ Cluster.esOpCodes es
1199       in failmsg ("'failed' not empty: " ++ show failed) (null failed) .&&.
1200          failmsg "'opcodes' is null" opcodes .&&.
1201          case moved of
1202            [(idx', gdx, _)] -> failmsg "invalid instance moved" (idx == idx')
1203                                .&&.
1204                                failmsg "wrong target group"
1205                                          (gdx == Group.idx grp)
1206            v -> failmsg  ("invalid solution: " ++ show v) False
1207   where failmsg = \msg -> printTestCase ("Failed to evacuate: " ++ msg)
1208         idx = Instance.idx inst
1209
1210 -- | Checks that on a 4-8 node cluster, once we allocate an instance,
1211 -- we can also node-evacuate it.
1212 prop_ClusterAllocEvacuate =
1213   forAll (choose (4, 8)) $ \count ->
1214   forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
1215   forAll (genInstanceSmallerThanNode node) $ \inst ->
1216   case genClusterAlloc count node inst of
1217     Types.Bad msg -> failTest msg
1218     Types.Ok (nl, il, inst') ->
1219       conjoin $ map (\mode -> check_EvacMode defGroup inst' $
1220                               Cluster.tryNodeEvac defGroupList nl il mode
1221                                 [Instance.idx inst']) [minBound..maxBound]
1222
1223 -- | Checks that on a 4-8 node cluster with two node groups, once we
1224 -- allocate an instance on the first node group, we can also change
1225 -- its group.
1226 prop_ClusterAllocChangeGroup =
1227   forAll (choose (4, 8)) $ \count ->
1228   forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
1229   forAll (genInstanceSmallerThanNode node) $ \inst ->
1230   case genClusterAlloc count node inst of
1231     Types.Bad msg -> failTest msg
1232     Types.Ok (nl, il, inst') ->
1233       -- we need to add a second node group and nodes to the cluster
1234       let nl2 = Container.elems $ makeSmallCluster node count
1235           grp2 = Group.setIdx defGroup (Group.idx defGroup + 1)
1236           maxndx = maximum . map Node.idx $ nl2
1237           nl3 = map (\n -> n { Node.group = Group.idx grp2
1238                              , Node.idx = Node.idx n + maxndx }) nl2
1239           nl4 = Container.fromList . map (\n -> (Node.idx n, n)) $ nl3
1240           gl' = Container.add (Group.idx grp2) grp2 defGroupList
1241           nl' = IntMap.union nl nl4
1242       in check_EvacMode grp2 inst' $
1243          Cluster.tryChangeGroup gl' nl' il [] [Instance.idx inst']
1244
1245 -- | Check that allocating multiple instances on a cluster, then
1246 -- adding an empty node, results in a valid rebalance.
1247 prop_ClusterAllocBalance =
1248   forAll (genNode (Just 5) (Just 128)) $ \node ->
1249   forAll (choose (3, 5)) $ \count ->
1250   not (Node.offline node) && not (Node.failN1 node) ==>
1251   let nl = makeSmallCluster node count
1252       (hnode, nl') = IntMap.deleteFindMax nl
1253       il = Container.empty
1254       allocnodes = Cluster.genAllocNodes defGroupList nl' 2 True
1255       i_templ = createInstance Types.unitMem Types.unitDsk Types.unitCpu
1256   in case allocnodes >>= \allocnodes' ->
1257     Cluster.iterateAlloc nl' il (Just 5) i_templ allocnodes' [] [] of
1258        Types.Bad msg -> failTest $ "Failed to allocate: " ++ msg
1259        Types.Ok (_, _, _, [], _) -> failTest "Failed to allocate: no instances"
1260        Types.Ok (_, xnl, il', _, _) ->
1261          let ynl = Container.add (Node.idx hnode) hnode xnl
1262              cv = Cluster.compCV ynl
1263              tbl = Cluster.Table ynl il' cv []
1264          in printTestCase "Failed to rebalance" $
1265             canBalance tbl True True False
1266
1267 -- | Checks consistency.
1268 prop_ClusterCheckConsistency node inst =
1269   let nl = makeSmallCluster node 3
1270       [node1, node2, node3] = Container.elems nl
1271       node3' = node3 { Node.group = 1 }
1272       nl' = Container.add (Node.idx node3') node3' nl
1273       inst1 = Instance.setBoth inst (Node.idx node1) (Node.idx node2)
1274       inst2 = Instance.setBoth inst (Node.idx node1) Node.noSecondary
1275       inst3 = Instance.setBoth inst (Node.idx node1) (Node.idx node3)
1276       ccheck = Cluster.findSplitInstances nl' . Container.fromList
1277   in null (ccheck [(0, inst1)]) &&
1278      null (ccheck [(0, inst2)]) &&
1279      (not . null $ ccheck [(0, inst3)])
1280
1281 -- | For now, we only test that we don't lose instances during the split.
1282 prop_ClusterSplitCluster node inst =
1283   forAll (choose (0, 100)) $ \icnt ->
1284   let nl = makeSmallCluster node 2
1285       (nl', il') = foldl (\(ns, is) _ -> assignInstance ns is inst 0 1)
1286                    (nl, Container.empty) [1..icnt]
1287       gni = Cluster.splitCluster nl' il'
1288   in sum (map (Container.size . snd . snd) gni) == icnt &&
1289      all (\(guuid, (nl'', _)) -> all ((== guuid) . Node.group)
1290                                  (Container.elems nl'')) gni
1291
1292 -- | Helper function to check if we can allocate an instance on a
1293 -- given node list.
1294 canAllocOn :: Node.List -> Int -> Instance.Instance -> Bool
1295 canAllocOn nl reqnodes inst =
1296   case Cluster.genAllocNodes defGroupList nl reqnodes True >>=
1297        Cluster.tryAlloc nl (Container.empty) inst of
1298        Types.Bad _ -> False
1299        Types.Ok as ->
1300          case Cluster.asSolution as of
1301            Nothing -> False
1302            Just _ -> True
1303
1304 -- | Checks that allocation obeys minimum and maximum instance
1305 -- policies. The unittest generates a random node, duplicates it count
1306 -- times, and generates a random instance that can be allocated on
1307 -- this mini-cluster; it then checks that after applying a policy that
1308 -- the instance doesn't fits, the allocation fails.
1309 prop_ClusterAllocPolicy node =
1310   -- rqn is the required nodes (1 or 2)
1311   forAll (choose (1, 2)) $ \rqn ->
1312   forAll (choose (5, 20)) $ \count ->
1313   forAll (arbitrary `suchThat` (canAllocOn (makeSmallCluster node count) rqn))
1314          $ \inst ->
1315   forAll (arbitrary `suchThat` (isFailure .
1316                                 Instance.instMatchesPolicy inst)) $ \ipol ->
1317   let node' = Node.setPolicy ipol node
1318       nl = makeSmallCluster node' count
1319   in not $ canAllocOn nl rqn inst
1320
1321 testSuite "Cluster"
1322             [ 'prop_Score_Zero
1323             , 'prop_CStats_sane
1324             , 'prop_ClusterAlloc_sane
1325             , 'prop_ClusterCanTieredAlloc
1326             , 'prop_ClusterAllocRelocate
1327             , 'prop_ClusterAllocEvacuate
1328             , 'prop_ClusterAllocChangeGroup
1329             , 'prop_ClusterAllocBalance
1330             , 'prop_ClusterCheckConsistency
1331             , 'prop_ClusterSplitCluster
1332             , 'prop_ClusterAllocPolicy
1333             ]
1334
1335 -- ** OpCodes tests
1336
1337 -- | Check that opcode serialization is idempotent.
1338 prop_OpCodes_serialization op =
1339   case J.readJSON (J.showJSON op) of
1340     J.Error e -> failTest $ "Cannot deserialise: " ++ e
1341     J.Ok op' -> op ==? op'
1342   where _types = op::OpCodes.OpCode
1343
1344 testSuite "OpCodes"
1345             [ 'prop_OpCodes_serialization ]
1346
1347 -- ** Jobs tests
1348
1349 -- | Check that (queued) job\/opcode status serialization is idempotent.
1350 prop_OpStatus_serialization os =
1351   case J.readJSON (J.showJSON os) of
1352     J.Error e -> failTest $ "Cannot deserialise: " ++ e
1353     J.Ok os' -> os ==? os'
1354   where _types = os::Jobs.OpStatus
1355
1356 prop_JobStatus_serialization js =
1357   case J.readJSON (J.showJSON js) of
1358     J.Error e -> failTest $ "Cannot deserialise: " ++ e
1359     J.Ok js' -> js ==? js'
1360   where _types = js::Jobs.JobStatus
1361
1362 testSuite "Jobs"
1363             [ 'prop_OpStatus_serialization
1364             , 'prop_JobStatus_serialization
1365             ]
1366
1367 -- ** Loader tests
1368
1369 prop_Loader_lookupNode ktn inst node =
1370   Loader.lookupNode nl inst node ==? Data.Map.lookup node nl
1371     where nl = Data.Map.fromList ktn
1372
1373 prop_Loader_lookupInstance kti inst =
1374   Loader.lookupInstance il inst ==? Data.Map.lookup inst il
1375     where il = Data.Map.fromList kti
1376
1377 prop_Loader_assignIndices =
1378   -- generate nodes with unique names
1379   forAll (arbitrary `suchThat`
1380           (\nodes ->
1381              let names = map Node.name nodes
1382              in length names == length (nub names))) $ \nodes ->
1383   let (nassoc, kt) =
1384         Loader.assignIndices (map (\n -> (Node.name n, n)) nodes)
1385   in Data.Map.size nassoc == length nodes &&
1386      Container.size kt == length nodes &&
1387      if not (null nodes)
1388        then maximum (IntMap.keys kt) == length nodes - 1
1389        else True
1390
1391 -- | Checks that the number of primary instances recorded on the nodes
1392 -- is zero.
1393 prop_Loader_mergeData ns =
1394   let na = Container.fromList $ map (\n -> (Node.idx n, n)) ns
1395   in case Loader.mergeData [] [] [] []
1396          (Loader.emptyCluster {Loader.cdNodes = na}) of
1397     Types.Bad _ -> False
1398     Types.Ok (Loader.ClusterData _ nl il _ _) ->
1399       let nodes = Container.elems nl
1400           instances = Container.elems il
1401       in (sum . map (length . Node.pList)) nodes == 0 &&
1402          null instances
1403
1404 -- | Check that compareNameComponent on equal strings works.
1405 prop_Loader_compareNameComponent_equal :: String -> Bool
1406 prop_Loader_compareNameComponent_equal s =
1407   Loader.compareNameComponent s s ==
1408     Loader.LookupResult Loader.ExactMatch s
1409
1410 -- | Check that compareNameComponent on prefix strings works.
1411 prop_Loader_compareNameComponent_prefix :: NonEmptyList Char -> String -> Bool
1412 prop_Loader_compareNameComponent_prefix (NonEmpty s1) s2 =
1413   Loader.compareNameComponent (s1 ++ "." ++ s2) s1 ==
1414     Loader.LookupResult Loader.PartialMatch s1
1415
1416 testSuite "Loader"
1417             [ 'prop_Loader_lookupNode
1418             , 'prop_Loader_lookupInstance
1419             , 'prop_Loader_assignIndices
1420             , 'prop_Loader_mergeData
1421             , 'prop_Loader_compareNameComponent_equal
1422             , 'prop_Loader_compareNameComponent_prefix
1423             ]
1424
1425 -- ** Types tests
1426
1427 prop_Types_AllocPolicy_serialisation apol =
1428   case J.readJSON (J.showJSON apol) of
1429     J.Ok p -> p ==? apol
1430     J.Error s -> failTest $ "Failed to deserialise: " ++ s
1431       where _types = apol::Types.AllocPolicy
1432
1433 prop_Types_DiskTemplate_serialisation dt =
1434   case J.readJSON (J.showJSON dt) of
1435     J.Ok p -> p ==? dt
1436     J.Error s -> failTest $ "Failed to deserialise: " ++ s
1437       where _types = dt::Types.DiskTemplate
1438
1439 prop_Types_ISpec_serialisation ispec =
1440   case J.readJSON (J.showJSON ispec) of
1441     J.Ok p -> p ==? ispec
1442     J.Error s -> failTest $ "Failed to deserialise: " ++ s
1443       where _types = ispec::Types.ISpec
1444
1445 prop_Types_IPolicy_serialisation ipol =
1446   case J.readJSON (J.showJSON ipol) of
1447     J.Ok p -> p ==? ipol
1448     J.Error s -> failTest $ "Failed to deserialise: " ++ s
1449       where _types = ipol::Types.IPolicy
1450
1451 prop_Types_EvacMode_serialisation em =
1452   case J.readJSON (J.showJSON em) of
1453     J.Ok p -> p ==? em
1454     J.Error s -> failTest $ "Failed to deserialise: " ++ s
1455       where _types = em::Types.EvacMode
1456
1457 prop_Types_opToResult op =
1458   case op of
1459     Types.OpFail _ -> Types.isBad r
1460     Types.OpGood v -> case r of
1461                         Types.Bad _ -> False
1462                         Types.Ok v' -> v == v'
1463   where r = Types.opToResult op
1464         _types = op::Types.OpResult Int
1465
1466 prop_Types_eitherToResult ei =
1467   case ei of
1468     Left _ -> Types.isBad r
1469     Right v -> case r of
1470                  Types.Bad _ -> False
1471                  Types.Ok v' -> v == v'
1472     where r = Types.eitherToResult ei
1473           _types = ei::Either String Int
1474
1475 testSuite "Types"
1476             [ 'prop_Types_AllocPolicy_serialisation
1477             , 'prop_Types_DiskTemplate_serialisation
1478             , 'prop_Types_ISpec_serialisation
1479             , 'prop_Types_IPolicy_serialisation
1480             , 'prop_Types_EvacMode_serialisation
1481             , 'prop_Types_opToResult
1482             , 'prop_Types_eitherToResult
1483             ]
1484
1485 -- ** CLI tests
1486
1487 -- | Test correct parsing.
1488 prop_CLI_parseISpec descr dsk mem cpu =
1489   let str = printf "%d,%d,%d" dsk mem cpu
1490   in CLI.parseISpecString descr str ==? Types.Ok (Types.RSpec cpu mem dsk)
1491
1492 -- | Test parsing failure due to wrong section count.
1493 prop_CLI_parseISpecFail descr =
1494   forAll (choose (0,100) `suchThat` ((/=) 3)) $ \nelems ->
1495   forAll (replicateM nelems arbitrary) $ \values ->
1496   let str = intercalate "," $ map show (values::[Int])
1497   in case CLI.parseISpecString descr str of
1498        Types.Ok v -> failTest $ "Expected failure, got " ++ show v
1499        _ -> property True
1500
1501 -- | Test parseYesNo.
1502 prop_CLI_parseYesNo def testval val =
1503   forAll (elements [val, "yes", "no"]) $ \actual_val ->
1504   if testval
1505     then CLI.parseYesNo def Nothing ==? Types.Ok def
1506     else let result = CLI.parseYesNo def (Just actual_val)
1507          in if actual_val `elem` ["yes", "no"]
1508               then result ==? Types.Ok (actual_val == "yes")
1509               else property $ Types.isBad result
1510
1511 -- | Helper to check for correct parsing of string arg.
1512 checkStringArg val (opt, fn) =
1513   let GetOpt.Option _ longs _ _ = opt
1514   in case longs of
1515        [] -> failTest "no long options?"
1516        cmdarg:_ ->
1517          case CLI.parseOptsInner ["--" ++ cmdarg ++ "=" ++ val] "prog" [opt] of
1518            Left e -> failTest $ "Failed to parse option: " ++ show e
1519            Right (options, _) -> fn options ==? Just val
1520
1521 -- | Test a few string arguments.
1522 prop_CLI_StringArg argument =
1523   let args = [ (CLI.oDataFile,      CLI.optDataFile)
1524              , (CLI.oDynuFile,      CLI.optDynuFile)
1525              , (CLI.oSaveCluster,   CLI.optSaveCluster)
1526              , (CLI.oReplay,        CLI.optReplay)
1527              , (CLI.oPrintCommands, CLI.optShowCmds)
1528              , (CLI.oLuxiSocket,    CLI.optLuxi)
1529              ]
1530   in conjoin $ map (checkStringArg argument) args
1531
1532 -- | Helper to test that a given option is accepted OK with quick exit.
1533 checkEarlyExit name options param =
1534   case CLI.parseOptsInner [param] name options of
1535     Left (code, _) -> if code == 0
1536                           then property True
1537                           else failTest $ "Program " ++ name ++
1538                                  " returns invalid code " ++ show code ++
1539                                  " for option " ++ param
1540     _ -> failTest $ "Program " ++ name ++ " doesn't consider option " ++
1541          param ++ " as early exit one"
1542
1543 -- | Test that all binaries support some common options. There is
1544 -- nothing actually random about this test...
1545 prop_CLI_stdopts =
1546   let params = ["-h", "--help", "-V", "--version"]
1547       opts = map (\(name, (_, o)) -> (name, o)) Program.personalities
1548       -- apply checkEarlyExit across the cartesian product of params and opts
1549   in conjoin [checkEarlyExit n o p | p <- params, (n, o) <- opts]
1550
1551 testSuite "CLI"
1552           [ 'prop_CLI_parseISpec
1553           , 'prop_CLI_parseISpecFail
1554           , 'prop_CLI_parseYesNo
1555           , 'prop_CLI_StringArg
1556           , 'prop_CLI_stdopts
1557           ]