Statistics
| Branch: | Tag: | Revision:

root / htools / Ganeti / HTools / QC.hs @ 3ad57194

History | View | Annotate | Download (63 kB)

1
{-# LANGUAGE TemplateHaskell #-}
2

    
3
{-| Unittests for ganeti-htools.
4

    
5
-}
6

    
7
{-
8

    
9
Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
10

    
11
This program is free software; you can redistribute it and/or modify
12
it under the terms of the GNU General Public License as published by
13
the Free Software Foundation; either version 2 of the License, or
14
(at your option) any later version.
15

    
16
This program is distributed in the hope that it will be useful, but
17
WITHOUT ANY WARRANTY; without even the implied warranty of
18
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
19
General Public License for more details.
20

    
21
You should have received a copy of the GNU General Public License
22
along with this program; if not, write to the Free Software
23
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
24
02110-1301, USA.
25

    
26
-}
27

    
28
module Ganeti.HTools.QC
29
  ( testUtils
30
  , testPeerMap
31
  , testContainer
32
  , testInstance
33
  , testNode
34
  , testText
35
  , testSimu
36
  , testOpCodes
37
  , testJobs
38
  , testCluster
39
  , testLoader
40
  , testTypes
41
  , testCLI
42
  , testJSON
43
  ) where
44

    
45
import Test.QuickCheck
46
import Text.Printf (printf)
47
import Data.List (findIndex, intercalate, nub, isPrefixOf)
48
import qualified Data.Set as Set
49
import Data.Maybe
50
import Control.Monad
51
import qualified System.Console.GetOpt as GetOpt
52
import qualified Text.JSON as J
53
import qualified Data.Map
54
import qualified Data.IntMap as IntMap
55

    
56
import qualified Ganeti.OpCodes as OpCodes
57
import qualified Ganeti.Jobs as Jobs
58
import qualified Ganeti.Luxi
59
import qualified Ganeti.HTools.CLI as CLI
60
import qualified Ganeti.HTools.Cluster as Cluster
61
import qualified Ganeti.HTools.Container as Container
62
import qualified Ganeti.HTools.ExtLoader
63
import qualified Ganeti.HTools.IAlloc as IAlloc
64
import qualified Ganeti.HTools.Instance as Instance
65
import qualified Ganeti.HTools.JSON as JSON
66
import qualified Ganeti.HTools.Loader as Loader
67
import qualified Ganeti.HTools.Luxi
68
import qualified Ganeti.HTools.Node as Node
69
import qualified Ganeti.HTools.Group as Group
70
import qualified Ganeti.HTools.PeerMap as PeerMap
71
import qualified Ganeti.HTools.Rapi
72
import qualified Ganeti.HTools.Simu as Simu
73
import qualified Ganeti.HTools.Text as Text
74
import qualified Ganeti.HTools.Types as Types
75
import qualified Ganeti.HTools.Utils as Utils
76
import qualified Ganeti.HTools.Version
77
import qualified Ganeti.Constants as C
78

    
79
import qualified Ganeti.HTools.Program as Program
80
import qualified Ganeti.HTools.Program.Hail
81
import qualified Ganeti.HTools.Program.Hbal
82
import qualified Ganeti.HTools.Program.Hscan
83
import qualified Ganeti.HTools.Program.Hspace
84

    
85
import Ganeti.HTools.QCHelper (testSuite)
86

    
87
-- * Constants
88

    
89
-- | Maximum memory (1TiB, somewhat random value).
90
maxMem :: Int
91
maxMem = 1024 * 1024
92

    
93
-- | Maximum disk (8TiB, somewhat random value).
94
maxDsk :: Int
95
maxDsk = 1024 * 1024 * 8
96

    
97
-- | Max CPUs (1024, somewhat random value).
98
maxCpu :: Int
99
maxCpu = 1024
100

    
101
-- | Max vcpu ratio (random value).
102
maxVcpuRatio :: Double
103
maxVcpuRatio = 1024.0
104

    
105
-- | Max spindle ratio (random value).
106
maxSpindleRatio :: Double
107
maxSpindleRatio = 1024.0
108

    
109
-- | All disk templates (used later)
110
allDiskTemplates :: [Types.DiskTemplate]
111
allDiskTemplates = [minBound..maxBound]
112

    
113
-- | Null iPolicy, and by null we mean very liberal.
114
nullIPolicy = Types.IPolicy
115
  { Types.iPolicyMinSpec = Types.ISpec { Types.iSpecMemorySize = 0
116
                                       , Types.iSpecCpuCount   = 0
117
                                       , Types.iSpecDiskSize   = 0
118
                                       , Types.iSpecDiskCount  = 0
119
                                       , Types.iSpecNicCount   = 0
120
                                       , Types.iSpecSpindleUse = 0
121
                                       }
122
  , Types.iPolicyMaxSpec = Types.ISpec { Types.iSpecMemorySize = maxBound
123
                                       , Types.iSpecCpuCount   = maxBound
124
                                       , Types.iSpecDiskSize   = maxBound
125
                                       , Types.iSpecDiskCount  = C.maxDisks
126
                                       , Types.iSpecNicCount   = C.maxNics
127
                                       , Types.iSpecSpindleUse = maxBound
128
                                       }
129
  , Types.iPolicyStdSpec = Types.ISpec { Types.iSpecMemorySize = Types.unitMem
130
                                       , Types.iSpecCpuCount   = Types.unitCpu
131
                                       , Types.iSpecDiskSize   = Types.unitDsk
132
                                       , Types.iSpecDiskCount  = 1
133
                                       , Types.iSpecNicCount   = 1
134
                                       , Types.iSpecSpindleUse = 1
135
                                       }
136
  , Types.iPolicyDiskTemplates = [minBound..maxBound]
137
  , Types.iPolicyVcpuRatio = maxVcpuRatio -- somewhat random value, high
138
                                          -- enough to not impact us
139
  , Types.iPolicySpindleRatio = maxSpindleRatio
140
  }
141

    
142

    
143
defGroup :: Group.Group
144
defGroup = flip Group.setIdx 0 $
145
             Group.create "default" Types.defaultGroupID Types.AllocPreferred
146
                  nullIPolicy
147

    
148
defGroupList :: Group.List
149
defGroupList = Container.fromList [(Group.idx defGroup, defGroup)]
150

    
151
defGroupAssoc :: Data.Map.Map String Types.Gdx
152
defGroupAssoc = Data.Map.singleton (Group.uuid defGroup) (Group.idx defGroup)
153

    
154
-- * Helper functions
155

    
156
-- | Simple checker for whether OpResult is fail or pass.
157
isFailure :: Types.OpResult a -> Bool
158
isFailure (Types.OpFail _) = True
159
isFailure _ = False
160

    
161
-- | Checks for equality with proper annotation.
162
(==?) :: (Show a, Eq a) => a -> a -> Property
163
(==?) x y = printTestCase
164
            ("Expected equality, but '" ++
165
             show x ++ "' /= '" ++ show y ++ "'") (x == y)
166
infix 3 ==?
167

    
168
-- | Show a message and fail the test.
169
failTest :: String -> Property
170
failTest msg = printTestCase msg False
171

    
172
-- | Update an instance to be smaller than a node.
173
setInstanceSmallerThanNode node inst =
174
  inst { Instance.mem = Node.availMem node `div` 2
175
       , Instance.dsk = Node.availDisk node `div` 2
176
       , Instance.vcpus = Node.availCpu node `div` 2
177
       }
178

    
179
-- | Create an instance given its spec.
180
createInstance mem dsk vcpus =
181
  Instance.create "inst-unnamed" mem dsk vcpus Types.Running [] True (-1) (-1)
182
    Types.DTDrbd8 1
183

    
184
-- | Create a small cluster by repeating a node spec.
185
makeSmallCluster :: Node.Node -> Int -> Node.List
186
makeSmallCluster node count =
187
  let origname = Node.name node
188
      origalias = Node.alias node
189
      nodes = map (\idx -> node { Node.name = origname ++ "-" ++ show idx
190
                                , Node.alias = origalias ++ "-" ++ show idx })
191
              [1..count]
192
      fn = flip Node.buildPeers Container.empty
193
      namelst = map (\n -> (Node.name n, fn n)) nodes
194
      (_, nlst) = Loader.assignIndices namelst
195
  in nlst
196

    
197
-- | Make a small cluster, both nodes and instances.
198
makeSmallEmptyCluster :: Node.Node -> Int -> Instance.Instance
199
                      -> (Node.List, Instance.List, Instance.Instance)
200
makeSmallEmptyCluster node count inst =
201
  (makeSmallCluster node count, Container.empty,
202
   setInstanceSmallerThanNode node inst)
203

    
204
-- | Checks if a node is "big" enough.
205
isNodeBig :: Int -> Node.Node -> Bool
206
isNodeBig size node = Node.availDisk node > size * Types.unitDsk
207
                      && Node.availMem node > size * Types.unitMem
208
                      && Node.availCpu node > size * Types.unitCpu
209

    
210
canBalance :: Cluster.Table -> Bool -> Bool -> Bool -> Bool
211
canBalance tbl dm im evac = isJust $ Cluster.tryBalance tbl dm im evac 0 0
212

    
213
-- | Assigns a new fresh instance to a cluster; this is not
214
-- allocation, so no resource checks are done.
215
assignInstance :: Node.List -> Instance.List -> Instance.Instance ->
216
                  Types.Idx -> Types.Idx ->
217
                  (Node.List, Instance.List)
218
assignInstance nl il inst pdx sdx =
219
  let pnode = Container.find pdx nl
220
      snode = Container.find sdx nl
221
      maxiidx = if Container.null il
222
                  then 0
223
                  else fst (Container.findMax il) + 1
224
      inst' = inst { Instance.idx = maxiidx,
225
                     Instance.pNode = pdx, Instance.sNode = sdx }
226
      pnode' = Node.setPri pnode inst'
227
      snode' = Node.setSec snode inst'
228
      nl' = Container.addTwo pdx pnode' sdx snode' nl
229
      il' = Container.add maxiidx inst' il
230
  in (nl', il')
231

    
232
-- | Generates a list of a given size with non-duplicate elements.
233
genUniquesList :: (Eq a, Arbitrary a) => Int -> Gen [a]
234
genUniquesList cnt =
235
  foldM (\lst _ -> do
236
           newelem <- arbitrary `suchThat` (`notElem` lst)
237
           return (newelem:lst)) [] [1..cnt]
238

    
239
-- | Checks if an instance is mirrored.
240
isMirrored :: Instance.Instance -> Bool
241
isMirrored = (/= Types.MirrorNone) . Instance.mirrorType
242

    
243
-- | Returns the possible change node types for a disk template.
244
evacModeOptions :: Types.MirrorType -> [Types.EvacMode]
245
evacModeOptions Types.MirrorNone     = []
246
evacModeOptions Types.MirrorInternal = [minBound..maxBound] -- DRBD can do all
247
evacModeOptions Types.MirrorExternal = [Types.ChangePrimary, Types.ChangeAll]
248

    
249
-- * Arbitrary instances
250

    
251
-- | Defines a DNS name.
252
newtype DNSChar = DNSChar { dnsGetChar::Char }
253

    
254
instance Arbitrary DNSChar where
255
  arbitrary = do
256
    x <- elements (['a'..'z'] ++ ['0'..'9'] ++ "_-")
257
    return (DNSChar x)
258

    
259
-- | Generates a single name component.
260
getName :: Gen String
261
getName = do
262
  n <- choose (1, 64)
263
  dn <- vector n::Gen [DNSChar]
264
  return (map dnsGetChar dn)
265

    
266
-- | Generates an entire FQDN.
267
getFQDN :: Gen String
268
getFQDN = do
269
  ncomps <- choose (1, 4)
270
  names <- mapM (const getName) [1..ncomps::Int]
271
  return $ intercalate "." names
272

    
273
-- | Defines a tag type.
274
newtype TagChar = TagChar { tagGetChar :: Char }
275

    
276
-- | All valid tag chars. This doesn't need to match _exactly_
277
-- Ganeti's own tag regex, just enough for it to be close.
278
tagChar :: [Char]
279
tagChar = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ".+*/:@-"
280

    
281
instance Arbitrary TagChar where
282
  arbitrary = do
283
    c <- elements tagChar
284
    return (TagChar c)
285

    
286
-- | Generates a tag
287
genTag :: Gen [TagChar]
288
genTag = do
289
  -- the correct value would be C.maxTagLen, but that's way too
290
  -- verbose in unittests, and at the moment I don't see any possible
291
  -- bugs with longer tags and the way we use tags in htools
292
  n <- choose (1, 10)
293
  vector n
294

    
295
-- | Generates a list of tags (correctly upper bounded).
296
genTags :: Gen [String]
297
genTags = do
298
  -- the correct value would be C.maxTagsPerObj, but per the comment
299
  -- in genTag, we don't use tags enough in htools to warrant testing
300
  -- such big values
301
  n <- choose (0, 10::Int)
302
  tags <- mapM (const genTag) [1..n]
303
  return $ map (map tagGetChar) tags
304

    
305
instance Arbitrary Types.InstanceStatus where
306
    arbitrary = elements [minBound..maxBound]
307

    
308
-- | Generates a random instance with maximum disk/mem/cpu values.
309
genInstanceSmallerThan :: Int -> Int -> Int -> Gen Instance.Instance
310
genInstanceSmallerThan lim_mem lim_dsk lim_cpu = do
311
  name <- getFQDN
312
  mem <- choose (0, lim_mem)
313
  dsk <- choose (0, lim_dsk)
314
  run_st <- arbitrary
315
  pn <- arbitrary
316
  sn <- arbitrary
317
  vcpus <- choose (0, lim_cpu)
318
  dt <- arbitrary
319
  return $ Instance.create name mem dsk vcpus run_st [] True pn sn dt 1
320

    
321
-- | Generates an instance smaller than a node.
322
genInstanceSmallerThanNode :: Node.Node -> Gen Instance.Instance
323
genInstanceSmallerThanNode node =
324
  genInstanceSmallerThan (Node.availMem node `div` 2)
325
                         (Node.availDisk node `div` 2)
326
                         (Node.availCpu node `div` 2)
327

    
328
-- let's generate a random instance
329
instance Arbitrary Instance.Instance where
330
  arbitrary = genInstanceSmallerThan maxMem maxDsk maxCpu
331

    
332
-- | Generas an arbitrary node based on sizing information.
333
genNode :: Maybe Int -- ^ Minimum node size in terms of units
334
        -> Maybe Int -- ^ Maximum node size (when Nothing, bounded
335
                     -- just by the max... constants)
336
        -> Gen Node.Node
337
genNode min_multiplier max_multiplier = do
338
  let (base_mem, base_dsk, base_cpu) =
339
        case min_multiplier of
340
          Just mm -> (mm * Types.unitMem,
341
                      mm * Types.unitDsk,
342
                      mm * Types.unitCpu)
343
          Nothing -> (0, 0, 0)
344
      (top_mem, top_dsk, top_cpu)  =
345
        case max_multiplier of
346
          Just mm -> (mm * Types.unitMem,
347
                      mm * Types.unitDsk,
348
                      mm * Types.unitCpu)
349
          Nothing -> (maxMem, maxDsk, maxCpu)
350
  name  <- getFQDN
351
  mem_t <- choose (base_mem, top_mem)
352
  mem_f <- choose (base_mem, mem_t)
353
  mem_n <- choose (0, mem_t - mem_f)
354
  dsk_t <- choose (base_dsk, top_dsk)
355
  dsk_f <- choose (base_dsk, dsk_t)
356
  cpu_t <- choose (base_cpu, top_cpu)
357
  offl  <- arbitrary
358
  let n = Node.create name (fromIntegral mem_t) mem_n mem_f
359
          (fromIntegral dsk_t) dsk_f (fromIntegral cpu_t) offl 1 0
360
      n' = Node.setPolicy nullIPolicy n
361
  return $ Node.buildPeers n' Container.empty
362

    
363
-- | Helper function to generate a sane node.
364
genOnlineNode :: Gen Node.Node
365
genOnlineNode = do
366
  arbitrary `suchThat` (\n -> not (Node.offline n) &&
367
                              not (Node.failN1 n) &&
368
                              Node.availDisk n > 0 &&
369
                              Node.availMem n > 0 &&
370
                              Node.availCpu n > 0)
371

    
372
-- and a random node
373
instance Arbitrary Node.Node where
374
  arbitrary = genNode Nothing Nothing
375

    
376
-- replace disks
377
instance Arbitrary OpCodes.ReplaceDisksMode where
378
  arbitrary = elements [minBound..maxBound]
379

    
380
instance Arbitrary OpCodes.OpCode where
381
  arbitrary = do
382
    op_id <- elements [ "OP_TEST_DELAY"
383
                      , "OP_INSTANCE_REPLACE_DISKS"
384
                      , "OP_INSTANCE_FAILOVER"
385
                      , "OP_INSTANCE_MIGRATE"
386
                      ]
387
    case op_id of
388
      "OP_TEST_DELAY" ->
389
        liftM3 OpCodes.OpTestDelay arbitrary arbitrary arbitrary
390
      "OP_INSTANCE_REPLACE_DISKS" ->
391
        liftM5 OpCodes.OpInstanceReplaceDisks arbitrary arbitrary
392
          arbitrary arbitrary arbitrary
393
      "OP_INSTANCE_FAILOVER" ->
394
        liftM3 OpCodes.OpInstanceFailover arbitrary arbitrary
395
          arbitrary
396
      "OP_INSTANCE_MIGRATE" ->
397
        liftM5 OpCodes.OpInstanceMigrate arbitrary arbitrary
398
          arbitrary arbitrary arbitrary
399
      _ -> fail "Wrong opcode"
400

    
401
instance Arbitrary Jobs.OpStatus where
402
  arbitrary = elements [minBound..maxBound]
403

    
404
instance Arbitrary Jobs.JobStatus where
405
  arbitrary = elements [minBound..maxBound]
406

    
407
newtype SmallRatio = SmallRatio Double deriving Show
408
instance Arbitrary SmallRatio where
409
  arbitrary = do
410
    v <- choose (0, 1)
411
    return $ SmallRatio v
412

    
413
instance Arbitrary Types.AllocPolicy where
414
  arbitrary = elements [minBound..maxBound]
415

    
416
instance Arbitrary Types.DiskTemplate where
417
  arbitrary = elements [minBound..maxBound]
418

    
419
instance Arbitrary Types.FailMode where
420
  arbitrary = elements [minBound..maxBound]
421

    
422
instance Arbitrary Types.EvacMode where
423
  arbitrary = elements [minBound..maxBound]
424

    
425
instance Arbitrary a => Arbitrary (Types.OpResult a) where
426
  arbitrary = arbitrary >>= \c ->
427
              if c
428
                then liftM Types.OpGood arbitrary
429
                else liftM Types.OpFail arbitrary
430

    
431
instance Arbitrary Types.ISpec where
432
  arbitrary = do
433
    mem_s <- arbitrary::Gen (NonNegative Int)
434
    dsk_c <- arbitrary::Gen (NonNegative Int)
435
    dsk_s <- arbitrary::Gen (NonNegative Int)
436
    cpu_c <- arbitrary::Gen (NonNegative Int)
437
    nic_c <- arbitrary::Gen (NonNegative Int)
438
    su    <- arbitrary::Gen (NonNegative Int)
439
    return Types.ISpec { Types.iSpecMemorySize = fromIntegral mem_s
440
                       , Types.iSpecCpuCount   = fromIntegral cpu_c
441
                       , Types.iSpecDiskSize   = fromIntegral dsk_s
442
                       , Types.iSpecDiskCount  = fromIntegral dsk_c
443
                       , Types.iSpecNicCount   = fromIntegral nic_c
444
                       , Types.iSpecSpindleUse = fromIntegral su
445
                       }
446

    
447
-- | Generates an ispec bigger than the given one.
448
genBiggerISpec :: Types.ISpec -> Gen Types.ISpec
449
genBiggerISpec imin = do
450
  mem_s <- choose (Types.iSpecMemorySize imin, maxBound)
451
  dsk_c <- choose (Types.iSpecDiskCount imin, maxBound)
452
  dsk_s <- choose (Types.iSpecDiskSize imin, maxBound)
453
  cpu_c <- choose (Types.iSpecCpuCount imin, maxBound)
454
  nic_c <- choose (Types.iSpecNicCount imin, maxBound)
455
  su    <- choose (Types.iSpecSpindleUse imin, maxBound)
456
  return Types.ISpec { Types.iSpecMemorySize = fromIntegral mem_s
457
                     , Types.iSpecCpuCount   = fromIntegral cpu_c
458
                     , Types.iSpecDiskSize   = fromIntegral dsk_s
459
                     , Types.iSpecDiskCount  = fromIntegral dsk_c
460
                     , Types.iSpecNicCount   = fromIntegral nic_c
461
                     , Types.iSpecSpindleUse = fromIntegral su
462
                     }
463

    
464
instance Arbitrary Types.IPolicy where
465
  arbitrary = do
466
    imin <- arbitrary
467
    istd <- genBiggerISpec imin
468
    imax <- genBiggerISpec istd
469
    num_tmpl <- choose (0, length allDiskTemplates)
470
    dts  <- genUniquesList num_tmpl
471
    vcpu_ratio <- choose (1.0, maxVcpuRatio)
472
    spindle_ratio <- choose (1.0, maxSpindleRatio)
473
    return Types.IPolicy { Types.iPolicyMinSpec = imin
474
                         , Types.iPolicyStdSpec = istd
475
                         , Types.iPolicyMaxSpec = imax
476
                         , Types.iPolicyDiskTemplates = dts
477
                         , Types.iPolicyVcpuRatio = vcpu_ratio
478
                         , Types.iPolicySpindleRatio = spindle_ratio
479
                         }
480

    
481
-- * Actual tests
482

    
483
-- ** Utils tests
484

    
485
-- | Helper to generate a small string that doesn't contain commas.
486
genNonCommaString = do
487
  size <- choose (0, 20) -- arbitrary max size
488
  vectorOf size (arbitrary `suchThat` ((/=) ','))
489

    
490
-- | If the list is not just an empty element, and if the elements do
491
-- not contain commas, then join+split should be idempotent.
492
prop_Utils_commaJoinSplit =
493
  forAll (choose (0, 20)) $ \llen ->
494
  forAll (vectorOf llen genNonCommaString `suchThat` ((/=) [""])) $ \lst ->
495
  Utils.sepSplit ',' (Utils.commaJoin lst) ==? lst
496

    
497
-- | Split and join should always be idempotent.
498
prop_Utils_commaSplitJoin s =
499
  Utils.commaJoin (Utils.sepSplit ',' s) ==? s
500

    
501
-- | fromObjWithDefault, we test using the Maybe monad and an integer
502
-- value.
503
prop_Utils_fromObjWithDefault def_value random_key =
504
  -- a missing key will be returned with the default
505
  JSON.fromObjWithDefault [] random_key def_value == Just def_value &&
506
  -- a found key will be returned as is, not with default
507
  JSON.fromObjWithDefault [(random_key, J.showJSON def_value)]
508
       random_key (def_value+1) == Just def_value
509
    where _types = def_value :: Integer
510

    
511
-- | Test that functional if' behaves like the syntactic sugar if.
512
prop_Utils_if'if :: Bool -> Int -> Int -> Gen Prop
513
prop_Utils_if'if cnd a b =
514
  Utils.if' cnd a b ==? if cnd then a else b
515

    
516
-- | Test basic select functionality
517
prop_Utils_select :: Int      -- ^ Default result
518
                  -> [Int]    -- ^ List of False values
519
                  -> [Int]    -- ^ List of True values
520
                  -> Gen Prop -- ^ Test result
521
prop_Utils_select def lst1 lst2 =
522
  Utils.select def (flist ++ tlist) ==? expectedresult
523
    where expectedresult = Utils.if' (null lst2) def (head lst2)
524
          flist = zip (repeat False) lst1
525
          tlist = zip (repeat True)  lst2
526

    
527
-- | Test basic select functionality with undefined default
528
prop_Utils_select_undefd :: [Int]            -- ^ List of False values
529
                         -> NonEmptyList Int -- ^ List of True values
530
                         -> Gen Prop         -- ^ Test result
531
prop_Utils_select_undefd lst1 (NonEmpty lst2) =
532
  Utils.select undefined (flist ++ tlist) ==? head lst2
533
    where flist = zip (repeat False) lst1
534
          tlist = zip (repeat True)  lst2
535

    
536
-- | Test basic select functionality with undefined list values
537
prop_Utils_select_undefv :: [Int]            -- ^ List of False values
538
                         -> NonEmptyList Int -- ^ List of True values
539
                         -> Gen Prop         -- ^ Test result
540
prop_Utils_select_undefv lst1 (NonEmpty lst2) =
541
  Utils.select undefined cndlist ==? head lst2
542
    where flist = zip (repeat False) lst1
543
          tlist = zip (repeat True)  lst2
544
          cndlist = flist ++ tlist ++ [undefined]
545

    
546
prop_Utils_parseUnit (NonNegative n) =
547
  Utils.parseUnit (show n) ==? Types.Ok n .&&.
548
  Utils.parseUnit (show n ++ "m") ==? Types.Ok n .&&.
549
  Utils.parseUnit (show n ++ "M") ==? Types.Ok (truncate n_mb::Int) .&&.
550
  Utils.parseUnit (show n ++ "g") ==? Types.Ok (n*1024) .&&.
551
  Utils.parseUnit (show n ++ "G") ==? Types.Ok (truncate n_gb::Int) .&&.
552
  Utils.parseUnit (show n ++ "t") ==? Types.Ok (n*1048576) .&&.
553
  Utils.parseUnit (show n ++ "T") ==? Types.Ok (truncate n_tb::Int) .&&.
554
  printTestCase "Internal error/overflow?"
555
    (n_mb >=0 && n_gb >= 0 && n_tb >= 0) .&&.
556
  property (Types.isBad (Utils.parseUnit (show n ++ "x")::Types.Result Int))
557
  where _types = (n::Int)
558
        n_mb = (fromIntegral n::Rational) * 1000 * 1000 / 1024 / 1024
559
        n_gb = n_mb * 1000
560
        n_tb = n_gb * 1000
561

    
562
-- | Test list for the Utils module.
563
testSuite "Utils"
564
            [ 'prop_Utils_commaJoinSplit
565
            , 'prop_Utils_commaSplitJoin
566
            , 'prop_Utils_fromObjWithDefault
567
            , 'prop_Utils_if'if
568
            , 'prop_Utils_select
569
            , 'prop_Utils_select_undefd
570
            , 'prop_Utils_select_undefv
571
            , 'prop_Utils_parseUnit
572
            ]
573

    
574
-- ** PeerMap tests
575

    
576
-- | Make sure add is idempotent.
577
prop_PeerMap_addIdempotent pmap key em =
578
  fn puniq ==? fn (fn puniq)
579
    where _types = (pmap::PeerMap.PeerMap,
580
                    key::PeerMap.Key, em::PeerMap.Elem)
581
          fn = PeerMap.add key em
582
          puniq = PeerMap.accumArray const pmap
583

    
584
-- | Make sure remove is idempotent.
585
prop_PeerMap_removeIdempotent pmap key =
586
  fn puniq ==? fn (fn puniq)
587
    where _types = (pmap::PeerMap.PeerMap, key::PeerMap.Key)
588
          fn = PeerMap.remove key
589
          puniq = PeerMap.accumArray const pmap
590

    
591
-- | Make sure a missing item returns 0.
592
prop_PeerMap_findMissing pmap key =
593
  PeerMap.find key (PeerMap.remove key puniq) ==? 0
594
    where _types = (pmap::PeerMap.PeerMap, key::PeerMap.Key)
595
          puniq = PeerMap.accumArray const pmap
596

    
597
-- | Make sure an added item is found.
598
prop_PeerMap_addFind pmap key em =
599
  PeerMap.find key (PeerMap.add key em puniq) ==? em
600
    where _types = (pmap::PeerMap.PeerMap,
601
                    key::PeerMap.Key, em::PeerMap.Elem)
602
          puniq = PeerMap.accumArray const pmap
603

    
604
-- | Manual check that maxElem returns the maximum indeed, or 0 for null.
605
prop_PeerMap_maxElem pmap =
606
  PeerMap.maxElem puniq ==? if null puniq then 0
607
                              else (maximum . snd . unzip) puniq
608
    where _types = pmap::PeerMap.PeerMap
609
          puniq = PeerMap.accumArray const pmap
610

    
611
-- | List of tests for the PeerMap module.
612
testSuite "PeerMap"
613
            [ 'prop_PeerMap_addIdempotent
614
            , 'prop_PeerMap_removeIdempotent
615
            , 'prop_PeerMap_maxElem
616
            , 'prop_PeerMap_addFind
617
            , 'prop_PeerMap_findMissing
618
            ]
619

    
620
-- ** Container tests
621

    
622
-- we silence the following due to hlint bug fixed in later versions
623
{-# ANN prop_Container_addTwo "HLint: ignore Avoid lambda" #-}
624
prop_Container_addTwo cdata i1 i2 =
625
  fn i1 i2 cont == fn i2 i1 cont &&
626
  fn i1 i2 cont == fn i1 i2 (fn i1 i2 cont)
627
    where _types = (cdata::[Int],
628
                    i1::Int, i2::Int)
629
          cont = foldl (\c x -> Container.add x x c) Container.empty cdata
630
          fn x1 x2 = Container.addTwo x1 x1 x2 x2
631

    
632
prop_Container_nameOf node =
633
  let nl = makeSmallCluster node 1
634
      fnode = head (Container.elems nl)
635
  in Container.nameOf nl (Node.idx fnode) ==? Node.name fnode
636

    
637
-- | We test that in a cluster, given a random node, we can find it by
638
-- its name and alias, as long as all names and aliases are unique,
639
-- and that we fail to find a non-existing name.
640
prop_Container_findByName node =
641
  forAll (choose (1, 20)) $ \ cnt ->
642
  forAll (choose (0, cnt - 1)) $ \ fidx ->
643
  forAll (genUniquesList (cnt * 2)) $ \ allnames ->
644
  forAll (arbitrary `suchThat` (`notElem` allnames)) $ \ othername ->
645
  let names = zip (take cnt allnames) (drop cnt allnames)
646
      nl = makeSmallCluster node cnt
647
      nodes = Container.elems nl
648
      nodes' = map (\((name, alias), nn) -> (Node.idx nn,
649
                                             nn { Node.name = name,
650
                                                  Node.alias = alias }))
651
               $ zip names nodes
652
      nl' = Container.fromList nodes'
653
      target = snd (nodes' !! fidx)
654
  in Container.findByName nl' (Node.name target) == Just target &&
655
     Container.findByName nl' (Node.alias target) == Just target &&
656
     isNothing (Container.findByName nl' othername)
657

    
658
testSuite "Container"
659
            [ 'prop_Container_addTwo
660
            , 'prop_Container_nameOf
661
            , 'prop_Container_findByName
662
            ]
663

    
664
-- ** Instance tests
665

    
666
-- Simple instance tests, we only have setter/getters
667

    
668
prop_Instance_creat inst =
669
  Instance.name inst ==? Instance.alias inst
670

    
671
prop_Instance_setIdx inst idx =
672
  Instance.idx (Instance.setIdx inst idx) ==? idx
673
    where _types = (inst::Instance.Instance, idx::Types.Idx)
674

    
675
prop_Instance_setName inst name =
676
  Instance.name newinst == name &&
677
  Instance.alias newinst == name
678
    where _types = (inst::Instance.Instance, name::String)
679
          newinst = Instance.setName inst name
680

    
681
prop_Instance_setAlias inst name =
682
  Instance.name newinst == Instance.name inst &&
683
  Instance.alias newinst == name
684
    where _types = (inst::Instance.Instance, name::String)
685
          newinst = Instance.setAlias inst name
686

    
687
prop_Instance_setPri inst pdx =
688
  Instance.pNode (Instance.setPri inst pdx) ==? pdx
689
    where _types = (inst::Instance.Instance, pdx::Types.Ndx)
690

    
691
prop_Instance_setSec inst sdx =
692
  Instance.sNode (Instance.setSec inst sdx) ==? sdx
693
    where _types = (inst::Instance.Instance, sdx::Types.Ndx)
694

    
695
prop_Instance_setBoth inst pdx sdx =
696
  Instance.pNode si == pdx && Instance.sNode si == sdx
697
    where _types = (inst::Instance.Instance, pdx::Types.Ndx, sdx::Types.Ndx)
698
          si = Instance.setBoth inst pdx sdx
699

    
700
prop_Instance_shrinkMG inst =
701
  Instance.mem inst >= 2 * Types.unitMem ==>
702
    case Instance.shrinkByType inst Types.FailMem of
703
      Types.Ok inst' -> Instance.mem inst' == Instance.mem inst - Types.unitMem
704
      _ -> False
705

    
706
prop_Instance_shrinkMF inst =
707
  forAll (choose (0, 2 * Types.unitMem - 1)) $ \mem ->
708
    let inst' = inst { Instance.mem = mem}
709
    in Types.isBad $ Instance.shrinkByType inst' Types.FailMem
710

    
711
prop_Instance_shrinkCG inst =
712
  Instance.vcpus inst >= 2 * Types.unitCpu ==>
713
    case Instance.shrinkByType inst Types.FailCPU of
714
      Types.Ok inst' ->
715
        Instance.vcpus inst' == Instance.vcpus inst - Types.unitCpu
716
      _ -> False
717

    
718
prop_Instance_shrinkCF inst =
719
  forAll (choose (0, 2 * Types.unitCpu - 1)) $ \vcpus ->
720
    let inst' = inst { Instance.vcpus = vcpus }
721
    in Types.isBad $ Instance.shrinkByType inst' Types.FailCPU
722

    
723
prop_Instance_shrinkDG inst =
724
  Instance.dsk inst >= 2 * Types.unitDsk ==>
725
    case Instance.shrinkByType inst Types.FailDisk of
726
      Types.Ok inst' ->
727
        Instance.dsk inst' == Instance.dsk inst - Types.unitDsk
728
      _ -> False
729

    
730
prop_Instance_shrinkDF inst =
731
  forAll (choose (0, 2 * Types.unitDsk - 1)) $ \dsk ->
732
    let inst' = inst { Instance.dsk = dsk }
733
    in Types.isBad $ Instance.shrinkByType inst' Types.FailDisk
734

    
735
prop_Instance_setMovable inst m =
736
  Instance.movable inst' ==? m
737
    where inst' = Instance.setMovable inst m
738

    
739
testSuite "Instance"
740
            [ 'prop_Instance_creat
741
            , 'prop_Instance_setIdx
742
            , 'prop_Instance_setName
743
            , 'prop_Instance_setAlias
744
            , 'prop_Instance_setPri
745
            , 'prop_Instance_setSec
746
            , 'prop_Instance_setBoth
747
            , 'prop_Instance_shrinkMG
748
            , 'prop_Instance_shrinkMF
749
            , 'prop_Instance_shrinkCG
750
            , 'prop_Instance_shrinkCF
751
            , 'prop_Instance_shrinkDG
752
            , 'prop_Instance_shrinkDF
753
            , 'prop_Instance_setMovable
754
            ]
755

    
756
-- ** Backends
757

    
758
-- *** Text backend tests
759

    
760
-- Instance text loader tests
761

    
762
prop_Text_Load_Instance name mem dsk vcpus status
763
                        (NonEmpty pnode) snode
764
                        (NonNegative pdx) (NonNegative sdx) autobal dt su =
765
  pnode /= snode && pdx /= sdx ==>
766
  let vcpus_s = show vcpus
767
      dsk_s = show dsk
768
      mem_s = show mem
769
      su_s = show su
770
      status_s = Types.instanceStatusToRaw status
771
      ndx = if null snode
772
              then [(pnode, pdx)]
773
              else [(pnode, pdx), (snode, sdx)]
774
      nl = Data.Map.fromList ndx
775
      tags = ""
776
      sbal = if autobal then "Y" else "N"
777
      sdt = Types.diskTemplateToRaw dt
778
      inst = Text.loadInst nl
779
             [name, mem_s, dsk_s, vcpus_s, status_s,
780
              sbal, pnode, snode, sdt, tags, su_s]
781
      fail1 = Text.loadInst nl
782
              [name, mem_s, dsk_s, vcpus_s, status_s,
783
               sbal, pnode, pnode, tags]
784
      _types = ( name::String, mem::Int, dsk::Int
785
               , vcpus::Int, status::Types.InstanceStatus
786
               , snode::String
787
               , autobal::Bool)
788
  in case inst of
789
       Types.Bad msg -> failTest $ "Failed to load instance: " ++ msg
790
       Types.Ok (_, i) -> printTestCase "Mismatch in some field while\
791
                                        \ loading the instance" $
792
               Instance.name i == name &&
793
               Instance.vcpus i == vcpus &&
794
               Instance.mem i == mem &&
795
               Instance.pNode i == pdx &&
796
               Instance.sNode i == (if null snode
797
                                      then Node.noSecondary
798
                                      else sdx) &&
799
               Instance.autoBalance i == autobal &&
800
               Instance.spindleUse i == su &&
801
               Types.isBad fail1
802

    
803
prop_Text_Load_InstanceFail ktn fields =
804
  length fields /= 10 && length fields /= 11 ==>
805
    case Text.loadInst nl fields of
806
      Types.Ok _ -> failTest "Managed to load instance from invalid data"
807
      Types.Bad msg -> printTestCase ("Unrecognised error message: " ++ msg) $
808
                       "Invalid/incomplete instance data: '" `isPrefixOf` msg
809
    where nl = Data.Map.fromList ktn
810

    
811
prop_Text_Load_Node name tm nm fm td fd tc fo =
812
  let conv v = if v < 0
813
                 then "?"
814
                 else show v
815
      tm_s = conv tm
816
      nm_s = conv nm
817
      fm_s = conv fm
818
      td_s = conv td
819
      fd_s = conv fd
820
      tc_s = conv tc
821
      fo_s = if fo
822
               then "Y"
823
               else "N"
824
      any_broken = any (< 0) [tm, nm, fm, td, fd, tc]
825
      gid = Group.uuid defGroup
826
  in case Text.loadNode defGroupAssoc
827
       [name, tm_s, nm_s, fm_s, td_s, fd_s, tc_s, fo_s, gid] of
828
       Nothing -> False
829
       Just (name', node) ->
830
         if fo || any_broken
831
           then Node.offline node
832
           else Node.name node == name' && name' == name &&
833
                Node.alias node == name &&
834
                Node.tMem node == fromIntegral tm &&
835
                Node.nMem node == nm &&
836
                Node.fMem node == fm &&
837
                Node.tDsk node == fromIntegral td &&
838
                Node.fDsk node == fd &&
839
                Node.tCpu node == fromIntegral tc
840

    
841
prop_Text_Load_NodeFail fields =
842
  length fields /= 8 ==> isNothing $ Text.loadNode Data.Map.empty fields
843

    
844
prop_Text_NodeLSIdempotent node =
845
  (Text.loadNode defGroupAssoc.
846
       Utils.sepSplit '|' . Text.serializeNode defGroupList) n ==?
847
  Just (Node.name n, n)
848
    -- override failN1 to what loadNode returns by default
849
    where n = Node.setPolicy Types.defIPolicy $
850
              node { Node.failN1 = True, Node.offline = False }
851

    
852
prop_Text_ISpecIdempotent ispec =
853
  case Text.loadISpec "dummy" . Utils.sepSplit ',' .
854
       Text.serializeISpec $ ispec of
855
    Types.Bad msg -> failTest $ "Failed to load ispec: " ++ msg
856
    Types.Ok ispec' -> ispec ==? ispec'
857

    
858
prop_Text_IPolicyIdempotent ipol =
859
  case Text.loadIPolicy . Utils.sepSplit '|' $
860
       Text.serializeIPolicy owner ipol of
861
    Types.Bad msg -> failTest $ "Failed to load ispec: " ++ msg
862
    Types.Ok res -> (owner, ipol) ==? res
863
  where owner = "dummy"
864

    
865
-- | This property, while being in the text tests, does more than just
866
-- test end-to-end the serialisation and loading back workflow; it
867
-- also tests the Loader.mergeData and the actuall
868
-- Cluster.iterateAlloc (for well-behaving w.r.t. instance
869
-- allocations, not for the business logic). As such, it's a quite
870
-- complex and slow test, and that's the reason we restrict it to
871
-- small cluster sizes.
872
prop_Text_CreateSerialise =
873
  forAll genTags $ \ctags ->
874
  forAll (choose (1, 20)) $ \maxiter ->
875
  forAll (choose (2, 10)) $ \count ->
876
  forAll genOnlineNode $ \node ->
877
  forAll (genInstanceSmallerThanNode node) $ \inst ->
878
  let nl = makeSmallCluster node count
879
      reqnodes = Instance.requiredNodes $ Instance.diskTemplate inst
880
  in case Cluster.genAllocNodes defGroupList nl reqnodes True >>= \allocn ->
881
     Cluster.iterateAlloc nl Container.empty (Just maxiter) inst allocn [] []
882
     of
883
       Types.Bad msg -> failTest $ "Failed to allocate: " ++ msg
884
       Types.Ok (_, _, _, [], _) -> printTestCase
885
                                    "Failed to allocate: no allocations" False
886
       Types.Ok (_, nl', il', _, _) ->
887
         let cdata = Loader.ClusterData defGroupList nl' il' ctags
888
                     Types.defIPolicy
889
             saved = Text.serializeCluster cdata
890
         in case Text.parseData saved >>= Loader.mergeData [] [] [] [] of
891
              Types.Bad msg -> failTest $ "Failed to load/merge: " ++ msg
892
              Types.Ok (Loader.ClusterData gl2 nl2 il2 ctags2 cpol2) ->
893
                ctags ==? ctags2 .&&.
894
                Types.defIPolicy ==? cpol2 .&&.
895
                il' ==? il2 .&&.
896
                defGroupList ==? gl2 .&&.
897
                nl' ==? nl2
898

    
899
testSuite "Text"
900
            [ 'prop_Text_Load_Instance
901
            , 'prop_Text_Load_InstanceFail
902
            , 'prop_Text_Load_Node
903
            , 'prop_Text_Load_NodeFail
904
            , 'prop_Text_NodeLSIdempotent
905
            , 'prop_Text_ISpecIdempotent
906
            , 'prop_Text_IPolicyIdempotent
907
            , 'prop_Text_CreateSerialise
908
            ]
909

    
910
-- *** Simu backend
911

    
912
-- | Generates a tuple of specs for simulation.
913
genSimuSpec :: Gen (String, Int, Int, Int, Int)
914
genSimuSpec = do
915
  pol <- elements [C.allocPolicyPreferred,
916
                   C.allocPolicyLastResort, C.allocPolicyUnallocable,
917
                  "p", "a", "u"]
918
 -- should be reasonable (nodes/group), bigger values only complicate
919
 -- the display of failed tests, and we don't care (in this particular
920
 -- test) about big node groups
921
  nodes <- choose (0, 20)
922
  dsk <- choose (0, maxDsk)
923
  mem <- choose (0, maxMem)
924
  cpu <- choose (0, maxCpu)
925
  return (pol, nodes, dsk, mem, cpu)
926

    
927
-- | Checks that given a set of corrects specs, we can load them
928
-- successfully, and that at high-level the values look right.
929
prop_SimuLoad =
930
  forAll (choose (0, 10)) $ \ngroups ->
931
  forAll (replicateM ngroups genSimuSpec) $ \specs ->
932
  let strspecs = map (\(p, n, d, m, c) -> printf "%s,%d,%d,%d,%d"
933
                                          p n d m c::String) specs
934
      totnodes = sum $ map (\(_, n, _, _, _) -> n) specs
935
      mdc_in = concatMap (\(_, n, d, m, c) ->
936
                            replicate n (fromIntegral m, fromIntegral d,
937
                                         fromIntegral c,
938
                                         fromIntegral m, fromIntegral d)) specs
939
  in case Simu.parseData strspecs of
940
       Types.Bad msg -> failTest $ "Failed to load specs: " ++ msg
941
       Types.Ok (Loader.ClusterData gl nl il tags ipol) ->
942
         let nodes = map snd $ IntMap.toAscList nl
943
             nidx = map Node.idx nodes
944
             mdc_out = map (\n -> (Node.tMem n, Node.tDsk n, Node.tCpu n,
945
                                   Node.fMem n, Node.fDsk n)) nodes
946
         in
947
         Container.size gl ==? ngroups .&&.
948
         Container.size nl ==? totnodes .&&.
949
         Container.size il ==? 0 .&&.
950
         length tags ==? 0 .&&.
951
         ipol ==? Types.defIPolicy .&&.
952
         nidx ==? [1..totnodes] .&&.
953
         mdc_in ==? mdc_out .&&.
954
         map Group.iPolicy (Container.elems gl) ==?
955
             replicate ngroups Types.defIPolicy
956

    
957
testSuite "Simu"
958
            [ 'prop_SimuLoad
959
            ]
960

    
961
-- ** Node tests
962

    
963
prop_Node_setAlias node name =
964
  Node.name newnode == Node.name node &&
965
  Node.alias newnode == name
966
    where _types = (node::Node.Node, name::String)
967
          newnode = Node.setAlias node name
968

    
969
prop_Node_setOffline node status =
970
  Node.offline newnode ==? status
971
    where newnode = Node.setOffline node status
972

    
973
prop_Node_setXmem node xm =
974
  Node.xMem newnode ==? xm
975
    where newnode = Node.setXmem node xm
976

    
977
prop_Node_setMcpu node mc =
978
  Types.iPolicyVcpuRatio (Node.iPolicy newnode) ==? mc
979
    where newnode = Node.setMcpu node mc
980

    
981
-- | Check that an instance add with too high memory or disk will be
982
-- rejected.
983
prop_Node_addPriFM node inst =
984
  Instance.mem inst >= Node.fMem node && not (Node.failN1 node) &&
985
  not (Instance.isOffline inst) ==>
986
  case Node.addPri node inst'' of
987
    Types.OpFail Types.FailMem -> True
988
    _ -> False
989
  where _types = (node::Node.Node, inst::Instance.Instance)
990
        inst' = setInstanceSmallerThanNode node inst
991
        inst'' = inst' { Instance.mem = Instance.mem inst }
992

    
993
-- | Check that adding a primary instance with too much disk fails
994
-- with type FailDisk.
995
prop_Node_addPriFD node inst =
996
  forAll (elements Instance.localStorageTemplates) $ \dt ->
997
  Instance.dsk inst >= Node.fDsk node && not (Node.failN1 node) ==>
998
  let inst' = setInstanceSmallerThanNode node inst
999
      inst'' = inst' { Instance.dsk = Instance.dsk inst
1000
                     , Instance.diskTemplate = dt }
1001
  in case Node.addPri node inst'' of
1002
       Types.OpFail Types.FailDisk -> True
1003
       _ -> False
1004

    
1005
-- | Check that adding a primary instance with too many VCPUs fails
1006
-- with type FailCPU.
1007
prop_Node_addPriFC =
1008
  forAll (choose (1, maxCpu)) $ \extra ->
1009
  forAll genOnlineNode $ \node ->
1010
  forAll (arbitrary `suchThat` Instance.notOffline) $ \inst ->
1011
  let inst' = setInstanceSmallerThanNode node inst
1012
      inst'' = inst' { Instance.vcpus = Node.availCpu node + extra }
1013
  in case Node.addPri node inst'' of
1014
       Types.OpFail Types.FailCPU -> property True
1015
       v -> failTest $ "Expected OpFail FailCPU, but got " ++ show v
1016

    
1017
-- | Check that an instance add with too high memory or disk will be
1018
-- rejected.
1019
prop_Node_addSec node inst pdx =
1020
  ((Instance.mem inst >= (Node.fMem node - Node.rMem node) &&
1021
    not (Instance.isOffline inst)) ||
1022
   Instance.dsk inst >= Node.fDsk node) &&
1023
  not (Node.failN1 node) ==>
1024
      isFailure (Node.addSec node inst pdx)
1025
        where _types = (node::Node.Node, inst::Instance.Instance, pdx::Int)
1026

    
1027
-- | Check that an offline instance with reasonable disk size but
1028
-- extra mem/cpu can always be added.
1029
prop_Node_addOfflinePri (NonNegative extra_mem) (NonNegative extra_cpu) =
1030
  forAll genOnlineNode $ \node ->
1031
  forAll (genInstanceSmallerThanNode node) $ \inst ->
1032
  let inst' = inst { Instance.runSt = Types.AdminOffline
1033
                   , Instance.mem = Node.availMem node + extra_mem
1034
                   , Instance.vcpus = Node.availCpu node + extra_cpu }
1035
  in case Node.addPri node inst' of
1036
       Types.OpGood _ -> property True
1037
       v -> failTest $ "Expected OpGood, but got: " ++ show v
1038

    
1039
-- | Check that an offline instance with reasonable disk size but
1040
-- extra mem/cpu can always be added.
1041
prop_Node_addOfflineSec (NonNegative extra_mem) (NonNegative extra_cpu) pdx =
1042
  forAll genOnlineNode $ \node ->
1043
  forAll (genInstanceSmallerThanNode node) $ \inst ->
1044
  let inst' = inst { Instance.runSt = Types.AdminOffline
1045
                   , Instance.mem = Node.availMem node + extra_mem
1046
                   , Instance.vcpus = Node.availCpu node + extra_cpu
1047
                   , Instance.diskTemplate = Types.DTDrbd8 }
1048
  in case Node.addSec node inst' pdx of
1049
       Types.OpGood _ -> property True
1050
       v -> failTest $ "Expected OpGood/OpGood, but got: " ++ show v
1051

    
1052
-- | Checks for memory reservation changes.
1053
prop_Node_rMem inst =
1054
  not (Instance.isOffline inst) ==>
1055
  forAll (genOnlineNode `suchThat` ((> Types.unitMem) . Node.fMem)) $ \node ->
1056
  -- ab = auto_balance, nb = non-auto_balance
1057
  -- we use -1 as the primary node of the instance
1058
  let inst' = inst { Instance.pNode = -1, Instance.autoBalance = True
1059
                   , Instance.diskTemplate = Types.DTDrbd8 }
1060
      inst_ab = setInstanceSmallerThanNode node inst'
1061
      inst_nb = inst_ab { Instance.autoBalance = False }
1062
      -- now we have the two instances, identical except the
1063
      -- autoBalance attribute
1064
      orig_rmem = Node.rMem node
1065
      inst_idx = Instance.idx inst_ab
1066
      node_add_ab = Node.addSec node inst_ab (-1)
1067
      node_add_nb = Node.addSec node inst_nb (-1)
1068
      node_del_ab = liftM (`Node.removeSec` inst_ab) node_add_ab
1069
      node_del_nb = liftM (`Node.removeSec` inst_nb) node_add_nb
1070
  in case (node_add_ab, node_add_nb, node_del_ab, node_del_nb) of
1071
       (Types.OpGood a_ab, Types.OpGood a_nb,
1072
        Types.OpGood d_ab, Types.OpGood d_nb) ->
1073
         printTestCase "Consistency checks failed" $
1074
           Node.rMem a_ab >  orig_rmem &&
1075
           Node.rMem a_ab - orig_rmem == Instance.mem inst_ab &&
1076
           Node.rMem a_nb == orig_rmem &&
1077
           Node.rMem d_ab == orig_rmem &&
1078
           Node.rMem d_nb == orig_rmem &&
1079
           -- this is not related to rMem, but as good a place to
1080
           -- test as any
1081
           inst_idx `elem` Node.sList a_ab &&
1082
           inst_idx `notElem` Node.sList d_ab
1083
       x -> failTest $ "Failed to add/remove instances: " ++ show x
1084

    
1085
-- | Check mdsk setting.
1086
prop_Node_setMdsk node mx =
1087
  Node.loDsk node' >= 0 &&
1088
  fromIntegral (Node.loDsk node') <= Node.tDsk node &&
1089
  Node.availDisk node' >= 0 &&
1090
  Node.availDisk node' <= Node.fDsk node' &&
1091
  fromIntegral (Node.availDisk node') <= Node.tDsk node' &&
1092
  Node.mDsk node' == mx'
1093
    where _types = (node::Node.Node, mx::SmallRatio)
1094
          node' = Node.setMdsk node mx'
1095
          SmallRatio mx' = mx
1096

    
1097
-- Check tag maps
1098
prop_Node_tagMaps_idempotent =
1099
  forAll genTags $ \tags ->
1100
  Node.delTags (Node.addTags m tags) tags ==? m
1101
    where m = Data.Map.empty
1102

    
1103
prop_Node_tagMaps_reject =
1104
  forAll (genTags `suchThat` (not . null)) $ \tags ->
1105
  let m = Node.addTags Data.Map.empty tags
1106
  in all (\t -> Node.rejectAddTags m [t]) tags
1107

    
1108
prop_Node_showField node =
1109
  forAll (elements Node.defaultFields) $ \ field ->
1110
  fst (Node.showHeader field) /= Types.unknownField &&
1111
  Node.showField node field /= Types.unknownField
1112

    
1113
prop_Node_computeGroups nodes =
1114
  let ng = Node.computeGroups nodes
1115
      onlyuuid = map fst ng
1116
  in length nodes == sum (map (length . snd) ng) &&
1117
     all (\(guuid, ns) -> all ((== guuid) . Node.group) ns) ng &&
1118
     length (nub onlyuuid) == length onlyuuid &&
1119
     (null nodes || not (null ng))
1120

    
1121
-- Check idempotence of add/remove operations
1122
prop_Node_addPri_idempotent =
1123
  forAll genOnlineNode $ \node ->
1124
  forAll (genInstanceSmallerThanNode node) $ \inst ->
1125
  case Node.addPri node inst of
1126
    Types.OpGood node' -> Node.removePri node' inst ==? node
1127
    _ -> failTest "Can't add instance"
1128

    
1129
prop_Node_addSec_idempotent =
1130
  forAll genOnlineNode $ \node ->
1131
  forAll (genInstanceSmallerThanNode node) $ \inst ->
1132
  let pdx = Node.idx node + 1
1133
      inst' = Instance.setPri inst pdx
1134
      inst'' = inst' { Instance.diskTemplate = Types.DTDrbd8 }
1135
  in case Node.addSec node inst'' pdx of
1136
       Types.OpGood node' -> Node.removeSec node' inst'' ==? node
1137
       _ -> failTest "Can't add instance"
1138

    
1139
testSuite "Node"
1140
            [ 'prop_Node_setAlias
1141
            , 'prop_Node_setOffline
1142
            , 'prop_Node_setMcpu
1143
            , 'prop_Node_setXmem
1144
            , 'prop_Node_addPriFM
1145
            , 'prop_Node_addPriFD
1146
            , 'prop_Node_addPriFC
1147
            , 'prop_Node_addSec
1148
            , 'prop_Node_addOfflinePri
1149
            , 'prop_Node_addOfflineSec
1150
            , 'prop_Node_rMem
1151
            , 'prop_Node_setMdsk
1152
            , 'prop_Node_tagMaps_idempotent
1153
            , 'prop_Node_tagMaps_reject
1154
            , 'prop_Node_showField
1155
            , 'prop_Node_computeGroups
1156
            , 'prop_Node_addPri_idempotent
1157
            , 'prop_Node_addSec_idempotent
1158
            ]
1159

    
1160
-- ** Cluster tests
1161

    
1162
-- | Check that the cluster score is close to zero for a homogeneous
1163
-- cluster.
1164
prop_Score_Zero node =
1165
  forAll (choose (1, 1024)) $ \count ->
1166
    (not (Node.offline node) && not (Node.failN1 node) && (count > 0) &&
1167
     (Node.tDsk node > 0) && (Node.tMem node > 0)) ==>
1168
  let fn = Node.buildPeers node Container.empty
1169
      nlst = replicate count fn
1170
      score = Cluster.compCVNodes nlst
1171
  -- we can't say == 0 here as the floating point errors accumulate;
1172
  -- this should be much lower than the default score in CLI.hs
1173
  in score <= 1e-12
1174

    
1175
-- | Check that cluster stats are sane.
1176
prop_CStats_sane =
1177
  forAll (choose (1, 1024)) $ \count ->
1178
  forAll genOnlineNode $ \node ->
1179
  let fn = Node.buildPeers node Container.empty
1180
      nlst = zip [1..] $ replicate count fn::[(Types.Ndx, Node.Node)]
1181
      nl = Container.fromList nlst
1182
      cstats = Cluster.totalResources nl
1183
  in Cluster.csAdsk cstats >= 0 &&
1184
     Cluster.csAdsk cstats <= Cluster.csFdsk cstats
1185

    
1186
-- | Check that one instance is allocated correctly, without
1187
-- rebalances needed.
1188
prop_ClusterAlloc_sane inst =
1189
  forAll (choose (5, 20)) $ \count ->
1190
  forAll genOnlineNode $ \node ->
1191
  let (nl, il, inst') = makeSmallEmptyCluster node count inst
1192
      reqnodes = Instance.requiredNodes $ Instance.diskTemplate inst
1193
  in case Cluster.genAllocNodes defGroupList nl reqnodes True >>=
1194
     Cluster.tryAlloc nl il inst' of
1195
       Types.Bad _ -> False
1196
       Types.Ok as ->
1197
         case Cluster.asSolution as of
1198
           Nothing -> False
1199
           Just (xnl, xi, _, cv) ->
1200
             let il' = Container.add (Instance.idx xi) xi il
1201
                 tbl = Cluster.Table xnl il' cv []
1202
             in not (canBalance tbl True True False)
1203

    
1204
-- | Checks that on a 2-5 node cluster, we can allocate a random
1205
-- instance spec via tiered allocation (whatever the original instance
1206
-- spec), on either one or two nodes. Furthermore, we test that
1207
-- computed allocation statistics are correct.
1208
prop_ClusterCanTieredAlloc inst =
1209
  forAll (choose (2, 5)) $ \count ->
1210
  forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
1211
  let nl = makeSmallCluster node count
1212
      il = Container.empty
1213
      rqnodes = Instance.requiredNodes $ Instance.diskTemplate inst
1214
      allocnodes = Cluster.genAllocNodes defGroupList nl rqnodes True
1215
  in case allocnodes >>= \allocnodes' ->
1216
    Cluster.tieredAlloc nl il (Just 1) inst allocnodes' [] [] of
1217
       Types.Bad msg -> failTest $ "Failed to tiered alloc: " ++ msg
1218
       Types.Ok (_, nl', il', ixes, cstats) ->
1219
         let (ai_alloc, ai_pool, ai_unav) =
1220
               Cluster.computeAllocationDelta
1221
                (Cluster.totalResources nl)
1222
                (Cluster.totalResources nl')
1223
             all_nodes = Container.elems nl
1224
         in property (not (null ixes)) .&&.
1225
            IntMap.size il' ==? length ixes .&&.
1226
            length ixes ==? length cstats .&&.
1227
            sum (map Types.allocInfoVCpus [ai_alloc, ai_pool, ai_unav]) ==?
1228
              sum (map Node.hiCpu all_nodes) .&&.
1229
            sum (map Types.allocInfoNCpus [ai_alloc, ai_pool, ai_unav]) ==?
1230
              sum (map Node.tCpu all_nodes) .&&.
1231
            sum (map Types.allocInfoMem [ai_alloc, ai_pool, ai_unav]) ==?
1232
              truncate (sum (map Node.tMem all_nodes)) .&&.
1233
            sum (map Types.allocInfoDisk [ai_alloc, ai_pool, ai_unav]) ==?
1234
              truncate (sum (map Node.tDsk all_nodes))
1235

    
1236
-- | Helper function to create a cluster with the given range of nodes
1237
-- and allocate an instance on it.
1238
genClusterAlloc count node inst =
1239
  let nl = makeSmallCluster node count
1240
      reqnodes = Instance.requiredNodes $ Instance.diskTemplate inst
1241
  in case Cluster.genAllocNodes defGroupList nl reqnodes True >>=
1242
     Cluster.tryAlloc nl Container.empty inst of
1243
       Types.Bad _ -> Types.Bad "Can't allocate"
1244
       Types.Ok as ->
1245
         case Cluster.asSolution as of
1246
           Nothing -> Types.Bad "Empty solution?"
1247
           Just (xnl, xi, _, _) ->
1248
             let xil = Container.add (Instance.idx xi) xi Container.empty
1249
             in Types.Ok (xnl, xil, xi)
1250

    
1251
-- | Checks that on a 4-8 node cluster, once we allocate an instance,
1252
-- we can also relocate it.
1253
prop_ClusterAllocRelocate =
1254
  forAll (choose (4, 8)) $ \count ->
1255
  forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
1256
  forAll (genInstanceSmallerThanNode node `suchThat` isMirrored) $ \inst ->
1257
  case genClusterAlloc count node inst of
1258
    Types.Bad msg -> failTest msg
1259
    Types.Ok (nl, il, inst') ->
1260
      case IAlloc.processRelocate defGroupList nl il
1261
             (Instance.idx inst) 1
1262
             [(if Instance.diskTemplate inst' == Types.DTDrbd8
1263
                 then Instance.sNode
1264
                 else Instance.pNode) inst'] of
1265
        Types.Ok _ -> property True
1266
        Types.Bad msg -> failTest $ "Failed to relocate: " ++ msg
1267

    
1268
-- | Helper property checker for the result of a nodeEvac or
1269
-- changeGroup operation.
1270
check_EvacMode grp inst result =
1271
  case result of
1272
    Types.Bad msg -> failTest $ "Couldn't evacuate/change group:" ++ msg
1273
    Types.Ok (_, _, es) ->
1274
      let moved = Cluster.esMoved es
1275
          failed = Cluster.esFailed es
1276
          opcodes = not . null $ Cluster.esOpCodes es
1277
      in failmsg ("'failed' not empty: " ++ show failed) (null failed) .&&.
1278
         failmsg "'opcodes' is null" opcodes .&&.
1279
         case moved of
1280
           [(idx', gdx, _)] -> failmsg "invalid instance moved" (idx == idx')
1281
                               .&&.
1282
                               failmsg "wrong target group"
1283
                                         (gdx == Group.idx grp)
1284
           v -> failmsg  ("invalid solution: " ++ show v) False
1285
  where failmsg = \msg -> printTestCase ("Failed to evacuate: " ++ msg)
1286
        idx = Instance.idx inst
1287

    
1288
-- | Checks that on a 4-8 node cluster, once we allocate an instance,
1289
-- we can also node-evacuate it.
1290
prop_ClusterAllocEvacuate =
1291
  forAll (choose (4, 8)) $ \count ->
1292
  forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
1293
  forAll (genInstanceSmallerThanNode node `suchThat` isMirrored) $ \inst ->
1294
  case genClusterAlloc count node inst of
1295
    Types.Bad msg -> failTest msg
1296
    Types.Ok (nl, il, inst') ->
1297
      conjoin $ map (\mode -> check_EvacMode defGroup inst' $
1298
                              Cluster.tryNodeEvac defGroupList nl il mode
1299
                                [Instance.idx inst']) .
1300
                              evacModeOptions .
1301
                              Instance.mirrorType $ inst'
1302

    
1303
-- | Checks that on a 4-8 node cluster with two node groups, once we
1304
-- allocate an instance on the first node group, we can also change
1305
-- its group.
1306
prop_ClusterAllocChangeGroup =
1307
  forAll (choose (4, 8)) $ \count ->
1308
  forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
1309
  forAll (genInstanceSmallerThanNode node `suchThat` isMirrored) $ \inst ->
1310
  case genClusterAlloc count node inst of
1311
    Types.Bad msg -> failTest msg
1312
    Types.Ok (nl, il, inst') ->
1313
      -- we need to add a second node group and nodes to the cluster
1314
      let nl2 = Container.elems $ makeSmallCluster node count
1315
          grp2 = Group.setIdx defGroup (Group.idx defGroup + 1)
1316
          maxndx = maximum . map Node.idx $ nl2
1317
          nl3 = map (\n -> n { Node.group = Group.idx grp2
1318
                             , Node.idx = Node.idx n + maxndx }) nl2
1319
          nl4 = Container.fromList . map (\n -> (Node.idx n, n)) $ nl3
1320
          gl' = Container.add (Group.idx grp2) grp2 defGroupList
1321
          nl' = IntMap.union nl nl4
1322
      in check_EvacMode grp2 inst' $
1323
         Cluster.tryChangeGroup gl' nl' il [] [Instance.idx inst']
1324

    
1325
-- | Check that allocating multiple instances on a cluster, then
1326
-- adding an empty node, results in a valid rebalance.
1327
prop_ClusterAllocBalance =
1328
  forAll (genNode (Just 5) (Just 128)) $ \node ->
1329
  forAll (choose (3, 5)) $ \count ->
1330
  not (Node.offline node) && not (Node.failN1 node) ==>
1331
  let nl = makeSmallCluster node count
1332
      (hnode, nl') = IntMap.deleteFindMax nl
1333
      il = Container.empty
1334
      allocnodes = Cluster.genAllocNodes defGroupList nl' 2 True
1335
      i_templ = createInstance Types.unitMem Types.unitDsk Types.unitCpu
1336
  in case allocnodes >>= \allocnodes' ->
1337
    Cluster.iterateAlloc nl' il (Just 5) i_templ allocnodes' [] [] of
1338
       Types.Bad msg -> failTest $ "Failed to allocate: " ++ msg
1339
       Types.Ok (_, _, _, [], _) -> failTest "Failed to allocate: no instances"
1340
       Types.Ok (_, xnl, il', _, _) ->
1341
         let ynl = Container.add (Node.idx hnode) hnode xnl
1342
             cv = Cluster.compCV ynl
1343
             tbl = Cluster.Table ynl il' cv []
1344
         in printTestCase "Failed to rebalance" $
1345
            canBalance tbl True True False
1346

    
1347
-- | Checks consistency.
1348
prop_ClusterCheckConsistency node inst =
1349
  let nl = makeSmallCluster node 3
1350
      [node1, node2, node3] = Container.elems nl
1351
      node3' = node3 { Node.group = 1 }
1352
      nl' = Container.add (Node.idx node3') node3' nl
1353
      inst1 = Instance.setBoth inst (Node.idx node1) (Node.idx node2)
1354
      inst2 = Instance.setBoth inst (Node.idx node1) Node.noSecondary
1355
      inst3 = Instance.setBoth inst (Node.idx node1) (Node.idx node3)
1356
      ccheck = Cluster.findSplitInstances nl' . Container.fromList
1357
  in null (ccheck [(0, inst1)]) &&
1358
     null (ccheck [(0, inst2)]) &&
1359
     (not . null $ ccheck [(0, inst3)])
1360

    
1361
-- | For now, we only test that we don't lose instances during the split.
1362
prop_ClusterSplitCluster node inst =
1363
  forAll (choose (0, 100)) $ \icnt ->
1364
  let nl = makeSmallCluster node 2
1365
      (nl', il') = foldl (\(ns, is) _ -> assignInstance ns is inst 0 1)
1366
                   (nl, Container.empty) [1..icnt]
1367
      gni = Cluster.splitCluster nl' il'
1368
  in sum (map (Container.size . snd . snd) gni) == icnt &&
1369
     all (\(guuid, (nl'', _)) -> all ((== guuid) . Node.group)
1370
                                 (Container.elems nl'')) gni
1371

    
1372
-- | Helper function to check if we can allocate an instance on a
1373
-- given node list.
1374
canAllocOn :: Node.List -> Int -> Instance.Instance -> Bool
1375
canAllocOn nl reqnodes inst =
1376
  case Cluster.genAllocNodes defGroupList nl reqnodes True >>=
1377
       Cluster.tryAlloc nl (Container.empty) inst of
1378
       Types.Bad _ -> False
1379
       Types.Ok as ->
1380
         case Cluster.asSolution as of
1381
           Nothing -> False
1382
           Just _ -> True
1383

    
1384
-- | Checks that allocation obeys minimum and maximum instance
1385
-- policies. The unittest generates a random node, duplicates it count
1386
-- times, and generates a random instance that can be allocated on
1387
-- this mini-cluster; it then checks that after applying a policy that
1388
-- the instance doesn't fits, the allocation fails.
1389
prop_ClusterAllocPolicy node =
1390
  -- rqn is the required nodes (1 or 2)
1391
  forAll (choose (1, 2)) $ \rqn ->
1392
  forAll (choose (5, 20)) $ \count ->
1393
  forAll (arbitrary `suchThat` (canAllocOn (makeSmallCluster node count) rqn))
1394
         $ \inst ->
1395
  forAll (arbitrary `suchThat` (isFailure .
1396
                                Instance.instMatchesPolicy inst)) $ \ipol ->
1397
  let node' = Node.setPolicy ipol node
1398
      nl = makeSmallCluster node' count
1399
  in not $ canAllocOn nl rqn inst
1400

    
1401
testSuite "Cluster"
1402
            [ 'prop_Score_Zero
1403
            , 'prop_CStats_sane
1404
            , 'prop_ClusterAlloc_sane
1405
            , 'prop_ClusterCanTieredAlloc
1406
            , 'prop_ClusterAllocRelocate
1407
            , 'prop_ClusterAllocEvacuate
1408
            , 'prop_ClusterAllocChangeGroup
1409
            , 'prop_ClusterAllocBalance
1410
            , 'prop_ClusterCheckConsistency
1411
            , 'prop_ClusterSplitCluster
1412
            , 'prop_ClusterAllocPolicy
1413
            ]
1414

    
1415
-- ** OpCodes tests
1416

    
1417
-- | Check that opcode serialization is idempotent.
1418
prop_OpCodes_serialization op =
1419
  case J.readJSON (J.showJSON op) of
1420
    J.Error e -> failTest $ "Cannot deserialise: " ++ e
1421
    J.Ok op' -> op ==? op'
1422
  where _types = op::OpCodes.OpCode
1423

    
1424
testSuite "OpCodes"
1425
            [ 'prop_OpCodes_serialization ]
1426

    
1427
-- ** Jobs tests
1428

    
1429
-- | Check that (queued) job\/opcode status serialization is idempotent.
1430
prop_OpStatus_serialization os =
1431
  case J.readJSON (J.showJSON os) of
1432
    J.Error e -> failTest $ "Cannot deserialise: " ++ e
1433
    J.Ok os' -> os ==? os'
1434
  where _types = os::Jobs.OpStatus
1435

    
1436
prop_JobStatus_serialization js =
1437
  case J.readJSON (J.showJSON js) of
1438
    J.Error e -> failTest $ "Cannot deserialise: " ++ e
1439
    J.Ok js' -> js ==? js'
1440
  where _types = js::Jobs.JobStatus
1441

    
1442
testSuite "Jobs"
1443
            [ 'prop_OpStatus_serialization
1444
            , 'prop_JobStatus_serialization
1445
            ]
1446

    
1447
-- ** Loader tests
1448

    
1449
prop_Loader_lookupNode ktn inst node =
1450
  Loader.lookupNode nl inst node ==? Data.Map.lookup node nl
1451
    where nl = Data.Map.fromList ktn
1452

    
1453
prop_Loader_lookupInstance kti inst =
1454
  Loader.lookupInstance il inst ==? Data.Map.lookup inst il
1455
    where il = Data.Map.fromList kti
1456

    
1457
prop_Loader_assignIndices =
1458
  -- generate nodes with unique names
1459
  forAll (arbitrary `suchThat`
1460
          (\nodes ->
1461
             let names = map Node.name nodes
1462
             in length names == length (nub names))) $ \nodes ->
1463
  let (nassoc, kt) =
1464
        Loader.assignIndices (map (\n -> (Node.name n, n)) nodes)
1465
  in Data.Map.size nassoc == length nodes &&
1466
     Container.size kt == length nodes &&
1467
     if not (null nodes)
1468
       then maximum (IntMap.keys kt) == length nodes - 1
1469
       else True
1470

    
1471
-- | Checks that the number of primary instances recorded on the nodes
1472
-- is zero.
1473
prop_Loader_mergeData ns =
1474
  let na = Container.fromList $ map (\n -> (Node.idx n, n)) ns
1475
  in case Loader.mergeData [] [] [] []
1476
         (Loader.emptyCluster {Loader.cdNodes = na}) of
1477
    Types.Bad _ -> False
1478
    Types.Ok (Loader.ClusterData _ nl il _ _) ->
1479
      let nodes = Container.elems nl
1480
          instances = Container.elems il
1481
      in (sum . map (length . Node.pList)) nodes == 0 &&
1482
         null instances
1483

    
1484
-- | Check that compareNameComponent on equal strings works.
1485
prop_Loader_compareNameComponent_equal :: String -> Bool
1486
prop_Loader_compareNameComponent_equal s =
1487
  Loader.compareNameComponent s s ==
1488
    Loader.LookupResult Loader.ExactMatch s
1489

    
1490
-- | Check that compareNameComponent on prefix strings works.
1491
prop_Loader_compareNameComponent_prefix :: NonEmptyList Char -> String -> Bool
1492
prop_Loader_compareNameComponent_prefix (NonEmpty s1) s2 =
1493
  Loader.compareNameComponent (s1 ++ "." ++ s2) s1 ==
1494
    Loader.LookupResult Loader.PartialMatch s1
1495

    
1496
testSuite "Loader"
1497
            [ 'prop_Loader_lookupNode
1498
            , 'prop_Loader_lookupInstance
1499
            , 'prop_Loader_assignIndices
1500
            , 'prop_Loader_mergeData
1501
            , 'prop_Loader_compareNameComponent_equal
1502
            , 'prop_Loader_compareNameComponent_prefix
1503
            ]
1504

    
1505
-- ** Types tests
1506

    
1507
prop_Types_AllocPolicy_serialisation apol =
1508
  case J.readJSON (J.showJSON apol) of
1509
    J.Ok p -> p ==? apol
1510
    J.Error s -> failTest $ "Failed to deserialise: " ++ s
1511
      where _types = apol::Types.AllocPolicy
1512

    
1513
prop_Types_DiskTemplate_serialisation dt =
1514
  case J.readJSON (J.showJSON dt) of
1515
    J.Ok p -> p ==? dt
1516
    J.Error s -> failTest $ "Failed to deserialise: " ++ s
1517
      where _types = dt::Types.DiskTemplate
1518

    
1519
prop_Types_ISpec_serialisation ispec =
1520
  case J.readJSON (J.showJSON ispec) of
1521
    J.Ok p -> p ==? ispec
1522
    J.Error s -> failTest $ "Failed to deserialise: " ++ s
1523
      where _types = ispec::Types.ISpec
1524

    
1525
prop_Types_IPolicy_serialisation ipol =
1526
  case J.readJSON (J.showJSON ipol) of
1527
    J.Ok p -> p ==? ipol
1528
    J.Error s -> failTest $ "Failed to deserialise: " ++ s
1529
      where _types = ipol::Types.IPolicy
1530

    
1531
prop_Types_EvacMode_serialisation em =
1532
  case J.readJSON (J.showJSON em) of
1533
    J.Ok p -> p ==? em
1534
    J.Error s -> failTest $ "Failed to deserialise: " ++ s
1535
      where _types = em::Types.EvacMode
1536

    
1537
prop_Types_opToResult op =
1538
  case op of
1539
    Types.OpFail _ -> Types.isBad r
1540
    Types.OpGood v -> case r of
1541
                        Types.Bad _ -> False
1542
                        Types.Ok v' -> v == v'
1543
  where r = Types.opToResult op
1544
        _types = op::Types.OpResult Int
1545

    
1546
prop_Types_eitherToResult ei =
1547
  case ei of
1548
    Left _ -> Types.isBad r
1549
    Right v -> case r of
1550
                 Types.Bad _ -> False
1551
                 Types.Ok v' -> v == v'
1552
    where r = Types.eitherToResult ei
1553
          _types = ei::Either String Int
1554

    
1555
testSuite "Types"
1556
            [ 'prop_Types_AllocPolicy_serialisation
1557
            , 'prop_Types_DiskTemplate_serialisation
1558
            , 'prop_Types_ISpec_serialisation
1559
            , 'prop_Types_IPolicy_serialisation
1560
            , 'prop_Types_EvacMode_serialisation
1561
            , 'prop_Types_opToResult
1562
            , 'prop_Types_eitherToResult
1563
            ]
1564

    
1565
-- ** CLI tests
1566

    
1567
-- | Test correct parsing.
1568
prop_CLI_parseISpec descr dsk mem cpu =
1569
  let str = printf "%d,%d,%d" dsk mem cpu
1570
  in CLI.parseISpecString descr str ==? Types.Ok (Types.RSpec cpu mem dsk)
1571

    
1572
-- | Test parsing failure due to wrong section count.
1573
prop_CLI_parseISpecFail descr =
1574
  forAll (choose (0,100) `suchThat` ((/=) 3)) $ \nelems ->
1575
  forAll (replicateM nelems arbitrary) $ \values ->
1576
  let str = intercalate "," $ map show (values::[Int])
1577
  in case CLI.parseISpecString descr str of
1578
       Types.Ok v -> failTest $ "Expected failure, got " ++ show v
1579
       _ -> property True
1580

    
1581
-- | Test parseYesNo.
1582
prop_CLI_parseYesNo def testval val =
1583
  forAll (elements [val, "yes", "no"]) $ \actual_val ->
1584
  if testval
1585
    then CLI.parseYesNo def Nothing ==? Types.Ok def
1586
    else let result = CLI.parseYesNo def (Just actual_val)
1587
         in if actual_val `elem` ["yes", "no"]
1588
              then result ==? Types.Ok (actual_val == "yes")
1589
              else property $ Types.isBad result
1590

    
1591
-- | Helper to check for correct parsing of string arg.
1592
checkStringArg val (opt, fn) =
1593
  let GetOpt.Option _ longs _ _ = opt
1594
  in case longs of
1595
       [] -> failTest "no long options?"
1596
       cmdarg:_ ->
1597
         case CLI.parseOptsInner ["--" ++ cmdarg ++ "=" ++ val] "prog" [opt] of
1598
           Left e -> failTest $ "Failed to parse option: " ++ show e
1599
           Right (options, _) -> fn options ==? Just val
1600

    
1601
-- | Test a few string arguments.
1602
prop_CLI_StringArg argument =
1603
  let args = [ (CLI.oDataFile,      CLI.optDataFile)
1604
             , (CLI.oDynuFile,      CLI.optDynuFile)
1605
             , (CLI.oSaveCluster,   CLI.optSaveCluster)
1606
             , (CLI.oReplay,        CLI.optReplay)
1607
             , (CLI.oPrintCommands, CLI.optShowCmds)
1608
             , (CLI.oLuxiSocket,    CLI.optLuxi)
1609
             ]
1610
  in conjoin $ map (checkStringArg argument) args
1611

    
1612
-- | Helper to test that a given option is accepted OK with quick exit.
1613
checkEarlyExit name options param =
1614
  case CLI.parseOptsInner [param] name options of
1615
    Left (code, _) -> if code == 0
1616
                          then property True
1617
                          else failTest $ "Program " ++ name ++
1618
                                 " returns invalid code " ++ show code ++
1619
                                 " for option " ++ param
1620
    _ -> failTest $ "Program " ++ name ++ " doesn't consider option " ++
1621
         param ++ " as early exit one"
1622

    
1623
-- | Test that all binaries support some common options. There is
1624
-- nothing actually random about this test...
1625
prop_CLI_stdopts =
1626
  let params = ["-h", "--help", "-V", "--version"]
1627
      opts = map (\(name, (_, o)) -> (name, o)) Program.personalities
1628
      -- apply checkEarlyExit across the cartesian product of params and opts
1629
  in conjoin [checkEarlyExit n o p | p <- params, (n, o) <- opts]
1630

    
1631
testSuite "CLI"
1632
          [ 'prop_CLI_parseISpec
1633
          , 'prop_CLI_parseISpecFail
1634
          , 'prop_CLI_parseYesNo
1635
          , 'prop_CLI_StringArg
1636
          , 'prop_CLI_stdopts
1637
          ]
1638

    
1639
-- * JSON tests
1640

    
1641
prop_JSON_toArray :: [Int] -> Property
1642
prop_JSON_toArray intarr =
1643
  let arr = map J.showJSON intarr in
1644
  case JSON.toArray (J.JSArray arr) of
1645
    Types.Ok arr' -> arr ==? arr'
1646
    Types.Bad err -> failTest $ "Failed to parse array: " ++ err
1647

    
1648
prop_JSON_toArrayFail :: Int -> String -> Bool -> Property
1649
prop_JSON_toArrayFail i s b =
1650
  -- poor man's instance Arbitrary JSValue
1651
  forAll (elements [J.showJSON i, J.showJSON s, J.showJSON b]) $ \item ->
1652
  case JSON.toArray item of
1653
    Types.Bad _ -> property True
1654
    Types.Ok result -> failTest $ "Unexpected parse, got " ++ show result
1655

    
1656
testSuite "JSON"
1657
          [ 'prop_JSON_toArray
1658
          , 'prop_JSON_toArrayFail
1659
          ]