Revision 23fe06c2

b/htools/Ganeti/HTools/QC.hs
1
{-# LANGUAGE TemplateHaskell #-}
2

  
1 3
{-| Unittests for ganeti-htools.
2 4

  
3 5
-}
......
71 73
import qualified Ganeti.HTools.Program.Hscan
72 74
import qualified Ganeti.HTools.Program.Hspace
73 75

  
74
run :: Testable prop => prop -> Args -> IO Result
75
run = flip quickCheckWithResult
76
import Ganeti.HTools.QCHelper (testSuite)
76 77

  
77 78
-- * Constants
78 79

  
......
364 365
    where _types = n::Int
365 366

  
366 367
-- | Test list for the Utils module.
367
testUtils =
368
  [ run prop_Utils_commaJoinSplit
369
  , run prop_Utils_commaSplitJoin
370
  , run prop_Utils_fromObjWithDefault
371
  , run prop_Utils_if'if
372
  , run prop_Utils_select
373
  , run prop_Utils_select_undefd
374
  , run prop_Utils_select_undefv
375
  , run prop_Utils_parseUnit
376
  ]
368
testSuite "Utils"
369
              [ 'prop_Utils_commaJoinSplit
370
              , 'prop_Utils_commaSplitJoin
371
              , 'prop_Utils_fromObjWithDefault
372
              , 'prop_Utils_if'if
373
              , 'prop_Utils_select
374
              , 'prop_Utils_select_undefd
375
              , 'prop_Utils_select_undefv
376
              , 'prop_Utils_parseUnit
377
              ]
377 378

  
378 379
-- ** PeerMap tests
379 380

  
......
413 414
          puniq = PeerMap.accumArray const pmap
414 415

  
415 416
-- | List of tests for the PeerMap module.
416
testPeerMap =
417
    [ run prop_PeerMap_addIdempotent
418
    , run prop_PeerMap_removeIdempotent
419
    , run prop_PeerMap_maxElem
420
    , run prop_PeerMap_addFind
421
    , run prop_PeerMap_findMissing
422
    ]
417
testSuite "PeerMap"
418
              [ 'prop_PeerMap_addIdempotent
419
              , 'prop_PeerMap_removeIdempotent
420
              , 'prop_PeerMap_maxElem
421
              , 'prop_PeerMap_addFind
422
              , 'prop_PeerMap_findMissing
423
              ]
423 424

  
424 425
-- ** Container tests
425 426

  
......
458 459
     Container.findByName nl' (Node.alias target) == Just target &&
459 460
     Container.findByName nl' othername == Nothing
460 461

  
461
testContainer =
462
    [ run prop_Container_addTwo
463
    , run prop_Container_nameOf
464
    , run prop_Container_findByName
465
    ]
462
testSuite "Container"
463
              [ 'prop_Container_addTwo
464
              , 'prop_Container_nameOf
465
              , 'prop_Container_findByName
466
              ]
466 467

  
467 468
-- ** Instance tests
468 469

  
......
551 552
    Instance.movable inst' == m
552 553
    where inst' = Instance.setMovable inst m
553 554

  
554
testInstance =
555
    [ run prop_Instance_creat
556
    , run prop_Instance_setIdx
557
    , run prop_Instance_setName
558
    , run prop_Instance_setAlias
559
    , run prop_Instance_setPri
560
    , run prop_Instance_setSec
561
    , run prop_Instance_setBoth
562
    , run prop_Instance_runStatus_True
563
    , run prop_Instance_runStatus_False
564
    , run prop_Instance_shrinkMG
565
    , run prop_Instance_shrinkMF
566
    , run prop_Instance_shrinkCG
567
    , run prop_Instance_shrinkCF
568
    , run prop_Instance_shrinkDG
569
    , run prop_Instance_shrinkDF
570
    , run prop_Instance_setMovable
571
    ]
555
testSuite "Instance"
556
              [ 'prop_Instance_creat
557
              , 'prop_Instance_setIdx
558
              , 'prop_Instance_setName
559
              , 'prop_Instance_setAlias
560
              , 'prop_Instance_setPri
561
              , 'prop_Instance_setSec
562
              , 'prop_Instance_setBoth
563
              , 'prop_Instance_runStatus_True
564
              , 'prop_Instance_runStatus_False
565
              , 'prop_Instance_shrinkMG
566
              , 'prop_Instance_shrinkMF
567
              , 'prop_Instance_shrinkCG
568
              , 'prop_Instance_shrinkCF
569
              , 'prop_Instance_shrinkDG
570
              , 'prop_Instance_shrinkDF
571
              , 'prop_Instance_setMovable
572
              ]
572 573

  
573 574
-- ** Text backend tests
574 575

  
......
663 664
    -- override failN1 to what loadNode returns by default
664 665
    where n = node { Node.failN1 = True, Node.offline = False }
665 666

  
666
testText =
667
    [ run prop_Text_Load_Instance
668
    , run prop_Text_Load_InstanceFail
669
    , run prop_Text_Load_Node
670
    , run prop_Text_Load_NodeFail
671
    , run prop_Text_NodeLSIdempotent
672
    ]
667
testSuite "Text"
668
              [ 'prop_Text_Load_Instance
669
              , 'prop_Text_Load_InstanceFail
670
              , 'prop_Text_Load_Node
671
              , 'prop_Text_Load_NodeFail
672
              , 'prop_Text_NodeLSIdempotent
673
              ]
673 674

  
674 675
-- ** Node tests
675 676

  
......
790 791
  fst (Node.showHeader field) /= Types.unknownField &&
791 792
  Node.showField node field /= Types.unknownField
792 793

  
793

  
794 794
prop_Node_computeGroups nodes =
795 795
  let ng = Node.computeGroups nodes
796 796
      onlyuuid = map fst ng
......
799 799
     length (nub onlyuuid) == length onlyuuid &&
800 800
     (null nodes || not (null ng))
801 801

  
802
testNode =
803
    [ run prop_Node_setAlias
804
    , run prop_Node_setOffline
805
    , run prop_Node_setMcpu
806
    , run prop_Node_setXmem
807
    , run prop_Node_addPriFM
808
    , run prop_Node_addPriFD
809
    , run prop_Node_addPriFC
810
    , run prop_Node_addSec
811
    , run prop_Node_rMem
812
    , run prop_Node_setMdsk
813
    , run prop_Node_tagMaps_idempotent
814
    , run prop_Node_tagMaps_reject
815
    , run prop_Node_showField
816
    , run prop_Node_computeGroups
817
    ]
818

  
802
testSuite "Node"
803
              [ 'prop_Node_setAlias
804
              , 'prop_Node_setOffline
805
              , 'prop_Node_setMcpu
806
              , 'prop_Node_setXmem
807
              , 'prop_Node_addPriFM
808
              , 'prop_Node_addPriFD
809
              , 'prop_Node_addPriFC
810
              , 'prop_Node_addSec
811
              , 'prop_Node_rMem
812
              , 'prop_Node_setMdsk
813
              , 'prop_Node_tagMaps_idempotent
814
              , 'prop_Node_tagMaps_reject
815
              , 'prop_Node_showField
816
              , 'prop_Node_computeGroups
817
              ]
819 818

  
820 819
-- ** Cluster tests
821 820

  
......
957 956
     all (\(guuid, (nl'', _)) -> all ((== guuid) . Node.group)
958 957
                                 (Container.elems nl'')) gni
959 958

  
960
testCluster =
961
    [ run prop_Score_Zero
962
    , run prop_CStats_sane
963
    , run prop_ClusterAlloc_sane
964
    , run prop_ClusterCanTieredAlloc
965
    , run prop_ClusterAllocEvac
966
    , run prop_ClusterAllocBalance
967
    , run prop_ClusterCheckConsistency
968
    , run prop_ClusterSplitCluster
969
    ]
959
testSuite "Cluster"
960
              [ 'prop_Score_Zero
961
              , 'prop_CStats_sane
962
              , 'prop_ClusterAlloc_sane
963
              , 'prop_ClusterCanTieredAlloc
964
              , 'prop_ClusterAllocEvac
965
              , 'prop_ClusterAllocBalance
966
              , 'prop_ClusterCheckConsistency
967
              , 'prop_ClusterSplitCluster
968
              ]
970 969

  
971 970
-- ** OpCodes tests
972 971

  
......
977 976
    J.Ok op' -> op == op'
978 977
  where _types = op::OpCodes.OpCode
979 978

  
980
testOpCodes =
981
  [ run prop_OpCodes_serialization
982
  ]
979
testSuite "OpCodes"
980
              [ 'prop_OpCodes_serialization ]
983 981

  
984 982
-- ** Jobs tests
985 983

  
......
996 994
    J.Ok js' -> js == js'
997 995
  where _types = js::Jobs.JobStatus
998 996

  
999
testJobs =
1000
  [ run prop_OpStatus_serialization
1001
  , run prop_JobStatus_serialization
1002
  ]
997
testSuite "Jobs"
998
              [ 'prop_OpStatus_serialization
999
              , 'prop_JobStatus_serialization
1000
              ]
1003 1001

  
1004 1002
-- ** Loader tests
1005 1003

  
......
1044 1042
  Loader.compareNameComponent (s1 ++ "." ++ s2) s1 ==
1045 1043
    Loader.LookupResult Loader.PartialMatch s1
1046 1044

  
1047
testLoader =
1048
  [ run prop_Loader_lookupNode
1049
  , run prop_Loader_lookupInstance
1050
  , run prop_Loader_assignIndices
1051
  , run prop_Loader_mergeData
1052
  , run prop_Loader_compareNameComponent_equal
1053
  , run prop_Loader_compareNameComponent_prefix
1054
  ]
1045
testSuite "Loader"
1046
              [ 'prop_Loader_lookupNode
1047
              , 'prop_Loader_lookupInstance
1048
              , 'prop_Loader_assignIndices
1049
              , 'prop_Loader_mergeData
1050
              , 'prop_Loader_compareNameComponent_equal
1051
              , 'prop_Loader_compareNameComponent_prefix
1052
              ]
1055 1053

  
1056 1054
-- ** Types tests
1057 1055

  
......
1088 1086
    where r = Types.eitherToResult ei
1089 1087
          _types = ei::Either String Int
1090 1088

  
1091
testTypes =
1092
    [ run prop_Types_AllocPolicy_serialisation
1093
    , run prop_Types_DiskTemplate_serialisation
1094
    , run prop_Types_opToResult
1095
    , run prop_Types_eitherToResult
1096
    ]
1089
testSuite "Types"
1090
              [ 'prop_Types_AllocPolicy_serialisation
1091
              , 'prop_Types_DiskTemplate_serialisation
1092
              , 'prop_Types_opToResult
1093
              , 'prop_Types_eitherToResult
1094
              ]
b/htools/Ganeti/HTools/QCHelper.hs
1
{-# LANGUAGE TemplateHaskell #-}
2

  
3
{-| Unittest helpers for ganeti-htools
4

  
5
-}
6

  
7
{-
8

  
9
Copyright (C) 2011 Google Inc.
10

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

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

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

  
26
-}
27

  
28
module Ganeti.HTools.QCHelper
29
    ( testSuite
30
    ) where
31

  
32
import Test.QuickCheck
33
import Language.Haskell.TH
34

  
35
run :: Testable prop => prop -> Args -> IO Result
36
run = flip quickCheckWithResult
37

  
38
testSuite :: String -> [Name] -> Q [Dec]
39
testSuite tsname tdef = do
40
  let fullname = mkName $ "test" ++ tsname
41
  tests <- mapM (\n -> [| (run $(varE n), $(litE . StringL . nameBase $ n)) |])
42
           tdef
43
  sigtype <- [t| (String, [(Args -> IO Result, String)]) |]
44
  return $ [ SigD fullname sigtype
45
           , ValD (VarP fullname) (NormalB (TupE [LitE (StringL tsname),
46
                                                  ListE tests])) []
47
           ]
b/htools/test.hs
27 27

  
28 28
import Data.IORef
29 29
import Test.QuickCheck
30
import System.Console.GetOpt
30
import System.Console.GetOpt ()
31 31
import System.IO
32 32
import System.Exit
33 33
import System (getArgs)
......
63 63

  
64 64
-- | Wrapper over a test runner with error counting.
65 65
wrapTest :: IORef Int
66
         -> (Args -> IO Result)
66
         -> (Args -> IO Result, String)
67 67
         -> Args
68
         -> IO (Result, Char)
69
wrapTest ir test opts = do
68
         -> IO (Result, Char, String)
69
wrapTest ir (test, desc) opts = do
70 70
  r <- test opts
71 71
  c <- case r of
72 72
         Success {} -> return '.'
73 73
         GaveUp  {} -> return '?'
74 74
         Failure {} -> incIORef ir >> return '#'
75 75
         NoExpectedFailure {} -> incIORef ir >> return '*'
76
  return (r, c)
76
  return (r, c, desc)
77

  
78
runTests :: String
79
         -> Args
80
         -> [Args -> IO (Result, Char, String)]
81
         -> Int
82
         -> IO [(Result, String)]
77 83

  
78 84
runTests name opts tests max_count = do
79 85
  _ <- printf "%25s : " name
80 86
  hFlush stdout
81 87
  results <- mapM (\t -> do
82
                     (r, c) <- t opts
88
                     (r, c, desc) <- t opts
83 89
                     putChar c
84 90
                     hFlush stdout
85
                     return r
91
                     return (r, desc)
86 92
                  ) tests
87
  let alldone = sum . map numTests $ results
93
  let alldone = sum . map (numTests . fst) $ results
88 94
  _ <- printf "%*s(%d)\n" (max_count - length tests + 1) " " alldone
89
  mapM_ (\(idx, r) ->
95
  mapM_ (\(r, desc) ->
90 96
             case r of
91 97
               Failure { output = o, usedSeed = u, usedSize = size } ->
92
                   printf "Test %d failed (seed was %s, test size %d): %s\n"
93
                          idx (show u) size o
98
                   printf "Test %s failed (seed was %s, test size %d): %s\n"
99
                          desc (show u) size o
94 100
               GaveUp { numTests = passed } ->
95
                   printf "Test %d incomplete: gave up with only %d\
101
                   printf "Test %s incomplete: gave up with only %d\
96 102
                          \ passes after discarding %d tests\n"
97
                          idx passed (maxDiscard opts)
103
                          desc passed (maxDiscard opts)
98 104
               _ -> return ()
99
        ) $ zip ([1..]::[Int]) results
105
        ) results
100 106
  return results
101 107

  
102
allTests :: [(String, Args, [Args -> IO Result])]
108
allTests :: [(Args, (String, [(Args -> IO Result, String)]))]
103 109
allTests =
104
  [ ("Utils", fast, testUtils)
105
  , ("PeerMap", fast, testPeerMap)
106
  , ("Container", fast, testContainer)
107
  , ("Instance", fast, testInstance)
108
  , ("Node", fast, testNode)
109
  , ("Text", fast, testText)
110
  , ("OpCodes", fast, testOpCodes)
111
  , ("Jobs", fast, testJobs)
112
  , ("Loader", fast, testLoader)
113
  , ("Types", fast, testTypes)
114
  , ("Cluster", slow, testCluster)
110
  [ (fast, testUtils)
111
  , (fast, testPeerMap)
112
  , (fast, testContainer)
113
  , (fast, testInstance)
114
  , (fast, testNode)
115
  , (fast, testText)
116
  , (fast, testOpCodes)
117
  , (fast, testJobs)
118
  , (fast, testLoader)
119
  , (fast, testTypes)
120
  , (slow, testCluster)
115 121
  ]
116 122

  
117 123
transformTestOpts :: Args -> Options -> IO Args
......
135 141
  (opts, args) <- parseOpts cmd_args "test" options
136 142
  let tests = if null args
137 143
              then allTests
138
              else filter (\(name, _, _) -> name `elem` args) allTests
139
      max_count = maximum $ map (\(_, _, t) -> length t) tests
140
  mapM_ (\(name, targs, tl) ->
144
              else filter (\(_, (name, _)) -> name `elem` args) allTests
145
      max_count = maximum $ map (\(_, (_, t)) -> length t) tests
146
  mapM_ (\(targs, (name, tl)) ->
141 147
             transformTestOpts targs opts >>= \newargs ->
142 148
             runTests name newargs (wrap tl) max_count) tests
143 149
  terr <- readIORef errs

Also available in: Unified diff