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