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