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

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