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