Statistics
| Branch: | Tag: | Revision:

root / htools / Ganeti / HTools / QC.hs @ 96eccc1f

History | View | Annotate | Download (70.9 kB)

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
  ) where
52

    
53
import Test.QuickCheck
54
import Text.Printf (printf)
55
import Data.List (intercalate, nub, isPrefixOf)
56
import Data.Maybe
57
import Control.Monad
58
import Control.Applicative
59
import qualified System.Console.GetOpt as GetOpt
60
import qualified Text.JSON as J
61
import qualified Data.Map
62
import qualified Data.IntMap as IntMap
63

    
64
import qualified Ganeti.Confd as Confd
65
import qualified Ganeti.Config as Config
66
import qualified Ganeti.Daemon as Daemon
67
import qualified Ganeti.Hash as Hash
68
import qualified Ganeti.Jobs as Jobs
69
import qualified Ganeti.Logging as Logging
70
import qualified Ganeti.Luxi as Luxi
71
import qualified Ganeti.Objects as Objects
72
import qualified Ganeti.OpCodes as OpCodes
73
import qualified Ganeti.Query2 as Query2
74
import qualified Ganeti.Runtime as Runtime
75
import qualified Ganeti.Ssconf as Ssconf
76
import qualified Ganeti.HTools.CLI as CLI
77
import qualified Ganeti.HTools.Cluster as Cluster
78
import qualified Ganeti.HTools.Container as Container
79
import qualified Ganeti.HTools.ExtLoader
80
import qualified Ganeti.HTools.Group as Group
81
import qualified Ganeti.HTools.IAlloc as IAlloc
82
import qualified Ganeti.HTools.Instance as Instance
83
import qualified Ganeti.HTools.JSON as JSON
84
import qualified Ganeti.HTools.Loader as Loader
85
import qualified Ganeti.HTools.Luxi as HTools.Luxi
86
import qualified Ganeti.HTools.Node as Node
87
import qualified Ganeti.HTools.PeerMap as PeerMap
88
import qualified Ganeti.HTools.Rapi
89
import qualified Ganeti.HTools.Simu as Simu
90
import qualified Ganeti.HTools.Text as Text
91
import qualified Ganeti.HTools.Types as Types
92
import qualified Ganeti.HTools.Utils as Utils
93
import qualified Ganeti.HTools.Version
94
import qualified Ganeti.Constants as C
95

    
96
import qualified Ganeti.HTools.Program as Program
97
import qualified Ganeti.HTools.Program.Hail
98
import qualified Ganeti.HTools.Program.Hbal
99
import qualified Ganeti.HTools.Program.Hscan
100
import qualified Ganeti.HTools.Program.Hspace
101

    
102
import Ganeti.HTools.QCHelper (testSuite)
103

    
104
-- * Constants
105

    
106
-- | Maximum memory (1TiB, somewhat random value).
107
maxMem :: Int
108
maxMem = 1024 * 1024
109

    
110
-- | Maximum disk (8TiB, somewhat random value).
111
maxDsk :: Int
112
maxDsk = 1024 * 1024 * 8
113

    
114
-- | Max CPUs (1024, somewhat random value).
115
maxCpu :: Int
116
maxCpu = 1024
117

    
118
-- | Max vcpu ratio (random value).
119
maxVcpuRatio :: Double
120
maxVcpuRatio = 1024.0
121

    
122
-- | Max spindle ratio (random value).
123
maxSpindleRatio :: Double
124
maxSpindleRatio = 1024.0
125

    
126
-- | Max nodes, used just to limit arbitrary instances for smaller
127
-- opcode definitions (e.g. list of nodes in OpTestDelay).
128
maxNodes :: Int
129
maxNodes = 32
130

    
131
-- | Max opcodes or jobs in a submit job and submit many jobs.
132
maxOpCodes :: Int
133
maxOpCodes = 16
134

    
135
-- | All disk templates (used later)
136
allDiskTemplates :: [Types.DiskTemplate]
137
allDiskTemplates = [minBound..maxBound]
138

    
139
-- | Null iPolicy, and by null we mean very liberal.
140
nullIPolicy :: Types.IPolicy
141
nullIPolicy = Types.IPolicy
142
  { Types.iPolicyMinSpec = Types.ISpec { Types.iSpecMemorySize = 0
143
                                       , Types.iSpecCpuCount   = 0
144
                                       , Types.iSpecDiskSize   = 0
145
                                       , Types.iSpecDiskCount  = 0
146
                                       , Types.iSpecNicCount   = 0
147
                                       , Types.iSpecSpindleUse = 0
148
                                       }
149
  , Types.iPolicyMaxSpec = Types.ISpec { Types.iSpecMemorySize = maxBound
150
                                       , Types.iSpecCpuCount   = maxBound
151
                                       , Types.iSpecDiskSize   = maxBound
152
                                       , Types.iSpecDiskCount  = C.maxDisks
153
                                       , Types.iSpecNicCount   = C.maxNics
154
                                       , Types.iSpecSpindleUse = maxBound
155
                                       }
156
  , Types.iPolicyStdSpec = Types.ISpec { Types.iSpecMemorySize = Types.unitMem
157
                                       , Types.iSpecCpuCount   = Types.unitCpu
158
                                       , Types.iSpecDiskSize   = Types.unitDsk
159
                                       , Types.iSpecDiskCount  = 1
160
                                       , Types.iSpecNicCount   = 1
161
                                       , Types.iSpecSpindleUse = 1
162
                                       }
163
  , Types.iPolicyDiskTemplates = [minBound..maxBound]
164
  , Types.iPolicyVcpuRatio = maxVcpuRatio -- somewhat random value, high
165
                                          -- enough to not impact us
166
  , Types.iPolicySpindleRatio = maxSpindleRatio
167
  }
168

    
169

    
170
defGroup :: Group.Group
171
defGroup = flip Group.setIdx 0 $
172
             Group.create "default" Types.defaultGroupID Types.AllocPreferred
173
                  nullIPolicy
174

    
175
defGroupList :: Group.List
176
defGroupList = Container.fromList [(Group.idx defGroup, defGroup)]
177

    
178
defGroupAssoc :: Data.Map.Map String Types.Gdx
179
defGroupAssoc = Data.Map.singleton (Group.uuid defGroup) (Group.idx defGroup)
180

    
181
-- * Helper functions
182

    
183
-- | Simple checker for whether OpResult is fail or pass.
184
isFailure :: Types.OpResult a -> Bool
185
isFailure (Types.OpFail _) = True
186
isFailure _ = False
187

    
188
-- | Checks for equality with proper annotation.
189
(==?) :: (Show a, Eq a) => a -> a -> Property
190
(==?) x y = printTestCase
191
            ("Expected equality, but '" ++
192
             show x ++ "' /= '" ++ show y ++ "'") (x == y)
193
infix 3 ==?
194

    
195
-- | Show a message and fail the test.
196
failTest :: String -> Property
197
failTest msg = printTestCase msg False
198

    
199
-- | Update an instance to be smaller than a node.
200
setInstanceSmallerThanNode :: Node.Node
201
                           -> Instance.Instance -> Instance.Instance
202
setInstanceSmallerThanNode node inst =
203
  inst { Instance.mem = Node.availMem node `div` 2
204
       , Instance.dsk = Node.availDisk node `div` 2
205
       , Instance.vcpus = Node.availCpu node `div` 2
206
       }
207

    
208
-- | Create an instance given its spec.
209
createInstance :: Int -> Int -> Int -> Instance.Instance
210
createInstance mem dsk vcpus =
211
  Instance.create "inst-unnamed" mem dsk vcpus Types.Running [] True (-1) (-1)
212
    Types.DTDrbd8 1
213

    
214
-- | Create a small cluster by repeating a node spec.
215
makeSmallCluster :: Node.Node -> Int -> Node.List
216
makeSmallCluster node count =
217
  let origname = Node.name node
218
      origalias = Node.alias node
219
      nodes = map (\idx -> node { Node.name = origname ++ "-" ++ show idx
220
                                , Node.alias = origalias ++ "-" ++ show idx })
221
              [1..count]
222
      fn = flip Node.buildPeers Container.empty
223
      namelst = map (\n -> (Node.name n, fn n)) nodes
224
      (_, nlst) = Loader.assignIndices namelst
225
  in nlst
226

    
227
-- | Make a small cluster, both nodes and instances.
228
makeSmallEmptyCluster :: Node.Node -> Int -> Instance.Instance
229
                      -> (Node.List, Instance.List, Instance.Instance)
230
makeSmallEmptyCluster node count inst =
231
  (makeSmallCluster node count, Container.empty,
232
   setInstanceSmallerThanNode node inst)
233

    
234
-- | Checks if a node is "big" enough.
235
isNodeBig :: Int -> Node.Node -> Bool
236
isNodeBig size node = Node.availDisk node > size * Types.unitDsk
237
                      && Node.availMem node > size * Types.unitMem
238
                      && Node.availCpu node > size * Types.unitCpu
239

    
240
canBalance :: Cluster.Table -> Bool -> Bool -> Bool -> Bool
241
canBalance tbl dm im evac = isJust $ Cluster.tryBalance tbl dm im evac 0 0
242

    
243
-- | Assigns a new fresh instance to a cluster; this is not
244
-- allocation, so no resource checks are done.
245
assignInstance :: Node.List -> Instance.List -> Instance.Instance ->
246
                  Types.Idx -> Types.Idx ->
247
                  (Node.List, Instance.List)
248
assignInstance nl il inst pdx sdx =
249
  let pnode = Container.find pdx nl
250
      snode = Container.find sdx nl
251
      maxiidx = if Container.null il
252
                  then 0
253
                  else fst (Container.findMax il) + 1
254
      inst' = inst { Instance.idx = maxiidx,
255
                     Instance.pNode = pdx, Instance.sNode = sdx }
256
      pnode' = Node.setPri pnode inst'
257
      snode' = Node.setSec snode inst'
258
      nl' = Container.addTwo pdx pnode' sdx snode' nl
259
      il' = Container.add maxiidx inst' il
260
  in (nl', il')
261

    
262
-- | Generates a list of a given size with non-duplicate elements.
263
genUniquesList :: (Eq a, Arbitrary a) => Int -> Gen [a]
264
genUniquesList cnt =
265
  foldM (\lst _ -> do
266
           newelem <- arbitrary `suchThat` (`notElem` lst)
267
           return (newelem:lst)) [] [1..cnt]
268

    
269
-- | Checks if an instance is mirrored.
270
isMirrored :: Instance.Instance -> Bool
271
isMirrored = (/= Types.MirrorNone) . Instance.mirrorType
272

    
273
-- | Returns the possible change node types for a disk template.
274
evacModeOptions :: Types.MirrorType -> [Types.EvacMode]
275
evacModeOptions Types.MirrorNone     = []
276
evacModeOptions Types.MirrorInternal = [minBound..maxBound] -- DRBD can do all
277
evacModeOptions Types.MirrorExternal = [Types.ChangePrimary, Types.ChangeAll]
278

    
279
-- * Arbitrary instances
280

    
281
-- | Defines a DNS name.
282
newtype DNSChar = DNSChar { dnsGetChar::Char }
283

    
284
instance Arbitrary DNSChar where
285
  arbitrary = do
286
    x <- elements (['a'..'z'] ++ ['0'..'9'] ++ "_-")
287
    return (DNSChar x)
288

    
289
-- | Generates a single name component.
290
getName :: Gen String
291
getName = do
292
  n <- choose (1, 64)
293
  dn <- vector n
294
  return (map dnsGetChar dn)
295

    
296
-- | Generates an entire FQDN.
297
getFQDN :: Gen String
298
getFQDN = do
299
  ncomps <- choose (1, 4)
300
  names <- vectorOf ncomps getName
301
  return $ intercalate "." names
302

    
303
-- | Combinator that generates a 'Maybe' using a sub-combinator.
304
getMaybe :: Gen a -> Gen (Maybe a)
305
getMaybe subgen = do
306
  bool <- arbitrary
307
  if bool
308
    then Just <$> subgen
309
    else return Nothing
310

    
311
-- | Generates a fields list. This uses the same character set as a
312
-- DNS name (just for simplicity).
313
getFields :: Gen [String]
314
getFields = do
315
  n <- choose (1, 32)
316
  vectorOf n getName
317

    
318
-- | Defines a tag type.
319
newtype TagChar = TagChar { tagGetChar :: Char }
320

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

    
326
instance Arbitrary TagChar where
327
  arbitrary = do
328
    c <- elements tagChar
329
    return (TagChar c)
330

    
331
-- | Generates a tag
332
genTag :: Gen [TagChar]
333
genTag = do
334
  -- the correct value would be C.maxTagLen, but that's way too
335
  -- verbose in unittests, and at the moment I don't see any possible
336
  -- bugs with longer tags and the way we use tags in htools
337
  n <- choose (1, 10)
338
  vector n
339

    
340
-- | Generates a list of tags (correctly upper bounded).
341
genTags :: Gen [String]
342
genTags = do
343
  -- the correct value would be C.maxTagsPerObj, but per the comment
344
  -- in genTag, we don't use tags enough in htools to warrant testing
345
  -- such big values
346
  n <- choose (0, 10::Int)
347
  tags <- mapM (const genTag) [1..n]
348
  return $ map (map tagGetChar) tags
349

    
350
instance Arbitrary Types.InstanceStatus where
351
    arbitrary = elements [minBound..maxBound]
352

    
353
-- | Generates a random instance with maximum disk/mem/cpu values.
354
genInstanceSmallerThan :: Int -> Int -> Int -> Gen Instance.Instance
355
genInstanceSmallerThan lim_mem lim_dsk lim_cpu = do
356
  name <- getFQDN
357
  mem <- choose (0, lim_mem)
358
  dsk <- choose (0, lim_dsk)
359
  run_st <- arbitrary
360
  pn <- arbitrary
361
  sn <- arbitrary
362
  vcpus <- choose (0, lim_cpu)
363
  dt <- arbitrary
364
  return $ Instance.create name mem dsk vcpus run_st [] True pn sn dt 1
365

    
366
-- | Generates an instance smaller than a node.
367
genInstanceSmallerThanNode :: Node.Node -> Gen Instance.Instance
368
genInstanceSmallerThanNode node =
369
  genInstanceSmallerThan (Node.availMem node `div` 2)
370
                         (Node.availDisk node `div` 2)
371
                         (Node.availCpu node `div` 2)
372

    
373
-- let's generate a random instance
374
instance Arbitrary Instance.Instance where
375
  arbitrary = genInstanceSmallerThan maxMem maxDsk maxCpu
376

    
377
-- | Generas an arbitrary node based on sizing information.
378
genNode :: Maybe Int -- ^ Minimum node size in terms of units
379
        -> Maybe Int -- ^ Maximum node size (when Nothing, bounded
380
                     -- just by the max... constants)
381
        -> Gen Node.Node
382
genNode min_multiplier max_multiplier = do
383
  let (base_mem, base_dsk, base_cpu) =
384
        case min_multiplier of
385
          Just mm -> (mm * Types.unitMem,
386
                      mm * Types.unitDsk,
387
                      mm * Types.unitCpu)
388
          Nothing -> (0, 0, 0)
389
      (top_mem, top_dsk, top_cpu)  =
390
        case max_multiplier of
391
          Just mm -> (mm * Types.unitMem,
392
                      mm * Types.unitDsk,
393
                      mm * Types.unitCpu)
394
          Nothing -> (maxMem, maxDsk, maxCpu)
395
  name  <- getFQDN
396
  mem_t <- choose (base_mem, top_mem)
397
  mem_f <- choose (base_mem, mem_t)
398
  mem_n <- choose (0, mem_t - mem_f)
399
  dsk_t <- choose (base_dsk, top_dsk)
400
  dsk_f <- choose (base_dsk, dsk_t)
401
  cpu_t <- choose (base_cpu, top_cpu)
402
  offl  <- arbitrary
403
  let n = Node.create name (fromIntegral mem_t) mem_n mem_f
404
          (fromIntegral dsk_t) dsk_f (fromIntegral cpu_t) offl 1 0
405
      n' = Node.setPolicy nullIPolicy n
406
  return $ Node.buildPeers n' Container.empty
407

    
408
-- | Helper function to generate a sane node.
409
genOnlineNode :: Gen Node.Node
410
genOnlineNode = do
411
  arbitrary `suchThat` (\n -> not (Node.offline n) &&
412
                              not (Node.failN1 n) &&
413
                              Node.availDisk n > 0 &&
414
                              Node.availMem n > 0 &&
415
                              Node.availCpu n > 0)
416

    
417
-- and a random node
418
instance Arbitrary Node.Node where
419
  arbitrary = genNode Nothing Nothing
420

    
421
-- replace disks
422
instance Arbitrary OpCodes.ReplaceDisksMode where
423
  arbitrary = elements [minBound..maxBound]
424

    
425
instance Arbitrary OpCodes.OpCode where
426
  arbitrary = do
427
    op_id <- elements [ "OP_TEST_DELAY"
428
                      , "OP_INSTANCE_REPLACE_DISKS"
429
                      , "OP_INSTANCE_FAILOVER"
430
                      , "OP_INSTANCE_MIGRATE"
431
                      ]
432
    case op_id of
433
      "OP_TEST_DELAY" ->
434
        OpCodes.OpTestDelay <$> arbitrary <*> arbitrary
435
                 <*> resize maxNodes (listOf getFQDN)
436
      "OP_INSTANCE_REPLACE_DISKS" ->
437
        OpCodes.OpInstanceReplaceDisks <$> getFQDN <*> getMaybe getFQDN <*>
438
          arbitrary <*> resize C.maxDisks arbitrary <*> getMaybe getName
439
      "OP_INSTANCE_FAILOVER" ->
440
        OpCodes.OpInstanceFailover <$> getFQDN <*> arbitrary <*>
441
          getMaybe getFQDN
442
      "OP_INSTANCE_MIGRATE" ->
443
        OpCodes.OpInstanceMigrate <$> getFQDN <*> arbitrary <*>
444
          arbitrary <*> arbitrary <*> getMaybe getFQDN
445
      _ -> fail "Wrong opcode"
446

    
447
instance Arbitrary Jobs.OpStatus where
448
  arbitrary = elements [minBound..maxBound]
449

    
450
instance Arbitrary Jobs.JobStatus where
451
  arbitrary = elements [minBound..maxBound]
452

    
453
newtype SmallRatio = SmallRatio Double deriving Show
454
instance Arbitrary SmallRatio where
455
  arbitrary = do
456
    v <- choose (0, 1)
457
    return $ SmallRatio v
458

    
459
instance Arbitrary Types.AllocPolicy where
460
  arbitrary = elements [minBound..maxBound]
461

    
462
instance Arbitrary Types.DiskTemplate where
463
  arbitrary = elements [minBound..maxBound]
464

    
465
instance Arbitrary Types.FailMode where
466
  arbitrary = elements [minBound..maxBound]
467

    
468
instance Arbitrary Types.EvacMode where
469
  arbitrary = elements [minBound..maxBound]
470

    
471
instance Arbitrary a => Arbitrary (Types.OpResult a) where
472
  arbitrary = arbitrary >>= \c ->
473
              if c
474
                then Types.OpGood <$> arbitrary
475
                else Types.OpFail <$> arbitrary
476

    
477
instance Arbitrary Types.ISpec where
478
  arbitrary = do
479
    mem_s <- arbitrary::Gen (NonNegative Int)
480
    dsk_c <- arbitrary::Gen (NonNegative Int)
481
    dsk_s <- arbitrary::Gen (NonNegative Int)
482
    cpu_c <- arbitrary::Gen (NonNegative Int)
483
    nic_c <- arbitrary::Gen (NonNegative Int)
484
    su    <- arbitrary::Gen (NonNegative Int)
485
    return Types.ISpec { Types.iSpecMemorySize = fromIntegral mem_s
486
                       , Types.iSpecCpuCount   = fromIntegral cpu_c
487
                       , Types.iSpecDiskSize   = fromIntegral dsk_s
488
                       , Types.iSpecDiskCount  = fromIntegral dsk_c
489
                       , Types.iSpecNicCount   = fromIntegral nic_c
490
                       , Types.iSpecSpindleUse = fromIntegral su
491
                       }
492

    
493
-- | Generates an ispec bigger than the given one.
494
genBiggerISpec :: Types.ISpec -> Gen Types.ISpec
495
genBiggerISpec imin = do
496
  mem_s <- choose (Types.iSpecMemorySize imin, maxBound)
497
  dsk_c <- choose (Types.iSpecDiskCount imin, maxBound)
498
  dsk_s <- choose (Types.iSpecDiskSize imin, maxBound)
499
  cpu_c <- choose (Types.iSpecCpuCount imin, maxBound)
500
  nic_c <- choose (Types.iSpecNicCount imin, maxBound)
501
  su    <- choose (Types.iSpecSpindleUse imin, maxBound)
502
  return Types.ISpec { Types.iSpecMemorySize = fromIntegral mem_s
503
                     , Types.iSpecCpuCount   = fromIntegral cpu_c
504
                     , Types.iSpecDiskSize   = fromIntegral dsk_s
505
                     , Types.iSpecDiskCount  = fromIntegral dsk_c
506
                     , Types.iSpecNicCount   = fromIntegral nic_c
507
                     , Types.iSpecSpindleUse = fromIntegral su
508
                     }
509

    
510
instance Arbitrary Types.IPolicy where
511
  arbitrary = do
512
    imin <- arbitrary
513
    istd <- genBiggerISpec imin
514
    imax <- genBiggerISpec istd
515
    num_tmpl <- choose (0, length allDiskTemplates)
516
    dts  <- genUniquesList num_tmpl
517
    vcpu_ratio <- choose (1.0, maxVcpuRatio)
518
    spindle_ratio <- choose (1.0, maxSpindleRatio)
519
    return Types.IPolicy { Types.iPolicyMinSpec = imin
520
                         , Types.iPolicyStdSpec = istd
521
                         , Types.iPolicyMaxSpec = imax
522
                         , Types.iPolicyDiskTemplates = dts
523
                         , Types.iPolicyVcpuRatio = vcpu_ratio
524
                         , Types.iPolicySpindleRatio = spindle_ratio
525
                         }
526

    
527
-- * Actual tests
528

    
529
-- ** Utils tests
530

    
531
-- | Helper to generate a small string that doesn't contain commas.
532
genNonCommaString :: Gen [Char]
533
genNonCommaString = do
534
  size <- choose (0, 20) -- arbitrary max size
535
  vectorOf size (arbitrary `suchThat` ((/=) ','))
536

    
537
-- | If the list is not just an empty element, and if the elements do
538
-- not contain commas, then join+split should be idempotent.
539
prop_Utils_commaJoinSplit :: Property
540
prop_Utils_commaJoinSplit =
541
  forAll (choose (0, 20)) $ \llen ->
542
  forAll (vectorOf llen genNonCommaString `suchThat` ((/=) [""])) $ \lst ->
543
  Utils.sepSplit ',' (Utils.commaJoin lst) ==? lst
544

    
545
-- | Split and join should always be idempotent.
546
prop_Utils_commaSplitJoin :: [Char] -> Property
547
prop_Utils_commaSplitJoin s =
548
  Utils.commaJoin (Utils.sepSplit ',' s) ==? s
549

    
550
-- | fromObjWithDefault, we test using the Maybe monad and an integer
551
-- value.
552
prop_Utils_fromObjWithDefault :: Integer -> String -> Bool
553
prop_Utils_fromObjWithDefault def_value random_key =
554
  -- a missing key will be returned with the default
555
  JSON.fromObjWithDefault [] random_key def_value == Just def_value &&
556
  -- a found key will be returned as is, not with default
557
  JSON.fromObjWithDefault [(random_key, J.showJSON def_value)]
558
       random_key (def_value+1) == Just def_value
559

    
560
-- | Test that functional if' behaves like the syntactic sugar if.
561
prop_Utils_if'if :: Bool -> Int -> Int -> Gen Prop
562
prop_Utils_if'if cnd a b =
563
  Utils.if' cnd a b ==? if cnd then a else b
564

    
565
-- | Test basic select functionality
566
prop_Utils_select :: Int      -- ^ Default result
567
                  -> [Int]    -- ^ List of False values
568
                  -> [Int]    -- ^ List of True values
569
                  -> Gen Prop -- ^ Test result
570
prop_Utils_select def lst1 lst2 =
571
  Utils.select def (flist ++ tlist) ==? expectedresult
572
    where expectedresult = Utils.if' (null lst2) def (head lst2)
573
          flist = zip (repeat False) lst1
574
          tlist = zip (repeat True)  lst2
575

    
576
-- | Test basic select functionality with undefined default
577
prop_Utils_select_undefd :: [Int]            -- ^ List of False values
578
                         -> NonEmptyList Int -- ^ List of True values
579
                         -> Gen Prop         -- ^ Test result
580
prop_Utils_select_undefd lst1 (NonEmpty lst2) =
581
  Utils.select undefined (flist ++ tlist) ==? head lst2
582
    where flist = zip (repeat False) lst1
583
          tlist = zip (repeat True)  lst2
584

    
585
-- | Test basic select functionality with undefined list values
586
prop_Utils_select_undefv :: [Int]            -- ^ List of False values
587
                         -> NonEmptyList Int -- ^ List of True values
588
                         -> Gen Prop         -- ^ Test result
589
prop_Utils_select_undefv lst1 (NonEmpty lst2) =
590
  Utils.select undefined cndlist ==? head lst2
591
    where flist = zip (repeat False) lst1
592
          tlist = zip (repeat True)  lst2
593
          cndlist = flist ++ tlist ++ [undefined]
594

    
595
prop_Utils_parseUnit :: NonNegative Int -> Property
596
prop_Utils_parseUnit (NonNegative n) =
597
  Utils.parseUnit (show n) ==? Types.Ok n .&&.
598
  Utils.parseUnit (show n ++ "m") ==? Types.Ok n .&&.
599
  Utils.parseUnit (show n ++ "M") ==? Types.Ok (truncate n_mb::Int) .&&.
600
  Utils.parseUnit (show n ++ "g") ==? Types.Ok (n*1024) .&&.
601
  Utils.parseUnit (show n ++ "G") ==? Types.Ok (truncate n_gb::Int) .&&.
602
  Utils.parseUnit (show n ++ "t") ==? Types.Ok (n*1048576) .&&.
603
  Utils.parseUnit (show n ++ "T") ==? Types.Ok (truncate n_tb::Int) .&&.
604
  printTestCase "Internal error/overflow?"
605
    (n_mb >=0 && n_gb >= 0 && n_tb >= 0) .&&.
606
  property (Types.isBad (Utils.parseUnit (show n ++ "x")::Types.Result Int))
607
  where n_mb = (fromIntegral n::Rational) * 1000 * 1000 / 1024 / 1024
608
        n_gb = n_mb * 1000
609
        n_tb = n_gb * 1000
610

    
611
-- | Test list for the Utils module.
612
testSuite "Utils"
613
            [ 'prop_Utils_commaJoinSplit
614
            , 'prop_Utils_commaSplitJoin
615
            , 'prop_Utils_fromObjWithDefault
616
            , 'prop_Utils_if'if
617
            , 'prop_Utils_select
618
            , 'prop_Utils_select_undefd
619
            , 'prop_Utils_select_undefv
620
            , 'prop_Utils_parseUnit
621
            ]
622

    
623
-- ** PeerMap tests
624

    
625
-- | Make sure add is idempotent.
626
prop_PeerMap_addIdempotent :: PeerMap.PeerMap
627
                           -> PeerMap.Key -> PeerMap.Elem -> Property
628
prop_PeerMap_addIdempotent pmap key em =
629
  fn puniq ==? fn (fn puniq)
630
    where fn = PeerMap.add key em
631
          puniq = PeerMap.accumArray const pmap
632

    
633
-- | Make sure remove is idempotent.
634
prop_PeerMap_removeIdempotent :: PeerMap.PeerMap -> PeerMap.Key -> Property
635
prop_PeerMap_removeIdempotent pmap key =
636
  fn puniq ==? fn (fn puniq)
637
    where fn = PeerMap.remove key
638
          puniq = PeerMap.accumArray const pmap
639

    
640
-- | Make sure a missing item returns 0.
641
prop_PeerMap_findMissing :: PeerMap.PeerMap -> PeerMap.Key -> Property
642
prop_PeerMap_findMissing pmap key =
643
  PeerMap.find key (PeerMap.remove key puniq) ==? 0
644
    where puniq = PeerMap.accumArray const pmap
645

    
646
-- | Make sure an added item is found.
647
prop_PeerMap_addFind :: PeerMap.PeerMap
648
                     -> PeerMap.Key -> PeerMap.Elem -> Property
649
prop_PeerMap_addFind pmap key em =
650
  PeerMap.find key (PeerMap.add key em puniq) ==? em
651
    where puniq = PeerMap.accumArray const pmap
652

    
653
-- | Manual check that maxElem returns the maximum indeed, or 0 for null.
654
prop_PeerMap_maxElem :: PeerMap.PeerMap -> Property
655
prop_PeerMap_maxElem pmap =
656
  PeerMap.maxElem puniq ==? if null puniq then 0
657
                              else (maximum . snd . unzip) puniq
658
    where puniq = PeerMap.accumArray const pmap
659

    
660
-- | List of tests for the PeerMap module.
661
testSuite "PeerMap"
662
            [ 'prop_PeerMap_addIdempotent
663
            , 'prop_PeerMap_removeIdempotent
664
            , 'prop_PeerMap_maxElem
665
            , 'prop_PeerMap_addFind
666
            , 'prop_PeerMap_findMissing
667
            ]
668

    
669
-- ** Container tests
670

    
671
-- we silence the following due to hlint bug fixed in later versions
672
{-# ANN prop_Container_addTwo "HLint: ignore Avoid lambda" #-}
673
prop_Container_addTwo :: [Container.Key] -> Int -> Int -> Bool
674
prop_Container_addTwo cdata i1 i2 =
675
  fn i1 i2 cont == fn i2 i1 cont &&
676
  fn i1 i2 cont == fn i1 i2 (fn i1 i2 cont)
677
    where cont = foldl (\c x -> Container.add x x c) Container.empty cdata
678
          fn x1 x2 = Container.addTwo x1 x1 x2 x2
679

    
680
prop_Container_nameOf :: Node.Node -> Property
681
prop_Container_nameOf node =
682
  let nl = makeSmallCluster node 1
683
      fnode = head (Container.elems nl)
684
  in Container.nameOf nl (Node.idx fnode) ==? Node.name fnode
685

    
686
-- | We test that in a cluster, given a random node, we can find it by
687
-- its name and alias, as long as all names and aliases are unique,
688
-- and that we fail to find a non-existing name.
689
prop_Container_findByName :: Node.Node -> Property
690
prop_Container_findByName node =
691
  forAll (choose (1, 20)) $ \ cnt ->
692
  forAll (choose (0, cnt - 1)) $ \ fidx ->
693
  forAll (genUniquesList (cnt * 2)) $ \ allnames ->
694
  forAll (arbitrary `suchThat` (`notElem` allnames)) $ \ othername ->
695
  let names = zip (take cnt allnames) (drop cnt allnames)
696
      nl = makeSmallCluster node cnt
697
      nodes = Container.elems nl
698
      nodes' = map (\((name, alias), nn) -> (Node.idx nn,
699
                                             nn { Node.name = name,
700
                                                  Node.alias = alias }))
701
               $ zip names nodes
702
      nl' = Container.fromList nodes'
703
      target = snd (nodes' !! fidx)
704
  in Container.findByName nl' (Node.name target) == Just target &&
705
     Container.findByName nl' (Node.alias target) == Just target &&
706
     isNothing (Container.findByName nl' othername)
707

    
708
testSuite "Container"
709
            [ 'prop_Container_addTwo
710
            , 'prop_Container_nameOf
711
            , 'prop_Container_findByName
712
            ]
713

    
714
-- ** Instance tests
715

    
716
-- Simple instance tests, we only have setter/getters
717

    
718
prop_Instance_creat :: Instance.Instance -> Property
719
prop_Instance_creat inst =
720
  Instance.name inst ==? Instance.alias inst
721

    
722
prop_Instance_setIdx :: Instance.Instance -> Types.Idx -> Property
723
prop_Instance_setIdx inst idx =
724
  Instance.idx (Instance.setIdx inst idx) ==? idx
725

    
726
prop_Instance_setName :: Instance.Instance -> String -> Bool
727
prop_Instance_setName inst name =
728
  Instance.name newinst == name &&
729
  Instance.alias newinst == name
730
    where newinst = Instance.setName inst name
731

    
732
prop_Instance_setAlias :: Instance.Instance -> String -> Bool
733
prop_Instance_setAlias inst name =
734
  Instance.name newinst == Instance.name inst &&
735
  Instance.alias newinst == name
736
    where newinst = Instance.setAlias inst name
737

    
738
prop_Instance_setPri :: Instance.Instance -> Types.Ndx -> Property
739
prop_Instance_setPri inst pdx =
740
  Instance.pNode (Instance.setPri inst pdx) ==? pdx
741

    
742
prop_Instance_setSec :: Instance.Instance -> Types.Ndx -> Property
743
prop_Instance_setSec inst sdx =
744
  Instance.sNode (Instance.setSec inst sdx) ==? sdx
745

    
746
prop_Instance_setBoth :: Instance.Instance -> Types.Ndx -> Types.Ndx -> Bool
747
prop_Instance_setBoth inst pdx sdx =
748
  Instance.pNode si == pdx && Instance.sNode si == sdx
749
    where si = Instance.setBoth inst pdx sdx
750

    
751
prop_Instance_shrinkMG :: Instance.Instance -> Property
752
prop_Instance_shrinkMG inst =
753
  Instance.mem inst >= 2 * Types.unitMem ==>
754
    case Instance.shrinkByType inst Types.FailMem of
755
      Types.Ok inst' -> Instance.mem inst' == Instance.mem inst - Types.unitMem
756
      _ -> False
757

    
758
prop_Instance_shrinkMF :: Instance.Instance -> Property
759
prop_Instance_shrinkMF inst =
760
  forAll (choose (0, 2 * Types.unitMem - 1)) $ \mem ->
761
    let inst' = inst { Instance.mem = mem}
762
    in Types.isBad $ Instance.shrinkByType inst' Types.FailMem
763

    
764
prop_Instance_shrinkCG :: Instance.Instance -> Property
765
prop_Instance_shrinkCG inst =
766
  Instance.vcpus inst >= 2 * Types.unitCpu ==>
767
    case Instance.shrinkByType inst Types.FailCPU of
768
      Types.Ok inst' ->
769
        Instance.vcpus inst' == Instance.vcpus inst - Types.unitCpu
770
      _ -> False
771

    
772
prop_Instance_shrinkCF :: Instance.Instance -> Property
773
prop_Instance_shrinkCF inst =
774
  forAll (choose (0, 2 * Types.unitCpu - 1)) $ \vcpus ->
775
    let inst' = inst { Instance.vcpus = vcpus }
776
    in Types.isBad $ Instance.shrinkByType inst' Types.FailCPU
777

    
778
prop_Instance_shrinkDG :: Instance.Instance -> Property
779
prop_Instance_shrinkDG inst =
780
  Instance.dsk inst >= 2 * Types.unitDsk ==>
781
    case Instance.shrinkByType inst Types.FailDisk of
782
      Types.Ok inst' ->
783
        Instance.dsk inst' == Instance.dsk inst - Types.unitDsk
784
      _ -> False
785

    
786
prop_Instance_shrinkDF :: Instance.Instance -> Property
787
prop_Instance_shrinkDF inst =
788
  forAll (choose (0, 2 * Types.unitDsk - 1)) $ \dsk ->
789
    let inst' = inst { Instance.dsk = dsk }
790
    in Types.isBad $ Instance.shrinkByType inst' Types.FailDisk
791

    
792
prop_Instance_setMovable :: Instance.Instance -> Bool -> Property
793
prop_Instance_setMovable inst m =
794
  Instance.movable inst' ==? m
795
    where inst' = Instance.setMovable inst m
796

    
797
testSuite "Instance"
798
            [ 'prop_Instance_creat
799
            , 'prop_Instance_setIdx
800
            , 'prop_Instance_setName
801
            , 'prop_Instance_setAlias
802
            , 'prop_Instance_setPri
803
            , 'prop_Instance_setSec
804
            , 'prop_Instance_setBoth
805
            , 'prop_Instance_shrinkMG
806
            , 'prop_Instance_shrinkMF
807
            , 'prop_Instance_shrinkCG
808
            , 'prop_Instance_shrinkCF
809
            , 'prop_Instance_shrinkDG
810
            , 'prop_Instance_shrinkDF
811
            , 'prop_Instance_setMovable
812
            ]
813

    
814
-- ** Backends
815

    
816
-- *** Text backend tests
817

    
818
-- Instance text loader tests
819

    
820
prop_Text_Load_Instance :: String -> Int -> Int -> Int -> Types.InstanceStatus
821
                        -> NonEmptyList Char -> [Char]
822
                        -> NonNegative Int -> NonNegative Int -> Bool
823
                        -> Types.DiskTemplate -> Int -> Property
824
prop_Text_Load_Instance name mem dsk vcpus status
825
                        (NonEmpty pnode) snode
826
                        (NonNegative pdx) (NonNegative sdx) autobal dt su =
827
  pnode /= snode && pdx /= sdx ==>
828
  let vcpus_s = show vcpus
829
      dsk_s = show dsk
830
      mem_s = show mem
831
      su_s = show su
832
      status_s = Types.instanceStatusToRaw status
833
      ndx = if null snode
834
              then [(pnode, pdx)]
835
              else [(pnode, pdx), (snode, sdx)]
836
      nl = Data.Map.fromList ndx
837
      tags = ""
838
      sbal = if autobal then "Y" else "N"
839
      sdt = Types.diskTemplateToRaw dt
840
      inst = Text.loadInst nl
841
             [name, mem_s, dsk_s, vcpus_s, status_s,
842
              sbal, pnode, snode, sdt, tags, su_s]
843
      fail1 = Text.loadInst nl
844
              [name, mem_s, dsk_s, vcpus_s, status_s,
845
               sbal, pnode, pnode, tags]
846
  in case inst of
847
       Types.Bad msg -> failTest $ "Failed to load instance: " ++ msg
848
       Types.Ok (_, i) -> printTestCase "Mismatch in some field while\
849
                                        \ loading the instance" $
850
               Instance.name i == name &&
851
               Instance.vcpus i == vcpus &&
852
               Instance.mem i == mem &&
853
               Instance.pNode i == pdx &&
854
               Instance.sNode i == (if null snode
855
                                      then Node.noSecondary
856
                                      else sdx) &&
857
               Instance.autoBalance i == autobal &&
858
               Instance.spindleUse i == su &&
859
               Types.isBad fail1
860

    
861
prop_Text_Load_InstanceFail :: [(String, Int)] -> [String] -> Property
862
prop_Text_Load_InstanceFail ktn fields =
863
  length fields /= 10 && length fields /= 11 ==>
864
    case Text.loadInst nl fields of
865
      Types.Ok _ -> failTest "Managed to load instance from invalid data"
866
      Types.Bad msg -> printTestCase ("Unrecognised error message: " ++ msg) $
867
                       "Invalid/incomplete instance data: '" `isPrefixOf` msg
868
    where nl = Data.Map.fromList ktn
869

    
870
prop_Text_Load_Node :: String -> Int -> Int -> Int -> Int -> Int
871
                    -> Int -> Bool -> Bool
872
prop_Text_Load_Node name tm nm fm td fd tc fo =
873
  let conv v = if v < 0
874
                 then "?"
875
                 else show v
876
      tm_s = conv tm
877
      nm_s = conv nm
878
      fm_s = conv fm
879
      td_s = conv td
880
      fd_s = conv fd
881
      tc_s = conv tc
882
      fo_s = if fo
883
               then "Y"
884
               else "N"
885
      any_broken = any (< 0) [tm, nm, fm, td, fd, tc]
886
      gid = Group.uuid defGroup
887
  in case Text.loadNode defGroupAssoc
888
       [name, tm_s, nm_s, fm_s, td_s, fd_s, tc_s, fo_s, gid] of
889
       Nothing -> False
890
       Just (name', node) ->
891
         if fo || any_broken
892
           then Node.offline node
893
           else Node.name node == name' && name' == name &&
894
                Node.alias node == name &&
895
                Node.tMem node == fromIntegral tm &&
896
                Node.nMem node == nm &&
897
                Node.fMem node == fm &&
898
                Node.tDsk node == fromIntegral td &&
899
                Node.fDsk node == fd &&
900
                Node.tCpu node == fromIntegral tc
901

    
902
prop_Text_Load_NodeFail :: [String] -> Property
903
prop_Text_Load_NodeFail fields =
904
  length fields /= 8 ==> isNothing $ Text.loadNode Data.Map.empty fields
905

    
906
prop_Text_NodeLSIdempotent :: Node.Node -> Property
907
prop_Text_NodeLSIdempotent node =
908
  (Text.loadNode defGroupAssoc.
909
       Utils.sepSplit '|' . Text.serializeNode defGroupList) n ==?
910
  Just (Node.name n, n)
911
    -- override failN1 to what loadNode returns by default
912
    where n = Node.setPolicy Types.defIPolicy $
913
              node { Node.failN1 = True, Node.offline = False }
914

    
915
prop_Text_ISpecIdempotent :: Types.ISpec -> Property
916
prop_Text_ISpecIdempotent ispec =
917
  case Text.loadISpec "dummy" . Utils.sepSplit ',' .
918
       Text.serializeISpec $ ispec of
919
    Types.Bad msg -> failTest $ "Failed to load ispec: " ++ msg
920
    Types.Ok ispec' -> ispec ==? ispec'
921

    
922
prop_Text_IPolicyIdempotent :: Types.IPolicy -> Property
923
prop_Text_IPolicyIdempotent ipol =
924
  case Text.loadIPolicy . Utils.sepSplit '|' $
925
       Text.serializeIPolicy owner ipol of
926
    Types.Bad msg -> failTest $ "Failed to load ispec: " ++ msg
927
    Types.Ok res -> (owner, ipol) ==? res
928
  where owner = "dummy"
929

    
930
-- | This property, while being in the text tests, does more than just
931
-- test end-to-end the serialisation and loading back workflow; it
932
-- also tests the Loader.mergeData and the actuall
933
-- Cluster.iterateAlloc (for well-behaving w.r.t. instance
934
-- allocations, not for the business logic). As such, it's a quite
935
-- complex and slow test, and that's the reason we restrict it to
936
-- small cluster sizes.
937
prop_Text_CreateSerialise :: Property
938
prop_Text_CreateSerialise =
939
  forAll genTags $ \ctags ->
940
  forAll (choose (1, 20)) $ \maxiter ->
941
  forAll (choose (2, 10)) $ \count ->
942
  forAll genOnlineNode $ \node ->
943
  forAll (genInstanceSmallerThanNode node) $ \inst ->
944
  let nl = makeSmallCluster node count
945
      reqnodes = Instance.requiredNodes $ Instance.diskTemplate inst
946
  in case Cluster.genAllocNodes defGroupList nl reqnodes True >>= \allocn ->
947
     Cluster.iterateAlloc nl Container.empty (Just maxiter) inst allocn [] []
948
     of
949
       Types.Bad msg -> failTest $ "Failed to allocate: " ++ msg
950
       Types.Ok (_, _, _, [], _) -> printTestCase
951
                                    "Failed to allocate: no allocations" False
952
       Types.Ok (_, nl', il', _, _) ->
953
         let cdata = Loader.ClusterData defGroupList nl' il' ctags
954
                     Types.defIPolicy
955
             saved = Text.serializeCluster cdata
956
         in case Text.parseData saved >>= Loader.mergeData [] [] [] [] of
957
              Types.Bad msg -> failTest $ "Failed to load/merge: " ++ msg
958
              Types.Ok (Loader.ClusterData gl2 nl2 il2 ctags2 cpol2) ->
959
                ctags ==? ctags2 .&&.
960
                Types.defIPolicy ==? cpol2 .&&.
961
                il' ==? il2 .&&.
962
                defGroupList ==? gl2 .&&.
963
                nl' ==? nl2
964

    
965
testSuite "Text"
966
            [ 'prop_Text_Load_Instance
967
            , 'prop_Text_Load_InstanceFail
968
            , 'prop_Text_Load_Node
969
            , 'prop_Text_Load_NodeFail
970
            , 'prop_Text_NodeLSIdempotent
971
            , 'prop_Text_ISpecIdempotent
972
            , 'prop_Text_IPolicyIdempotent
973
            , 'prop_Text_CreateSerialise
974
            ]
975

    
976
-- *** Simu backend
977

    
978
-- | Generates a tuple of specs for simulation.
979
genSimuSpec :: Gen (String, Int, Int, Int, Int)
980
genSimuSpec = do
981
  pol <- elements [C.allocPolicyPreferred,
982
                   C.allocPolicyLastResort, C.allocPolicyUnallocable,
983
                  "p", "a", "u"]
984
 -- should be reasonable (nodes/group), bigger values only complicate
985
 -- the display of failed tests, and we don't care (in this particular
986
 -- test) about big node groups
987
  nodes <- choose (0, 20)
988
  dsk <- choose (0, maxDsk)
989
  mem <- choose (0, maxMem)
990
  cpu <- choose (0, maxCpu)
991
  return (pol, nodes, dsk, mem, cpu)
992

    
993
-- | Checks that given a set of corrects specs, we can load them
994
-- successfully, and that at high-level the values look right.
995
prop_SimuLoad :: Property
996
prop_SimuLoad =
997
  forAll (choose (0, 10)) $ \ngroups ->
998
  forAll (replicateM ngroups genSimuSpec) $ \specs ->
999
  let strspecs = map (\(p, n, d, m, c) -> printf "%s,%d,%d,%d,%d"
1000
                                          p n d m c::String) specs
1001
      totnodes = sum $ map (\(_, n, _, _, _) -> n) specs
1002
      mdc_in = concatMap (\(_, n, d, m, c) ->
1003
                            replicate n (fromIntegral m, fromIntegral d,
1004
                                         fromIntegral c,
1005
                                         fromIntegral m, fromIntegral d))
1006
               specs :: [(Double, Double, Double, Int, Int)]
1007
  in case Simu.parseData strspecs of
1008
       Types.Bad msg -> failTest $ "Failed to load specs: " ++ msg
1009
       Types.Ok (Loader.ClusterData gl nl il tags ipol) ->
1010
         let nodes = map snd $ IntMap.toAscList nl
1011
             nidx = map Node.idx nodes
1012
             mdc_out = map (\n -> (Node.tMem n, Node.tDsk n, Node.tCpu n,
1013
                                   Node.fMem n, Node.fDsk n)) nodes
1014
         in
1015
         Container.size gl ==? ngroups .&&.
1016
         Container.size nl ==? totnodes .&&.
1017
         Container.size il ==? 0 .&&.
1018
         length tags ==? 0 .&&.
1019
         ipol ==? Types.defIPolicy .&&.
1020
         nidx ==? [1..totnodes] .&&.
1021
         mdc_in ==? mdc_out .&&.
1022
         map Group.iPolicy (Container.elems gl) ==?
1023
             replicate ngroups Types.defIPolicy
1024

    
1025
testSuite "Simu"
1026
            [ 'prop_SimuLoad
1027
            ]
1028

    
1029
-- ** Node tests
1030

    
1031
prop_Node_setAlias :: Node.Node -> String -> Bool
1032
prop_Node_setAlias node name =
1033
  Node.name newnode == Node.name node &&
1034
  Node.alias newnode == name
1035
    where newnode = Node.setAlias node name
1036

    
1037
prop_Node_setOffline :: Node.Node -> Bool -> Property
1038
prop_Node_setOffline node status =
1039
  Node.offline newnode ==? status
1040
    where newnode = Node.setOffline node status
1041

    
1042
prop_Node_setXmem :: Node.Node -> Int -> Property
1043
prop_Node_setXmem node xm =
1044
  Node.xMem newnode ==? xm
1045
    where newnode = Node.setXmem node xm
1046

    
1047
prop_Node_setMcpu :: Node.Node -> Double -> Property
1048
prop_Node_setMcpu node mc =
1049
  Types.iPolicyVcpuRatio (Node.iPolicy newnode) ==? mc
1050
    where newnode = Node.setMcpu node mc
1051

    
1052
-- | Check that an instance add with too high memory or disk will be
1053
-- rejected.
1054
prop_Node_addPriFM :: Node.Node -> Instance.Instance -> Property
1055
prop_Node_addPriFM node inst =
1056
  Instance.mem inst >= Node.fMem node && not (Node.failN1 node) &&
1057
  not (Instance.isOffline inst) ==>
1058
  case Node.addPri node inst'' of
1059
    Types.OpFail Types.FailMem -> True
1060
    _ -> False
1061
  where inst' = setInstanceSmallerThanNode node inst
1062
        inst'' = inst' { Instance.mem = Instance.mem inst }
1063

    
1064
-- | Check that adding a primary instance with too much disk fails
1065
-- with type FailDisk.
1066
prop_Node_addPriFD :: Node.Node -> Instance.Instance -> Property
1067
prop_Node_addPriFD node inst =
1068
  forAll (elements Instance.localStorageTemplates) $ \dt ->
1069
  Instance.dsk inst >= Node.fDsk node && not (Node.failN1 node) ==>
1070
  let inst' = setInstanceSmallerThanNode node inst
1071
      inst'' = inst' { Instance.dsk = Instance.dsk inst
1072
                     , Instance.diskTemplate = dt }
1073
  in case Node.addPri node inst'' of
1074
       Types.OpFail Types.FailDisk -> True
1075
       _ -> False
1076

    
1077
-- | Check that adding a primary instance with too many VCPUs fails
1078
-- with type FailCPU.
1079
prop_Node_addPriFC :: Property
1080
prop_Node_addPriFC =
1081
  forAll (choose (1, maxCpu)) $ \extra ->
1082
  forAll genOnlineNode $ \node ->
1083
  forAll (arbitrary `suchThat` Instance.notOffline) $ \inst ->
1084
  let inst' = setInstanceSmallerThanNode node inst
1085
      inst'' = inst' { Instance.vcpus = Node.availCpu node + extra }
1086
  in case Node.addPri node inst'' of
1087
       Types.OpFail Types.FailCPU -> property True
1088
       v -> failTest $ "Expected OpFail FailCPU, but got " ++ show v
1089

    
1090
-- | Check that an instance add with too high memory or disk will be
1091
-- rejected.
1092
prop_Node_addSec :: Node.Node -> Instance.Instance -> Int -> Property
1093
prop_Node_addSec node inst pdx =
1094
  ((Instance.mem inst >= (Node.fMem node - Node.rMem node) &&
1095
    not (Instance.isOffline inst)) ||
1096
   Instance.dsk inst >= Node.fDsk node) &&
1097
  not (Node.failN1 node) ==>
1098
      isFailure (Node.addSec node inst pdx)
1099

    
1100
-- | Check that an offline instance with reasonable disk size but
1101
-- extra mem/cpu can always be added.
1102
prop_Node_addOfflinePri :: NonNegative Int -> NonNegative Int -> Property
1103
prop_Node_addOfflinePri (NonNegative extra_mem) (NonNegative extra_cpu) =
1104
  forAll genOnlineNode $ \node ->
1105
  forAll (genInstanceSmallerThanNode node) $ \inst ->
1106
  let inst' = inst { Instance.runSt = Types.AdminOffline
1107
                   , Instance.mem = Node.availMem node + extra_mem
1108
                   , Instance.vcpus = Node.availCpu node + extra_cpu }
1109
  in case Node.addPri node inst' of
1110
       Types.OpGood _ -> property True
1111
       v -> failTest $ "Expected OpGood, but got: " ++ show v
1112

    
1113
-- | Check that an offline instance with reasonable disk size but
1114
-- extra mem/cpu can always be added.
1115
prop_Node_addOfflineSec :: NonNegative Int -> NonNegative Int
1116
                        -> Types.Ndx -> Property
1117
prop_Node_addOfflineSec (NonNegative extra_mem) (NonNegative extra_cpu) pdx =
1118
  forAll genOnlineNode $ \node ->
1119
  forAll (genInstanceSmallerThanNode node) $ \inst ->
1120
  let inst' = inst { Instance.runSt = Types.AdminOffline
1121
                   , Instance.mem = Node.availMem node + extra_mem
1122
                   , Instance.vcpus = Node.availCpu node + extra_cpu
1123
                   , Instance.diskTemplate = Types.DTDrbd8 }
1124
  in case Node.addSec node inst' pdx of
1125
       Types.OpGood _ -> property True
1126
       v -> failTest $ "Expected OpGood/OpGood, but got: " ++ show v
1127

    
1128
-- | Checks for memory reservation changes.
1129
prop_Node_rMem :: Instance.Instance -> Property
1130
prop_Node_rMem inst =
1131
  not (Instance.isOffline inst) ==>
1132
  forAll (genOnlineNode `suchThat` ((> Types.unitMem) . Node.fMem)) $ \node ->
1133
  -- ab = auto_balance, nb = non-auto_balance
1134
  -- we use -1 as the primary node of the instance
1135
  let inst' = inst { Instance.pNode = -1, Instance.autoBalance = True
1136
                   , Instance.diskTemplate = Types.DTDrbd8 }
1137
      inst_ab = setInstanceSmallerThanNode node inst'
1138
      inst_nb = inst_ab { Instance.autoBalance = False }
1139
      -- now we have the two instances, identical except the
1140
      -- autoBalance attribute
1141
      orig_rmem = Node.rMem node
1142
      inst_idx = Instance.idx inst_ab
1143
      node_add_ab = Node.addSec node inst_ab (-1)
1144
      node_add_nb = Node.addSec node inst_nb (-1)
1145
      node_del_ab = liftM (`Node.removeSec` inst_ab) node_add_ab
1146
      node_del_nb = liftM (`Node.removeSec` inst_nb) node_add_nb
1147
  in case (node_add_ab, node_add_nb, node_del_ab, node_del_nb) of
1148
       (Types.OpGood a_ab, Types.OpGood a_nb,
1149
        Types.OpGood d_ab, Types.OpGood d_nb) ->
1150
         printTestCase "Consistency checks failed" $
1151
           Node.rMem a_ab >  orig_rmem &&
1152
           Node.rMem a_ab - orig_rmem == Instance.mem inst_ab &&
1153
           Node.rMem a_nb == orig_rmem &&
1154
           Node.rMem d_ab == orig_rmem &&
1155
           Node.rMem d_nb == orig_rmem &&
1156
           -- this is not related to rMem, but as good a place to
1157
           -- test as any
1158
           inst_idx `elem` Node.sList a_ab &&
1159
           inst_idx `notElem` Node.sList d_ab
1160
       x -> failTest $ "Failed to add/remove instances: " ++ show x
1161

    
1162
-- | Check mdsk setting.
1163
prop_Node_setMdsk :: Node.Node -> SmallRatio -> Bool
1164
prop_Node_setMdsk node mx =
1165
  Node.loDsk node' >= 0 &&
1166
  fromIntegral (Node.loDsk node') <= Node.tDsk node &&
1167
  Node.availDisk node' >= 0 &&
1168
  Node.availDisk node' <= Node.fDsk node' &&
1169
  fromIntegral (Node.availDisk node') <= Node.tDsk node' &&
1170
  Node.mDsk node' == mx'
1171
    where node' = Node.setMdsk node mx'
1172
          SmallRatio mx' = mx
1173

    
1174
-- Check tag maps
1175
prop_Node_tagMaps_idempotent :: Property
1176
prop_Node_tagMaps_idempotent =
1177
  forAll genTags $ \tags ->
1178
  Node.delTags (Node.addTags m tags) tags ==? m
1179
    where m = Data.Map.empty
1180

    
1181
prop_Node_tagMaps_reject :: Property
1182
prop_Node_tagMaps_reject =
1183
  forAll (genTags `suchThat` (not . null)) $ \tags ->
1184
  let m = Node.addTags Data.Map.empty tags
1185
  in all (\t -> Node.rejectAddTags m [t]) tags
1186

    
1187
prop_Node_showField :: Node.Node -> Property
1188
prop_Node_showField node =
1189
  forAll (elements Node.defaultFields) $ \ field ->
1190
  fst (Node.showHeader field) /= Types.unknownField &&
1191
  Node.showField node field /= Types.unknownField
1192

    
1193
prop_Node_computeGroups :: [Node.Node] -> Bool
1194
prop_Node_computeGroups nodes =
1195
  let ng = Node.computeGroups nodes
1196
      onlyuuid = map fst ng
1197
  in length nodes == sum (map (length . snd) ng) &&
1198
     all (\(guuid, ns) -> all ((== guuid) . Node.group) ns) ng &&
1199
     length (nub onlyuuid) == length onlyuuid &&
1200
     (null nodes || not (null ng))
1201

    
1202
-- Check idempotence of add/remove operations
1203
prop_Node_addPri_idempotent :: Property
1204
prop_Node_addPri_idempotent =
1205
  forAll genOnlineNode $ \node ->
1206
  forAll (genInstanceSmallerThanNode node) $ \inst ->
1207
  case Node.addPri node inst of
1208
    Types.OpGood node' -> Node.removePri node' inst ==? node
1209
    _ -> failTest "Can't add instance"
1210

    
1211
prop_Node_addSec_idempotent :: Property
1212
prop_Node_addSec_idempotent =
1213
  forAll genOnlineNode $ \node ->
1214
  forAll (genInstanceSmallerThanNode node) $ \inst ->
1215
  let pdx = Node.idx node + 1
1216
      inst' = Instance.setPri inst pdx
1217
      inst'' = inst' { Instance.diskTemplate = Types.DTDrbd8 }
1218
  in case Node.addSec node inst'' pdx of
1219
       Types.OpGood node' -> Node.removeSec node' inst'' ==? node
1220
       _ -> failTest "Can't add instance"
1221

    
1222
testSuite "Node"
1223
            [ 'prop_Node_setAlias
1224
            , 'prop_Node_setOffline
1225
            , 'prop_Node_setMcpu
1226
            , 'prop_Node_setXmem
1227
            , 'prop_Node_addPriFM
1228
            , 'prop_Node_addPriFD
1229
            , 'prop_Node_addPriFC
1230
            , 'prop_Node_addSec
1231
            , 'prop_Node_addOfflinePri
1232
            , 'prop_Node_addOfflineSec
1233
            , 'prop_Node_rMem
1234
            , 'prop_Node_setMdsk
1235
            , 'prop_Node_tagMaps_idempotent
1236
            , 'prop_Node_tagMaps_reject
1237
            , 'prop_Node_showField
1238
            , 'prop_Node_computeGroups
1239
            , 'prop_Node_addPri_idempotent
1240
            , 'prop_Node_addSec_idempotent
1241
            ]
1242

    
1243
-- ** Cluster tests
1244

    
1245
-- | Check that the cluster score is close to zero for a homogeneous
1246
-- cluster.
1247
prop_Score_Zero :: Node.Node -> Property
1248
prop_Score_Zero node =
1249
  forAll (choose (1, 1024)) $ \count ->
1250
    (not (Node.offline node) && not (Node.failN1 node) && (count > 0) &&
1251
     (Node.tDsk node > 0) && (Node.tMem node > 0)) ==>
1252
  let fn = Node.buildPeers node Container.empty
1253
      nlst = replicate count fn
1254
      score = Cluster.compCVNodes nlst
1255
  -- we can't say == 0 here as the floating point errors accumulate;
1256
  -- this should be much lower than the default score in CLI.hs
1257
  in score <= 1e-12
1258

    
1259
-- | Check that cluster stats are sane.
1260
prop_CStats_sane :: Property
1261
prop_CStats_sane =
1262
  forAll (choose (1, 1024)) $ \count ->
1263
  forAll genOnlineNode $ \node ->
1264
  let fn = Node.buildPeers node Container.empty
1265
      nlst = zip [1..] $ replicate count fn::[(Types.Ndx, Node.Node)]
1266
      nl = Container.fromList nlst
1267
      cstats = Cluster.totalResources nl
1268
  in Cluster.csAdsk cstats >= 0 &&
1269
     Cluster.csAdsk cstats <= Cluster.csFdsk cstats
1270

    
1271
-- | Check that one instance is allocated correctly, without
1272
-- rebalances needed.
1273
prop_ClusterAlloc_sane :: Instance.Instance -> Property
1274
prop_ClusterAlloc_sane inst =
1275
  forAll (choose (5, 20)) $ \count ->
1276
  forAll genOnlineNode $ \node ->
1277
  let (nl, il, inst') = makeSmallEmptyCluster node count inst
1278
      reqnodes = Instance.requiredNodes $ Instance.diskTemplate inst
1279
  in case Cluster.genAllocNodes defGroupList nl reqnodes True >>=
1280
     Cluster.tryAlloc nl il inst' of
1281
       Types.Bad _ -> False
1282
       Types.Ok as ->
1283
         case Cluster.asSolution as of
1284
           Nothing -> False
1285
           Just (xnl, xi, _, cv) ->
1286
             let il' = Container.add (Instance.idx xi) xi il
1287
                 tbl = Cluster.Table xnl il' cv []
1288
             in not (canBalance tbl True True False)
1289

    
1290
-- | Checks that on a 2-5 node cluster, we can allocate a random
1291
-- instance spec via tiered allocation (whatever the original instance
1292
-- spec), on either one or two nodes. Furthermore, we test that
1293
-- computed allocation statistics are correct.
1294
prop_ClusterCanTieredAlloc :: Instance.Instance -> Property
1295
prop_ClusterCanTieredAlloc inst =
1296
  forAll (choose (2, 5)) $ \count ->
1297
  forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
1298
  let nl = makeSmallCluster node count
1299
      il = Container.empty
1300
      rqnodes = Instance.requiredNodes $ Instance.diskTemplate inst
1301
      allocnodes = Cluster.genAllocNodes defGroupList nl rqnodes True
1302
  in case allocnodes >>= \allocnodes' ->
1303
    Cluster.tieredAlloc nl il (Just 1) inst allocnodes' [] [] of
1304
       Types.Bad msg -> failTest $ "Failed to tiered alloc: " ++ msg
1305
       Types.Ok (_, nl', il', ixes, cstats) ->
1306
         let (ai_alloc, ai_pool, ai_unav) =
1307
               Cluster.computeAllocationDelta
1308
                (Cluster.totalResources nl)
1309
                (Cluster.totalResources nl')
1310
             all_nodes = Container.elems nl
1311
         in property (not (null ixes)) .&&.
1312
            IntMap.size il' ==? length ixes .&&.
1313
            length ixes ==? length cstats .&&.
1314
            sum (map Types.allocInfoVCpus [ai_alloc, ai_pool, ai_unav]) ==?
1315
              sum (map Node.hiCpu all_nodes) .&&.
1316
            sum (map Types.allocInfoNCpus [ai_alloc, ai_pool, ai_unav]) ==?
1317
              sum (map Node.tCpu all_nodes) .&&.
1318
            sum (map Types.allocInfoMem [ai_alloc, ai_pool, ai_unav]) ==?
1319
              truncate (sum (map Node.tMem all_nodes)) .&&.
1320
            sum (map Types.allocInfoDisk [ai_alloc, ai_pool, ai_unav]) ==?
1321
              truncate (sum (map Node.tDsk all_nodes))
1322

    
1323
-- | Helper function to create a cluster with the given range of nodes
1324
-- and allocate an instance on it.
1325
genClusterAlloc :: Int -> Node.Node -> Instance.Instance
1326
                -> Types.Result (Node.List, Instance.List, Instance.Instance)
1327
genClusterAlloc count node inst =
1328
  let nl = makeSmallCluster node count
1329
      reqnodes = Instance.requiredNodes $ Instance.diskTemplate inst
1330
  in case Cluster.genAllocNodes defGroupList nl reqnodes True >>=
1331
     Cluster.tryAlloc nl Container.empty inst of
1332
       Types.Bad _ -> Types.Bad "Can't allocate"
1333
       Types.Ok as ->
1334
         case Cluster.asSolution as of
1335
           Nothing -> Types.Bad "Empty solution?"
1336
           Just (xnl, xi, _, _) ->
1337
             let xil = Container.add (Instance.idx xi) xi Container.empty
1338
             in Types.Ok (xnl, xil, xi)
1339

    
1340
-- | Checks that on a 4-8 node cluster, once we allocate an instance,
1341
-- we can also relocate it.
1342
prop_ClusterAllocRelocate :: Property
1343
prop_ClusterAllocRelocate =
1344
  forAll (choose (4, 8)) $ \count ->
1345
  forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
1346
  forAll (genInstanceSmallerThanNode node `suchThat` isMirrored) $ \inst ->
1347
  case genClusterAlloc count node inst of
1348
    Types.Bad msg -> failTest msg
1349
    Types.Ok (nl, il, inst') ->
1350
      case IAlloc.processRelocate defGroupList nl il
1351
             (Instance.idx inst) 1
1352
             [(if Instance.diskTemplate inst' == Types.DTDrbd8
1353
                 then Instance.sNode
1354
                 else Instance.pNode) inst'] of
1355
        Types.Ok _ -> property True
1356
        Types.Bad msg -> failTest $ "Failed to relocate: " ++ msg
1357

    
1358
-- | Helper property checker for the result of a nodeEvac or
1359
-- changeGroup operation.
1360
check_EvacMode :: Group.Group -> Instance.Instance
1361
               -> Types.Result (Node.List, Instance.List, Cluster.EvacSolution)
1362
               -> Property
1363
check_EvacMode grp inst result =
1364
  case result of
1365
    Types.Bad msg -> failTest $ "Couldn't evacuate/change group:" ++ msg
1366
    Types.Ok (_, _, es) ->
1367
      let moved = Cluster.esMoved es
1368
          failed = Cluster.esFailed es
1369
          opcodes = not . null $ Cluster.esOpCodes es
1370
      in failmsg ("'failed' not empty: " ++ show failed) (null failed) .&&.
1371
         failmsg "'opcodes' is null" opcodes .&&.
1372
         case moved of
1373
           [(idx', gdx, _)] -> failmsg "invalid instance moved" (idx == idx')
1374
                               .&&.
1375
                               failmsg "wrong target group"
1376
                                         (gdx == Group.idx grp)
1377
           v -> failmsg  ("invalid solution: " ++ show v) False
1378
  where failmsg :: String -> Bool -> Property
1379
        failmsg = \msg -> printTestCase ("Failed to evacuate: " ++ msg)
1380
        idx = Instance.idx inst
1381

    
1382
-- | Checks that on a 4-8 node cluster, once we allocate an instance,
1383
-- we can also node-evacuate it.
1384
prop_ClusterAllocEvacuate :: Property
1385
prop_ClusterAllocEvacuate =
1386
  forAll (choose (4, 8)) $ \count ->
1387
  forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
1388
  forAll (genInstanceSmallerThanNode node `suchThat` isMirrored) $ \inst ->
1389
  case genClusterAlloc count node inst of
1390
    Types.Bad msg -> failTest msg
1391
    Types.Ok (nl, il, inst') ->
1392
      conjoin $ map (\mode -> check_EvacMode defGroup inst' $
1393
                              Cluster.tryNodeEvac defGroupList nl il mode
1394
                                [Instance.idx inst']) .
1395
                              evacModeOptions .
1396
                              Instance.mirrorType $ inst'
1397

    
1398
-- | Checks that on a 4-8 node cluster with two node groups, once we
1399
-- allocate an instance on the first node group, we can also change
1400
-- its group.
1401
prop_ClusterAllocChangeGroup :: Property
1402
prop_ClusterAllocChangeGroup =
1403
  forAll (choose (4, 8)) $ \count ->
1404
  forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
1405
  forAll (genInstanceSmallerThanNode node `suchThat` isMirrored) $ \inst ->
1406
  case genClusterAlloc count node inst of
1407
    Types.Bad msg -> failTest msg
1408
    Types.Ok (nl, il, inst') ->
1409
      -- we need to add a second node group and nodes to the cluster
1410
      let nl2 = Container.elems $ makeSmallCluster node count
1411
          grp2 = Group.setIdx defGroup (Group.idx defGroup + 1)
1412
          maxndx = maximum . map Node.idx $ nl2
1413
          nl3 = map (\n -> n { Node.group = Group.idx grp2
1414
                             , Node.idx = Node.idx n + maxndx }) nl2
1415
          nl4 = Container.fromList . map (\n -> (Node.idx n, n)) $ nl3
1416
          gl' = Container.add (Group.idx grp2) grp2 defGroupList
1417
          nl' = IntMap.union nl nl4
1418
      in check_EvacMode grp2 inst' $
1419
         Cluster.tryChangeGroup gl' nl' il [] [Instance.idx inst']
1420

    
1421
-- | Check that allocating multiple instances on a cluster, then
1422
-- adding an empty node, results in a valid rebalance.
1423
prop_ClusterAllocBalance :: Property
1424
prop_ClusterAllocBalance =
1425
  forAll (genNode (Just 5) (Just 128)) $ \node ->
1426
  forAll (choose (3, 5)) $ \count ->
1427
  not (Node.offline node) && not (Node.failN1 node) ==>
1428
  let nl = makeSmallCluster node count
1429
      (hnode, nl') = IntMap.deleteFindMax nl
1430
      il = Container.empty
1431
      allocnodes = Cluster.genAllocNodes defGroupList nl' 2 True
1432
      i_templ = createInstance Types.unitMem Types.unitDsk Types.unitCpu
1433
  in case allocnodes >>= \allocnodes' ->
1434
    Cluster.iterateAlloc nl' il (Just 5) i_templ allocnodes' [] [] of
1435
       Types.Bad msg -> failTest $ "Failed to allocate: " ++ msg
1436
       Types.Ok (_, _, _, [], _) -> failTest "Failed to allocate: no instances"
1437
       Types.Ok (_, xnl, il', _, _) ->
1438
         let ynl = Container.add (Node.idx hnode) hnode xnl
1439
             cv = Cluster.compCV ynl
1440
             tbl = Cluster.Table ynl il' cv []
1441
         in printTestCase "Failed to rebalance" $
1442
            canBalance tbl True True False
1443

    
1444
-- | Checks consistency.
1445
prop_ClusterCheckConsistency :: Node.Node -> Instance.Instance -> Bool
1446
prop_ClusterCheckConsistency node inst =
1447
  let nl = makeSmallCluster node 3
1448
      [node1, node2, node3] = Container.elems nl
1449
      node3' = node3 { Node.group = 1 }
1450
      nl' = Container.add (Node.idx node3') node3' nl
1451
      inst1 = Instance.setBoth inst (Node.idx node1) (Node.idx node2)
1452
      inst2 = Instance.setBoth inst (Node.idx node1) Node.noSecondary
1453
      inst3 = Instance.setBoth inst (Node.idx node1) (Node.idx node3)
1454
      ccheck = Cluster.findSplitInstances nl' . Container.fromList
1455
  in null (ccheck [(0, inst1)]) &&
1456
     null (ccheck [(0, inst2)]) &&
1457
     (not . null $ ccheck [(0, inst3)])
1458

    
1459
-- | For now, we only test that we don't lose instances during the split.
1460
prop_ClusterSplitCluster :: Node.Node -> Instance.Instance -> Property
1461
prop_ClusterSplitCluster node inst =
1462
  forAll (choose (0, 100)) $ \icnt ->
1463
  let nl = makeSmallCluster node 2
1464
      (nl', il') = foldl (\(ns, is) _ -> assignInstance ns is inst 0 1)
1465
                   (nl, Container.empty) [1..icnt]
1466
      gni = Cluster.splitCluster nl' il'
1467
  in sum (map (Container.size . snd . snd) gni) == icnt &&
1468
     all (\(guuid, (nl'', _)) -> all ((== guuid) . Node.group)
1469
                                 (Container.elems nl'')) gni
1470

    
1471
-- | Helper function to check if we can allocate an instance on a
1472
-- given node list.
1473
canAllocOn :: Node.List -> Int -> Instance.Instance -> Bool
1474
canAllocOn nl reqnodes inst =
1475
  case Cluster.genAllocNodes defGroupList nl reqnodes True >>=
1476
       Cluster.tryAlloc nl (Container.empty) inst of
1477
       Types.Bad _ -> False
1478
       Types.Ok as ->
1479
         case Cluster.asSolution as of
1480
           Nothing -> False
1481
           Just _ -> True
1482

    
1483
-- | Checks that allocation obeys minimum and maximum instance
1484
-- policies. The unittest generates a random node, duplicates it /count/
1485
-- times, and generates a random instance that can be allocated on
1486
-- this mini-cluster; it then checks that after applying a policy that
1487
-- the instance doesn't fits, the allocation fails.
1488
prop_ClusterAllocPolicy :: Node.Node -> Property
1489
prop_ClusterAllocPolicy node =
1490
  -- rqn is the required nodes (1 or 2)
1491
  forAll (choose (1, 2)) $ \rqn ->
1492
  forAll (choose (5, 20)) $ \count ->
1493
  forAll (arbitrary `suchThat` (canAllocOn (makeSmallCluster node count) rqn))
1494
         $ \inst ->
1495
  forAll (arbitrary `suchThat` (isFailure .
1496
                                Instance.instMatchesPolicy inst)) $ \ipol ->
1497
  let node' = Node.setPolicy ipol node
1498
      nl = makeSmallCluster node' count
1499
  in not $ canAllocOn nl rqn inst
1500

    
1501
testSuite "Cluster"
1502
            [ 'prop_Score_Zero
1503
            , 'prop_CStats_sane
1504
            , 'prop_ClusterAlloc_sane
1505
            , 'prop_ClusterCanTieredAlloc
1506
            , 'prop_ClusterAllocRelocate
1507
            , 'prop_ClusterAllocEvacuate
1508
            , 'prop_ClusterAllocChangeGroup
1509
            , 'prop_ClusterAllocBalance
1510
            , 'prop_ClusterCheckConsistency
1511
            , 'prop_ClusterSplitCluster
1512
            , 'prop_ClusterAllocPolicy
1513
            ]
1514

    
1515
-- ** OpCodes tests
1516

    
1517
-- | Check that opcode serialization is idempotent.
1518
prop_OpCodes_serialization :: OpCodes.OpCode -> Property
1519
prop_OpCodes_serialization op =
1520
  case J.readJSON (J.showJSON op) of
1521
    J.Error e -> failTest $ "Cannot deserialise: " ++ e
1522
    J.Ok op' -> op ==? op'
1523

    
1524
testSuite "OpCodes"
1525
            [ 'prop_OpCodes_serialization ]
1526

    
1527
-- ** Jobs tests
1528

    
1529
-- | Check that (queued) job\/opcode status serialization is idempotent.
1530
prop_OpStatus_serialization :: Jobs.OpStatus -> Property
1531
prop_OpStatus_serialization os =
1532
  case J.readJSON (J.showJSON os) of
1533
    J.Error e -> failTest $ "Cannot deserialise: " ++ e
1534
    J.Ok os' -> os ==? os'
1535

    
1536
prop_JobStatus_serialization :: Jobs.JobStatus -> Property
1537
prop_JobStatus_serialization js =
1538
  case J.readJSON (J.showJSON js) of
1539
    J.Error e -> failTest $ "Cannot deserialise: " ++ e
1540
    J.Ok js' -> js ==? js'
1541

    
1542
testSuite "Jobs"
1543
            [ 'prop_OpStatus_serialization
1544
            , 'prop_JobStatus_serialization
1545
            ]
1546

    
1547
-- ** Loader tests
1548

    
1549
prop_Loader_lookupNode :: [(String, Int)] -> String -> String -> Property
1550
prop_Loader_lookupNode ktn inst node =
1551
  Loader.lookupNode nl inst node ==? Data.Map.lookup node nl
1552
    where nl = Data.Map.fromList ktn
1553

    
1554
prop_Loader_lookupInstance :: [(String, Int)] -> String -> Property
1555
prop_Loader_lookupInstance kti inst =
1556
  Loader.lookupInstance il inst ==? Data.Map.lookup inst il
1557
    where il = Data.Map.fromList kti
1558

    
1559
prop_Loader_assignIndices :: Property
1560
prop_Loader_assignIndices =
1561
  -- generate nodes with unique names
1562
  forAll (arbitrary `suchThat`
1563
          (\nodes ->
1564
             let names = map Node.name nodes
1565
             in length names == length (nub names))) $ \nodes ->
1566
  let (nassoc, kt) =
1567
        Loader.assignIndices (map (\n -> (Node.name n, n)) nodes)
1568
  in Data.Map.size nassoc == length nodes &&
1569
     Container.size kt == length nodes &&
1570
     if not (null nodes)
1571
       then maximum (IntMap.keys kt) == length nodes - 1
1572
       else True
1573

    
1574
-- | Checks that the number of primary instances recorded on the nodes
1575
-- is zero.
1576
prop_Loader_mergeData :: [Node.Node] -> Bool
1577
prop_Loader_mergeData ns =
1578
  let na = Container.fromList $ map (\n -> (Node.idx n, n)) ns
1579
  in case Loader.mergeData [] [] [] []
1580
         (Loader.emptyCluster {Loader.cdNodes = na}) of
1581
    Types.Bad _ -> False
1582
    Types.Ok (Loader.ClusterData _ nl il _ _) ->
1583
      let nodes = Container.elems nl
1584
          instances = Container.elems il
1585
      in (sum . map (length . Node.pList)) nodes == 0 &&
1586
         null instances
1587

    
1588
-- | Check that compareNameComponent on equal strings works.
1589
prop_Loader_compareNameComponent_equal :: String -> Bool
1590
prop_Loader_compareNameComponent_equal s =
1591
  Loader.compareNameComponent s s ==
1592
    Loader.LookupResult Loader.ExactMatch s
1593

    
1594
-- | Check that compareNameComponent on prefix strings works.
1595
prop_Loader_compareNameComponent_prefix :: NonEmptyList Char -> String -> Bool
1596
prop_Loader_compareNameComponent_prefix (NonEmpty s1) s2 =
1597
  Loader.compareNameComponent (s1 ++ "." ++ s2) s1 ==
1598
    Loader.LookupResult Loader.PartialMatch s1
1599

    
1600
testSuite "Loader"
1601
            [ 'prop_Loader_lookupNode
1602
            , 'prop_Loader_lookupInstance
1603
            , 'prop_Loader_assignIndices
1604
            , 'prop_Loader_mergeData
1605
            , 'prop_Loader_compareNameComponent_equal
1606
            , 'prop_Loader_compareNameComponent_prefix
1607
            ]
1608

    
1609
-- ** Types tests
1610

    
1611
prop_Types_AllocPolicy_serialisation :: Types.AllocPolicy -> Property
1612
prop_Types_AllocPolicy_serialisation apol =
1613
  case J.readJSON (J.showJSON apol) of
1614
    J.Ok p -> p ==? apol
1615
    J.Error s -> failTest $ "Failed to deserialise: " ++ s
1616

    
1617
prop_Types_DiskTemplate_serialisation :: Types.DiskTemplate -> Property
1618
prop_Types_DiskTemplate_serialisation dt =
1619
  case J.readJSON (J.showJSON dt) of
1620
    J.Ok p -> p ==? dt
1621
    J.Error s -> failTest $ "Failed to deserialise: " ++ s
1622

    
1623
prop_Types_ISpec_serialisation :: Types.ISpec -> Property
1624
prop_Types_ISpec_serialisation ispec =
1625
  case J.readJSON (J.showJSON ispec) of
1626
    J.Ok p -> p ==? ispec
1627
    J.Error s -> failTest $ "Failed to deserialise: " ++ s
1628

    
1629
prop_Types_IPolicy_serialisation :: Types.IPolicy -> Property
1630
prop_Types_IPolicy_serialisation ipol =
1631
  case J.readJSON (J.showJSON ipol) of
1632
    J.Ok p -> p ==? ipol
1633
    J.Error s -> failTest $ "Failed to deserialise: " ++ s
1634

    
1635
prop_Types_EvacMode_serialisation :: Types.EvacMode -> Property
1636
prop_Types_EvacMode_serialisation em =
1637
  case J.readJSON (J.showJSON em) of
1638
    J.Ok p -> p ==? em
1639
    J.Error s -> failTest $ "Failed to deserialise: " ++ s
1640

    
1641
prop_Types_opToResult :: Types.OpResult Int -> Bool
1642
prop_Types_opToResult op =
1643
  case op of
1644
    Types.OpFail _ -> Types.isBad r
1645
    Types.OpGood v -> case r of
1646
                        Types.Bad _ -> False
1647
                        Types.Ok v' -> v == v'
1648
  where r = Types.opToResult op
1649

    
1650
prop_Types_eitherToResult :: Either String Int -> Bool
1651
prop_Types_eitherToResult ei =
1652
  case ei of
1653
    Left _ -> Types.isBad r
1654
    Right v -> case r of
1655
                 Types.Bad _ -> False
1656
                 Types.Ok v' -> v == v'
1657
    where r = Types.eitherToResult ei
1658

    
1659
testSuite "Types"
1660
            [ 'prop_Types_AllocPolicy_serialisation
1661
            , 'prop_Types_DiskTemplate_serialisation
1662
            , 'prop_Types_ISpec_serialisation
1663
            , 'prop_Types_IPolicy_serialisation
1664
            , 'prop_Types_EvacMode_serialisation
1665
            , 'prop_Types_opToResult
1666
            , 'prop_Types_eitherToResult
1667
            ]
1668

    
1669
-- ** CLI tests
1670

    
1671
-- | Test correct parsing.
1672
prop_CLI_parseISpec :: String -> Int -> Int -> Int -> Property
1673
prop_CLI_parseISpec descr dsk mem cpu =
1674
  let str = printf "%d,%d,%d" dsk mem cpu::String
1675
  in CLI.parseISpecString descr str ==? Types.Ok (Types.RSpec cpu mem dsk)
1676

    
1677
-- | Test parsing failure due to wrong section count.
1678
prop_CLI_parseISpecFail :: String -> Property
1679
prop_CLI_parseISpecFail descr =
1680
  forAll (choose (0,100) `suchThat` ((/=) 3)) $ \nelems ->
1681
  forAll (replicateM nelems arbitrary) $ \values ->
1682
  let str = intercalate "," $ map show (values::[Int])
1683
  in case CLI.parseISpecString descr str of
1684
       Types.Ok v -> failTest $ "Expected failure, got " ++ show v
1685
       _ -> property True
1686

    
1687
-- | Test parseYesNo.
1688
prop_CLI_parseYesNo :: Bool -> Bool -> [Char] -> Property
1689
prop_CLI_parseYesNo def testval val =
1690
  forAll (elements [val, "yes", "no"]) $ \actual_val ->
1691
  if testval
1692
    then CLI.parseYesNo def Nothing ==? Types.Ok def
1693
    else let result = CLI.parseYesNo def (Just actual_val)
1694
         in if actual_val `elem` ["yes", "no"]
1695
              then result ==? Types.Ok (actual_val == "yes")
1696
              else property $ Types.isBad result
1697

    
1698
-- | Helper to check for correct parsing of string arg.
1699
checkStringArg :: [Char]
1700
               -> (GetOpt.OptDescr (CLI.Options -> Types.Result CLI.Options),
1701
                   CLI.Options -> Maybe [Char])
1702
               -> Property
1703
checkStringArg val (opt, fn) =
1704
  let GetOpt.Option _ longs _ _ = opt
1705
  in case longs of
1706
       [] -> failTest "no long options?"
1707
       cmdarg:_ ->
1708
         case CLI.parseOptsInner ["--" ++ cmdarg ++ "=" ++ val] "prog" [opt] of
1709
           Left e -> failTest $ "Failed to parse option: " ++ show e
1710
           Right (options, _) -> fn options ==? Just val
1711

    
1712
-- | Test a few string arguments.
1713
prop_CLI_StringArg :: [Char] -> Property
1714
prop_CLI_StringArg argument =
1715
  let args = [ (CLI.oDataFile,      CLI.optDataFile)
1716
             , (CLI.oDynuFile,      CLI.optDynuFile)
1717
             , (CLI.oSaveCluster,   CLI.optSaveCluster)
1718
             , (CLI.oReplay,        CLI.optReplay)
1719
             , (CLI.oPrintCommands, CLI.optShowCmds)
1720
             , (CLI.oLuxiSocket,    CLI.optLuxi)
1721
             ]
1722
  in conjoin $ map (checkStringArg argument) args
1723

    
1724
-- | Helper to test that a given option is accepted OK with quick exit.
1725
checkEarlyExit :: String -> [CLI.OptType] -> String -> Property
1726
checkEarlyExit name options param =
1727
  case CLI.parseOptsInner [param] name options of
1728
    Left (code, _) -> if code == 0
1729
                          then property True
1730
                          else failTest $ "Program " ++ name ++
1731
                                 " returns invalid code " ++ show code ++
1732
                                 " for option " ++ param
1733
    _ -> failTest $ "Program " ++ name ++ " doesn't consider option " ++
1734
         param ++ " as early exit one"
1735

    
1736
-- | Test that all binaries support some common options. There is
1737
-- nothing actually random about this test...
1738
prop_CLI_stdopts :: Property
1739
prop_CLI_stdopts =
1740
  let params = ["-h", "--help", "-V", "--version"]
1741
      opts = map (\(name, (_, o)) -> (name, o)) Program.personalities
1742
      -- apply checkEarlyExit across the cartesian product of params and opts
1743
  in conjoin [checkEarlyExit n o p | p <- params, (n, o) <- opts]
1744

    
1745
testSuite "CLI"
1746
          [ 'prop_CLI_parseISpec
1747
          , 'prop_CLI_parseISpecFail
1748
          , 'prop_CLI_parseYesNo
1749
          , 'prop_CLI_StringArg
1750
          , 'prop_CLI_stdopts
1751
          ]
1752

    
1753
-- * JSON tests
1754

    
1755
prop_JSON_toArray :: [Int] -> Property
1756
prop_JSON_toArray intarr =
1757
  let arr = map J.showJSON intarr in
1758
  case JSON.toArray (J.JSArray arr) of
1759
    Types.Ok arr' -> arr ==? arr'
1760
    Types.Bad err -> failTest $ "Failed to parse array: " ++ err
1761

    
1762
prop_JSON_toArrayFail :: Int -> String -> Bool -> Property
1763
prop_JSON_toArrayFail i s b =
1764
  -- poor man's instance Arbitrary JSValue
1765
  forAll (elements [J.showJSON i, J.showJSON s, J.showJSON b]) $ \item ->
1766
  case JSON.toArray item of
1767
    Types.Bad _ -> property True
1768
    Types.Ok result -> failTest $ "Unexpected parse, got " ++ show result
1769

    
1770
testSuite "JSON"
1771
          [ 'prop_JSON_toArray
1772
          , 'prop_JSON_toArrayFail
1773
          ]
1774

    
1775
-- * Luxi tests
1776

    
1777
instance Arbitrary Luxi.LuxiReq where
1778
  arbitrary = elements [minBound..maxBound]
1779

    
1780
instance Arbitrary Luxi.QrViaLuxi where
1781
  arbitrary = elements [minBound..maxBound]
1782

    
1783
instance Arbitrary Luxi.LuxiOp where
1784
  arbitrary = do
1785
    lreq <- arbitrary
1786
    case lreq of
1787
      Luxi.ReqQuery -> Luxi.Query <$> arbitrary <*> getFields <*> arbitrary
1788
      Luxi.ReqQueryNodes -> Luxi.QueryNodes <$> (listOf getFQDN) <*>
1789
                            getFields <*> arbitrary
1790
      Luxi.ReqQueryGroups -> Luxi.QueryGroups <$> arbitrary <*>
1791
                             arbitrary <*> arbitrary
1792
      Luxi.ReqQueryInstances -> Luxi.QueryInstances <$> (listOf getFQDN) <*>
1793
                                getFields <*> arbitrary
1794
      Luxi.ReqQueryJobs -> Luxi.QueryJobs <$> arbitrary <*> getFields
1795
      Luxi.ReqQueryExports -> Luxi.QueryExports <$>
1796
                              (listOf getFQDN) <*> arbitrary
1797
      Luxi.ReqQueryConfigValues -> Luxi.QueryConfigValues <$> getFields
1798
      Luxi.ReqQueryClusterInfo -> pure Luxi.QueryClusterInfo
1799
      Luxi.ReqQueryTags -> Luxi.QueryTags <$> getName <*> getFQDN
1800
      Luxi.ReqSubmitJob -> Luxi.SubmitJob <$> (resize maxOpCodes arbitrary)
1801
      Luxi.ReqSubmitManyJobs -> Luxi.SubmitManyJobs <$>
1802
                                (resize maxOpCodes arbitrary)
1803
      Luxi.ReqWaitForJobChange -> Luxi.WaitForJobChange <$> arbitrary <*>
1804
                                  getFields <*> pure J.JSNull <*>
1805
                                  pure J.JSNull <*> arbitrary
1806
      Luxi.ReqArchiveJob -> Luxi.ArchiveJob <$> arbitrary
1807
      Luxi.ReqAutoArchiveJobs -> Luxi.AutoArchiveJobs <$> arbitrary <*>
1808
                                 arbitrary
1809
      Luxi.ReqCancelJob -> Luxi.CancelJob <$> arbitrary
1810
      Luxi.ReqSetDrainFlag -> Luxi.SetDrainFlag <$> arbitrary
1811
      Luxi.ReqSetWatcherPause -> Luxi.SetWatcherPause <$> arbitrary
1812

    
1813
-- | Simple check that encoding/decoding of LuxiOp works.
1814
prop_Luxi_CallEncoding :: Luxi.LuxiOp -> Property
1815
prop_Luxi_CallEncoding op =
1816
  (Luxi.validateCall (Luxi.buildCall op) >>= Luxi.decodeCall) ==? Types.Ok op
1817

    
1818
testSuite "LUXI"
1819
          [ 'prop_Luxi_CallEncoding
1820
          ]
1821

    
1822
-- * Ssconf tests
1823

    
1824
instance Arbitrary Ssconf.SSKey where
1825
  arbitrary = elements [minBound..maxBound]
1826

    
1827
prop_Ssconf_filename :: Ssconf.SSKey -> Property
1828
prop_Ssconf_filename key =
1829
  printTestCase "Key doesn't start with correct prefix" $
1830
    Ssconf.sSFilePrefix `isPrefixOf` Ssconf.keyToFilename (Just "") key
1831

    
1832
testSuite "Ssconf"
1833
  [ 'prop_Ssconf_filename
1834
  ]