Statistics
| Branch: | Tag: | Revision:

root / htools / Ganeti / HTools / QC.hs @ 746b7aa6

History | View | Annotate | Download (51.7 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
  , testOpCodes
36
  , testJobs
37
  , testCluster
38
  , testLoader
39
  , testTypes
40
  ) where
41

    
42
import Test.QuickCheck
43
import Data.List (findIndex, intercalate, nub, isPrefixOf)
44
import Data.Maybe
45
import Control.Monad
46
import qualified Text.JSON as J
47
import qualified Data.Map
48
import qualified Data.IntMap as IntMap
49
import qualified Ganeti.OpCodes as OpCodes
50
import qualified Ganeti.Jobs as Jobs
51
import qualified Ganeti.Luxi
52
import qualified Ganeti.HTools.CLI as CLI
53
import qualified Ganeti.HTools.Cluster as Cluster
54
import qualified Ganeti.HTools.Container as Container
55
import qualified Ganeti.HTools.ExtLoader
56
import qualified Ganeti.HTools.IAlloc as IAlloc
57
import qualified Ganeti.HTools.Instance as Instance
58
import qualified Ganeti.HTools.JSON as JSON
59
import qualified Ganeti.HTools.Loader as Loader
60
import qualified Ganeti.HTools.Luxi
61
import qualified Ganeti.HTools.Node as Node
62
import qualified Ganeti.HTools.Group as Group
63
import qualified Ganeti.HTools.PeerMap as PeerMap
64
import qualified Ganeti.HTools.Rapi
65
import qualified Ganeti.HTools.Simu
66
import qualified Ganeti.HTools.Text as Text
67
import qualified Ganeti.HTools.Types as Types
68
import qualified Ganeti.HTools.Utils as Utils
69
import qualified Ganeti.HTools.Version
70
import qualified Ganeti.Constants as C
71

    
72
import qualified Ganeti.HTools.Program.Hail
73
import qualified Ganeti.HTools.Program.Hbal
74
import qualified Ganeti.HTools.Program.Hscan
75
import qualified Ganeti.HTools.Program.Hspace
76

    
77
import Ganeti.HTools.QCHelper (testSuite)
78

    
79
-- * Constants
80

    
81
-- | Maximum memory (1TiB, somewhat random value).
82
maxMem :: Int
83
maxMem = 1024 * 1024
84

    
85
-- | Maximum disk (8TiB, somewhat random value).
86
maxDsk :: Int
87
maxDsk = 1024 * 1024 * 8
88

    
89
-- | Max CPUs (1024, somewhat random value).
90
maxCpu :: Int
91
maxCpu = 1024
92

    
93
-- | Null iPolicy, and by null we mean very liberal.
94
nullIPolicy = Types.IPolicy
95
  { Types.iPolicyMinSpec = Types.ISpec { Types.iSpecMemorySize = 0
96
                                       , Types.iSpecCpuCount   = 0
97
                                       , Types.iSpecDiskSize   = 0
98
                                       , Types.iSpecDiskCount  = 0
99
                                       , Types.iSpecNicCount   = 0
100
                                       }
101
  , Types.iPolicyMaxSpec = Types.ISpec { Types.iSpecMemorySize = maxBound
102
                                       , Types.iSpecCpuCount   = maxBound
103
                                       , Types.iSpecDiskSize   = maxBound
104
                                       , Types.iSpecDiskCount  = C.maxDisks
105
                                       , Types.iSpecNicCount   = C.maxNics
106
                                       }
107
  , Types.iPolicyStdSpec = Types.ISpec { Types.iSpecMemorySize = Types.unitMem
108
                                       , Types.iSpecCpuCount   = Types.unitCpu
109
                                       , Types.iSpecDiskSize   = Types.unitDsk
110
                                       , Types.iSpecDiskCount  = 1
111
                                       , Types.iSpecNicCount   = 1
112
                                       }
113
  , Types.iPolicyDiskTemplates = [Types.DTDrbd8, Types.DTPlain]
114
  }
115

    
116

    
117
defGroup :: Group.Group
118
defGroup = flip Group.setIdx 0 $
119
             Group.create "default" Types.defaultGroupID Types.AllocPreferred
120
                  nullIPolicy
121

    
122
defGroupList :: Group.List
123
defGroupList = Container.fromList [(Group.idx defGroup, defGroup)]
124

    
125
defGroupAssoc :: Data.Map.Map String Types.Gdx
126
defGroupAssoc = Data.Map.singleton (Group.uuid defGroup) (Group.idx defGroup)
127

    
128
-- * Helper functions
129

    
130
-- | Simple checker for whether OpResult is fail or pass.
131
isFailure :: Types.OpResult a -> Bool
132
isFailure (Types.OpFail _) = True
133
isFailure _ = False
134

    
135
-- | Checks for equality with proper annotation.
136
(==?) :: (Show a, Eq a) => a -> a -> Property
137
(==?) x y = printTestCase
138
            ("Expected equality, but '" ++
139
             show x ++ "' /= '" ++ show y ++ "'") (x == y)
140
infix 3 ==?
141

    
142
-- | Show a message and fail the test.
143
failTest :: String -> Property
144
failTest msg = printTestCase msg False
145

    
146
-- | Update an instance to be smaller than a node.
147
setInstanceSmallerThanNode node inst =
148
  inst { Instance.mem = Node.availMem node `div` 2
149
       , Instance.dsk = Node.availDisk node `div` 2
150
       , Instance.vcpus = Node.availCpu node `div` 2
151
       }
152

    
153
-- | Check if an instance is smaller than a node.
154
isInstanceSmallerThanNode node inst =
155
  Instance.mem inst   <= Node.availMem node `div` 2 &&
156
  Instance.dsk inst   <= Node.availDisk node `div` 2 &&
157
  Instance.vcpus inst <= Node.availCpu node `div` 2
158

    
159
-- | Create an instance given its spec.
160
createInstance mem dsk vcpus =
161
  Instance.create "inst-unnamed" mem dsk vcpus Types.Running [] True (-1) (-1)
162
    Types.DTDrbd8
163

    
164
-- | Create a small cluster by repeating a node spec.
165
makeSmallCluster :: Node.Node -> Int -> Node.List
166
makeSmallCluster node count =
167
  let origname = Node.name node
168
      origalias = Node.alias node
169
      nodes = map (\idx -> node { Node.name = origname ++ "-" ++ show idx
170
                                , Node.alias = origalias ++ "-" ++ show idx })
171
              [1..count]
172
      fn = flip Node.buildPeers Container.empty
173
      namelst = map (\n -> (Node.name n, fn n)) nodes
174
      (_, nlst) = Loader.assignIndices namelst
175
  in nlst
176

    
177
-- | Make a small cluster, both nodes and instances.
178
makeSmallEmptyCluster :: Node.Node -> Int -> Instance.Instance
179
                      -> (Node.List, Instance.List, Instance.Instance)
180
makeSmallEmptyCluster node count inst =
181
  (makeSmallCluster node count, Container.empty,
182
   setInstanceSmallerThanNode node inst)
183

    
184
-- | Checks if a node is "big" enough.
185
isNodeBig :: Int -> Node.Node -> Bool
186
isNodeBig size node = Node.availDisk node > size * Types.unitDsk
187
                      && Node.availMem node > size * Types.unitMem
188
                      && Node.availCpu node > size * Types.unitCpu
189

    
190
canBalance :: Cluster.Table -> Bool -> Bool -> Bool -> Bool
191
canBalance tbl dm im evac = isJust $ Cluster.tryBalance tbl dm im evac 0 0
192

    
193
-- | Assigns a new fresh instance to a cluster; this is not
194
-- allocation, so no resource checks are done.
195
assignInstance :: Node.List -> Instance.List -> Instance.Instance ->
196
                  Types.Idx -> Types.Idx ->
197
                  (Node.List, Instance.List)
198
assignInstance nl il inst pdx sdx =
199
  let pnode = Container.find pdx nl
200
      snode = Container.find sdx nl
201
      maxiidx = if Container.null il
202
                  then 0
203
                  else fst (Container.findMax il) + 1
204
      inst' = inst { Instance.idx = maxiidx,
205
                     Instance.pNode = pdx, Instance.sNode = sdx }
206
      pnode' = Node.setPri pnode inst'
207
      snode' = Node.setSec snode inst'
208
      nl' = Container.addTwo pdx pnode' sdx snode' nl
209
      il' = Container.add maxiidx inst' il
210
  in (nl', il')
211

    
212
-- | Generates a list of a given size with non-duplicate elements.
213
genUniquesList :: (Eq a, Arbitrary a) => Int -> Gen [a]
214
genUniquesList cnt =
215
  foldM (\lst _ -> do
216
           newelem <- arbitrary `suchThat` (`notElem` lst)
217
           return (newelem:lst)) [] [1..cnt]
218

    
219
-- * Arbitrary instances
220

    
221
-- | Defines a DNS name.
222
newtype DNSChar = DNSChar { dnsGetChar::Char }
223

    
224
instance Arbitrary DNSChar where
225
  arbitrary = do
226
    x <- elements (['a'..'z'] ++ ['0'..'9'] ++ "_-")
227
    return (DNSChar x)
228

    
229
-- | Generates a single name component.
230
getName :: Gen String
231
getName = do
232
  n <- choose (1, 64)
233
  dn <- vector n::Gen [DNSChar]
234
  return (map dnsGetChar dn)
235

    
236
-- | Generates an entire FQDN.
237
getFQDN :: Gen String
238
getFQDN = do
239
  ncomps <- choose (1, 4)
240
  names <- mapM (const getName) [1..ncomps::Int]
241
  return $ intercalate "." names
242

    
243
-- | Defines a tag type.
244
newtype TagChar = TagChar { tagGetChar :: Char }
245

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

    
251
instance Arbitrary TagChar where
252
  arbitrary = do
253
    c <- elements tagChar
254
    return (TagChar c)
255

    
256
-- | Generates a tag
257
genTag :: Gen [TagChar]
258
genTag = do
259
  -- the correct value would be C.maxTagLen, but that's way too
260
  -- verbose in unittests, and at the moment I don't see any possible
261
  -- bugs with longer tags and the way we use tags in htools
262
  n <- choose (1, 10)
263
  vector n
264

    
265
-- | Generates a list of tags (correctly upper bounded).
266
genTags :: Gen [String]
267
genTags = do
268
  -- the correct value would be C.maxTagsPerObj, but per the comment
269
  -- in genTag, we don't use tags enough in htools to warrant testing
270
  -- such big values
271
  n <- choose (0, 10::Int)
272
  tags <- mapM (const genTag) [1..n]
273
  return $ map (map tagGetChar) tags
274

    
275
instance Arbitrary Types.InstanceStatus where
276
    arbitrary = elements [minBound..maxBound]
277

    
278
-- let's generate a random instance
279
instance Arbitrary Instance.Instance where
280
  arbitrary = do
281
    name <- getFQDN
282
    mem <- choose (0, maxMem)
283
    dsk <- choose (0, maxDsk)
284
    run_st <- arbitrary
285
    pn <- arbitrary
286
    sn <- arbitrary
287
    vcpus <- choose (0, maxCpu)
288
    return $ Instance.create name mem dsk vcpus run_st [] True pn sn
289
              Types.DTDrbd8
290

    
291
-- | Generas an arbitrary node based on sizing information.
292
genNode :: Maybe Int -- ^ Minimum node size in terms of units
293
        -> Maybe Int -- ^ Maximum node size (when Nothing, bounded
294
                     -- just by the max... constants)
295
        -> Gen Node.Node
296
genNode min_multiplier max_multiplier = do
297
  let (base_mem, base_dsk, base_cpu) =
298
        case min_multiplier of
299
          Just mm -> (mm * Types.unitMem,
300
                      mm * Types.unitDsk,
301
                      mm * Types.unitCpu)
302
          Nothing -> (0, 0, 0)
303
      (top_mem, top_dsk, top_cpu)  =
304
        case max_multiplier of
305
          Just mm -> (mm * Types.unitMem,
306
                      mm * Types.unitDsk,
307
                      mm * Types.unitCpu)
308
          Nothing -> (maxMem, maxDsk, maxCpu)
309
  name  <- getFQDN
310
  mem_t <- choose (base_mem, top_mem)
311
  mem_f <- choose (base_mem, mem_t)
312
  mem_n <- choose (0, mem_t - mem_f)
313
  dsk_t <- choose (base_dsk, top_dsk)
314
  dsk_f <- choose (base_dsk, dsk_t)
315
  cpu_t <- choose (base_cpu, top_cpu)
316
  offl  <- arbitrary
317
  let n = Node.create name (fromIntegral mem_t) mem_n mem_f
318
          (fromIntegral dsk_t) dsk_f (fromIntegral cpu_t) offl 0
319
      n' = Node.setPolicy nullIPolicy n
320
  return $ Node.buildPeers n' Container.empty
321

    
322
-- | Helper function to generate a sane node.
323
genOnlineNode :: Gen Node.Node
324
genOnlineNode = do
325
  arbitrary `suchThat` (\n -> not (Node.offline n) &&
326
                              not (Node.failN1 n) &&
327
                              Node.availDisk n > 0 &&
328
                              Node.availMem n > 0 &&
329
                              Node.availCpu n > 0)
330

    
331
-- and a random node
332
instance Arbitrary Node.Node where
333
  arbitrary = genNode Nothing Nothing
334

    
335
-- replace disks
336
instance Arbitrary OpCodes.ReplaceDisksMode where
337
  arbitrary = elements [minBound..maxBound]
338

    
339
instance Arbitrary OpCodes.OpCode where
340
  arbitrary = do
341
    op_id <- elements [ "OP_TEST_DELAY"
342
                      , "OP_INSTANCE_REPLACE_DISKS"
343
                      , "OP_INSTANCE_FAILOVER"
344
                      , "OP_INSTANCE_MIGRATE"
345
                      ]
346
    case op_id of
347
      "OP_TEST_DELAY" ->
348
        liftM3 OpCodes.OpTestDelay arbitrary arbitrary arbitrary
349
      "OP_INSTANCE_REPLACE_DISKS" ->
350
        liftM5 OpCodes.OpInstanceReplaceDisks arbitrary arbitrary
351
          arbitrary arbitrary arbitrary
352
      "OP_INSTANCE_FAILOVER" ->
353
        liftM3 OpCodes.OpInstanceFailover arbitrary arbitrary
354
          arbitrary
355
      "OP_INSTANCE_MIGRATE" ->
356
        liftM5 OpCodes.OpInstanceMigrate arbitrary arbitrary
357
          arbitrary arbitrary arbitrary
358
      _ -> fail "Wrong opcode"
359

    
360
instance Arbitrary Jobs.OpStatus where
361
  arbitrary = elements [minBound..maxBound]
362

    
363
instance Arbitrary Jobs.JobStatus where
364
  arbitrary = elements [minBound..maxBound]
365

    
366
newtype SmallRatio = SmallRatio Double deriving Show
367
instance Arbitrary SmallRatio where
368
  arbitrary = do
369
    v <- choose (0, 1)
370
    return $ SmallRatio v
371

    
372
instance Arbitrary Types.AllocPolicy where
373
  arbitrary = elements [minBound..maxBound]
374

    
375
instance Arbitrary Types.DiskTemplate where
376
  arbitrary = elements [minBound..maxBound]
377

    
378
instance Arbitrary Types.FailMode where
379
  arbitrary = elements [minBound..maxBound]
380

    
381
instance Arbitrary Types.EvacMode where
382
  arbitrary = elements [minBound..maxBound]
383

    
384
instance Arbitrary a => Arbitrary (Types.OpResult a) where
385
  arbitrary = arbitrary >>= \c ->
386
              if c
387
                then liftM Types.OpGood arbitrary
388
                else liftM Types.OpFail arbitrary
389

    
390
instance Arbitrary Types.ISpec where
391
  arbitrary = do
392
    mem <- arbitrary::Gen (NonNegative Int)
393
    dsk_c <- arbitrary::Gen (NonNegative Int)
394
    dsk_s <- arbitrary::Gen (NonNegative Int)
395
    cpu <- arbitrary::Gen (NonNegative Int)
396
    nic <- arbitrary::Gen (NonNegative Int)
397
    return Types.ISpec { Types.iSpecMemorySize = fromIntegral mem
398
                       , Types.iSpecCpuCount   = fromIntegral cpu
399
                       , Types.iSpecDiskSize   = fromIntegral dsk_s
400
                       , Types.iSpecDiskCount  = fromIntegral dsk_c
401
                       , Types.iSpecNicCount   = fromIntegral nic
402
                       }
403

    
404
-- | Helper function to check whether a spec is LTE than another
405
iSpecSmaller :: Types.ISpec -> Types.ISpec -> Bool
406
iSpecSmaller imin imax =
407
  Types.iSpecMemorySize imin <= Types.iSpecMemorySize imax &&
408
  Types.iSpecCpuCount imin   <= Types.iSpecCpuCount imax &&
409
  Types.iSpecDiskSize imin   <= Types.iSpecDiskSize imax &&
410
  Types.iSpecDiskCount imin  <= Types.iSpecDiskCount imax &&
411
  Types.iSpecNicCount imin   <= Types.iSpecNicCount imax
412

    
413
instance Arbitrary Types.IPolicy where
414
  arbitrary = do
415
    imin <- arbitrary
416
    istd <- arbitrary `suchThat` (iSpecSmaller imin)
417
    imax <- arbitrary `suchThat` (iSpecSmaller istd)
418
    dts  <- arbitrary
419
    return Types.IPolicy { Types.iPolicyMinSpec = imin
420
                         , Types.iPolicyStdSpec = istd
421
                         , Types.iPolicyMaxSpec = imax
422
                         , Types.iPolicyDiskTemplates = dts
423
                         }
424

    
425
-- * Actual tests
426

    
427
-- ** Utils tests
428

    
429
-- | If the list is not just an empty element, and if the elements do
430
-- not contain commas, then join+split should be idempotent.
431
prop_Utils_commaJoinSplit =
432
  forAll (arbitrary `suchThat`
433
          (\l -> l /= [""] && all (notElem ',') l )) $ \lst ->
434
  Utils.sepSplit ',' (Utils.commaJoin lst) ==? lst
435

    
436
-- | Split and join should always be idempotent.
437
prop_Utils_commaSplitJoin s =
438
  Utils.commaJoin (Utils.sepSplit ',' s) ==? s
439

    
440
-- | fromObjWithDefault, we test using the Maybe monad and an integer
441
-- value.
442
prop_Utils_fromObjWithDefault def_value random_key =
443
  -- a missing key will be returned with the default
444
  JSON.fromObjWithDefault [] random_key def_value == Just def_value &&
445
  -- a found key will be returned as is, not with default
446
  JSON.fromObjWithDefault [(random_key, J.showJSON def_value)]
447
       random_key (def_value+1) == Just def_value
448
    where _types = def_value :: Integer
449

    
450
-- | Test that functional if' behaves like the syntactic sugar if.
451
prop_Utils_if'if :: Bool -> Int -> Int -> Gen Prop
452
prop_Utils_if'if cnd a b =
453
  Utils.if' cnd a b ==? if cnd then a else b
454

    
455
-- | Test basic select functionality
456
prop_Utils_select :: Int      -- ^ Default result
457
                  -> [Int]    -- ^ List of False values
458
                  -> [Int]    -- ^ List of True values
459
                  -> Gen Prop -- ^ Test result
460
prop_Utils_select def lst1 lst2 =
461
  Utils.select def (flist ++ tlist) ==? expectedresult
462
    where expectedresult = Utils.if' (null lst2) def (head lst2)
463
          flist = zip (repeat False) lst1
464
          tlist = zip (repeat True)  lst2
465

    
466
-- | Test basic select functionality with undefined default
467
prop_Utils_select_undefd :: [Int]            -- ^ List of False values
468
                         -> NonEmptyList Int -- ^ List of True values
469
                         -> Gen Prop         -- ^ Test result
470
prop_Utils_select_undefd lst1 (NonEmpty lst2) =
471
  Utils.select undefined (flist ++ tlist) ==? head lst2
472
    where flist = zip (repeat False) lst1
473
          tlist = zip (repeat True)  lst2
474

    
475
-- | Test basic select functionality with undefined list values
476
prop_Utils_select_undefv :: [Int]            -- ^ List of False values
477
                         -> NonEmptyList Int -- ^ List of True values
478
                         -> Gen Prop         -- ^ Test result
479
prop_Utils_select_undefv lst1 (NonEmpty lst2) =
480
  Utils.select undefined cndlist ==? head lst2
481
    where flist = zip (repeat False) lst1
482
          tlist = zip (repeat True)  lst2
483
          cndlist = flist ++ tlist ++ [undefined]
484

    
485
prop_Utils_parseUnit (NonNegative n) =
486
  Utils.parseUnit (show n) == Types.Ok n &&
487
  Utils.parseUnit (show n ++ "m") == Types.Ok n &&
488
  (case Utils.parseUnit (show n ++ "M") of
489
     Types.Ok m -> if n > 0
490
                     then m < n  -- for positive values, X MB is < than X MiB
491
                     else m == 0 -- but for 0, 0 MB == 0 MiB
492
     Types.Bad _ -> False) &&
493
  Utils.parseUnit (show n ++ "g") == Types.Ok (n*1024) &&
494
  Utils.parseUnit (show n ++ "t") == Types.Ok (n*1048576) &&
495
  Types.isBad (Utils.parseUnit (show n ++ "x")::Types.Result Int)
496
    where _types = n::Int
497

    
498
-- | Test list for the Utils module.
499
testSuite "Utils"
500
            [ 'prop_Utils_commaJoinSplit
501
            , 'prop_Utils_commaSplitJoin
502
            , 'prop_Utils_fromObjWithDefault
503
            , 'prop_Utils_if'if
504
            , 'prop_Utils_select
505
            , 'prop_Utils_select_undefd
506
            , 'prop_Utils_select_undefv
507
            , 'prop_Utils_parseUnit
508
            ]
509

    
510
-- ** PeerMap tests
511

    
512
-- | Make sure add is idempotent.
513
prop_PeerMap_addIdempotent pmap key em =
514
  fn puniq ==? fn (fn puniq)
515
    where _types = (pmap::PeerMap.PeerMap,
516
                    key::PeerMap.Key, em::PeerMap.Elem)
517
          fn = PeerMap.add key em
518
          puniq = PeerMap.accumArray const pmap
519

    
520
-- | Make sure remove is idempotent.
521
prop_PeerMap_removeIdempotent pmap key =
522
  fn puniq ==? fn (fn puniq)
523
    where _types = (pmap::PeerMap.PeerMap, key::PeerMap.Key)
524
          fn = PeerMap.remove key
525
          puniq = PeerMap.accumArray const pmap
526

    
527
-- | Make sure a missing item returns 0.
528
prop_PeerMap_findMissing pmap key =
529
  PeerMap.find key (PeerMap.remove key puniq) ==? 0
530
    where _types = (pmap::PeerMap.PeerMap, key::PeerMap.Key)
531
          puniq = PeerMap.accumArray const pmap
532

    
533
-- | Make sure an added item is found.
534
prop_PeerMap_addFind pmap key em =
535
  PeerMap.find key (PeerMap.add key em puniq) ==? em
536
    where _types = (pmap::PeerMap.PeerMap,
537
                    key::PeerMap.Key, em::PeerMap.Elem)
538
          puniq = PeerMap.accumArray const pmap
539

    
540
-- | Manual check that maxElem returns the maximum indeed, or 0 for null.
541
prop_PeerMap_maxElem pmap =
542
  PeerMap.maxElem puniq ==? if null puniq then 0
543
                              else (maximum . snd . unzip) puniq
544
    where _types = pmap::PeerMap.PeerMap
545
          puniq = PeerMap.accumArray const pmap
546

    
547
-- | List of tests for the PeerMap module.
548
testSuite "PeerMap"
549
            [ 'prop_PeerMap_addIdempotent
550
            , 'prop_PeerMap_removeIdempotent
551
            , 'prop_PeerMap_maxElem
552
            , 'prop_PeerMap_addFind
553
            , 'prop_PeerMap_findMissing
554
            ]
555

    
556
-- ** Container tests
557

    
558
-- we silence the following due to hlint bug fixed in later versions
559
{-# ANN prop_Container_addTwo "HLint: ignore Avoid lambda" #-}
560
prop_Container_addTwo cdata i1 i2 =
561
  fn i1 i2 cont == fn i2 i1 cont &&
562
  fn i1 i2 cont == fn i1 i2 (fn i1 i2 cont)
563
    where _types = (cdata::[Int],
564
                    i1::Int, i2::Int)
565
          cont = foldl (\c x -> Container.add x x c) Container.empty cdata
566
          fn x1 x2 = Container.addTwo x1 x1 x2 x2
567

    
568
prop_Container_nameOf node =
569
  let nl = makeSmallCluster node 1
570
      fnode = head (Container.elems nl)
571
  in Container.nameOf nl (Node.idx fnode) ==? Node.name fnode
572

    
573
-- | We test that in a cluster, given a random node, we can find it by
574
-- its name and alias, as long as all names and aliases are unique,
575
-- and that we fail to find a non-existing name.
576
prop_Container_findByName node =
577
  forAll (choose (1, 20)) $ \ cnt ->
578
  forAll (choose (0, cnt - 1)) $ \ fidx ->
579
  forAll (genUniquesList (cnt * 2)) $ \ allnames ->
580
  forAll (arbitrary `suchThat` (`notElem` allnames)) $ \ othername ->
581
  let names = zip (take cnt allnames) (drop cnt allnames)
582
      nl = makeSmallCluster node cnt
583
      nodes = Container.elems nl
584
      nodes' = map (\((name, alias), nn) -> (Node.idx nn,
585
                                             nn { Node.name = name,
586
                                                  Node.alias = alias }))
587
               $ zip names nodes
588
      nl' = Container.fromList nodes'
589
      target = snd (nodes' !! fidx)
590
  in Container.findByName nl' (Node.name target) == Just target &&
591
     Container.findByName nl' (Node.alias target) == Just target &&
592
     isNothing (Container.findByName nl' othername)
593

    
594
testSuite "Container"
595
            [ 'prop_Container_addTwo
596
            , 'prop_Container_nameOf
597
            , 'prop_Container_findByName
598
            ]
599

    
600
-- ** Instance tests
601

    
602
-- Simple instance tests, we only have setter/getters
603

    
604
prop_Instance_creat inst =
605
  Instance.name inst ==? Instance.alias inst
606

    
607
prop_Instance_setIdx inst idx =
608
  Instance.idx (Instance.setIdx inst idx) ==? idx
609
    where _types = (inst::Instance.Instance, idx::Types.Idx)
610

    
611
prop_Instance_setName inst name =
612
  Instance.name newinst == name &&
613
  Instance.alias newinst == name
614
    where _types = (inst::Instance.Instance, name::String)
615
          newinst = Instance.setName inst name
616

    
617
prop_Instance_setAlias inst name =
618
  Instance.name newinst == Instance.name inst &&
619
  Instance.alias newinst == name
620
    where _types = (inst::Instance.Instance, name::String)
621
          newinst = Instance.setAlias inst name
622

    
623
prop_Instance_setPri inst pdx =
624
  Instance.pNode (Instance.setPri inst pdx) ==? pdx
625
    where _types = (inst::Instance.Instance, pdx::Types.Ndx)
626

    
627
prop_Instance_setSec inst sdx =
628
  Instance.sNode (Instance.setSec inst sdx) ==? sdx
629
    where _types = (inst::Instance.Instance, sdx::Types.Ndx)
630

    
631
prop_Instance_setBoth inst pdx sdx =
632
  Instance.pNode si == pdx && Instance.sNode si == sdx
633
    where _types = (inst::Instance.Instance, pdx::Types.Ndx, sdx::Types.Ndx)
634
          si = Instance.setBoth inst pdx sdx
635

    
636
prop_Instance_shrinkMG inst =
637
  Instance.mem inst >= 2 * Types.unitMem ==>
638
    case Instance.shrinkByType inst Types.FailMem of
639
      Types.Ok inst' -> Instance.mem inst' == Instance.mem inst - Types.unitMem
640
      _ -> False
641

    
642
prop_Instance_shrinkMF inst =
643
  forAll (choose (0, 2 * Types.unitMem - 1)) $ \mem ->
644
    let inst' = inst { Instance.mem = mem}
645
    in Types.isBad $ Instance.shrinkByType inst' Types.FailMem
646

    
647
prop_Instance_shrinkCG inst =
648
  Instance.vcpus inst >= 2 * Types.unitCpu ==>
649
    case Instance.shrinkByType inst Types.FailCPU of
650
      Types.Ok inst' ->
651
        Instance.vcpus inst' == Instance.vcpus inst - Types.unitCpu
652
      _ -> False
653

    
654
prop_Instance_shrinkCF inst =
655
  forAll (choose (0, 2 * Types.unitCpu - 1)) $ \vcpus ->
656
    let inst' = inst { Instance.vcpus = vcpus }
657
    in Types.isBad $ Instance.shrinkByType inst' Types.FailCPU
658

    
659
prop_Instance_shrinkDG inst =
660
  Instance.dsk inst >= 2 * Types.unitDsk ==>
661
    case Instance.shrinkByType inst Types.FailDisk of
662
      Types.Ok inst' ->
663
        Instance.dsk inst' == Instance.dsk inst - Types.unitDsk
664
      _ -> False
665

    
666
prop_Instance_shrinkDF inst =
667
  forAll (choose (0, 2 * Types.unitDsk - 1)) $ \dsk ->
668
    let inst' = inst { Instance.dsk = dsk }
669
    in Types.isBad $ Instance.shrinkByType inst' Types.FailDisk
670

    
671
prop_Instance_setMovable inst m =
672
  Instance.movable inst' ==? m
673
    where inst' = Instance.setMovable inst m
674

    
675
testSuite "Instance"
676
            [ 'prop_Instance_creat
677
            , 'prop_Instance_setIdx
678
            , 'prop_Instance_setName
679
            , 'prop_Instance_setAlias
680
            , 'prop_Instance_setPri
681
            , 'prop_Instance_setSec
682
            , 'prop_Instance_setBoth
683
            , 'prop_Instance_shrinkMG
684
            , 'prop_Instance_shrinkMF
685
            , 'prop_Instance_shrinkCG
686
            , 'prop_Instance_shrinkCF
687
            , 'prop_Instance_shrinkDG
688
            , 'prop_Instance_shrinkDF
689
            , 'prop_Instance_setMovable
690
            ]
691

    
692
-- ** Text backend tests
693

    
694
-- Instance text loader tests
695

    
696
prop_Text_Load_Instance name mem dsk vcpus status
697
                        (NonEmpty pnode) snode
698
                        (NonNegative pdx) (NonNegative sdx) autobal dt =
699
  pnode /= snode && pdx /= sdx ==>
700
  let vcpus_s = show vcpus
701
      dsk_s = show dsk
702
      mem_s = show mem
703
      status_s = Types.instanceStatusToRaw status
704
      ndx = if null snode
705
              then [(pnode, pdx)]
706
              else [(pnode, pdx), (snode, sdx)]
707
      nl = Data.Map.fromList ndx
708
      tags = ""
709
      sbal = if autobal then "Y" else "N"
710
      sdt = Types.diskTemplateToRaw dt
711
      inst = Text.loadInst nl
712
             [name, mem_s, dsk_s, vcpus_s, status_s,
713
              sbal, pnode, snode, sdt, tags]
714
      fail1 = Text.loadInst nl
715
              [name, mem_s, dsk_s, vcpus_s, status_s,
716
               sbal, pnode, pnode, tags]
717
      _types = ( name::String, mem::Int, dsk::Int
718
               , vcpus::Int, status::Types.InstanceStatus
719
               , snode::String
720
               , autobal::Bool)
721
  in case inst of
722
       Types.Bad msg -> failTest $ "Failed to load instance: " ++ msg
723
       Types.Ok (_, i) -> printTestCase "Mismatch in some field while\
724
                                        \ loading the instance" $
725
               Instance.name i == name &&
726
               Instance.vcpus i == vcpus &&
727
               Instance.mem i == mem &&
728
               Instance.pNode i == pdx &&
729
               Instance.sNode i == (if null snode
730
                                      then Node.noSecondary
731
                                      else sdx) &&
732
               Instance.autoBalance i == autobal &&
733
               Types.isBad fail1
734

    
735
prop_Text_Load_InstanceFail ktn fields =
736
  length fields /= 10 ==>
737
    case Text.loadInst nl fields of
738
      Types.Ok _ -> failTest "Managed to load instance from invalid data"
739
      Types.Bad msg -> printTestCase ("Unrecognised error message: " ++ msg) $
740
                       "Invalid/incomplete instance data: '" `isPrefixOf` msg
741
    where nl = Data.Map.fromList ktn
742

    
743
prop_Text_Load_Node name tm nm fm td fd tc fo =
744
  let conv v = if v < 0
745
                 then "?"
746
                 else show v
747
      tm_s = conv tm
748
      nm_s = conv nm
749
      fm_s = conv fm
750
      td_s = conv td
751
      fd_s = conv fd
752
      tc_s = conv tc
753
      fo_s = if fo
754
               then "Y"
755
               else "N"
756
      any_broken = any (< 0) [tm, nm, fm, td, fd, tc]
757
      gid = Group.uuid defGroup
758
  in case Text.loadNode defGroupAssoc
759
       [name, tm_s, nm_s, fm_s, td_s, fd_s, tc_s, fo_s, gid] of
760
       Nothing -> False
761
       Just (name', node) ->
762
         if fo || any_broken
763
           then Node.offline node
764
           else Node.name node == name' && name' == name &&
765
                Node.alias node == name &&
766
                Node.tMem node == fromIntegral tm &&
767
                Node.nMem node == nm &&
768
                Node.fMem node == fm &&
769
                Node.tDsk node == fromIntegral td &&
770
                Node.fDsk node == fd &&
771
                Node.tCpu node == fromIntegral tc
772

    
773
prop_Text_Load_NodeFail fields =
774
  length fields /= 8 ==> isNothing $ Text.loadNode Data.Map.empty fields
775

    
776
prop_Text_NodeLSIdempotent node =
777
  (Text.loadNode defGroupAssoc.
778
       Utils.sepSplit '|' . Text.serializeNode defGroupList) n ==
779
  Just (Node.name n, n)
780
    -- override failN1 to what loadNode returns by default
781
    where n = node { Node.failN1 = True, Node.offline = False
782
                   , Node.iPolicy = Types.defIPolicy }
783

    
784
prop_Text_ISpecIdempotent ispec =
785
  case Text.loadISpec "dummy" . Utils.sepSplit ',' .
786
       Text.serializeISpec $ ispec of
787
    Types.Bad msg -> failTest $ "Failed to load ispec: " ++ msg
788
    Types.Ok ispec' -> ispec ==? ispec'
789

    
790
prop_Text_IPolicyIdempotent ipol =
791
  case Text.loadIPolicy . Utils.sepSplit '|' $
792
       Text.serializeIPolicy owner ipol of
793
    Types.Bad msg -> failTest $ "Failed to load ispec: " ++ msg
794
    Types.Ok res -> (owner, ipol) ==? res
795
  where owner = "dummy"
796

    
797
-- | This property, while being in the text tests, does more than just
798
-- test end-to-end the serialisation and loading back workflow; it
799
-- also tests the Loader.mergeData and the actuall
800
-- Cluster.iterateAlloc (for well-behaving w.r.t. instance
801
-- allocations, not for the business logic). As such, it's a quite
802
-- complex and slow test, and that's the reason we restrict it to
803
-- small cluster sizes.
804
prop_Text_CreateSerialise =
805
  forAll genTags $ \ctags ->
806
  forAll (choose (1, 2)) $ \reqnodes ->
807
  forAll (choose (1, 20)) $ \maxiter ->
808
  forAll (choose (2, 10)) $ \count ->
809
  forAll genOnlineNode $ \node ->
810
  forAll (arbitrary `suchThat` isInstanceSmallerThanNode node) $ \inst ->
811
  let inst' = Instance.setMovable inst $ Utils.if' (reqnodes == 2) True False
812
      nl = makeSmallCluster node count
813
  in case Cluster.genAllocNodes defGroupList nl reqnodes True >>= \allocn ->
814
     Cluster.iterateAlloc nl Container.empty (Just maxiter) inst' allocn [] []
815
     of
816
       Types.Bad msg -> failTest $ "Failed to allocate: " ++ msg
817
       Types.Ok (_, _, _, [], _) -> printTestCase
818
                                    "Failed to allocate: no allocations" False
819
       Types.Ok (_, nl', il', _, _) ->
820
         let cdata = Loader.ClusterData defGroupList nl' il' ctags
821
                     Types.defIPolicy
822
             saved = Text.serializeCluster cdata
823
         in case Text.parseData saved >>= Loader.mergeData [] [] [] [] of
824
              Types.Bad msg -> failTest $ "Failed to load/merge: " ++ msg
825
              Types.Ok (Loader.ClusterData gl2 nl2 il2 ctags2 cpol2) ->
826
                ctags ==? ctags2 .&&.
827
                Types.defIPolicy ==? cpol2 .&&.
828
                il' ==? il2 .&&.
829
                defGroupList ==? gl2 .&&.
830
                nl' ==? nl2
831

    
832
testSuite "Text"
833
            [ 'prop_Text_Load_Instance
834
            , 'prop_Text_Load_InstanceFail
835
            , 'prop_Text_Load_Node
836
            , 'prop_Text_Load_NodeFail
837
            , 'prop_Text_NodeLSIdempotent
838
            , 'prop_Text_ISpecIdempotent
839
            , 'prop_Text_IPolicyIdempotent
840
            , 'prop_Text_CreateSerialise
841
            ]
842

    
843
-- ** Node tests
844

    
845
prop_Node_setAlias node name =
846
  Node.name newnode == Node.name node &&
847
  Node.alias newnode == name
848
    where _types = (node::Node.Node, name::String)
849
          newnode = Node.setAlias node name
850

    
851
prop_Node_setOffline node status =
852
  Node.offline newnode ==? status
853
    where newnode = Node.setOffline node status
854

    
855
prop_Node_setXmem node xm =
856
  Node.xMem newnode ==? xm
857
    where newnode = Node.setXmem node xm
858

    
859
prop_Node_setMcpu node mc =
860
  Node.mCpu newnode ==? mc
861
    where newnode = Node.setMcpu node mc
862

    
863
-- | Check that an instance add with too high memory or disk will be
864
-- rejected.
865
prop_Node_addPriFM node inst =
866
  Instance.mem inst >= Node.fMem node && not (Node.failN1 node) &&
867
  not (Instance.instanceOffline inst) ==>
868
  case Node.addPri node inst'' of
869
    Types.OpFail Types.FailMem -> True
870
    _ -> False
871
  where _types = (node::Node.Node, inst::Instance.Instance)
872
        inst' = setInstanceSmallerThanNode node inst
873
        inst'' = inst' { Instance.mem = Instance.mem inst }
874

    
875
prop_Node_addPriFD node inst =
876
  Instance.dsk inst >= Node.fDsk node && not (Node.failN1 node) ==>
877
    case Node.addPri node inst'' of
878
      Types.OpFail Types.FailDisk -> True
879
      _ -> False
880
    where _types = (node::Node.Node, inst::Instance.Instance)
881
          inst' = setInstanceSmallerThanNode node inst
882
          inst'' = inst' { Instance.dsk = Instance.dsk inst }
883

    
884
prop_Node_addPriFC (Positive extra) =
885
  forAll genOnlineNode $ \node ->
886
  forAll (arbitrary `suchThat` Instance.instanceNotOffline) $ \inst ->
887
  let inst' = setInstanceSmallerThanNode node inst
888
      inst'' = inst' { Instance.vcpus = Node.availCpu node + extra }
889
  in case Node.addPri node inst'' of
890
       Types.OpFail Types.FailCPU -> property True
891
       v -> failTest $ "Expected OpFail FailCPU, but got " ++ show v
892

    
893
-- | Check that an instance add with too high memory or disk will be
894
-- rejected.
895
prop_Node_addSec node inst pdx =
896
  ((Instance.mem inst >= (Node.fMem node - Node.rMem node) &&
897
    not (Instance.instanceOffline inst)) ||
898
   Instance.dsk inst >= Node.fDsk node) &&
899
  not (Node.failN1 node) ==>
900
      isFailure (Node.addSec node inst pdx)
901
        where _types = (node::Node.Node, inst::Instance.Instance, pdx::Int)
902

    
903
-- | Check that an offline instance with reasonable disk size can always
904
-- be added.
905
prop_Node_addPriOffline =
906
  forAll (arbitrary `suchThat` ((> 0) . Node.fMem)) $ \node ->
907
  forAll (arbitrary `suchThat`
908
          (\ x ->  (Instance.dsk x  < Node.fDsk node) &&
909
                   Instance.instanceOffline x)) $ \inst ->
910
  case Node.addPri node inst of
911
    Types.OpGood _ -> True
912
    _ -> False
913

    
914
prop_Node_addSecOffline pdx =
915
  forAll genOnlineNode $ \node ->
916
  forAll (arbitrary `suchThat`
917
          (\ inst -> Instance.dsk inst  < Node.availDisk node)) $ \inst ->
918
  case Node.addSec node (inst { Instance.runSt = Types.AdminOffline }) pdx of
919
    Types.OpGood _ -> True
920
    _ -> False
921

    
922
-- | Checks for memory reservation changes.
923
prop_Node_rMem inst =
924
  not (Instance.instanceOffline inst) ==>
925
  forAll (arbitrary `suchThat` ((> Types.unitMem) . Node.fMem)) $ \node ->
926
  -- ab = auto_balance, nb = non-auto_balance
927
  -- we use -1 as the primary node of the instance
928
  let inst' = inst { Instance.pNode = -1, Instance.autoBalance = True }
929
      inst_ab = setInstanceSmallerThanNode node inst'
930
      inst_nb = inst_ab { Instance.autoBalance = False }
931
      -- now we have the two instances, identical except the
932
      -- autoBalance attribute
933
      orig_rmem = Node.rMem node
934
      inst_idx = Instance.idx inst_ab
935
      node_add_ab = Node.addSec node inst_ab (-1)
936
      node_add_nb = Node.addSec node inst_nb (-1)
937
      node_del_ab = liftM (`Node.removeSec` inst_ab) node_add_ab
938
      node_del_nb = liftM (`Node.removeSec` inst_nb) node_add_nb
939
  in case (node_add_ab, node_add_nb, node_del_ab, node_del_nb) of
940
       (Types.OpGood a_ab, Types.OpGood a_nb,
941
        Types.OpGood d_ab, Types.OpGood d_nb) ->
942
         printTestCase "Consistency checks failed" $
943
           Node.rMem a_ab >  orig_rmem &&
944
           Node.rMem a_ab - orig_rmem == Instance.mem inst_ab &&
945
           Node.rMem a_nb == orig_rmem &&
946
           Node.rMem d_ab == orig_rmem &&
947
           Node.rMem d_nb == orig_rmem &&
948
           -- this is not related to rMem, but as good a place to
949
           -- test as any
950
           inst_idx `elem` Node.sList a_ab &&
951
           inst_idx `notElem` Node.sList d_ab
952
       x -> failTest $ "Failed to add/remove instances: " ++ show x
953

    
954
-- | Check mdsk setting.
955
prop_Node_setMdsk node mx =
956
  Node.loDsk node' >= 0 &&
957
  fromIntegral (Node.loDsk node') <= Node.tDsk node &&
958
  Node.availDisk node' >= 0 &&
959
  Node.availDisk node' <= Node.fDsk node' &&
960
  fromIntegral (Node.availDisk node') <= Node.tDsk node' &&
961
  Node.mDsk node' == mx'
962
    where _types = (node::Node.Node, mx::SmallRatio)
963
          node' = Node.setMdsk node mx'
964
          SmallRatio mx' = mx
965

    
966
-- Check tag maps
967
prop_Node_tagMaps_idempotent tags =
968
  Node.delTags (Node.addTags m tags) tags ==? m
969
    where m = Data.Map.empty
970

    
971
prop_Node_tagMaps_reject tags =
972
  not (null tags) ==>
973
  all (\t -> Node.rejectAddTags m [t]) tags
974
    where m = Node.addTags Data.Map.empty tags
975

    
976
prop_Node_showField node =
977
  forAll (elements Node.defaultFields) $ \ field ->
978
  fst (Node.showHeader field) /= Types.unknownField &&
979
  Node.showField node field /= Types.unknownField
980

    
981
prop_Node_computeGroups nodes =
982
  let ng = Node.computeGroups nodes
983
      onlyuuid = map fst ng
984
  in length nodes == sum (map (length . snd) ng) &&
985
     all (\(guuid, ns) -> all ((== guuid) . Node.group) ns) ng &&
986
     length (nub onlyuuid) == length onlyuuid &&
987
     (null nodes || not (null ng))
988

    
989
testSuite "Node"
990
            [ 'prop_Node_setAlias
991
            , 'prop_Node_setOffline
992
            , 'prop_Node_setMcpu
993
            , 'prop_Node_setXmem
994
            , 'prop_Node_addPriFM
995
            , 'prop_Node_addPriFD
996
            , 'prop_Node_addPriFC
997
            , 'prop_Node_addSec
998
            , 'prop_Node_addPriOffline
999
            , 'prop_Node_addSecOffline
1000
            , 'prop_Node_rMem
1001
            , 'prop_Node_setMdsk
1002
            , 'prop_Node_tagMaps_idempotent
1003
            , 'prop_Node_tagMaps_reject
1004
            , 'prop_Node_showField
1005
            , 'prop_Node_computeGroups
1006
            ]
1007

    
1008
-- ** Cluster tests
1009

    
1010
-- | Check that the cluster score is close to zero for a homogeneous
1011
-- cluster.
1012
prop_Score_Zero node =
1013
  forAll (choose (1, 1024)) $ \count ->
1014
    (not (Node.offline node) && not (Node.failN1 node) && (count > 0) &&
1015
     (Node.tDsk node > 0) && (Node.tMem node > 0)) ==>
1016
  let fn = Node.buildPeers node Container.empty
1017
      nlst = replicate count fn
1018
      score = Cluster.compCVNodes nlst
1019
  -- we can't say == 0 here as the floating point errors accumulate;
1020
  -- this should be much lower than the default score in CLI.hs
1021
  in score <= 1e-12
1022

    
1023
-- | Check that cluster stats are sane.
1024
prop_CStats_sane =
1025
  forAll (choose (1, 1024)) $ \count ->
1026
  forAll genOnlineNode $ \node ->
1027
  let fn = Node.buildPeers node Container.empty
1028
      nlst = zip [1..] $ replicate count fn::[(Types.Ndx, Node.Node)]
1029
      nl = Container.fromList nlst
1030
      cstats = Cluster.totalResources nl
1031
  in Cluster.csAdsk cstats >= 0 &&
1032
     Cluster.csAdsk cstats <= Cluster.csFdsk cstats
1033

    
1034
-- | Check that one instance is allocated correctly, without
1035
-- rebalances needed.
1036
prop_ClusterAlloc_sane inst =
1037
  forAll (choose (5, 20)) $ \count ->
1038
  forAll genOnlineNode $ \node ->
1039
  let (nl, il, inst') = makeSmallEmptyCluster node count inst
1040
  in case Cluster.genAllocNodes defGroupList nl 2 True >>=
1041
     Cluster.tryAlloc nl il inst' of
1042
       Types.Bad _ -> False
1043
       Types.Ok as ->
1044
         case Cluster.asSolution as of
1045
           Nothing -> False
1046
           Just (xnl, xi, _, cv) ->
1047
             let il' = Container.add (Instance.idx xi) xi il
1048
                 tbl = Cluster.Table xnl il' cv []
1049
             in not (canBalance tbl True True False)
1050

    
1051
-- | Checks that on a 2-5 node cluster, we can allocate a random
1052
-- instance spec via tiered allocation (whatever the original instance
1053
-- spec), on either one or two nodes.
1054
prop_ClusterCanTieredAlloc inst =
1055
  forAll (choose (2, 5)) $ \count ->
1056
  forAll (choose (1, 2)) $ \rqnodes ->
1057
  forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
1058
  let nl = makeSmallCluster node count
1059
      il = Container.empty
1060
      allocnodes = Cluster.genAllocNodes defGroupList nl rqnodes True
1061
  in case allocnodes >>= \allocnodes' ->
1062
    Cluster.tieredAlloc nl il (Just 1) inst allocnodes' [] [] of
1063
       Types.Bad _ -> False
1064
       Types.Ok (_, _, il', ixes, cstats) -> not (null ixes) &&
1065
                                             IntMap.size il' == length ixes &&
1066
                                             length ixes == length cstats
1067

    
1068
-- | Helper function to create a cluster with the given range of nodes
1069
-- and allocate an instance on it.
1070
genClusterAlloc count node inst =
1071
  let nl = makeSmallCluster node count
1072
  in case Cluster.genAllocNodes defGroupList nl 2 True >>=
1073
     Cluster.tryAlloc nl Container.empty inst of
1074
       Types.Bad _ -> Types.Bad "Can't allocate"
1075
       Types.Ok as ->
1076
         case Cluster.asSolution as of
1077
           Nothing -> Types.Bad "Empty solution?"
1078
           Just (xnl, xi, _, _) ->
1079
             let xil = Container.add (Instance.idx xi) xi Container.empty
1080
             in Types.Ok (xnl, xil, xi)
1081

    
1082
-- | Checks that on a 4-8 node cluster, once we allocate an instance,
1083
-- we can also relocate it.
1084
prop_ClusterAllocRelocate =
1085
  forAll (choose (4, 8)) $ \count ->
1086
  forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
1087
  forAll (arbitrary `suchThat` (isInstanceSmallerThanNode node)) $ \inst ->
1088
  case genClusterAlloc count node inst of
1089
    Types.Bad msg -> failTest msg
1090
    Types.Ok (nl, il, inst') ->
1091
      case IAlloc.processRelocate defGroupList nl il
1092
             (Instance.idx inst) 1 [Instance.sNode inst'] of
1093
        Types.Ok _ -> printTestCase "??" True  -- huh, how to make
1094
                                               -- this nicer...
1095
        Types.Bad msg -> failTest $ "Failed to relocate: " ++ msg
1096

    
1097
-- | Helper property checker for the result of a nodeEvac or
1098
-- changeGroup operation.
1099
check_EvacMode grp inst result =
1100
  case result of
1101
    Types.Bad msg -> failTest $ "Couldn't evacuate/change group:" ++ msg
1102
    Types.Ok (_, _, es) ->
1103
      let moved = Cluster.esMoved es
1104
          failed = Cluster.esFailed es
1105
          opcodes = not . null $ Cluster.esOpCodes es
1106
      in failmsg ("'failed' not empty: " ++ show failed) (null failed) .&&.
1107
         failmsg "'opcodes' is null" opcodes .&&.
1108
         case moved of
1109
           [(idx', gdx, _)] -> failmsg "invalid instance moved" (idx == idx')
1110
                               .&&.
1111
                               failmsg "wrong target group"
1112
                                         (gdx == Group.idx grp)
1113
           v -> failmsg  ("invalid solution: " ++ show v) False
1114
  where failmsg = \msg -> printTestCase ("Failed to evacuate: " ++ msg)
1115
        idx = Instance.idx inst
1116

    
1117
-- | Checks that on a 4-8 node cluster, once we allocate an instance,
1118
-- we can also node-evacuate it.
1119
prop_ClusterAllocEvacuate =
1120
  forAll (choose (4, 8)) $ \count ->
1121
  forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
1122
  forAll (arbitrary `suchThat` (isInstanceSmallerThanNode node)) $ \inst ->
1123
  case genClusterAlloc count node inst of
1124
    Types.Bad msg -> failTest msg
1125
    Types.Ok (nl, il, inst') ->
1126
      conjoin $ map (\mode -> check_EvacMode defGroup inst' $
1127
                              Cluster.tryNodeEvac defGroupList nl il mode
1128
                                [Instance.idx inst']) [minBound..maxBound]
1129

    
1130
-- | Checks that on a 4-8 node cluster with two node groups, once we
1131
-- allocate an instance on the first node group, we can also change
1132
-- its group.
1133
prop_ClusterAllocChangeGroup =
1134
  forAll (choose (4, 8)) $ \count ->
1135
  forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
1136
  forAll (arbitrary `suchThat` (isInstanceSmallerThanNode node)) $ \inst ->
1137
  case genClusterAlloc count node inst of
1138
    Types.Bad msg -> failTest msg
1139
    Types.Ok (nl, il, inst') ->
1140
      -- we need to add a second node group and nodes to the cluster
1141
      let nl2 = Container.elems $ makeSmallCluster node count
1142
          grp2 = Group.setIdx defGroup (Group.idx defGroup + 1)
1143
          maxndx = maximum . map Node.idx $ nl2
1144
          nl3 = map (\n -> n { Node.group = Group.idx grp2
1145
                             , Node.idx = Node.idx n + maxndx }) nl2
1146
          nl4 = Container.fromList . map (\n -> (Node.idx n, n)) $ nl3
1147
          gl' = Container.add (Group.idx grp2) grp2 defGroupList
1148
          nl' = IntMap.union nl nl4
1149
      in check_EvacMode grp2 inst' $
1150
         Cluster.tryChangeGroup gl' nl' il [] [Instance.idx inst']
1151

    
1152
-- | Check that allocating multiple instances on a cluster, then
1153
-- adding an empty node, results in a valid rebalance.
1154
prop_ClusterAllocBalance =
1155
  forAll (genNode (Just 5) (Just 128)) $ \node ->
1156
  forAll (choose (3, 5)) $ \count ->
1157
  not (Node.offline node) && not (Node.failN1 node) ==>
1158
  let nl = makeSmallCluster node count
1159
      (hnode, nl') = IntMap.deleteFindMax nl
1160
      il = Container.empty
1161
      allocnodes = Cluster.genAllocNodes defGroupList nl' 2 True
1162
      i_templ = createInstance Types.unitMem Types.unitDsk Types.unitCpu
1163
  in case allocnodes >>= \allocnodes' ->
1164
    Cluster.iterateAlloc nl' il (Just 5) i_templ allocnodes' [] [] of
1165
       Types.Bad msg -> failTest $ "Failed to allocate: " ++ msg
1166
       Types.Ok (_, _, _, [], _) -> failTest "Failed to allocate: no instances"
1167
       Types.Ok (_, xnl, il', _, _) ->
1168
         let ynl = Container.add (Node.idx hnode) hnode xnl
1169
             cv = Cluster.compCV ynl
1170
             tbl = Cluster.Table ynl il' cv []
1171
         in printTestCase "Failed to rebalance" $
1172
            canBalance tbl True True False
1173

    
1174
-- | Checks consistency.
1175
prop_ClusterCheckConsistency node inst =
1176
  let nl = makeSmallCluster node 3
1177
      [node1, node2, node3] = Container.elems nl
1178
      node3' = node3 { Node.group = 1 }
1179
      nl' = Container.add (Node.idx node3') node3' nl
1180
      inst1 = Instance.setBoth inst (Node.idx node1) (Node.idx node2)
1181
      inst2 = Instance.setBoth inst (Node.idx node1) Node.noSecondary
1182
      inst3 = Instance.setBoth inst (Node.idx node1) (Node.idx node3)
1183
      ccheck = Cluster.findSplitInstances nl' . Container.fromList
1184
  in null (ccheck [(0, inst1)]) &&
1185
     null (ccheck [(0, inst2)]) &&
1186
     (not . null $ ccheck [(0, inst3)])
1187

    
1188
-- | For now, we only test that we don't lose instances during the split.
1189
prop_ClusterSplitCluster node inst =
1190
  forAll (choose (0, 100)) $ \icnt ->
1191
  let nl = makeSmallCluster node 2
1192
      (nl', il') = foldl (\(ns, is) _ -> assignInstance ns is inst 0 1)
1193
                   (nl, Container.empty) [1..icnt]
1194
      gni = Cluster.splitCluster nl' il'
1195
  in sum (map (Container.size . snd . snd) gni) == icnt &&
1196
     all (\(guuid, (nl'', _)) -> all ((== guuid) . Node.group)
1197
                                 (Container.elems nl'')) gni
1198

    
1199
-- | Helper function to check if we can allocate an instance on a
1200
-- given node list.
1201
canAllocOn :: Node.List -> Int -> Instance.Instance -> Bool
1202
canAllocOn nl reqnodes inst =
1203
  case Cluster.genAllocNodes defGroupList nl reqnodes True >>=
1204
       Cluster.tryAlloc nl (Container.empty) inst of
1205
       Types.Bad _ -> False
1206
       Types.Ok as ->
1207
         case Cluster.asSolution as of
1208
           Nothing -> False
1209
           Just _ -> True
1210

    
1211
-- | Checks that allocation obeys minimum and maximum instance
1212
-- policies. The unittest generates a random node, duplicates it count
1213
-- times, and generates a random instance that can be allocated on
1214
-- this mini-cluster; it then checks that after applying a policy that
1215
-- the instance doesn't fits, the allocation fails.
1216
prop_ClusterAllocPolicy node =
1217
  -- rqn is the required nodes (1 or 2)
1218
  forAll (choose (1, 2)) $ \rqn ->
1219
  forAll (choose (5, 20)) $ \count ->
1220
  forAll (arbitrary `suchThat` (canAllocOn (makeSmallCluster node count) rqn))
1221
         $ \inst ->
1222
  forAll (arbitrary `suchThat` (isFailure .
1223
                                Instance.instMatchesPolicy inst)) $ \ipol ->
1224
  let node' = Node.setPolicy ipol node
1225
      nl = makeSmallCluster node' count
1226
  in not $ canAllocOn nl rqn inst
1227

    
1228
testSuite "Cluster"
1229
            [ 'prop_Score_Zero
1230
            , 'prop_CStats_sane
1231
            , 'prop_ClusterAlloc_sane
1232
            , 'prop_ClusterCanTieredAlloc
1233
            , 'prop_ClusterAllocRelocate
1234
            , 'prop_ClusterAllocEvacuate
1235
            , 'prop_ClusterAllocChangeGroup
1236
            , 'prop_ClusterAllocBalance
1237
            , 'prop_ClusterCheckConsistency
1238
            , 'prop_ClusterSplitCluster
1239
            , 'prop_ClusterAllocPolicy
1240
            ]
1241

    
1242
-- ** OpCodes tests
1243

    
1244
-- | Check that opcode serialization is idempotent.
1245
prop_OpCodes_serialization op =
1246
  case J.readJSON (J.showJSON op) of
1247
    J.Error e -> failTest $ "Cannot deserialise: " ++ e
1248
    J.Ok op' -> op ==? op'
1249
  where _types = op::OpCodes.OpCode
1250

    
1251
testSuite "OpCodes"
1252
            [ 'prop_OpCodes_serialization ]
1253

    
1254
-- ** Jobs tests
1255

    
1256
-- | Check that (queued) job\/opcode status serialization is idempotent.
1257
prop_OpStatus_serialization os =
1258
  case J.readJSON (J.showJSON os) of
1259
    J.Error e -> failTest $ "Cannot deserialise: " ++ e
1260
    J.Ok os' -> os ==? os'
1261
  where _types = os::Jobs.OpStatus
1262

    
1263
prop_JobStatus_serialization js =
1264
  case J.readJSON (J.showJSON js) of
1265
    J.Error e -> failTest $ "Cannot deserialise: " ++ e
1266
    J.Ok js' -> js ==? js'
1267
  where _types = js::Jobs.JobStatus
1268

    
1269
testSuite "Jobs"
1270
            [ 'prop_OpStatus_serialization
1271
            , 'prop_JobStatus_serialization
1272
            ]
1273

    
1274
-- ** Loader tests
1275

    
1276
prop_Loader_lookupNode ktn inst node =
1277
  Loader.lookupNode nl inst node ==? Data.Map.lookup node nl
1278
    where nl = Data.Map.fromList ktn
1279

    
1280
prop_Loader_lookupInstance kti inst =
1281
  Loader.lookupInstance il inst ==? Data.Map.lookup inst il
1282
    where il = Data.Map.fromList kti
1283

    
1284
prop_Loader_assignIndices =
1285
  -- generate nodes with unique names
1286
  forAll (arbitrary `suchThat`
1287
          (\nodes ->
1288
             let names = map Node.name nodes
1289
             in length names == length (nub names))) $ \nodes ->
1290
  let (nassoc, kt) =
1291
        Loader.assignIndices (map (\n -> (Node.name n, n)) nodes)
1292
  in Data.Map.size nassoc == length nodes &&
1293
     Container.size kt == length nodes &&
1294
     if not (null nodes)
1295
       then maximum (IntMap.keys kt) == length nodes - 1
1296
       else True
1297

    
1298
-- | Checks that the number of primary instances recorded on the nodes
1299
-- is zero.
1300
prop_Loader_mergeData ns =
1301
  let na = Container.fromList $ map (\n -> (Node.idx n, n)) ns
1302
  in case Loader.mergeData [] [] [] []
1303
         (Loader.emptyCluster {Loader.cdNodes = na}) of
1304
    Types.Bad _ -> False
1305
    Types.Ok (Loader.ClusterData _ nl il _ _) ->
1306
      let nodes = Container.elems nl
1307
          instances = Container.elems il
1308
      in (sum . map (length . Node.pList)) nodes == 0 &&
1309
         null instances
1310

    
1311
-- | Check that compareNameComponent on equal strings works.
1312
prop_Loader_compareNameComponent_equal :: String -> Bool
1313
prop_Loader_compareNameComponent_equal s =
1314
  Loader.compareNameComponent s s ==
1315
    Loader.LookupResult Loader.ExactMatch s
1316

    
1317
-- | Check that compareNameComponent on prefix strings works.
1318
prop_Loader_compareNameComponent_prefix :: NonEmptyList Char -> String -> Bool
1319
prop_Loader_compareNameComponent_prefix (NonEmpty s1) s2 =
1320
  Loader.compareNameComponent (s1 ++ "." ++ s2) s1 ==
1321
    Loader.LookupResult Loader.PartialMatch s1
1322

    
1323
testSuite "Loader"
1324
            [ 'prop_Loader_lookupNode
1325
            , 'prop_Loader_lookupInstance
1326
            , 'prop_Loader_assignIndices
1327
            , 'prop_Loader_mergeData
1328
            , 'prop_Loader_compareNameComponent_equal
1329
            , 'prop_Loader_compareNameComponent_prefix
1330
            ]
1331

    
1332
-- ** Types tests
1333

    
1334
prop_Types_AllocPolicy_serialisation apol =
1335
  case J.readJSON (J.showJSON apol) of
1336
    J.Ok p -> p ==? apol
1337
    J.Error s -> failTest $ "Failed to deserialise: " ++ s
1338
      where _types = apol::Types.AllocPolicy
1339

    
1340
prop_Types_DiskTemplate_serialisation dt =
1341
  case J.readJSON (J.showJSON dt) of
1342
    J.Ok p -> p ==? dt
1343
    J.Error s -> failTest $ "Failed to deserialise: " ++ s
1344
      where _types = dt::Types.DiskTemplate
1345

    
1346
prop_Types_ISpec_serialisation ispec =
1347
  case J.readJSON (J.showJSON ispec) of
1348
    J.Ok p -> p ==? ispec
1349
    J.Error s -> failTest $ "Failed to deserialise: " ++ s
1350
      where _types = ispec::Types.ISpec
1351

    
1352
prop_Types_IPolicy_serialisation ipol =
1353
  case J.readJSON (J.showJSON ipol) of
1354
    J.Ok p -> p ==? ipol
1355
    J.Error s -> failTest $ "Failed to deserialise: " ++ s
1356
      where _types = ipol::Types.IPolicy
1357

    
1358
prop_Types_EvacMode_serialisation em =
1359
  case J.readJSON (J.showJSON em) of
1360
    J.Ok p -> p ==? em
1361
    J.Error s -> failTest $ "Failed to deserialise: " ++ s
1362
      where _types = em::Types.EvacMode
1363

    
1364
prop_Types_opToResult op =
1365
  case op of
1366
    Types.OpFail _ -> Types.isBad r
1367
    Types.OpGood v -> case r of
1368
                        Types.Bad _ -> False
1369
                        Types.Ok v' -> v == v'
1370
  where r = Types.opToResult op
1371
        _types = op::Types.OpResult Int
1372

    
1373
prop_Types_eitherToResult ei =
1374
  case ei of
1375
    Left _ -> Types.isBad r
1376
    Right v -> case r of
1377
                 Types.Bad _ -> False
1378
                 Types.Ok v' -> v == v'
1379
    where r = Types.eitherToResult ei
1380
          _types = ei::Either String Int
1381

    
1382
testSuite "Types"
1383
            [ 'prop_Types_AllocPolicy_serialisation
1384
            , 'prop_Types_DiskTemplate_serialisation
1385
            , 'prop_Types_ISpec_serialisation
1386
            , 'prop_Types_IPolicy_serialisation
1387
            , 'prop_Types_EvacMode_serialisation
1388
            , 'prop_Types_opToResult
1389
            , 'prop_Types_eitherToResult
1390
            ]