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