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