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

   1 {-| Unittests for ganeti-htools.
   2
   3 -}
   4
   5 {-
   6
   7 Copyright (C) 2009, 2010, 2011 Google Inc.
   8
   9 This program is free software; you can redistribute it and/or modify
  10 it under the terms of the GNU General Public License as published by
  11 the Free Software Foundation; either version 2 of the License, or
  12 (at your option) any later version.
  13
  14 This program is distributed in the hope that it will be useful, but
  15 WITHOUT ANY WARRANTY; without even the implied warranty of
  16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 General Public License for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with this program; if not, write to the Free Software
  21 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  22 02110-1301, USA.
  23
  24 -}
  25
  26 module Ganeti.HTools.QC
  27     ( testUtils
  28     , testPeerMap
  29     , testContainer
  30     , testInstance
  31     , testNode
  32     , testText
  33     , testOpCodes
  34     , testJobs
  35     , testCluster
  36     , testLoader
  37     , testTypes
  38     ) where
  39
  40 import Test.QuickCheck
  41 import Data.List (findIndex, intercalate, nub, isPrefixOf)
  42 import Data.Maybe
  43 import Control.Monad
  44 import qualified Text.JSON as J
  45 import qualified Data.Map
  46 import qualified Data.IntMap as IntMap
  47 import qualified Ganeti.OpCodes as OpCodes
  48 import qualified Ganeti.Jobs as Jobs
  49 import qualified Ganeti.Luxi
  50 import qualified Ganeti.HTools.CLI as CLI
  51 import qualified Ganeti.HTools.Cluster as Cluster
  52 import qualified Ganeti.HTools.Container as Container
  53 import qualified Ganeti.HTools.ExtLoader
  54 import qualified Ganeti.HTools.IAlloc as IAlloc
  55 import qualified Ganeti.HTools.Instance as Instance
  56 import qualified Ganeti.HTools.Loader as Loader
  57 import qualified Ganeti.HTools.Luxi
  58 import qualified Ganeti.HTools.Node as Node
  59 import qualified Ganeti.HTools.Group as Group
  60 import qualified Ganeti.HTools.PeerMap as PeerMap
  61 import qualified Ganeti.HTools.Rapi
  62 import qualified Ganeti.HTools.Simu
  63 import qualified Ganeti.HTools.Text as Text
  64 import qualified Ganeti.HTools.Types as Types
  65 import qualified Ganeti.HTools.Utils as Utils
  66 import qualified Ganeti.HTools.Version
  67 import qualified Ganeti.Constants as C
  68
  69 import qualified Ganeti.HTools.Program.Hail
  70 import qualified Ganeti.HTools.Program.Hbal
  71 import qualified Ganeti.HTools.Program.Hscan
  72 import qualified Ganeti.HTools.Program.Hspace
  73
  74 run :: Testable prop => prop -> Args -> IO Result
  75 run = flip quickCheckWithResult
  76
  77 -- * Constants
  78
  79 -- | Maximum memory (1TiB, somewhat random value).
  80 maxMem :: Int
  81 maxMem = 1024 * 1024
  82
  83 -- | Maximum disk (8TiB, somewhat random value).
  84 maxDsk :: Int
  85 maxDsk = 1024 * 1024 * 8
  86
  87 -- | Max CPUs (1024, somewhat random value).
  88 maxCpu :: Int
  89 maxCpu = 1024
  90
  91 defGroup :: Group.Group
  92 defGroup = flip Group.setIdx 0 $
  93                Group.create "default" Utils.defaultGroupID
  94                     Types.AllocPreferred
  95
  96 defGroupList :: Group.List
  97 defGroupList = Container.fromList [(Group.idx defGroup, defGroup)]
  98
  99 defGroupAssoc :: Data.Map.Map String Types.Gdx
 100 defGroupAssoc = Data.Map.singleton (Group.uuid defGroup) (Group.idx defGroup)
 101
 102 -- * Helper functions
 103
 104 -- | Simple checker for whether OpResult is fail or pass.
 105 isFailure :: Types.OpResult a -> Bool
 106 isFailure (Types.OpFail _) = True
 107 isFailure _ = False
 108
 109 -- | Update an instance to be smaller than a node.
 110 setInstanceSmallerThanNode node inst =
 111     inst { Instance.mem = Node.availMem node `div` 2
 112          , Instance.dsk = Node.availDisk node `div` 2
 113          , Instance.vcpus = Node.availCpu node `div` 2
 114          }
 115
 116 -- | Create an instance given its spec.
 117 createInstance mem dsk vcpus =
 118     Instance.create "inst-unnamed" mem dsk vcpus "running" [] True (-1) (-1)
 119                     Types.DTDrbd8
 120
 121 -- | Create a small cluster by repeating a node spec.
 122 makeSmallCluster :: Node.Node -> Int -> Node.List
 123 makeSmallCluster node count =
 124     let fn = Node.buildPeers node Container.empty
 125         namelst = map (\n -> (Node.name n, n)) (replicate count fn)
 126         (_, nlst) = Loader.assignIndices namelst
 127     in nlst
 128
 129 -- | Checks if a node is "big" enough.
 130 isNodeBig :: Node.Node -> Int -> Bool
 131 isNodeBig node size = Node.availDisk node > size * Types.unitDsk
 132                       && Node.availMem node > size * Types.unitMem
 133                       && Node.availCpu node > size * Types.unitCpu
 134
 135 canBalance :: Cluster.Table -> Bool -> Bool -> Bool -> Bool
 136 canBalance tbl dm im evac = isJust $ Cluster.tryBalance tbl dm im evac 0 0
 137
 138 -- | Assigns a new fresh instance to a cluster; this is not
 139 -- allocation, so no resource checks are done.
 140 assignInstance :: Node.List -> Instance.List -> Instance.Instance ->
 141                   Types.Idx -> Types.Idx ->
 142                   (Node.List, Instance.List)
 143 assignInstance nl il inst pdx sdx =
 144   let pnode = Container.find pdx nl
 145       snode = Container.find sdx nl
 146       maxiidx = if Container.null il
 147                 then 0
 148                 else fst (Container.findMax il) + 1
 149       inst' = inst { Instance.idx = maxiidx,
 150                      Instance.pNode = pdx, Instance.sNode = sdx }
 151       pnode' = Node.setPri pnode inst'
 152       snode' = Node.setSec snode inst'
 153       nl' = Container.addTwo pdx pnode' sdx snode' nl
 154       il' = Container.add maxiidx inst' il
 155   in (nl', il')
 156
 157 -- * Arbitrary instances
 158
 159 -- | Defines a DNS name.
 160 newtype DNSChar = DNSChar { dnsGetChar::Char }
 161
 162 instance Arbitrary DNSChar where
 163     arbitrary = do
 164       x <- elements (['a'..'z'] ++ ['0'..'9'] ++ "_-")
 165       return (DNSChar x)
 166
 167 getName :: Gen String
 168 getName = do
 169   n <- choose (1, 64)
 170   dn <- vector n::Gen [DNSChar]
 171   return (map dnsGetChar dn)
 172
 173
 174 getFQDN :: Gen String
 175 getFQDN = do
 176   felem <- getName
 177   ncomps <- choose (1, 4)
 178   frest <- vector ncomps::Gen [[DNSChar]]
 179   let frest' = map (map dnsGetChar) frest
 180   return (felem ++ "." ++ intercalate "." frest')
 181
 182 -- let's generate a random instance
 183 instance Arbitrary Instance.Instance where
 184     arbitrary = do
 185       name <- getFQDN
 186       mem <- choose (0, maxMem)
 187       dsk <- choose (0, maxDsk)
 188       run_st <- elements [ C.inststErrorup
 189                          , C.inststErrordown
 190                          , C.inststAdmindown
 191                          , C.inststNodedown
 192                          , C.inststNodeoffline
 193                          , C.inststRunning
 194                          , "no_such_status1"
 195                          , "no_such_status2"]
 196       pn <- arbitrary
 197       sn <- arbitrary
 198       vcpus <- choose (0, maxCpu)
 199       return $ Instance.create name mem dsk vcpus run_st [] True pn sn
 200                                Types.DTDrbd8
 201
 202 -- | Generas an arbitrary node based on sizing information.
 203 genNode :: Maybe Int -- ^ Minimum node size in terms of units
 204         -> Maybe Int -- ^ Maximum node size (when Nothing, bounded
 205                      -- just by the max... constants)
 206         -> Gen Node.Node
 207 genNode min_multiplier max_multiplier = do
 208   let (base_mem, base_dsk, base_cpu) =
 209           case min_multiplier of
 210             Just mm -> (mm * Types.unitMem,
 211                         mm * Types.unitDsk,
 212                         mm * Types.unitCpu)
 213             Nothing -> (0, 0, 0)
 214       (top_mem, top_dsk, top_cpu)  =
 215           case max_multiplier of
 216             Just mm -> (mm * Types.unitMem,
 217                         mm * Types.unitDsk,
 218                         mm * Types.unitCpu)
 219             Nothing -> (maxMem, maxDsk, maxCpu)
 220   name  <- getFQDN
 221   mem_t <- choose (base_mem, top_mem)
 222   mem_f <- choose (base_mem, mem_t)
 223   mem_n <- choose (0, mem_t - mem_f)
 224   dsk_t <- choose (base_dsk, top_dsk)
 225   dsk_f <- choose (base_dsk, dsk_t)
 226   cpu_t <- choose (base_cpu, top_cpu)
 227   offl  <- arbitrary
 228   let n = Node.create name (fromIntegral mem_t) mem_n mem_f
 229           (fromIntegral dsk_t) dsk_f (fromIntegral cpu_t) offl 0
 230   return $ Node.buildPeers n Container.empty
 231
 232 -- and a random node
 233 instance Arbitrary Node.Node where
 234     arbitrary = genNode Nothing Nothing
 235
 236 -- replace disks
 237 instance Arbitrary OpCodes.ReplaceDisksMode where
 238   arbitrary = elements [ OpCodes.ReplaceOnPrimary
 239                        , OpCodes.ReplaceOnSecondary
 240                        , OpCodes.ReplaceNewSecondary
 241                        , OpCodes.ReplaceAuto
 242                        ]
 243
 244 instance Arbitrary OpCodes.OpCode where
 245   arbitrary = do
 246     op_id <- elements [ "OP_TEST_DELAY"
 247                       , "OP_INSTANCE_REPLACE_DISKS"
 248                       , "OP_INSTANCE_FAILOVER"
 249                       , "OP_INSTANCE_MIGRATE"
 250                       ]
 251     (case op_id of
 252         "OP_TEST_DELAY" ->
 253           liftM3 OpCodes.OpTestDelay arbitrary arbitrary arbitrary
 254         "OP_INSTANCE_REPLACE_DISKS" ->
 255           liftM5 OpCodes.OpInstanceReplaceDisks arbitrary arbitrary
 256           arbitrary arbitrary arbitrary
 257         "OP_INSTANCE_FAILOVER" ->
 258           liftM2 OpCodes.OpInstanceFailover arbitrary arbitrary
 259         "OP_INSTANCE_MIGRATE" ->
 260           liftM4 OpCodes.OpInstanceMigrate arbitrary arbitrary arbitrary
 261           arbitrary
 262         _ -> fail "Wrong opcode")
 263
 264 instance Arbitrary Jobs.OpStatus where
 265   arbitrary = elements [minBound..maxBound]
 266
 267 instance Arbitrary Jobs.JobStatus where
 268   arbitrary = elements [minBound..maxBound]
 269
 270 newtype SmallRatio = SmallRatio Double deriving Show
 271 instance Arbitrary SmallRatio where
 272     arbitrary = do
 273       v <- choose (0, 1)
 274       return $ SmallRatio v
 275
 276 instance Arbitrary Types.AllocPolicy where
 277   arbitrary = elements [minBound..maxBound]
 278
 279 instance Arbitrary Types.DiskTemplate where
 280   arbitrary = elements [minBound..maxBound]
 281
 282 -- * Actual tests
 283
 284 -- ** Utils tests
 285
 286 -- | If the list is not just an empty element, and if the elements do
 287 -- not contain commas, then join+split should be idempotent.
 288 prop_Utils_commaJoinSplit =
 289     forAll (arbitrary `suchThat`
 290             (\l -> l /= [""] && all (not . elem ',') l )) $ \lst ->
 291     Utils.sepSplit ',' (Utils.commaJoin lst) == lst
 292
 293 -- | Split and join should always be idempotent.
 294 prop_Utils_commaSplitJoin s = Utils.commaJoin (Utils.sepSplit ',' s) == s
 295
 296 -- | fromObjWithDefault, we test using the Maybe monad and an integer
 297 -- value.
 298 prop_Utils_fromObjWithDefault def_value random_key =
 299     -- a missing key will be returned with the default
 300     Utils.fromObjWithDefault [] random_key def_value == Just def_value &&
 301     -- a found key will be returned as is, not with default
 302     Utils.fromObjWithDefault [(random_key, J.showJSON def_value)]
 303          random_key (def_value+1) == Just def_value
 304         where _types = def_value :: Integer
 305
 306 -- | Test that functional if' behaves like the syntactic sugar if.
 307 prop_Utils_if'if :: Bool -> Int -> Int -> Bool
 308 prop_Utils_if'if cnd a b = Utils.if' cnd a b == if cnd then a else b
 309
 310 -- | Test basic select functionality
 311 prop_Utils_select :: Int   -- ^ Default result
 312                   -> [Int] -- ^ List of False values
 313                   -> [Int] -- ^ List of True values
 314                   -> Bool  -- ^ Test result
 315 prop_Utils_select def lst1 lst2 =
 316   Utils.select def cndlist == expectedresult
 317   where expectedresult = Utils.if' (null lst2) def (head lst2)
 318         flist = map (\e -> (False, e)) lst1
 319         tlist = map (\e -> (True, e)) lst2
 320         cndlist = flist ++ tlist
 321
 322 -- | Test basic select functionality with undefined default
 323 prop_Utils_select_undefd :: [Int] -- ^ List of False values
 324                          -> NonEmptyList Int -- ^ List of True values
 325                          -> Bool  -- ^ Test result
 326 prop_Utils_select_undefd lst1 (NonEmpty lst2) =
 327   Utils.select undefined cndlist == head lst2
 328   where flist = map (\e -> (False, e)) lst1
 329         tlist = map (\e -> (True, e)) lst2
 330         cndlist = flist ++ tlist
 331
 332 -- | Test basic select functionality with undefined list values
 333 prop_Utils_select_undefv :: [Int] -- ^ List of False values
 334                          -> NonEmptyList Int -- ^ List of True values
 335                          -> Bool  -- ^ Test result
 336 prop_Utils_select_undefv lst1 (NonEmpty lst2) =
 337   Utils.select undefined cndlist == head lst2
 338   where flist = map (\e -> (False, e)) lst1
 339         tlist = map (\e -> (True, e)) lst2
 340         cndlist = flist ++ tlist ++ [undefined]
 341
 342 prop_Utils_parseUnit (NonNegative n) =
 343     Utils.parseUnit (show n) == Types.Ok n &&
 344     Utils.parseUnit (show n ++ "m") == Types.Ok n &&
 345     (case Utils.parseUnit (show n ++ "M") of
 346       Types.Ok m -> if n > 0
 347                     then m < n  -- for positive values, X MB is less than X MiB
 348                     else m == 0 -- but for 0, 0 MB == 0 MiB
 349       Types.Bad _ -> False) &&
 350     Utils.parseUnit (show n ++ "g") == Types.Ok (n*1024) &&
 351     Utils.parseUnit (show n ++ "t") == Types.Ok (n*1048576) &&
 352     Types.isBad (Utils.parseUnit (show n ++ "x")::Types.Result Int)
 353     where _types = (n::Int)
 354
 355 -- | Test list for the Utils module.
 356 testUtils =
 357   [ run prop_Utils_commaJoinSplit
 358   , run prop_Utils_commaSplitJoin
 359   , run prop_Utils_fromObjWithDefault
 360   , run prop_Utils_if'if
 361   , run prop_Utils_select
 362   , run prop_Utils_select_undefd
 363   , run prop_Utils_select_undefv
 364   , run prop_Utils_parseUnit
 365   ]
 366
 367 -- ** PeerMap tests
 368
 369 -- | Make sure add is idempotent.
 370 prop_PeerMap_addIdempotent pmap key em =
 371     fn puniq == fn (fn puniq)
 372     where _types = (pmap::PeerMap.PeerMap,
 373                     key::PeerMap.Key, em::PeerMap.Elem)
 374           fn = PeerMap.add key em
 375           puniq = PeerMap.accumArray const pmap
 376
 377 -- | Make sure remove is idempotent.
 378 prop_PeerMap_removeIdempotent pmap key =
 379     fn puniq == fn (fn puniq)
 380     where _types = (pmap::PeerMap.PeerMap, key::PeerMap.Key)
 381           fn = PeerMap.remove key
 382           puniq = PeerMap.accumArray const pmap
 383
 384 -- | Make sure a missing item returns 0.
 385 prop_PeerMap_findMissing pmap key =
 386     PeerMap.find key (PeerMap.remove key puniq) == 0
 387     where _types = (pmap::PeerMap.PeerMap, key::PeerMap.Key)
 388           puniq = PeerMap.accumArray const pmap
 389
 390 -- | Make sure an added item is found.
 391 prop_PeerMap_addFind pmap key em =
 392     PeerMap.find key (PeerMap.add key em puniq) == em
 393     where _types = (pmap::PeerMap.PeerMap,
 394                     key::PeerMap.Key, em::PeerMap.Elem)
 395           puniq = PeerMap.accumArray const pmap
 396
 397 -- | Manual check that maxElem returns the maximum indeed, or 0 for null.
 398 prop_PeerMap_maxElem pmap =
 399     PeerMap.maxElem puniq == if null puniq then 0
 400                              else (maximum . snd . unzip) puniq
 401     where _types = pmap::PeerMap.PeerMap
 402           puniq = PeerMap.accumArray const pmap
 403
 404 -- | List of tests for the PeerMap module.
 405 testPeerMap =
 406     [ run prop_PeerMap_addIdempotent
 407     , run prop_PeerMap_removeIdempotent
 408     , run prop_PeerMap_maxElem
 409     , run prop_PeerMap_addFind
 410     , run prop_PeerMap_findMissing
 411     ]
 412
 413 -- ** Container tests
 414
 415 prop_Container_addTwo cdata i1 i2 =
 416     fn i1 i2 cont == fn i2 i1 cont &&
 417        fn i1 i2 cont == fn i1 i2 (fn i1 i2 cont)
 418     where _types = (cdata::[Int],
 419                     i1::Int, i2::Int)
 420           cont = foldl (\c x -> Container.add x x c) Container.empty cdata
 421           fn x1 x2 = Container.addTwo x1 x1 x2 x2
 422
 423 prop_Container_nameOf node =
 424   let nl = makeSmallCluster node 1
 425       fnode = head (Container.elems nl)
 426   in Container.nameOf nl (Node.idx fnode) == Node.name fnode
 427
 428 -- | We test that in a cluster, given a random node, we can find it by
 429 -- its name and alias, as long as all names and aliases are unique,
 430 -- and that we fail to find a non-existing name.
 431 prop_Container_findByName node othername =
 432   forAll (choose (1, 20)) $ \ cnt ->
 433   forAll (choose (0, cnt - 1)) $ \ fidx ->
 434   forAll (vector cnt) $ \ names ->
 435   (length . nub) (map fst names ++ map snd names) ==
 436   length names * 2 &&
 437   not (othername `elem` (map fst names ++ map snd names)) ==>
 438   let nl = makeSmallCluster node cnt
 439       nodes = Container.elems nl
 440       nodes' = map (\((name, alias), nn) -> (Node.idx nn,
 441                                              nn { Node.name = name,
 442                                                   Node.alias = alias }))
 443                $ zip names nodes
 444       nl' = Container.fromList nodes'
 445       target = snd (nodes' !! fidx)
 446   in Container.findByName nl' (Node.name target) == Just target &&
 447      Container.findByName nl' (Node.alias target) == Just target &&
 448      Container.findByName nl' othername == Nothing
 449
 450 testContainer =
 451     [ run prop_Container_addTwo
 452     , run prop_Container_nameOf
 453     , run prop_Container_findByName
 454     ]
 455
 456 -- ** Instance tests
 457
 458 -- Simple instance tests, we only have setter/getters
 459
 460 prop_Instance_creat inst =
 461     Instance.name inst == Instance.alias inst
 462
 463 prop_Instance_setIdx inst idx =
 464     Instance.idx (Instance.setIdx inst idx) == idx
 465     where _types = (inst::Instance.Instance, idx::Types.Idx)
 466
 467 prop_Instance_setName inst name =
 468     Instance.name newinst == name &&
 469     Instance.alias newinst == name
 470     where _types = (inst::Instance.Instance, name::String)
 471           newinst = Instance.setName inst name
 472
 473 prop_Instance_setAlias inst name =
 474     Instance.name newinst == Instance.name inst &&
 475     Instance.alias newinst == name
 476     where _types = (inst::Instance.Instance, name::String)
 477           newinst = Instance.setAlias inst name
 478
 479 prop_Instance_setPri inst pdx =
 480     Instance.pNode (Instance.setPri inst pdx) == pdx
 481     where _types = (inst::Instance.Instance, pdx::Types.Ndx)
 482
 483 prop_Instance_setSec inst sdx =
 484     Instance.sNode (Instance.setSec inst sdx) == sdx
 485     where _types = (inst::Instance.Instance, sdx::Types.Ndx)
 486
 487 prop_Instance_setBoth inst pdx sdx =
 488     Instance.pNode si == pdx && Instance.sNode si == sdx
 489     where _types = (inst::Instance.Instance, pdx::Types.Ndx, sdx::Types.Ndx)
 490           si = Instance.setBoth inst pdx sdx
 491
 492 prop_Instance_runStatus_True =
 493     forAll (arbitrary `suchThat`
 494             ((`elem` Instance.runningStates) . Instance.runSt))
 495     Instance.running
 496
 497 prop_Instance_runStatus_False inst =
 498     let run_st = Instance.running inst
 499         run_tx = Instance.runSt inst
 500     in
 501       run_tx `notElem` Instance.runningStates ==> not run_st
 502
 503 prop_Instance_shrinkMG inst =
 504     Instance.mem inst >= 2 * Types.unitMem ==>
 505         case Instance.shrinkByType inst Types.FailMem of
 506           Types.Ok inst' ->
 507               Instance.mem inst' == Instance.mem inst - Types.unitMem
 508           _ -> False
 509
 510 prop_Instance_shrinkMF inst =
 511     forAll (choose (0, 2 * Types.unitMem - 1)) $ \mem ->
 512     let inst' = inst { Instance.mem = mem}
 513     in Types.isBad $ Instance.shrinkByType inst' Types.FailMem
 514
 515 prop_Instance_shrinkCG inst =
 516     Instance.vcpus inst >= 2 * Types.unitCpu ==>
 517         case Instance.shrinkByType inst Types.FailCPU of
 518           Types.Ok inst' ->
 519               Instance.vcpus inst' == Instance.vcpus inst - Types.unitCpu
 520           _ -> False
 521
 522 prop_Instance_shrinkCF inst =
 523     forAll (choose (0, 2 * Types.unitCpu - 1)) $ \vcpus ->
 524     let inst' = inst { Instance.vcpus = vcpus }
 525     in Types.isBad $ Instance.shrinkByType inst' Types.FailCPU
 526
 527 prop_Instance_shrinkDG inst =
 528     Instance.dsk inst >= 2 * Types.unitDsk ==>
 529         case Instance.shrinkByType inst Types.FailDisk of
 530           Types.Ok inst' ->
 531               Instance.dsk inst' == Instance.dsk inst - Types.unitDsk
 532           _ -> False
 533
 534 prop_Instance_shrinkDF inst =
 535     forAll (choose (0, 2 * Types.unitDsk - 1)) $ \dsk ->
 536     let inst' = inst { Instance.dsk = dsk }
 537     in Types.isBad $ Instance.shrinkByType inst' Types.FailDisk
 538
 539 prop_Instance_setMovable inst m =
 540     Instance.movable inst' == m
 541     where inst' = Instance.setMovable inst m
 542
 543 testInstance =
 544     [ run prop_Instance_creat
 545     , run prop_Instance_setIdx
 546     , run prop_Instance_setName
 547     , run prop_Instance_setAlias
 548     , run prop_Instance_setPri
 549     , run prop_Instance_setSec
 550     , run prop_Instance_setBoth
 551     , run prop_Instance_runStatus_True
 552     , run prop_Instance_runStatus_False
 553     , run prop_Instance_shrinkMG
 554     , run prop_Instance_shrinkMF
 555     , run prop_Instance_shrinkCG
 556     , run prop_Instance_shrinkCF
 557     , run prop_Instance_shrinkDG
 558     , run prop_Instance_shrinkDF
 559     , run prop_Instance_setMovable
 560     ]
 561
 562 -- ** Text backend tests
 563
 564 -- Instance text loader tests
 565
 566 prop_Text_Load_Instance name mem dsk vcpus status
 567                         (NonEmpty pnode) snode
 568                         (NonNegative pdx) (NonNegative sdx) autobal dt =
 569     pnode /= snode && pdx /= sdx ==>
 570     let vcpus_s = show vcpus
 571         dsk_s = show dsk
 572         mem_s = show mem
 573         ndx = if null snode
 574               then [(pnode, pdx)]
 575               else [(pnode, pdx), (snode, sdx)]
 576         nl = Data.Map.fromList ndx
 577         tags = ""
 578         sbal = if autobal then "Y" else "N"
 579         sdt = Types.dtToString dt
 580         inst = Text.loadInst nl
 581                [name, mem_s, dsk_s, vcpus_s, status,
 582                 sbal, pnode, snode, sdt, tags]
 583         fail1 = Text.loadInst nl
 584                [name, mem_s, dsk_s, vcpus_s, status,
 585                 sbal, pnode, pnode, tags]
 586         _types = ( name::String, mem::Int, dsk::Int
 587                  , vcpus::Int, status::String
 588                  , snode::String
 589                  , autobal::Bool)
 590     in
 591       case inst of
 592         Types.Bad msg -> printTestCase ("Failed to load instance: " ++ msg)
 593                          False
 594         Types.Ok (_, i) -> printTestCase ("Mismatch in some field while\
 595                                           \ loading the instance") $
 596             Instance.name i == name &&
 597             Instance.vcpus i == vcpus &&
 598             Instance.mem i == mem &&
 599             Instance.pNode i == pdx &&
 600             Instance.sNode i == (if null snode
 601                                  then Node.noSecondary
 602                                  else sdx) &&
 603             Instance.autoBalance i == autobal &&
 604             Types.isBad fail1
 605
 606 prop_Text_Load_InstanceFail ktn fields =
 607     length fields /= 10 ==>
 608     case Text.loadInst nl fields of
 609       Types.Ok _ -> printTestCase "Managed to load instance from invalid\
 610                                   \ data" False
 611       Types.Bad msg -> printTestCase ("Unrecognised error message: " ++ msg) $
 612                        "Invalid/incomplete instance data: '" `isPrefixOf` msg
 613     where nl = Data.Map.fromList ktn
 614
 615 prop_Text_Load_Node name tm nm fm td fd tc fo =
 616     let conv v = if v < 0
 617                     then "?"
 618                     else show v
 619         tm_s = conv tm
 620         nm_s = conv nm
 621         fm_s = conv fm
 622         td_s = conv td
 623         fd_s = conv fd
 624         tc_s = conv tc
 625         fo_s = if fo
 626                then "Y"
 627                else "N"
 628         any_broken = any (< 0) [tm, nm, fm, td, fd, tc]
 629         gid = Group.uuid defGroup
 630     in case Text.loadNode defGroupAssoc
 631            [name, tm_s, nm_s, fm_s, td_s, fd_s, tc_s, fo_s, gid] of
 632          Nothing -> False
 633          Just (name', node) ->
 634              if fo || any_broken
 635              then Node.offline node
 636              else Node.name node == name' && name' == name &&
 637                   Node.alias node == name &&
 638                   Node.tMem node == fromIntegral tm &&
 639                   Node.nMem node == nm &&
 640                   Node.fMem node == fm &&
 641                   Node.tDsk node == fromIntegral td &&
 642                   Node.fDsk node == fd &&
 643                   Node.tCpu node == fromIntegral tc
 644
 645 prop_Text_Load_NodeFail fields =
 646     length fields /= 8 ==> isNothing $ Text.loadNode Data.Map.empty fields
 647
 648 prop_Text_NodeLSIdempotent node =
 649     (Text.loadNode defGroupAssoc.
 650          Utils.sepSplit '|' . Text.serializeNode defGroupList) n ==
 651     Just (Node.name n, n)
 652     -- override failN1 to what loadNode returns by default
 653     where n = node { Node.failN1 = True, Node.offline = False }
 654
 655 testText =
 656     [ run prop_Text_Load_Instance
 657     , run prop_Text_Load_InstanceFail
 658     , run prop_Text_Load_Node
 659     , run prop_Text_Load_NodeFail
 660     , run prop_Text_NodeLSIdempotent
 661     ]
 662
 663 -- ** Node tests
 664
 665 prop_Node_setAlias node name =
 666     Node.name newnode == Node.name node &&
 667     Node.alias newnode == name
 668     where _types = (node::Node.Node, name::String)
 669           newnode = Node.setAlias node name
 670
 671 prop_Node_setOffline node status =
 672     Node.offline newnode == status
 673     where newnode = Node.setOffline node status
 674
 675 prop_Node_setXmem node xm =
 676     Node.xMem newnode == xm
 677     where newnode = Node.setXmem node xm
 678
 679 prop_Node_setMcpu node mc =
 680     Node.mCpu newnode == mc
 681     where newnode = Node.setMcpu node mc
 682
 683 -- | Check that an instance add with too high memory or disk will be
 684 -- rejected.
 685 prop_Node_addPriFM node inst = Instance.mem inst >= Node.fMem node &&
 686                                not (Node.failN1 node)
 687                                ==>
 688                                case Node.addPri node inst'' of
 689                                  Types.OpFail Types.FailMem -> True
 690                                  _ -> False
 691     where _types = (node::Node.Node, inst::Instance.Instance)
 692           inst' = setInstanceSmallerThanNode node inst
 693           inst'' = inst' { Instance.mem = Instance.mem inst }
 694
 695 prop_Node_addPriFD node inst = Instance.dsk inst >= Node.fDsk node &&
 696                                not (Node.failN1 node)
 697                                ==>
 698                                case Node.addPri node inst'' of
 699                                  Types.OpFail Types.FailDisk -> True
 700                                  _ -> False
 701     where _types = (node::Node.Node, inst::Instance.Instance)
 702           inst' = setInstanceSmallerThanNode node inst
 703           inst'' = inst' { Instance.dsk = Instance.dsk inst }
 704
 705 prop_Node_addPriFC node inst (Positive extra) =
 706     not (Node.failN1 node) ==>
 707         case Node.addPri node inst'' of
 708           Types.OpFail Types.FailCPU -> True
 709           _ -> False
 710     where _types = (node::Node.Node, inst::Instance.Instance)
 711           inst' = setInstanceSmallerThanNode node inst
 712           inst'' = inst' { Instance.vcpus = Node.availCpu node + extra }
 713
 714 -- | Check that an instance add with too high memory or disk will be
 715 -- rejected.
 716 prop_Node_addSec node inst pdx =
 717     (Instance.mem inst >= (Node.fMem node - Node.rMem node) ||
 718      Instance.dsk inst >= Node.fDsk node) &&
 719     not (Node.failN1 node)
 720     ==> isFailure (Node.addSec node inst pdx)
 721         where _types = (node::Node.Node, inst::Instance.Instance, pdx::Int)
 722
 723 -- | Checks for memory reservation changes.
 724 prop_Node_rMem inst =
 725     forAll (arbitrary `suchThat` ((> Types.unitMem) . Node.fMem)) $ \node ->
 726     -- ab = auto_balance, nb = non-auto_balance
 727     -- we use -1 as the primary node of the instance
 728     let inst' = inst { Instance.pNode = -1, Instance.autoBalance = True }
 729         inst_ab = setInstanceSmallerThanNode node inst'
 730         inst_nb = inst_ab { Instance.autoBalance = False }
 731         -- now we have the two instances, identical except the
 732         -- autoBalance attribute
 733         orig_rmem = Node.rMem node
 734         inst_idx = Instance.idx inst_ab
 735         node_add_ab = Node.addSec node inst_ab (-1)
 736         node_add_nb = Node.addSec node inst_nb (-1)
 737         node_del_ab = liftM (flip Node.removeSec inst_ab) node_add_ab
 738         node_del_nb = liftM (flip Node.removeSec inst_nb) node_add_nb
 739     in case (node_add_ab, node_add_nb, node_del_ab, node_del_nb) of
 740          (Types.OpGood a_ab, Types.OpGood a_nb,
 741           Types.OpGood d_ab, Types.OpGood d_nb) ->
 742              printTestCase "Consistency checks failed" $
 743              Node.rMem a_ab >  orig_rmem &&
 744              Node.rMem a_ab - orig_rmem == Instance.mem inst_ab &&
 745              Node.rMem a_nb == orig_rmem &&
 746              Node.rMem d_ab == orig_rmem &&
 747              Node.rMem d_nb == orig_rmem &&
 748              -- this is not related to rMem, but as good a place to
 749              -- test as any
 750              inst_idx `elem` Node.sList a_ab &&
 751              not (inst_idx `elem` Node.sList d_ab)
 752          x -> printTestCase ("Failed to add/remove instances: " ++ show x)
 753               False
 754
 755 -- | Check mdsk setting.
 756 prop_Node_setMdsk node mx =
 757     Node.loDsk node' >= 0 &&
 758     fromIntegral (Node.loDsk node') <= Node.tDsk node &&
 759     Node.availDisk node' >= 0 &&
 760     Node.availDisk node' <= Node.fDsk node' &&
 761     fromIntegral (Node.availDisk node') <= Node.tDsk node' &&
 762     Node.mDsk node' == mx'
 763     where _types = (node::Node.Node, mx::SmallRatio)
 764           node' = Node.setMdsk node mx'
 765           SmallRatio mx' = mx
 766
 767 -- Check tag maps
 768 prop_Node_tagMaps_idempotent tags =
 769     Node.delTags (Node.addTags m tags) tags == m
 770     where m = Data.Map.empty
 771
 772 prop_Node_tagMaps_reject tags =
 773     not (null tags) ==>
 774     any (\t -> Node.rejectAddTags m [t]) tags
 775     where m = Node.addTags Data.Map.empty tags
 776
 777 prop_Node_showField node =
 778   forAll (elements Node.defaultFields) $ \ field ->
 779   fst (Node.showHeader field) /= Types.unknownField &&
 780   Node.showField node field /= Types.unknownField
 781
 782
 783 prop_Node_computeGroups nodes =
 784   let ng = Node.computeGroups nodes
 785       onlyuuid = map fst ng
 786   in length nodes == sum (map (length . snd) ng) &&
 787      all (\(guuid, ns) -> all ((== guuid) . Node.group) ns) ng &&
 788      length (nub onlyuuid) == length onlyuuid &&
 789      (null nodes || not (null ng))
 790
 791 testNode =
 792     [ run prop_Node_setAlias
 793     , run prop_Node_setOffline
 794     , run prop_Node_setMcpu
 795     , run prop_Node_setXmem
 796     , run prop_Node_addPriFM
 797     , run prop_Node_addPriFD
 798     , run prop_Node_addPriFC
 799     , run prop_Node_addSec
 800     , run prop_Node_rMem
 801     , run prop_Node_setMdsk
 802     , run prop_Node_tagMaps_idempotent
 803     , run prop_Node_tagMaps_reject
 804     , run prop_Node_showField
 805     , run prop_Node_computeGroups
 806     ]
 807
 808
 809 -- ** Cluster tests
 810
 811 -- | Check that the cluster score is close to zero for a homogeneous
 812 -- cluster.
 813 prop_Score_Zero node =
 814     forAll (choose (1, 1024)) $ \count ->
 815     (not (Node.offline node) && not (Node.failN1 node) && (count > 0) &&
 816      (Node.tDsk node > 0) && (Node.tMem node > 0)) ==>
 817     let fn = Node.buildPeers node Container.empty
 818         nlst = replicate count fn
 819         score = Cluster.compCVNodes nlst
 820     -- we can't say == 0 here as the floating point errors accumulate;
 821     -- this should be much lower than the default score in CLI.hs
 822     in score <= 1e-12
 823
 824 -- | Check that cluster stats are sane.
 825 prop_CStats_sane node =
 826     forAll (choose (1, 1024)) $ \count ->
 827     (not (Node.offline node) && not (Node.failN1 node) &&
 828      (Node.availDisk node > 0) && (Node.availMem node > 0)) ==>
 829     let fn = Node.buildPeers node Container.empty
 830         nlst = zip [1..] $ replicate count fn::[(Types.Ndx, Node.Node)]
 831         nl = Container.fromList nlst
 832         cstats = Cluster.totalResources nl
 833     in Cluster.csAdsk cstats >= 0 &&
 834        Cluster.csAdsk cstats <= Cluster.csFdsk cstats
 835
 836 -- | Check that one instance is allocated correctly, without
 837 -- rebalances needed.
 838 prop_ClusterAlloc_sane node inst =
 839     forAll (choose (5, 20)) $ \count ->
 840     not (Node.offline node)
 841             && not (Node.failN1 node)
 842             && Node.availDisk node > 0
 843             && Node.availMem node > 0
 844             ==>
 845     let nl = makeSmallCluster node count
 846         il = Container.empty
 847         inst' = setInstanceSmallerThanNode node inst
 848     in case Cluster.genAllocNodes defGroupList nl 2 True >>=
 849        Cluster.tryAlloc nl il inst' of
 850          Types.Bad _ -> False
 851          Types.Ok as ->
 852              case Cluster.asSolutions as of
 853                [] -> False
 854                (xnl, xi, _, cv):[] ->
 855                    let il' = Container.add (Instance.idx xi) xi il
 856                        tbl = Cluster.Table xnl il' cv []
 857                    in not (canBalance tbl True True False)
 858                _ -> False
 859
 860 -- | Checks that on a 2-5 node cluster, we can allocate a random
 861 -- instance spec via tiered allocation (whatever the original instance
 862 -- spec), on either one or two nodes.
 863 prop_ClusterCanTieredAlloc node inst =
 864     forAll (choose (2, 5)) $ \count ->
 865     forAll (choose (1, 2)) $ \rqnodes ->
 866     not (Node.offline node)
 867             && not (Node.failN1 node)
 868             && isNodeBig node 4
 869             ==>
 870     let nl = makeSmallCluster node count
 871         il = Container.empty
 872         allocnodes = Cluster.genAllocNodes defGroupList nl rqnodes True
 873     in case allocnodes >>= \allocnodes' ->
 874         Cluster.tieredAlloc nl il (Just 1) inst allocnodes' [] [] of
 875          Types.Bad _ -> False
 876          Types.Ok (_, _, il', ixes, cstats) -> not (null ixes) &&
 877                                       IntMap.size il' == length ixes &&
 878                                       length ixes == length cstats
 879
 880 -- | Checks that on a 4-8 node cluster, once we allocate an instance,
 881 -- we can also evacuate it.
 882 prop_ClusterAllocEvac node inst =
 883     forAll (choose (4, 8)) $ \count ->
 884     not (Node.offline node)
 885             && not (Node.failN1 node)
 886             && isNodeBig node 4
 887             ==>
 888     let nl = makeSmallCluster node count
 889         il = Container.empty
 890         inst' = setInstanceSmallerThanNode node inst
 891     in case Cluster.genAllocNodes defGroupList nl 2 True >>=
 892        Cluster.tryAlloc nl il inst' of
 893          Types.Bad _ -> False
 894          Types.Ok as ->
 895              case Cluster.asSolutions as of
 896                [] -> False
 897                (xnl, xi, _, _):[] ->
 898                    let sdx = Instance.sNode xi
 899                        il' = Container.add (Instance.idx xi) xi il
 900                    in case Cluster.tryEvac xnl il' [Instance.idx xi] [sdx] of
 901                         Just _ -> True
 902                         _ -> False
 903                _ -> False
 904
 905 -- | Check that allocating multiple instances on a cluster, then
 906 -- adding an empty node, results in a valid rebalance.
 907 prop_ClusterAllocBalance =
 908     forAll (genNode (Just 5) (Just 128)) $ \node ->
 909     forAll (choose (3, 5)) $ \count ->
 910     not (Node.offline node) && not (Node.failN1 node) ==>
 911     let nl = makeSmallCluster node count
 912         (hnode, nl') = IntMap.deleteFindMax nl
 913         il = Container.empty
 914         allocnodes = Cluster.genAllocNodes defGroupList nl' 2 True
 915         i_templ = createInstance Types.unitMem Types.unitDsk Types.unitCpu
 916     in case allocnodes >>= \allocnodes' ->
 917         Cluster.iterateAlloc nl' il (Just 5) i_templ allocnodes' [] [] of
 918          Types.Bad _ -> False
 919          Types.Ok (_, xnl, il', _, _) ->
 920                    let ynl = Container.add (Node.idx hnode) hnode xnl
 921                        cv = Cluster.compCV ynl
 922                        tbl = Cluster.Table ynl il' cv []
 923                    in canBalance tbl True True False
 924
 925 -- | Checks consistency.
 926 prop_ClusterCheckConsistency node inst =
 927   let nl = makeSmallCluster node 3
 928       [node1, node2, node3] = Container.elems nl
 929       node3' = node3 { Node.group = 1 }
 930       nl' = Container.add (Node.idx node3') node3' nl
 931       inst1 = Instance.setBoth inst (Node.idx node1) (Node.idx node2)
 932       inst2 = Instance.setBoth inst (Node.idx node1) Node.noSecondary
 933       inst3 = Instance.setBoth inst (Node.idx node1) (Node.idx node3)
 934       ccheck = Cluster.findSplitInstances nl' . Container.fromList
 935   in null (ccheck [(0, inst1)]) &&
 936      null (ccheck [(0, inst2)]) &&
 937      (not . null $ ccheck [(0, inst3)])
 938
 939 -- | For now, we only test that we don't lose instances during the split.
 940 prop_ClusterSplitCluster node inst =
 941   forAll (choose (0, 100)) $ \icnt ->
 942   let nl = makeSmallCluster node 2
 943       (nl', il') = foldl (\(ns, is) _ -> assignInstance ns is inst 0 1)
 944                    (nl, Container.empty) [1..icnt]
 945       gni = Cluster.splitCluster nl' il'
 946   in sum (map (Container.size . snd . snd) gni) == icnt &&
 947      all (\(guuid, (nl'', _)) -> all ((== guuid) . Node.group)
 948                                  (Container.elems nl'')) gni
 949
 950 testCluster =
 951     [ run prop_Score_Zero
 952     , run prop_CStats_sane
 953     , run prop_ClusterAlloc_sane
 954     , run prop_ClusterCanTieredAlloc
 955     , run prop_ClusterAllocEvac
 956     , run prop_ClusterAllocBalance
 957     , run prop_ClusterCheckConsistency
 958     , run prop_ClusterSplitCluster
 959     ]
 960
 961 -- ** OpCodes tests
 962
 963 -- | Check that opcode serialization is idempotent.
 964 prop_OpCodes_serialization op =
 965   case J.readJSON (J.showJSON op) of
 966     J.Error _ -> False
 967     J.Ok op' -> op == op'
 968   where _types = op::OpCodes.OpCode
 969
 970 testOpCodes =
 971   [ run prop_OpCodes_serialization
 972   ]
 973
 974 -- ** Jobs tests
 975
 976 -- | Check that (queued) job\/opcode status serialization is idempotent.
 977 prop_OpStatus_serialization os =
 978   case J.readJSON (J.showJSON os) of
 979     J.Error _ -> False
 980     J.Ok os' -> os == os'
 981   where _types = os::Jobs.OpStatus
 982
 983 prop_JobStatus_serialization js =
 984   case J.readJSON (J.showJSON js) of
 985     J.Error _ -> False
 986     J.Ok js' -> js == js'
 987   where _types = js::Jobs.JobStatus
 988
 989 testJobs =
 990   [ run prop_OpStatus_serialization
 991   , run prop_JobStatus_serialization
 992   ]
 993
 994 -- ** Loader tests
 995
 996 prop_Loader_lookupNode ktn inst node =
 997   Loader.lookupNode nl inst node == Data.Map.lookup node nl
 998   where nl = Data.Map.fromList ktn
 999
1000 prop_Loader_lookupInstance kti inst =
1001   Loader.lookupInstance il inst == Data.Map.lookup inst il
1002   where il = Data.Map.fromList kti
1003
1004 prop_Loader_assignIndices nodes =
1005   Data.Map.size nassoc == length nodes &&
1006   Container.size kt == length nodes &&
1007   (if not (null nodes)
1008    then maximum (IntMap.keys kt) == length nodes - 1
1009    else True)
1010   where (nassoc, kt) = Loader.assignIndices (map (\n -> (Node.name n, n)) nodes)
1011
1012 -- | Checks that the number of primary instances recorded on the nodes
1013 -- is zero.
1014 prop_Loader_mergeData ns =
1015   let na = Container.fromList $ map (\n -> (Node.idx n, n)) ns
1016   in case Loader.mergeData [] [] [] []
1017          (Loader.emptyCluster {Loader.cdNodes = na}) of
1018     Types.Bad _ -> False
1019     Types.Ok (Loader.ClusterData _ nl il _) ->
1020       let nodes = Container.elems nl
1021           instances = Container.elems il
1022       in (sum . map (length . Node.pList)) nodes == 0 &&
1023          null instances
1024
1025 -- | Check that compareNameComponent on equal strings works.
1026 prop_Loader_compareNameComponent_equal :: String -> Bool
1027 prop_Loader_compareNameComponent_equal s =
1028   Loader.compareNameComponent s s ==
1029     Loader.LookupResult Loader.ExactMatch s
1030
1031 -- | Check that compareNameComponent on prefix strings works.
1032 prop_Loader_compareNameComponent_prefix :: NonEmptyList Char -> String -> Bool
1033 prop_Loader_compareNameComponent_prefix (NonEmpty s1) s2 =
1034   Loader.compareNameComponent (s1 ++ "." ++ s2) s1 ==
1035     Loader.LookupResult Loader.PartialMatch s1
1036
1037 testLoader =
1038   [ run prop_Loader_lookupNode
1039   , run prop_Loader_lookupInstance
1040   , run prop_Loader_assignIndices
1041   , run prop_Loader_mergeData
1042   , run prop_Loader_compareNameComponent_equal
1043   , run prop_Loader_compareNameComponent_prefix
1044   ]
1045
1046 -- ** Types tests
1047
1048 prop_AllocPolicy_serialisation apol =
1049     case Types.apolFromString (Types.apolToString apol) of
1050       Types.Ok p -> printTestCase ("invalid deserialisation " ++ show p) $
1051                     p == apol
1052       Types.Bad s -> printTestCase ("failed to deserialise: " ++ s) False
1053
1054 prop_DiskTemplate_serialisation dt =
1055     case Types.dtFromString (Types.dtToString dt) of
1056       Types.Ok p -> printTestCase ("invalid deserialisation " ++ show p) $
1057                     p == dt
1058       Types.Bad s -> printTestCase ("failed to deserialise: " ++ s) False
1059
1060 testTypes =
1061     [ run prop_AllocPolicy_serialisation
1062     , run prop_DiskTemplate_serialisation
1063     ]