Commit 72747d91 authored by Iustin Pop's avatar Iustin Pop

Remove use of 'head' and add hlint warning for it

Since 'head' is unsafe to use in most cases, this patch removes its
use from most of the code, adds a lint warning for it (and for tail as
well), and adds override annotations in the few cases where it's
actually OK to use it (mainly when using head over the result of
functions which guarantee to return a non-empty list by documentation,
not type).
Signed-off-by: default avatarIustin Pop <iustin@google.com>
Reviewed-by: default avatarHelga Velroyen <helgav@google.com>
parent b6ad806f
......@@ -4,7 +4,7 @@
{-
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
......@@ -82,14 +82,14 @@ parseInstance :: NameAssoc -- ^ The node name-to-index association list
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.
......
......@@ -4,7 +4,7 @@
{-
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
......@@ -163,10 +163,10 @@ parseInstance ktn [ name, disk, mem, vcpus
_ -> 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
......
......@@ -4,7 +4,7 @@
{-
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
......@@ -138,9 +138,9 @@ parseInstance ktn a = do
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
......
......@@ -829,14 +829,13 @@ findBestAllocGroup mggl mgnl mgil allowed_gdxs inst cnt =
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
......
......@@ -28,7 +28,7 @@ University Clausthal, 1-9.
{-
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
......@@ -147,6 +147,7 @@ verticesColorSet cMap = IntSet.fromList . verticesColors cMap
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
......
......@@ -6,7 +6,7 @@
{-
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
......@@ -679,10 +679,13 @@ defaultFields =
, "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''
......@@ -4,7 +4,7 @@
{-
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
......@@ -59,9 +59,11 @@ arguments = [ArgCompletion OptComplFile 1 (Just 1)]
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
......
......@@ -4,7 +4,7 @@
{-
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
......@@ -135,8 +135,9 @@ iterateDepth printmove ini_tbl max_rounds disk_moves inst_moves nmlen imlen
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
......@@ -261,8 +262,8 @@ selectGroup opts gl nlf ilf = do
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
......
......@@ -4,7 +4,7 @@
{-
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
......@@ -105,6 +105,11 @@ specDescription :: SpecType -> String
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)
......@@ -191,12 +196,14 @@ printResults True _ fin_nl num_instances allocs sreason = do
\ != 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
......@@ -210,6 +217,7 @@ printResults False ini_nl fin_nl _ allocs sreason = do
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]
......@@ -217,6 +225,7 @@ 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
......@@ -365,7 +374,7 @@ runAllocation cdata stop_allocation actual_result spec dt mode opts = do
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
......
......@@ -6,7 +6,7 @@
{-
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
......@@ -87,6 +87,9 @@ handleCall :: ConfigData -> LuxiOp -> IO (ErrorResult JSValue)
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)
......@@ -97,7 +100,7 @@ handleCall cdata QueryClusterInfo =
, ("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)
......
......@@ -51,6 +51,8 @@ module Ganeti.Utils
, chompPrefix
, wrap
, trim
, defaultHead
, exitIfEmpty
) where
import Data.Char (toUpper, isAlphaNum, isDigit, isSpace)
......@@ -369,3 +371,14 @@ wrap maxWidth = filter (not . null) . map trim . wrap0
-- 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
......@@ -20,3 +20,9 @@ warn = map (\v -> (x, v)) ==> zip (repeat x)
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"
......@@ -83,7 +83,10 @@ passFailOpt :: (StandardOptions b) =>
-> 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] [],
......
......@@ -7,7 +7,7 @@
{-
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
......@@ -52,8 +52,10 @@ prop_addTwo cdata i1 i2 =
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,
......
......@@ -6,7 +6,7 @@
{-
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
......@@ -135,14 +135,12 @@ prop_JobStatus =
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
......
......@@ -7,7 +7,7 @@
{-
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
......@@ -272,9 +272,8 @@ prop_Config_serialisation =
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)) .
......@@ -322,9 +321,8 @@ getNetworkProperties 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 $
......
......@@ -7,7 +7,7 @@
{-
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
......@@ -440,10 +440,9 @@ case_AllDefined = do
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'
......
......@@ -4,7 +4,7 @@
{-
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
......@@ -294,3 +294,12 @@ readTestData :: String -> IO String
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
......@@ -88,24 +88,30 @@ prop_select :: Int -- ^ Default result
-> 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
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment