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