Revision 942a9a6a
| b/htest/Test/Ganeti/BasicTypes.hs | ||
|---|---|---|
| 114 | 114 |
-> Fun Int (Result Int) |
| 115 | 115 |
-> Property |
| 116 | 116 |
prop_monad_laws a m (Fun _ k) (Fun _ h) = |
| 117 |
printTestCase "return a >>= k == k a" ((return a >>= k) ==? k a) .&&. |
|
| 118 |
printTestCase "m >>= return == m" ((m >>= return) ==? m) .&&. |
|
| 119 |
printTestCase "m >>= (\\x -> k x >>= h) == (m >>= k) >>= h)" |
|
| 117 |
conjoin |
|
| 118 |
[ printTestCase "return a >>= k == k a" ((return a >>= k) ==? k a) |
|
| 119 |
, printTestCase "m >>= return == m" ((m >>= return) ==? m) |
|
| 120 |
, printTestCase "m >>= (\\x -> k x >>= h) == (m >>= k) >>= h)" |
|
| 120 | 121 |
((m >>= (\x -> k x >>= h)) ==? ((m >>= k) >>= h)) |
| 122 |
] |
|
| 121 | 123 |
|
| 122 | 124 |
-- | Tests the monad plus laws ( mzero >>= f = mzero, v >> mzero = mzero). |
| 123 | 125 |
prop_monadplus_mzero :: Result Int -> Fun Int (Result Int) -> Property |
| b/htest/Test/Ganeti/HTools/Cluster.hs | ||
|---|---|---|
| 266 | 266 |
let moved = Cluster.esMoved es |
| 267 | 267 |
failed = Cluster.esFailed es |
| 268 | 268 |
opcodes = not . null $ Cluster.esOpCodes es |
| 269 |
in failmsg ("'failed' not empty: " ++ show failed) (null failed) .&&.
|
|
| 270 |
failmsg "'opcodes' is null" opcodes .&&. |
|
| 271 |
case moved of |
|
| 272 |
[(idx', gdx, _)] -> failmsg "invalid instance moved" (idx == idx') |
|
| 273 |
.&&. |
|
| 274 |
failmsg "wrong target group" |
|
| 275 |
(gdx == Group.idx grp) |
|
| 276 |
v -> failmsg ("invalid solution: " ++ show v) False
|
|
| 269 |
in conjoin |
|
| 270 |
[ failmsg ("'failed' not empty: " ++ show failed) (null failed)
|
|
| 271 |
, failmsg "'opcodes' is null" opcodes |
|
| 272 |
, case moved of |
|
| 273 |
[(idx', gdx, _)] -> |
|
| 274 |
failmsg "invalid instance moved" (idx == idx') .&&. |
|
| 275 |
failmsg "wrong target group" (gdx == Group.idx grp) |
|
| 276 |
v -> failmsg ("invalid solution: " ++ show v) False
|
|
| 277 |
] |
|
| 277 | 278 |
where failmsg :: String -> Bool -> Property |
| 278 | 279 |
failmsg msg = printTestCase ("Failed to evacuate: " ++ msg)
|
| 279 | 280 |
idx = Instance.idx inst |
| b/htest/Test/Ganeti/HTools/Container.hs | ||
|---|---|---|
| 74 | 74 |
$ zip names nodes |
| 75 | 75 |
nl' = Container.fromList nodes' |
| 76 | 76 |
target = snd (nodes' !! fidx) |
| 77 |
in Container.findByName nl' (Node.name target) ==? Just target .&&. |
|
| 78 |
Container.findByName nl' (Node.alias target) ==? Just target .&&. |
|
| 79 |
printTestCase "Found non-existing name" |
|
| 80 |
(isNothing (Container.findByName nl' othername)) |
|
| 77 |
in conjoin |
|
| 78 |
[ Container.findByName nl' (Node.name target) ==? Just target |
|
| 79 |
, Container.findByName nl' (Node.alias target) ==? Just target |
|
| 80 |
, printTestCase "Found non-existing name" |
|
| 81 |
(isNothing (Container.findByName nl' othername)) |
|
| 82 |
] |
|
| 81 | 83 |
|
| 82 | 84 |
testSuite "HTools/Container" |
| 83 | 85 |
[ 'prop_addTwo |
| b/htest/Test/Ganeti/HTools/Simu.hs | ||
|---|---|---|
| 82 | 82 |
nidx = map Node.idx nodes |
| 83 | 83 |
mdc_out = map (\n -> (Node.tMem n, Node.tDsk n, Node.tCpu n, |
| 84 | 84 |
Node.fMem n, Node.fDsk n)) nodes |
| 85 |
in |
|
| 86 |
Container.size gl ==? ngroups .&&.
|
|
| 87 |
Container.size nl ==? totnodes .&&.
|
|
| 88 |
Container.size il ==? 0 .&&.
|
|
| 89 |
length tags ==? 0 .&&.
|
|
| 90 |
ipol ==? Types.defIPolicy .&&.
|
|
| 91 |
nidx ==? [1..totnodes] .&&.
|
|
| 92 |
mdc_in ==? mdc_out .&&.
|
|
| 93 |
map Group.iPolicy (Container.elems gl) ==?
|
|
| 94 |
replicate ngroups Types.defIPolicy
|
|
| 85 |
in conjoin [ Container.size gl ==? ngroups
|
|
| 86 |
, Container.size nl ==? totnodes
|
|
| 87 |
, Container.size il ==? 0
|
|
| 88 |
, length tags ==? 0
|
|
| 89 |
, ipol ==? Types.defIPolicy
|
|
| 90 |
, nidx ==? [1..totnodes]
|
|
| 91 |
, mdc_in ==? mdc_out
|
|
| 92 |
, map Group.iPolicy (Container.elems gl) ==?
|
|
| 93 |
replicate ngroups Types.defIPolicy
|
|
| 94 |
]
|
|
| 95 | 95 |
|
| 96 | 96 |
testSuite "HTools/Simu" |
| 97 | 97 |
[ 'prop_Load |
| b/htest/Test/Ganeti/HTools/Text.hs | ||
|---|---|---|
| 194 | 194 |
in case Text.parseData saved >>= Loader.mergeData [] [] [] [] of |
| 195 | 195 |
Bad msg -> failTest $ "Failed to load/merge: " ++ msg |
| 196 | 196 |
Ok (Loader.ClusterData gl2 nl2 il2 ctags2 cpol2) -> |
| 197 |
ctags ==? ctags2 .&&. |
|
| 198 |
Types.defIPolicy ==? cpol2 .&&. |
|
| 199 |
il' ==? il2 .&&. |
|
| 200 |
defGroupList ==? gl2 .&&. |
|
| 201 |
nl' ==? nl2 |
|
| 197 |
conjoin [ ctags ==? ctags2 |
|
| 198 |
, Types.defIPolicy ==? cpol2 |
|
| 199 |
, il' ==? il2 |
|
| 200 |
, defGroupList ==? gl2 |
|
| 201 |
, nl' ==? nl2 |
|
| 202 |
] |
|
| 202 | 203 |
|
| 203 | 204 |
testSuite "HTools/Text" |
| 204 | 205 |
[ 'prop_Load_Instance |
| b/htest/Test/Ganeti/Objects.hs | ||
|---|---|---|
| 199 | 199 |
d_keys = map fst defaults |
| 200 | 200 |
c_map = Map.fromList custom |
| 201 | 201 |
c_keys = map fst custom |
| 202 |
in printTestCase "Empty custom filling" |
|
| 203 |
(fillDict d_map Map.empty [] == d_map) .&&. |
|
| 204 |
printTestCase "Empty defaults filling" |
|
| 205 |
(fillDict Map.empty c_map [] == c_map) .&&. |
|
| 206 |
printTestCase "Delete all keys" |
|
| 207 |
(fillDict d_map c_map (d_keys++c_keys) == Map.empty) |
|
| 202 |
in conjoin [ printTestCase "Empty custom filling" |
|
| 203 |
(fillDict d_map Map.empty [] == d_map) |
|
| 204 |
, printTestCase "Empty defaults filling" |
|
| 205 |
(fillDict Map.empty c_map [] == c_map) |
|
| 206 |
, printTestCase "Delete all keys" |
|
| 207 |
(fillDict d_map c_map (d_keys++c_keys) == Map.empty) |
|
| 208 |
] |
|
| 208 | 209 |
|
| 209 | 210 |
-- | Test that the serialisation of 'DiskLogicalId', which is |
| 210 | 211 |
-- implemented manually, is idempotent. Since we don't have a |
| b/htest/Test/Ganeti/Query/Query.hs | ||
|---|---|---|
| 68 | 68 |
run (query cluster False (Query QRNode [field] EmptyFilter)) >>= resultProp |
| 69 | 69 |
QueryFieldsResult fdefs' <- |
| 70 | 70 |
resultProp $ queryFields (QueryFields QRNode [field]) |
| 71 |
stop $ printTestCase ("Got unknown fields via query (" ++ show fdefs ++ ")")
|
|
| 72 |
(hasUnknownFields fdefs) .&&. |
|
| 73 |
printTestCase ("Got unknown result status via query (" ++
|
|
| 74 |
show fdata ++ ")") |
|
| 75 |
(all (all ((/= RSUnknown) . rentryStatus)) fdata) .&&. |
|
| 76 |
printTestCase ("Got unknown fields via query fields (" ++ show fdefs'
|
|
| 77 |
++ ")") (hasUnknownFields fdefs') |
|
| 71 |
stop $ conjoin |
|
| 72 |
[ printTestCase ("Got unknown fields via query (" ++
|
|
| 73 |
show fdefs ++ ")") (hasUnknownFields fdefs) |
|
| 74 |
, printTestCase ("Got unknown result status via query (" ++
|
|
| 75 |
show fdata ++ ")") |
|
| 76 |
(all (all ((/= RSUnknown) . rentryStatus)) fdata) |
|
| 77 |
, printTestCase ("Got unknown fields via query fields (" ++
|
|
| 78 |
show fdefs'++ ")") (hasUnknownFields fdefs') |
|
| 79 |
] |
|
| 78 | 80 |
|
| 79 | 81 |
-- | Tests that an unknown field is returned as such. |
| 80 | 82 |
prop_queryNode_Unknown :: Property |
| ... | ... | |
| 86 | 88 |
run (query cluster False (Query QRNode [field] EmptyFilter)) >>= resultProp |
| 87 | 89 |
QueryFieldsResult fdefs' <- |
| 88 | 90 |
resultProp $ queryFields (QueryFields QRNode [field]) |
| 89 |
stop $ printTestCase ("Got known fields via query (" ++ show fdefs ++ ")")
|
|
| 90 |
(not $ hasUnknownFields fdefs) .&&. |
|
| 91 |
printTestCase ("Got /= ResultUnknown result status via query (" ++
|
|
| 92 |
show fdata ++ ")") |
|
| 93 |
(all (all ((== RSUnknown) . rentryStatus)) fdata) .&&. |
|
| 94 |
printTestCase ("Got a Just in a result value (" ++
|
|
| 95 |
show fdata ++ ")") |
|
| 96 |
(all (all (isNothing . rentryValue)) fdata) .&&. |
|
| 97 |
printTestCase ("Got known fields via query fields (" ++ show fdefs'
|
|
| 98 |
++ ")") (not $ hasUnknownFields fdefs') |
|
| 91 |
stop $ conjoin |
|
| 92 |
[ printTestCase ("Got known fields via query (" ++ show fdefs ++ ")")
|
|
| 93 |
(not $ hasUnknownFields fdefs) |
|
| 94 |
, printTestCase ("Got /= ResultUnknown result status via query (" ++
|
|
| 95 |
show fdata ++ ")") |
|
| 96 |
(all (all ((== RSUnknown) . rentryStatus)) fdata) |
|
| 97 |
, printTestCase ("Got a Just in a result value (" ++
|
|
| 98 |
show fdata ++ ")") |
|
| 99 |
(all (all (isNothing . rentryValue)) fdata) |
|
| 100 |
, printTestCase ("Got known fields via query fields (" ++ show fdefs'
|
|
| 101 |
++ ")") (not $ hasUnknownFields fdefs') |
|
| 102 |
] |
|
| 99 | 103 |
|
| 100 | 104 |
-- | Checks that a result type is conforming to a field definition. |
| 101 | 105 |
checkResultType :: FieldDefinition -> ResultEntry -> Property |
| ... | ... | |
| 128 | 132 |
forAll (elements (Map.keys nodeFieldsMap)) $ \field -> monadicIO $ do |
| 129 | 133 |
QueryResult fdefs fdata <- |
| 130 | 134 |
run (query cfg False (Query QRNode [field] EmptyFilter)) >>= resultProp |
| 131 |
stop $ printTestCase ("Inconsistent result entries (" ++ show fdata ++ ")")
|
|
| 132 |
(conjoin $ map (conjoin . zipWith checkResultType fdefs) fdata) .&&. |
|
| 133 |
printTestCase "Wrong field definitions length" |
|
| 134 |
(length fdefs ==? 1) .&&. |
|
| 135 |
printTestCase "Wrong field result rows length" |
|
| 136 |
(all ((== 1) . length) fdata) .&&. |
|
| 137 |
printTestCase "Wrong number of result rows" |
|
| 135 |
stop $ conjoin |
|
| 136 |
[ printTestCase ("Inconsistent result entries (" ++ show fdata ++ ")")
|
|
| 137 |
(conjoin $ map (conjoin . zipWith checkResultType fdefs) fdata) |
|
| 138 |
, printTestCase "Wrong field definitions length" |
|
| 139 |
(length fdefs ==? 1) |
|
| 140 |
, printTestCase "Wrong field result rows length" |
|
| 141 |
(all ((== 1) . length) fdata) |
|
| 142 |
, printTestCase "Wrong number of result rows" |
|
| 138 | 143 |
(length fdata ==? numnodes) |
| 144 |
] |
|
| 139 | 145 |
|
| 140 | 146 |
-- | Test that queryFields with empty fields list returns all node fields. |
| 141 | 147 |
case_queryNode_allfields :: Assertion |
| ... | ... | |
| 155 | 161 |
forAll (choose (0, maxNodes) >>= genEmptyCluster) $ \cluster -> |
| 156 | 162 |
forAll (elements (Map.keys groupFieldsMap)) $ \field -> monadicIO $ do |
| 157 | 163 |
QueryResult fdefs fdata <- |
| 158 |
run (query cluster False (Query QRGroup [field] EmptyFilter)) >>= resultProp |
|
| 164 |
run (query cluster False (Query QRGroup [field] EmptyFilter)) >>= |
|
| 165 |
resultProp |
|
| 159 | 166 |
QueryFieldsResult fdefs' <- |
| 160 | 167 |
resultProp $ queryFields (QueryFields QRGroup [field]) |
| 161 |
stop $ printTestCase ("Got unknown fields via query (" ++ show fdefs ++ ")")
|
|
| 162 |
(hasUnknownFields fdefs) .&&. |
|
| 163 |
printTestCase ("Got unknown result status via query (" ++
|
|
| 164 |
show fdata ++ ")") |
|
| 165 |
(all (all ((/= RSUnknown) . rentryStatus)) fdata) .&&. |
|
| 166 |
printTestCase ("Got unknown fields via query fields (" ++ show fdefs'
|
|
| 167 |
++ ")") (hasUnknownFields fdefs') |
|
| 168 |
stop $ conjoin |
|
| 169 |
[ printTestCase ("Got unknown fields via query (" ++ show fdefs ++ ")")
|
|
| 170 |
(hasUnknownFields fdefs) |
|
| 171 |
, printTestCase ("Got unknown result status via query (" ++
|
|
| 172 |
show fdata ++ ")") |
|
| 173 |
(all (all ((/= RSUnknown) . rentryStatus)) fdata) |
|
| 174 |
, printTestCase ("Got unknown fields via query fields (" ++ show fdefs'
|
|
| 175 |
++ ")") (hasUnknownFields fdefs') |
|
| 176 |
] |
|
| 168 | 177 |
|
| 169 | 178 |
prop_queryGroup_Unknown :: Property |
| 170 | 179 |
prop_queryGroup_Unknown = |
| ... | ... | |
| 175 | 184 |
run (query cluster False (Query QRGroup [field] EmptyFilter)) >>= resultProp |
| 176 | 185 |
QueryFieldsResult fdefs' <- |
| 177 | 186 |
resultProp $ queryFields (QueryFields QRGroup [field]) |
| 178 |
stop $ printTestCase ("Got known fields via query (" ++ show fdefs ++ ")")
|
|
| 179 |
(not $ hasUnknownFields fdefs) .&&. |
|
| 180 |
printTestCase ("Got /= ResultUnknown result status via query (" ++
|
|
| 181 |
show fdata ++ ")") |
|
| 182 |
(all (all ((== RSUnknown) . rentryStatus)) fdata) .&&. |
|
| 183 |
printTestCase ("Got a Just in a result value (" ++
|
|
| 184 |
show fdata ++ ")") |
|
| 185 |
(all (all (isNothing . rentryValue)) fdata) .&&. |
|
| 186 |
printTestCase ("Got known fields via query fields (" ++ show fdefs'
|
|
| 187 |
++ ")") (not $ hasUnknownFields fdefs') |
|
| 187 |
stop $ conjoin |
|
| 188 |
[ printTestCase ("Got known fields via query (" ++ show fdefs ++ ")")
|
|
| 189 |
(not $ hasUnknownFields fdefs) |
|
| 190 |
, printTestCase ("Got /= ResultUnknown result status via query (" ++
|
|
| 191 |
show fdata ++ ")") |
|
| 192 |
(all (all ((== RSUnknown) . rentryStatus)) fdata) |
|
| 193 |
, printTestCase ("Got a Just in a result value (" ++
|
|
| 194 |
show fdata ++ ")") |
|
| 195 |
(all (all (isNothing . rentryValue)) fdata) |
|
| 196 |
, printTestCase ("Got known fields via query fields (" ++ show fdefs'
|
|
| 197 |
++ ")") (not $ hasUnknownFields fdefs') |
|
| 198 |
] |
|
| 188 | 199 |
|
| 189 | 200 |
prop_queryGroup_types :: Property |
| 190 | 201 |
prop_queryGroup_types = |
| ... | ... | |
| 193 | 204 |
forAll (elements (Map.keys groupFieldsMap)) $ \field -> monadicIO $ do |
| 194 | 205 |
QueryResult fdefs fdata <- |
| 195 | 206 |
run (query cfg False (Query QRGroup [field] EmptyFilter)) >>= resultProp |
| 196 |
stop $ printTestCase ("Inconsistent result entries (" ++ show fdata ++ ")")
|
|
| 197 |
(conjoin $ map (conjoin . zipWith checkResultType fdefs) fdata) .&&.
|
|
| 198 |
printTestCase "Wrong field definitions length"
|
|
| 199 |
(length fdefs ==? 1) .&&.
|
|
| 200 |
printTestCase "Wrong field result rows length" |
|
| 207 |
stop $ conjoin
|
|
| 208 |
[ printTestCase ("Inconsistent result entries (" ++ show fdata ++ ")")
|
|
| 209 |
(conjoin $ map (conjoin . zipWith checkResultType fdefs) fdata)
|
|
| 210 |
, printTestCase "Wrong field definitions length" (length fdefs ==? 1)
|
|
| 211 |
, printTestCase "Wrong field result rows length"
|
|
| 201 | 212 |
(all ((== 1) . length) fdata) |
| 213 |
] |
|
| 202 | 214 |
|
| 203 | 215 |
case_queryGroup_allfields :: Assertion |
| 204 | 216 |
case_queryGroup_allfields = do |
Also available in: Unified diff