Revision 72747d91
b/src/Ganeti/HTools/Backend/IAlloc.hs | ||
---|---|---|
4 | 4 |
|
5 | 5 |
{- |
6 | 6 |
|
7 |
Copyright (C) 2009, 2010, 2011, 2012 Google Inc. |
|
7 |
Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
|
|
8 | 8 |
|
9 | 9 |
This program is free software; you can redistribute it and/or modify |
10 | 10 |
it under the terms of the GNU General Public License as published by |
... | ... | |
82 | 82 |
parseInstance ktn n a = do |
83 | 83 |
base <- parseBaseInstance n a |
84 | 84 |
nodes <- fromObj a "nodes" |
85 |
pnode <- if null nodes |
|
86 |
then Bad $ "empty node list for instance " ++ n |
|
87 |
else readEitherString $ head nodes |
|
85 |
(pnode, snodes) <- |
|
86 |
case nodes of |
|
87 |
[] -> Bad $ "empty node list for instance " ++ n |
|
88 |
x:xs -> readEitherString x >>= \x' -> return (x', xs) |
|
88 | 89 |
pidx <- lookupNode ktn n pnode |
89 |
let snodes = tail nodes |
|
90 |
sidx <- if null snodes |
|
91 |
then return Node.noSecondary |
|
92 |
else readEitherString (head snodes) >>= lookupNode ktn n |
|
90 |
sidx <- case snodes of |
|
91 |
[] -> return Node.noSecondary |
|
92 |
x:_ -> readEitherString x >>= lookupNode ktn n |
|
93 | 93 |
return (n, Instance.setBoth (snd base) pidx sidx) |
94 | 94 |
|
95 | 95 |
-- | Parses a node as found in the cluster node list. |
b/src/Ganeti/HTools/Backend/Luxi.hs | ||
---|---|---|
4 | 4 |
|
5 | 5 |
{- |
6 | 6 |
|
7 |
Copyright (C) 2009, 2010, 2011, 2012 Google Inc. |
|
7 |
Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
|
|
8 | 8 |
|
9 | 9 |
This program is free software; you can redistribute it and/or modify |
10 | 10 |
it under the terms of the GNU General Public License as published by |
... | ... | |
163 | 163 |
_ -> convert "be/memory" mem |
164 | 164 |
xvcpus <- convert "be/vcpus" vcpus |
165 | 165 |
xpnode <- convert "pnode" pnode >>= lookupNode ktn xname |
166 |
xsnodes <- convert "snodes" snodes::Result [JSString]
|
|
167 |
snode <- if null xsnodes
|
|
168 |
then return Node.noSecondary
|
|
169 |
else lookupNode ktn xname (fromJSString $ head xsnodes)
|
|
166 |
xsnodes <- convert "snodes" snodes::Result [String] |
|
167 |
snode <- case xsnodes of
|
|
168 |
[] -> return Node.noSecondary
|
|
169 |
x:_ -> lookupNode ktn xname x
|
|
170 | 170 |
xrunning <- convert "status" status |
171 | 171 |
xtags <- convert "tags" tags |
172 | 172 |
xauto_balance <- convert "auto_balance" auto_balance |
b/src/Ganeti/HTools/Backend/Rapi.hs | ||
---|---|---|
4 | 4 |
|
5 | 5 |
{- |
6 | 6 |
|
7 |
Copyright (C) 2009, 2010, 2011, 2012 Google Inc. |
|
7 |
Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
|
|
8 | 8 |
|
9 | 9 |
This program is free software; you can redistribute it and/or modify |
10 | 10 |
it under the terms of the GNU General Public License as published by |
... | ... | |
138 | 138 |
vcpus <- extract "vcpus" beparams |
139 | 139 |
pnode <- extract "pnode" a >>= lookupNode ktn name |
140 | 140 |
snodes <- extract "snodes" a |
141 |
snode <- if null snodes
|
|
142 |
then return Node.noSecondary
|
|
143 |
else readEitherString (head snodes) >>= lookupNode ktn name
|
|
141 |
snode <- case snodes of
|
|
142 |
[] -> return Node.noSecondary
|
|
143 |
x:_ -> readEitherString x >>= lookupNode ktn name
|
|
144 | 144 |
running <- extract "status" a |
145 | 145 |
tags <- extract "tags" a |
146 | 146 |
auto_balance <- extract "auto_balance" beparams |
b/src/Ganeti/HTools/Cluster.hs | ||
---|---|---|
829 | 829 |
all_msgs = concatMap (solutionDescription mggl) sols |
830 | 830 |
goodSols = filterMGResults mggl sols |
831 | 831 |
sortedSols = sortMGResults mggl goodSols |
832 |
in if null sortedSols |
|
833 |
then Bad $ if null groups' |
|
834 |
then "no groups for evacuation: allowed groups was" ++ |
|
835 |
show allowed_gdxs ++ ", all groups: " ++ |
|
836 |
show (map fst groups) |
|
837 |
else intercalate ", " all_msgs |
|
838 |
else let (final_group, final_sol) = head sortedSols |
|
839 |
in return (final_group, final_sol, all_msgs) |
|
832 |
in case sortedSols of |
|
833 |
[] -> Bad $ if null groups' |
|
834 |
then "no groups for evacuation: allowed groups was" ++ |
|
835 |
show allowed_gdxs ++ ", all groups: " ++ |
|
836 |
show (map fst groups) |
|
837 |
else intercalate ", " all_msgs |
|
838 |
(final_group, final_sol):_ -> return (final_group, final_sol, all_msgs) |
|
840 | 839 |
|
841 | 840 |
-- | Try to allocate an instance on a multi-group cluster. |
842 | 841 |
tryMGAlloc :: Group.List -- ^ The group list |
b/src/Ganeti/HTools/Graph.hs | ||
---|---|---|
28 | 28 |
|
29 | 29 |
{- |
30 | 30 |
|
31 |
Copyright (C) 2012, Google Inc. |
|
31 |
Copyright (C) 2012, 2013, Google Inc.
|
|
32 | 32 |
|
33 | 33 |
This program is free software; you can redistribute it and/or modify |
34 | 34 |
it under the terms of the GNU General Public License as published by |
... | ... | |
147 | 147 |
neighColors :: Graph.Graph -> VertColorMap -> Graph.Vertex -> [Color] |
148 | 148 |
neighColors g cMap v = verticesColors cMap $ neighbors g v |
149 | 149 |
|
150 |
{-# ANN colorNode "HLint: ignore Use alternative" #-} |
|
150 | 151 |
-- | Color one node. |
151 | 152 |
colorNode :: Graph.Graph -> VertColorMap -> Graph.Vertex -> Color |
152 | 153 |
-- use of "head" is A-ok as the source is an infinite list |
b/src/Ganeti/HTools/Node.hs | ||
---|---|---|
6 | 6 |
|
7 | 7 |
{- |
8 | 8 |
|
9 |
Copyright (C) 2009, 2010, 2011, 2012 Google Inc. |
|
9 |
Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
|
|
10 | 10 |
|
11 | 11 |
This program is free software; you can redistribute it and/or modify |
12 | 12 |
it under the terms of the GNU General Public License as published by |
... | ... | |
679 | 679 |
, "pfmem", "pfdsk", "rcpu" |
680 | 680 |
, "cload", "mload", "dload", "nload" ] |
681 | 681 |
|
682 |
{-# ANN computeGroups "HLint: ignore Use alternative" #-} |
|
682 | 683 |
-- | Split a list of nodes into a list of (node group UUID, list of |
683 | 684 |
-- associated nodes). |
684 | 685 |
computeGroups :: [Node] -> [(T.Gdx, [Node])] |
685 | 686 |
computeGroups nodes = |
686 | 687 |
let nodes' = sortBy (comparing group) nodes |
687 | 688 |
nodes'' = groupBy ((==) `on` group) nodes' |
689 |
-- use of head here is OK, since groupBy returns non-empty lists; if |
|
690 |
-- you remove groupBy, also remove use of head |
|
688 | 691 |
in map (\nl -> (group (head nl), nl)) nodes'' |
b/src/Ganeti/HTools/Program/Hail.hs | ||
---|---|---|
4 | 4 |
|
5 | 5 |
{- |
6 | 6 |
|
7 |
Copyright (C) 2009, 2010, 2011, 2012 Google Inc. |
|
7 |
Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
|
|
8 | 8 |
|
9 | 9 |
This program is free software; you can redistribute it and/or modify |
10 | 10 |
it under the terms of the GNU General Public License as published by |
... | ... | |
59 | 59 |
|
60 | 60 |
wrapReadRequest :: Options -> [String] -> IO Request |
61 | 61 |
wrapReadRequest opts args = do |
62 |
when (null args) $ exitErr "This program needs an input file." |
|
62 |
r1 <- case args of |
|
63 |
[] -> exitErr "This program needs an input file." |
|
64 |
_:_:_ -> exitErr "Only one argument is accepted (the input file)" |
|
65 |
x:_ -> readRequest x |
|
63 | 66 |
|
64 |
r1 <- readRequest (head args) |
|
65 | 67 |
if isJust (optDataFile opts) || (not . null . optNodeSim) opts |
66 | 68 |
then do |
67 | 69 |
cdata <- loadExternalData opts |
b/src/Ganeti/HTools/Program/Hbal.hs | ||
---|---|---|
4 | 4 |
|
5 | 5 |
{- |
6 | 6 |
|
7 |
Copyright (C) 2009, 2010, 2011, 2012 Google Inc. |
|
7 |
Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
|
|
8 | 8 |
|
9 | 9 |
This program is free software; you can redistribute it and/or modify |
10 | 10 |
it under the terms of the GNU General Public License as published by |
... | ... | |
135 | 135 |
Just fin_tbl -> |
136 | 136 |
do |
137 | 137 |
let (Cluster.Table _ _ _ fin_plc) = fin_tbl |
138 |
fin_plc_len = length fin_plc |
|
139 |
cur_plc@(idx, _, _, move, _) = head fin_plc |
|
138 |
cur_plc@(idx, _, _, move, _) <- |
|
139 |
exitIfEmpty "Empty placement list returned for solution?!" fin_plc |
|
140 |
let fin_plc_len = length fin_plc |
|
140 | 141 |
(sol_line, cmds) = Cluster.printSolutionLine ini_nl ini_il |
141 | 142 |
nmlen imlen cur_plc fin_plc_len |
142 | 143 |
afn = Cluster.involvedNodes ini_il cur_plc |
... | ... | |
261 | 262 |
|
262 | 263 |
case optGroup opts of |
263 | 264 |
Nothing -> do |
264 |
let (gidx, cdata) = head ngroups
|
|
265 |
grp = Container.find gidx gl
|
|
265 |
(gidx, cdata) <- exitIfEmpty "No groups found by splitCluster?!" ngroups
|
|
266 |
let grp = Container.find gidx gl
|
|
266 | 267 |
return (Group.name grp, cdata) |
267 | 268 |
Just g -> case Container.findByName gl g of |
268 | 269 |
Nothing -> do |
b/src/Ganeti/HTools/Program/Hspace.hs | ||
---|---|---|
4 | 4 |
|
5 | 5 |
{- |
6 | 6 |
|
7 |
Copyright (C) 2009, 2010, 2011, 2012 Google Inc. |
|
7 |
Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
|
|
8 | 8 |
|
9 | 9 |
This program is free software; you can redistribute it and/or modify |
10 | 10 |
it under the terms of the GNU General Public License as published by |
... | ... | |
105 | 105 |
specDescription SpecNormal = "Standard (fixed-size)" |
106 | 106 |
specDescription SpecTiered = "Tiered (initial size)" |
107 | 107 |
|
108 |
-- | The \"name\" of a 'SpecType'. |
|
109 |
specName :: SpecType -> String |
|
110 |
specName SpecNormal = "Standard" |
|
111 |
specName SpecTiered = "Tiered" |
|
112 |
|
|
108 | 113 |
-- | Efficiency generic function. |
109 | 114 |
effFn :: (Cluster.CStats -> Integer) |
110 | 115 |
-> (Cluster.CStats -> Double) |
... | ... | |
191 | 196 |
\ != counted (%d)\n" (num_instances + allocs) |
192 | 197 |
(Cluster.csNinst fin_stats) |
193 | 198 |
|
199 |
main_reason <- exitIfEmpty "Internal error, no failure reasons?!" sreason |
|
200 |
|
|
194 | 201 |
printKeysHTS $ printStats PFinal fin_stats |
195 | 202 |
printKeysHTS [ ("ALLOC_USAGE", printf "%.8f" |
196 | 203 |
((fromIntegral num_instances::Double) / |
197 | 204 |
fromIntegral fin_instances)) |
198 | 205 |
, ("ALLOC_INSTANCES", printf "%d" allocs) |
199 |
, ("ALLOC_FAIL_REASON", map toUpper . show . fst $ head sreason)
|
|
206 |
, ("ALLOC_FAIL_REASON", map toUpper . show . fst $ main_reason)
|
|
200 | 207 |
] |
201 | 208 |
printKeysHTS $ map (\(x, y) -> (printf "ALLOC_%s_CNT" (show x), |
202 | 209 |
printf "%d" y)) sreason |
... | ... | |
210 | 217 |
printFinalHTS :: Bool -> IO () |
211 | 218 |
printFinalHTS = printFinal htsPrefix |
212 | 219 |
|
220 |
{-# ANN tieredSpecMap "HLint: ignore Use alternative" #-} |
|
213 | 221 |
-- | Compute the tiered spec counts from a list of allocated |
214 | 222 |
-- instances. |
215 | 223 |
tieredSpecMap :: [Instance.Instance] |
... | ... | |
217 | 225 |
tieredSpecMap trl_ixes = |
218 | 226 |
let fin_trl_ixes = reverse trl_ixes |
219 | 227 |
ix_byspec = groupBy ((==) `on` Instance.specOf) fin_trl_ixes |
228 |
-- head is "safe" here, as groupBy returns list of non-empty lists |
|
220 | 229 |
spec_map = map (\ixs -> (Instance.specOf $ head ixs, length ixs)) |
221 | 230 |
ix_byspec |
222 | 231 |
in spec_map |
... | ... | |
365 | 374 |
Just result_noalloc -> return result_noalloc |
366 | 375 |
Nothing -> exitIfBad "failure during allocation" actual_result |
367 | 376 |
|
368 |
let name = head . words . specDescription $ mode
|
|
377 |
let name = specName mode
|
|
369 | 378 |
descr = name ++ " allocation" |
370 | 379 |
ldescr = "after " ++ map toLower descr |
371 | 380 |
|
b/src/Ganeti/Query/Server.hs | ||
---|---|---|
6 | 6 |
|
7 | 7 |
{- |
8 | 8 |
|
9 |
Copyright (C) 2012 Google Inc. |
|
9 |
Copyright (C) 2012, 2013 Google Inc.
|
|
10 | 10 |
|
11 | 11 |
This program is free software; you can redistribute it and/or modify |
12 | 12 |
it under the terms of the GNU General Public License as published by |
... | ... | |
87 | 87 |
handleCall cdata QueryClusterInfo = |
88 | 88 |
let cluster = configCluster cdata |
89 | 89 |
hypervisors = clusterEnabledHypervisors cluster |
90 |
def_hv = case hypervisors of |
|
91 |
x:_ -> showJSON x |
|
92 |
[] -> JSNull |
|
90 | 93 |
bits = show (bitSize (0::Int)) ++ "bits" |
91 | 94 |
arch_tuple = [bits, arch] |
92 | 95 |
obj = [ ("software_version", showJSON C.releaseVersion) |
... | ... | |
97 | 100 |
, ("architecture", showJSON arch_tuple) |
98 | 101 |
, ("name", showJSON $ clusterClusterName cluster) |
99 | 102 |
, ("master", showJSON $ clusterMasterNode cluster) |
100 |
, ("default_hypervisor", showJSON $ head hypervisors)
|
|
103 |
, ("default_hypervisor", def_hv)
|
|
101 | 104 |
, ("enabled_hypervisors", showJSON hypervisors) |
102 | 105 |
, ("hvparams", showJSON $ clusterHvparams cluster) |
103 | 106 |
, ("os_hvp", showJSON $ clusterOsHvp cluster) |
b/src/Ganeti/Utils.hs | ||
---|---|---|
51 | 51 |
, chompPrefix |
52 | 52 |
, wrap |
53 | 53 |
, trim |
54 |
, defaultHead |
|
55 |
, exitIfEmpty |
|
54 | 56 |
) where |
55 | 57 |
|
56 | 58 |
import Data.Char (toUpper, isAlphaNum, isDigit, isSpace) |
... | ... | |
369 | 371 |
-- strings. |
370 | 372 |
trim :: String -> String |
371 | 373 |
trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace |
374 |
|
|
375 |
-- | A safer head version, with a default value. |
|
376 |
defaultHead :: a -> [a] -> a |
|
377 |
defaultHead def [] = def |
|
378 |
defaultHead _ (x:_) = x |
|
379 |
|
|
380 |
-- | A 'head' version in the I/O monad, for validating parameters |
|
381 |
-- without which we cannot continue. |
|
382 |
exitIfEmpty :: String -> [a] -> IO a |
|
383 |
exitIfEmpty _ (x:_) = return x |
|
384 |
exitIfEmpty s [] = exitErr s |
b/src/lint-hints.hs | ||
---|---|---|
20 | 20 |
warn = length x > 0 ==> not (null x) |
21 | 21 |
warn = length x /= 0 ==> not (null x) |
22 | 22 |
warn = length x == 0 ==> null x |
23 |
|
|
24 |
-- Never use head, use 'case' which covers all possibilities |
|
25 |
warn = head x ==> case x of { y:_ -> y } where note = "Head is unsafe, please use case and handle the empty list as well" |
|
26 |
|
|
27 |
-- Never use tail, use 'case' which covers all possibilities |
|
28 |
warn = tail x ==> case x of { _:y -> y } where note = "Tail is unsafe, please use case and handle the empty list as well" |
b/test/hs/Test/Ganeti/Common.hs | ||
---|---|---|
83 | 83 |
-> c |
84 | 84 |
passFailOpt defaults failfn passfn |
85 | 85 |
(opt@(GetOpt.Option _ longs _ _, _), bad, good) = |
86 |
let prefix = "--" ++ head longs ++ "=" |
|
86 |
let first_opt = case longs of |
|
87 |
[] -> error "no long options?" |
|
88 |
x:_ -> x |
|
89 |
prefix = "--" ++ first_opt ++ "=" |
|
87 | 90 |
good_cmd = prefix ++ good |
88 | 91 |
bad_cmd = prefix ++ bad in |
89 | 92 |
case (parseOptsInner defaults [bad_cmd] "prog" [opt] [], |
b/test/hs/Test/Ganeti/HTools/Container.hs | ||
---|---|---|
7 | 7 |
|
8 | 8 |
{- |
9 | 9 |
|
10 |
Copyright (C) 2009, 2010, 2011, 2012 Google Inc. |
|
10 |
Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
|
|
11 | 11 |
|
12 | 12 |
This program is free software; you can redistribute it and/or modify |
13 | 13 |
it under the terms of the GNU General Public License as published by |
... | ... | |
52 | 52 |
prop_nameOf :: Node.Node -> Property |
53 | 53 |
prop_nameOf node = |
54 | 54 |
let nl = makeSmallCluster node 1 |
55 |
fnode = head (Container.elems nl) |
|
56 |
in Container.nameOf nl (Node.idx fnode) ==? Node.name fnode |
|
55 |
in case Container.elems nl of |
|
56 |
[] -> failTest "makeSmallCluster 1 returned empty cluster?" |
|
57 |
_:_:_ -> failTest "makeSmallCluster 1 returned >1 node?" |
|
58 |
fnode:_ -> Container.nameOf nl (Node.idx fnode) ==? Node.name fnode |
|
57 | 59 |
|
58 | 60 |
-- | We test that in a cluster, given a random node, we can find it by |
59 | 61 |
-- its name and alias, as long as all names and aliases are unique, |
b/test/hs/Test/Ganeti/JQueue.hs | ||
---|---|---|
6 | 6 |
|
7 | 7 |
{- |
8 | 8 |
|
9 |
Copyright (C) 2012 Google Inc. |
|
9 |
Copyright (C) 2012, 2013 Google Inc.
|
|
10 | 10 |
|
11 | 11 |
This program is free software; you can redistribute it and/or modify |
12 | 12 |
it under the terms of the GNU General Public License as published by |
... | ... | |
135 | 135 |
case_JobStatusPri_py_equiv :: Assertion |
136 | 136 |
case_JobStatusPri_py_equiv = do |
137 | 137 |
let num_jobs = 2000::Int |
138 |
sample_jobs <- sample' (vectorOf num_jobs $ do |
|
139 |
num_ops <- choose (1, 5) |
|
140 |
ops <- vectorOf num_ops genQueuedOpCode |
|
141 |
jid <- genJobId |
|
142 |
return $ QueuedJob jid ops justNoTs justNoTs |
|
143 |
justNoTs) |
|
144 |
let jobs = head sample_jobs |
|
145 |
serialized = encode jobs |
|
138 |
jobs <- genSample (vectorOf num_jobs $ do |
|
139 |
num_ops <- choose (1, 5) |
|
140 |
ops <- vectorOf num_ops genQueuedOpCode |
|
141 |
jid <- genJobId |
|
142 |
return $ QueuedJob jid ops justNoTs justNoTs justNoTs) |
|
143 |
let serialized = encode jobs |
|
146 | 144 |
-- check for non-ASCII fields, usually due to 'arbitrary :: String' |
147 | 145 |
mapM_ (\job -> when (any (not . isAscii) (encode job)) . |
148 | 146 |
assertFailure $ "Job has non-ASCII fields: " ++ show job |
b/test/hs/Test/Ganeti/Objects.hs | ||
---|---|---|
7 | 7 |
|
8 | 8 |
{- |
9 | 9 |
|
10 |
Copyright (C) 2009, 2010, 2011, 2012 Google Inc. |
|
10 |
Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
|
|
11 | 11 |
|
12 | 12 |
This program is free software; you can redistribute it and/or modify |
13 | 13 |
it under the terms of the GNU General Public License as published by |
... | ... | |
272 | 272 |
case_py_compat_networks :: HUnit.Assertion |
273 | 273 |
case_py_compat_networks = do |
274 | 274 |
let num_networks = 500::Int |
275 |
sample_networks <- sample' (vectorOf num_networks genValidNetwork) |
|
276 |
let networks = head sample_networks |
|
277 |
networks_with_properties = map getNetworkProperties networks |
|
275 |
networks <- genSample (vectorOf num_networks genValidNetwork) |
|
276 |
let networks_with_properties = map getNetworkProperties networks |
|
278 | 277 |
serialized = J.encode networks |
279 | 278 |
-- check for non-ASCII fields, usually due to 'arbitrary :: String' |
280 | 279 |
mapM_ (\net -> when (any (not . isAscii) (J.encode net)) . |
... | ... | |
322 | 321 |
case_py_compat_nodegroups :: HUnit.Assertion |
323 | 322 |
case_py_compat_nodegroups = do |
324 | 323 |
let num_groups = 500::Int |
325 |
sample_groups <- sample' (vectorOf num_groups genNodeGroup) |
|
326 |
let groups = head sample_groups |
|
327 |
serialized = J.encode groups |
|
324 |
groups <- genSample (vectorOf num_groups genNodeGroup) |
|
325 |
let serialized = J.encode groups |
|
328 | 326 |
-- check for non-ASCII fields, usually due to 'arbitrary :: String' |
329 | 327 |
mapM_ (\group -> when (any (not . isAscii) (J.encode group)) . |
330 | 328 |
HUnit.assertFailure $ |
b/test/hs/Test/Ganeti/OpCodes.hs | ||
---|---|---|
7 | 7 |
|
8 | 8 |
{- |
9 | 9 |
|
10 |
Copyright (C) 2009, 2010, 2011, 2012 Google Inc. |
|
10 |
Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
|
|
11 | 11 |
|
12 | 12 |
This program is free software; you can redistribute it and/or modify |
13 | 13 |
it under the terms of the GNU General Public License as published by |
... | ... | |
440 | 440 |
case_py_compat_types :: HUnit.Assertion |
441 | 441 |
case_py_compat_types = do |
442 | 442 |
let num_opcodes = length OpCodes.allOpIDs * 100 |
443 |
sample_opcodes <- sample' (vectorOf num_opcodes |
|
444 |
(arbitrary::Gen OpCodes.MetaOpCode)) |
|
445 |
let opcodes = head sample_opcodes |
|
446 |
with_sum = map (\o -> (OpCodes.opSummary $ |
|
443 |
opcodes <- genSample (vectorOf num_opcodes |
|
444 |
(arbitrary::Gen OpCodes.MetaOpCode)) |
|
445 |
let with_sum = map (\o -> (OpCodes.opSummary $ |
|
447 | 446 |
OpCodes.metaOpCode o, o)) opcodes |
448 | 447 |
serialized = J.encode opcodes |
449 | 448 |
-- check for non-ASCII fields, usually due to 'arbitrary :: String' |
b/test/hs/Test/Ganeti/TestCommon.hs | ||
---|---|---|
4 | 4 |
|
5 | 5 |
{- |
6 | 6 |
|
7 |
Copyright (C) 2009, 2010, 2011, 2012 Google Inc. |
|
7 |
Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
|
|
8 | 8 |
|
9 | 9 |
This program is free software; you can redistribute it and/or modify |
10 | 10 |
it under the terms of the GNU General Public License as published by |
... | ... | |
294 | 294 |
readTestData filename = do |
295 | 295 |
name <- testDataFilename "/test/data/" filename |
296 | 296 |
readFile name |
297 |
|
|
298 |
-- | Generate arbitrary values in the IO monad. This is a simple |
|
299 |
-- wrapper over 'sample''. |
|
300 |
genSample :: Gen a -> IO a |
|
301 |
genSample gen = do |
|
302 |
values <- sample' gen |
|
303 |
case values of |
|
304 |
[] -> error "sample' returned an empty list of values??" |
|
305 |
x:_ -> return x |
b/test/hs/Test/Ganeti/Utils.hs | ||
---|---|---|
88 | 88 |
-> Gen Prop -- ^ Test result |
89 | 89 |
prop_select def lst1 lst2 = |
90 | 90 |
select def (flist ++ tlist) ==? expectedresult |
91 |
where expectedresult = if' (null lst2) def (head lst2)
|
|
91 |
where expectedresult = defaultHead def lst2
|
|
92 | 92 |
flist = zip (repeat False) lst1 |
93 | 93 |
tlist = zip (repeat True) lst2 |
94 | 94 |
|
95 |
{-# ANN prop_select_undefd "HLint: ignore Use alternative" #-} |
|
95 | 96 |
-- | Test basic select functionality with undefined default |
96 | 97 |
prop_select_undefd :: [Int] -- ^ List of False values |
97 | 98 |
-> NonEmptyList Int -- ^ List of True values |
98 | 99 |
-> Gen Prop -- ^ Test result |
99 | 100 |
prop_select_undefd lst1 (NonEmpty lst2) = |
101 |
-- head is fine as NonEmpty "guarantees" a non-empty list, but not |
|
102 |
-- via types |
|
100 | 103 |
select undefined (flist ++ tlist) ==? head lst2 |
101 | 104 |
where flist = zip (repeat False) lst1 |
102 | 105 |
tlist = zip (repeat True) lst2 |
103 | 106 |
|
107 |
{-# ANN prop_select_undefv "HLint: ignore Use alternative" #-} |
|
104 | 108 |
-- | Test basic select functionality with undefined list values |
105 | 109 |
prop_select_undefv :: [Int] -- ^ List of False values |
106 | 110 |
-> NonEmptyList Int -- ^ List of True values |
107 | 111 |
-> Gen Prop -- ^ Test result |
108 | 112 |
prop_select_undefv lst1 (NonEmpty lst2) = |
113 |
-- head is fine as NonEmpty "guarantees" a non-empty list, but not |
|
114 |
-- via types |
|
109 | 115 |
select undefined cndlist ==? head lst2 |
110 | 116 |
where flist = zip (repeat False) lst1 |
111 | 117 |
tlist = zip (repeat True) lst2 |
Also available in: Unified diff