{-
-Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
+Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
parseInstance ktn n a = do
base <- parseBaseInstance n a
nodes <- fromObj a "nodes"
- pnode <- if null nodes
- then Bad $ "empty node list for instance " ++ n
- else readEitherString $ head nodes
+ (pnode, snodes) <-
+ case nodes of
+ [] -> Bad $ "empty node list for instance " ++ n
+ x:xs -> readEitherString x >>= \x' -> return (x', xs)
pidx <- lookupNode ktn n pnode
- let snodes = tail nodes
- sidx <- if null snodes
- then return Node.noSecondary
- else readEitherString (head snodes) >>= lookupNode ktn n
+ sidx <- case snodes of
+ [] -> return Node.noSecondary
+ x:_ -> readEitherString x >>= lookupNode ktn n
return (n, Instance.setBoth (snd base) pidx sidx)
-- | Parses a node as found in the cluster node list.
{-
-Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
+Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
_ -> convert "be/memory" mem
xvcpus <- convert "be/vcpus" vcpus
xpnode <- convert "pnode" pnode >>= lookupNode ktn xname
- xsnodes <- convert "snodes" snodes::Result [JSString]
- snode <- if null xsnodes
- then return Node.noSecondary
- else lookupNode ktn xname (fromJSString $ head xsnodes)
+ xsnodes <- convert "snodes" snodes::Result [String]
+ snode <- case xsnodes of
+ [] -> return Node.noSecondary
+ x:_ -> lookupNode ktn xname x
xrunning <- convert "status" status
xtags <- convert "tags" tags
xauto_balance <- convert "auto_balance" auto_balance
{-
-Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
+Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
vcpus <- extract "vcpus" beparams
pnode <- extract "pnode" a >>= lookupNode ktn name
snodes <- extract "snodes" a
- snode <- if null snodes
- then return Node.noSecondary
- else readEitherString (head snodes) >>= lookupNode ktn name
+ snode <- case snodes of
+ [] -> return Node.noSecondary
+ x:_ -> readEitherString x >>= lookupNode ktn name
running <- extract "status" a
tags <- extract "tags" a
auto_balance <- extract "auto_balance" beparams
all_msgs = concatMap (solutionDescription mggl) sols
goodSols = filterMGResults mggl sols
sortedSols = sortMGResults mggl goodSols
- in if null sortedSols
- then Bad $ if null groups'
- then "no groups for evacuation: allowed groups was" ++
- show allowed_gdxs ++ ", all groups: " ++
- show (map fst groups)
- else intercalate ", " all_msgs
- else let (final_group, final_sol) = head sortedSols
- in return (final_group, final_sol, all_msgs)
+ in case sortedSols of
+ [] -> Bad $ if null groups'
+ then "no groups for evacuation: allowed groups was" ++
+ show allowed_gdxs ++ ", all groups: " ++
+ show (map fst groups)
+ else intercalate ", " all_msgs
+ (final_group, final_sol):_ -> return (final_group, final_sol, all_msgs)
-- | Try to allocate an instance on a multi-group cluster.
tryMGAlloc :: Group.List -- ^ The group list
{-
-Copyright (C) 2012, Google Inc.
+Copyright (C) 2012, 2013, Google Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
neighColors :: Graph.Graph -> VertColorMap -> Graph.Vertex -> [Color]
neighColors g cMap v = verticesColors cMap $ neighbors g v
+{-# ANN colorNode "HLint: ignore Use alternative" #-}
-- | Color one node.
colorNode :: Graph.Graph -> VertColorMap -> Graph.Vertex -> Color
-- use of "head" is A-ok as the source is an infinite list
{-
-Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
+Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
, "pfmem", "pfdsk", "rcpu"
, "cload", "mload", "dload", "nload" ]
+{-# ANN computeGroups "HLint: ignore Use alternative" #-}
-- | Split a list of nodes into a list of (node group UUID, list of
-- associated nodes).
computeGroups :: [Node] -> [(T.Gdx, [Node])]
computeGroups nodes =
let nodes' = sortBy (comparing group) nodes
nodes'' = groupBy ((==) `on` group) nodes'
+ -- use of head here is OK, since groupBy returns non-empty lists; if
+ -- you remove groupBy, also remove use of head
in map (\nl -> (group (head nl), nl)) nodes''
{-
-Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
+Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
wrapReadRequest :: Options -> [String] -> IO Request
wrapReadRequest opts args = do
- when (null args) $ exitErr "This program needs an input file."
+ r1 <- case args of
+ [] -> exitErr "This program needs an input file."
+ _:_:_ -> exitErr "Only one argument is accepted (the input file)"
+ x:_ -> readRequest x
- r1 <- readRequest (head args)
if isJust (optDataFile opts) || (not . null . optNodeSim) opts
then do
cdata <- loadExternalData opts
{-
-Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
+Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
Just fin_tbl ->
do
let (Cluster.Table _ _ _ fin_plc) = fin_tbl
- fin_plc_len = length fin_plc
- cur_plc@(idx, _, _, move, _) = head fin_plc
+ cur_plc@(idx, _, _, move, _) <-
+ exitIfEmpty "Empty placement list returned for solution?!" fin_plc
+ let fin_plc_len = length fin_plc
(sol_line, cmds) = Cluster.printSolutionLine ini_nl ini_il
nmlen imlen cur_plc fin_plc_len
afn = Cluster.involvedNodes ini_il cur_plc
case optGroup opts of
Nothing -> do
- let (gidx, cdata) = head ngroups
- grp = Container.find gidx gl
+ (gidx, cdata) <- exitIfEmpty "No groups found by splitCluster?!" ngroups
+ let grp = Container.find gidx gl
return (Group.name grp, cdata)
Just g -> case Container.findByName gl g of
Nothing -> do
{-
-Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
+Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
specDescription SpecNormal = "Standard (fixed-size)"
specDescription SpecTiered = "Tiered (initial size)"
+-- | The \"name\" of a 'SpecType'.
+specName :: SpecType -> String
+specName SpecNormal = "Standard"
+specName SpecTiered = "Tiered"
+
-- | Efficiency generic function.
effFn :: (Cluster.CStats -> Integer)
-> (Cluster.CStats -> Double)
\ != counted (%d)\n" (num_instances + allocs)
(Cluster.csNinst fin_stats)
+ main_reason <- exitIfEmpty "Internal error, no failure reasons?!" sreason
+
printKeysHTS $ printStats PFinal fin_stats
printKeysHTS [ ("ALLOC_USAGE", printf "%.8f"
((fromIntegral num_instances::Double) /
fromIntegral fin_instances))
, ("ALLOC_INSTANCES", printf "%d" allocs)
- , ("ALLOC_FAIL_REASON", map toUpper . show . fst $ head sreason)
+ , ("ALLOC_FAIL_REASON", map toUpper . show . fst $ main_reason)
]
printKeysHTS $ map (\(x, y) -> (printf "ALLOC_%s_CNT" (show x),
printf "%d" y)) sreason
printFinalHTS :: Bool -> IO ()
printFinalHTS = printFinal htsPrefix
+{-# ANN tieredSpecMap "HLint: ignore Use alternative" #-}
-- | Compute the tiered spec counts from a list of allocated
-- instances.
tieredSpecMap :: [Instance.Instance]
tieredSpecMap trl_ixes =
let fin_trl_ixes = reverse trl_ixes
ix_byspec = groupBy ((==) `on` Instance.specOf) fin_trl_ixes
+ -- head is "safe" here, as groupBy returns list of non-empty lists
spec_map = map (\ixs -> (Instance.specOf $ head ixs, length ixs))
ix_byspec
in spec_map
Just result_noalloc -> return result_noalloc
Nothing -> exitIfBad "failure during allocation" actual_result
- let name = head . words . specDescription $ mode
+ let name = specName mode
descr = name ++ " allocation"
ldescr = "after " ++ map toLower descr
{-
-Copyright (C) 2012 Google Inc.
+Copyright (C) 2012, 2013 Google Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
handleCall cdata QueryClusterInfo =
let cluster = configCluster cdata
hypervisors = clusterEnabledHypervisors cluster
+ def_hv = case hypervisors of
+ x:_ -> showJSON x
+ [] -> JSNull
bits = show (bitSize (0::Int)) ++ "bits"
arch_tuple = [bits, arch]
obj = [ ("software_version", showJSON C.releaseVersion)
, ("architecture", showJSON arch_tuple)
, ("name", showJSON $ clusterClusterName cluster)
, ("master", showJSON $ clusterMasterNode cluster)
- , ("default_hypervisor", showJSON $ head hypervisors)
+ , ("default_hypervisor", def_hv)
, ("enabled_hypervisors", showJSON hypervisors)
, ("hvparams", showJSON $ clusterHvparams cluster)
, ("os_hvp", showJSON $ clusterOsHvp cluster)
, chompPrefix
, wrap
, trim
+ , defaultHead
+ , exitIfEmpty
) where
import Data.Char (toUpper, isAlphaNum, isDigit, isSpace)
-- strings.
trim :: String -> String
trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
+
+-- | A safer head version, with a default value.
+defaultHead :: a -> [a] -> a
+defaultHead def [] = def
+defaultHead _ (x:_) = x
+
+-- | A 'head' version in the I/O monad, for validating parameters
+-- without which we cannot continue.
+exitIfEmpty :: String -> [a] -> IO a
+exitIfEmpty _ (x:_) = return x
+exitIfEmpty s [] = exitErr s
warn = length x > 0 ==> not (null x)
warn = length x /= 0 ==> not (null x)
warn = length x == 0 ==> null x
+
+-- Never use head, use 'case' which covers all possibilities
+warn = head x ==> case x of { y:_ -> y } where note = "Head is unsafe, please use case and handle the empty list as well"
+
+-- Never use tail, use 'case' which covers all possibilities
+warn = tail x ==> case x of { _:y -> y } where note = "Tail is unsafe, please use case and handle the empty list as well"
-> c
passFailOpt defaults failfn passfn
(opt@(GetOpt.Option _ longs _ _, _), bad, good) =
- let prefix = "--" ++ head longs ++ "="
+ let first_opt = case longs of
+ [] -> error "no long options?"
+ x:_ -> x
+ prefix = "--" ++ first_opt ++ "="
good_cmd = prefix ++ good
bad_cmd = prefix ++ bad in
case (parseOptsInner defaults [bad_cmd] "prog" [opt] [],
{-
-Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
+Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
prop_nameOf :: Node.Node -> Property
prop_nameOf node =
let nl = makeSmallCluster node 1
- fnode = head (Container.elems nl)
- in Container.nameOf nl (Node.idx fnode) ==? Node.name fnode
+ in case Container.elems nl of
+ [] -> failTest "makeSmallCluster 1 returned empty cluster?"
+ _:_:_ -> failTest "makeSmallCluster 1 returned >1 node?"
+ fnode:_ -> Container.nameOf nl (Node.idx fnode) ==? Node.name fnode
-- | We test that in a cluster, given a random node, we can find it by
-- its name and alias, as long as all names and aliases are unique,
{-
-Copyright (C) 2012 Google Inc.
+Copyright (C) 2012, 2013 Google Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
case_JobStatusPri_py_equiv :: Assertion
case_JobStatusPri_py_equiv = do
let num_jobs = 2000::Int
- sample_jobs <- sample' (vectorOf num_jobs $ do
- num_ops <- choose (1, 5)
- ops <- vectorOf num_ops genQueuedOpCode
- jid <- genJobId
- return $ QueuedJob jid ops justNoTs justNoTs
- justNoTs)
- let jobs = head sample_jobs
- serialized = encode jobs
+ jobs <- genSample (vectorOf num_jobs $ do
+ num_ops <- choose (1, 5)
+ ops <- vectorOf num_ops genQueuedOpCode
+ jid <- genJobId
+ return $ QueuedJob jid ops justNoTs justNoTs justNoTs)
+ let serialized = encode jobs
-- check for non-ASCII fields, usually due to 'arbitrary :: String'
mapM_ (\job -> when (any (not . isAscii) (encode job)) .
assertFailure $ "Job has non-ASCII fields: " ++ show job
{-
-Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
+Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
case_py_compat_networks :: HUnit.Assertion
case_py_compat_networks = do
let num_networks = 500::Int
- sample_networks <- sample' (vectorOf num_networks genValidNetwork)
- let networks = head sample_networks
- networks_with_properties = map getNetworkProperties networks
+ networks <- genSample (vectorOf num_networks genValidNetwork)
+ let networks_with_properties = map getNetworkProperties networks
serialized = J.encode networks
-- check for non-ASCII fields, usually due to 'arbitrary :: String'
mapM_ (\net -> when (any (not . isAscii) (J.encode net)) .
case_py_compat_nodegroups :: HUnit.Assertion
case_py_compat_nodegroups = do
let num_groups = 500::Int
- sample_groups <- sample' (vectorOf num_groups genNodeGroup)
- let groups = head sample_groups
- serialized = J.encode groups
+ groups <- genSample (vectorOf num_groups genNodeGroup)
+ let serialized = J.encode groups
-- check for non-ASCII fields, usually due to 'arbitrary :: String'
mapM_ (\group -> when (any (not . isAscii) (J.encode group)) .
HUnit.assertFailure $
{-
-Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
+Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
case_py_compat_types :: HUnit.Assertion
case_py_compat_types = do
let num_opcodes = length OpCodes.allOpIDs * 100
- sample_opcodes <- sample' (vectorOf num_opcodes
- (arbitrary::Gen OpCodes.MetaOpCode))
- let opcodes = head sample_opcodes
- with_sum = map (\o -> (OpCodes.opSummary $
+ opcodes <- genSample (vectorOf num_opcodes
+ (arbitrary::Gen OpCodes.MetaOpCode))
+ let with_sum = map (\o -> (OpCodes.opSummary $
OpCodes.metaOpCode o, o)) opcodes
serialized = J.encode opcodes
-- check for non-ASCII fields, usually due to 'arbitrary :: String'
{-
-Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
+Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
readTestData filename = do
name <- testDataFilename "/test/data/" filename
readFile name
+
+-- | Generate arbitrary values in the IO monad. This is a simple
+-- wrapper over 'sample''.
+genSample :: Gen a -> IO a
+genSample gen = do
+ values <- sample' gen
+ case values of
+ [] -> error "sample' returned an empty list of values??"
+ x:_ -> return x
-> Gen Prop -- ^ Test result
prop_select def lst1 lst2 =
select def (flist ++ tlist) ==? expectedresult
- where expectedresult = if' (null lst2) def (head lst2)
+ where expectedresult = defaultHead def lst2
flist = zip (repeat False) lst1
tlist = zip (repeat True) lst2
+{-# ANN prop_select_undefd "HLint: ignore Use alternative" #-}
-- | Test basic select functionality with undefined default
prop_select_undefd :: [Int] -- ^ List of False values
-> NonEmptyList Int -- ^ List of True values
-> Gen Prop -- ^ Test result
prop_select_undefd lst1 (NonEmpty lst2) =
+ -- head is fine as NonEmpty "guarantees" a non-empty list, but not
+ -- via types
select undefined (flist ++ tlist) ==? head lst2
where flist = zip (repeat False) lst1
tlist = zip (repeat True) lst2
+{-# ANN prop_select_undefv "HLint: ignore Use alternative" #-}
-- | Test basic select functionality with undefined list values
prop_select_undefv :: [Int] -- ^ List of False values
-> NonEmptyList Int -- ^ List of True values
-> Gen Prop -- ^ Test result
prop_select_undefv lst1 (NonEmpty lst2) =
+ -- head is fine as NonEmpty "guarantees" a non-empty list, but not
+ -- via types
select undefined cndlist ==? head lst2
where flist = zip (repeat False) lst1
tlist = zip (repeat True) lst2
projects / ganeti-local / commitdiff