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

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