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