diff --git a/Makefile.am b/Makefile.am
index 57bc27e91106df268ec5bf4c3c8046e3d626b79d..417c2766bdebe0fe49295e0a86186a810fe65d6e 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -1170,7 +1170,13 @@ lint: $(BUILT_SOURCES)
.PHONY: hlint
hlint: $(HS_BUILT_SRCS)
if tty -s; then C="-c"; else C=""; fi; \
- hlint --report=doc/hs-lint.html $$C htools
+ hlint --report=doc/hs-lint.html --cross $$C \
+ --ignore "Use first" \
+ --ignore "Use comparing" \
+ --ignore "Use on" \
+ --ignore "Use Control.Exception.catch" \
+ --ignore "Reduce duplication" \
+ $(filter-out htools/Ganeti/THH.hs,$(HS_LIB_SRCS))
# a dist hook rule for updating the vcs-version file; this is
# hardcoded due to where it needs to build the file...
diff --git a/doc/devnotes.rst b/doc/devnotes.rst
index 9c11eb99b0450314d9882ac0b31b8f20c15a9536..2d2a2cf18c488d03187980516883a25642d6bc3e 100644
--- a/doc/devnotes.rst
+++ b/doc/devnotes.rst
@@ -36,7 +36,8 @@ document, plus:
- `HsColour <http://hackage.haskell.org/package/hscolour>`_, again
used for documentation (it's source-code pretty-printing)
- `hlint <http://community.haskell.org/~ndm/hlint/>`_, a source code
- linter (equivalent to pylint for Python)
+ linter (equivalent to pylint for Python), recommended version 1.8 or
+ above (tested with 1.8.15)
- the `QuickCheck <http://hackage.haskell.org/package/QuickCheck>`_
library, version 2.x
- ``hpc``, which comes with the compiler, so you should already have
@@ -69,9 +70,9 @@ You can run the Haskell linter :command:`hlint` via::
make hlint
-This is not enabled by default as it gets many false positives, and
-thus the normal output is not βcleanβ. The above command will generate
-both output on the terminal and also a HTML report at
+This is not enabled by default (as the htools component is
+optional). The above command will generate both output on the terminal
+and, if any warnings are found, also an HTML report at
``doc/hs-lint.html``.
When writing or debugging TemplateHaskell code, it's useful to see
diff --git a/htools/Ganeti/HTools/CLI.hs b/htools/Ganeti/HTools/CLI.hs
index d8d310a5ebe4c755921133c885cde6418c6fdad6..85ac4ecdb94a33a8d3e06327280d7cfc7282424f 100644
--- a/htools/Ganeti/HTools/CLI.hs
+++ b/htools/Ganeti/HTools/CLI.hs
@@ -452,13 +452,13 @@ parseOpts argv progname options =
(o, n, []) ->
do
let (pr, args) = (foldM (flip id) defaultOptions o, n)
- po <- (case pr of
- Bad msg -> do
- hPutStrLn stderr "Error while parsing command\
- \line arguments:"
- hPutStrLn stderr msg
- exitWith $ ExitFailure 1
- Ok val -> return val)
+ po <- case pr of
+ Bad msg -> do
+ hPutStrLn stderr "Error while parsing command\
+ \line arguments:"
+ hPutStrLn stderr msg
+ exitWith $ ExitFailure 1
+ Ok val -> return val
when (optShowHelp po) $ do
putStr $ usageHelp progname options
exitWith ExitSuccess
@@ -534,7 +534,7 @@ setNodeStatus opts fixed_nl = do
m_cpu = optMcpu opts
m_dsk = optMdsk opts
- when (not (null offline_wrong)) $ do
+ unless (null offline_wrong) $ do
hPrintf stderr "Error: Wrong node name(s) set as offline: %s\n"
(commaJoin (map lrContent offline_wrong)) :: IO ()
exitWith $ ExitFailure 1
diff --git a/htools/Ganeti/HTools/Cluster.hs b/htools/Ganeti/HTools/Cluster.hs
index 70dcb5ec75e425ceeab2d909c066e6f00f2950ee..d3b1bc71c1bc867f318ab6a4ed9f82bd683abe7b 100644
--- a/htools/Ganeti/HTools/Cluster.hs
+++ b/htools/Ganeti/HTools/Cluster.hs
@@ -373,9 +373,8 @@ applyMove nl inst Failover =
let (old_pdx, old_sdx, old_p, old_s) = instanceNodes nl inst
int_p = Node.removePri old_p inst
int_s = Node.removeSec old_s inst
- force_p = Node.offline old_p
new_nl = do -- Maybe monad
- new_p <- Node.addPriEx force_p int_s inst
+ new_p <- Node.addPriEx (Node.offline old_p) int_s inst
new_s <- Node.addSec int_p inst old_sdx
let new_inst = Instance.setBoth inst old_sdx old_pdx
return (Container.addTwo old_pdx new_s old_sdx new_p nl,
@@ -526,7 +525,8 @@ checkInstanceMove :: [Ndx] -- ^ Allowed target node indices
checkInstanceMove nodes_idx disk_moves inst_moves ini_tbl target =
let opdx = Instance.pNode target
osdx = Instance.sNode target
- nodes = filter (\idx -> idx /= opdx && idx /= osdx) nodes_idx
+ bad_nodes = [opdx, osdx]
+ nodes = filter (`notElem` bad_nodes) nodes_idx
use_secondary = elem osdx nodes_idx && inst_moves
aft_failover = if use_secondary -- if allowed to failover
then checkSingleStep ini_tbl target ini_tbl Failover
@@ -1308,7 +1308,7 @@ printNodes nl fs =
_ -> fs
snl = sortBy (comparing Node.idx) (Container.elems nl)
(header, isnum) = unzip $ map Node.showHeader fields
- in unlines . map ((:) ' ' . intercalate " ") $
+ in unlines . map ((:) ' ' . unwords) $
formatTable (header:map (Node.list fields) snl) isnum
-- | Print the instance list.
@@ -1335,7 +1335,7 @@ printInsts nl il =
header = [ "F", "Name", "Pri_node", "Sec_node", "Auto_bal"
, "vcpu", "mem" , "dsk", "lCpu", "lMem", "lDsk", "lNet" ]
isnum = False:False:False:False:False:repeat True
- in unlines . map ((:) ' ' . intercalate " ") $
+ in unlines . map ((:) ' ' . unwords) $
formatTable (header:map helper sil) isnum
-- | Shows statistics for a given node list.
diff --git a/htools/Ganeti/HTools/ExtLoader.hs b/htools/Ganeti/HTools/ExtLoader.hs
index 210c888dc2a04a2137ddc58093d7f55ef43f9446..f5db7f5b7a7af184232017cf860b5972c084561a 100644
--- a/htools/Ganeti/HTools/ExtLoader.hs
+++ b/htools/Ganeti/HTools/ExtLoader.hs
@@ -95,16 +95,14 @@ loadExternalData opts = do
" files options should be given.")
exitWith $ ExitFailure 1
- util_contents <- (case optDynuFile opts of
- Just path -> readFile path
- Nothing -> return "")
+ util_contents <- maybe (return "") readFile (optDynuFile opts)
let util_data = mapM parseUtilisation $ lines util_contents
- util_data' <- (case util_data of
- Ok x -> return x
- Bad y -> do
- hPutStrLn stderr ("Error: can't parse utilisation" ++
- " data: " ++ show y)
- exitWith $ ExitFailure 1)
+ util_data' <- case util_data of
+ Ok x -> return x
+ Bad y -> do
+ hPutStrLn stderr ("Error: can't parse utilisation" ++
+ " data: " ++ show y)
+ exitWith $ ExitFailure 1
input_data <-
case () of
_ | setRapi -> wrapIO $ Rapi.loadData mhost
@@ -115,13 +113,12 @@ loadExternalData opts = do
let ldresult = input_data >>= mergeData util_data' exTags selInsts exInsts
cdata <-
- (case ldresult of
- Ok x -> return x
- Bad s -> do
- hPrintf stderr
- "Error: failed to load data, aborting. Details:\n%s\n" s:: IO ()
- exitWith $ ExitFailure 1
- )
+ case ldresult of
+ Ok x -> return x
+ Bad s -> do
+ hPrintf stderr
+ "Error: failed to load data, aborting. Details:\n%s\n" s:: IO ()
+ exitWith $ ExitFailure 1
let (fix_msgs, nl) = checkData (cdNodes cdata) (cdInstances cdata)
unless (optVerbose opts == 0) $ maybeShowWarnings fix_msgs
diff --git a/htools/Ganeti/HTools/IAlloc.hs b/htools/Ganeti/HTools/IAlloc.hs
index faefa526c6655ae5d9475f333a74bcafd335c7c4..8c4a415cf84fbcabe46269251c06f7398fdac054 100644
--- a/htools/Ganeti/HTools/IAlloc.hs
+++ b/htools/Ganeti/HTools/IAlloc.hs
@@ -50,6 +50,8 @@ import Ganeti.HTools.ExtLoader (loadExternalData)
import Ganeti.HTools.Utils
import Ganeti.HTools.Types
+{-# ANN module "HLint: ignore Eta reduce" #-}
+
-- | Type alias for the result of an IAllocator call.
type IAllocResult = (String, JSValue, Node.List, Instance.List)
@@ -83,8 +85,9 @@ parseInstance ktn n a = do
else readEitherString $ head nodes
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 <- if null snodes
+ then return Node.noSecondary
+ else readEitherString (head snodes) >>= lookupNode ktn n
return (n, Instance.setBoth (snd base) pidx sidx)
-- | Parses a node as found in the cluster node list.
@@ -101,17 +104,17 @@ parseNode ktg n a = do
vm_capable <- annotateResult desc $ maybeFromObj a "vm_capable"
let vm_capable' = fromMaybe True vm_capable
gidx <- lookupGroup ktg n guuid
- node <- (if offline || drained || not vm_capable'
- then return $ Node.create n 0 0 0 0 0 0 True gidx
- else do
- mtotal <- extract "total_memory"
- mnode <- extract "reserved_memory"
- mfree <- extract "free_memory"
- dtotal <- extract "total_disk"
- dfree <- extract "free_disk"
- ctotal <- extract "total_cpus"
- return $ Node.create n mtotal mnode mfree
- dtotal dfree ctotal False gidx)
+ node <- if offline || drained || not vm_capable'
+ then return $ Node.create n 0 0 0 0 0 0 True gidx
+ else do
+ mtotal <- extract "total_memory"
+ mnode <- extract "reserved_memory"
+ mfree <- extract "free_memory"
+ dtotal <- extract "total_disk"
+ dfree <- extract "free_disk"
+ ctotal <- extract "total_cpus"
+ return $ Node.create n mtotal mnode mfree
+ dtotal dfree ctotal False gidx
return (n, node)
-- | Parses a group as found in the cluster group list.
@@ -330,12 +333,12 @@ readRequest opts args = do
hPutStrLn stderr $ "Error: " ++ err
exitWith $ ExitFailure 1
Ok (fix_msgs, rq) -> maybeShowWarnings fix_msgs >> return rq
- (if isJust (optDataFile opts) || (not . null . optNodeSim) opts
- then do
- cdata <- loadExternalData opts
- let Request rqt _ = r1
- return $ Request rqt cdata
- else return r1)
+ if isJust (optDataFile opts) || (not . null . optNodeSim) opts
+ then do
+ cdata <- loadExternalData opts
+ let Request rqt _ = r1
+ return $ Request rqt cdata
+ else return r1
-- | Main iallocator pipeline.
runIAllocator :: Request -> (Maybe (Node.List, Instance.List), String)
diff --git a/htools/Ganeti/HTools/Loader.hs b/htools/Ganeti/HTools/Loader.hs
index 875436660d02465197b2eddcefda25e8b74201a6..a9c9e0ebfad401af725881ca3db87e1110a97004 100644
--- a/htools/Ganeti/HTools/Loader.hs
+++ b/htools/Ganeti/HTools/Loader.hs
@@ -317,10 +317,9 @@ checkData nl il =
(Node.fMem node - adj_mem)
umsg1 =
if delta_mem > 512 || delta_dsk > 1024
- then (printf "node %s is missing %d MB ram \
- \and %d GB disk"
- nname delta_mem (delta_dsk `div` 1024)):
- msgs
+ then printf "node %s is missing %d MB ram \
+ \and %d GB disk"
+ nname delta_mem (delta_dsk `div` 1024):msgs
else msgs
in (umsg1, newn)
) [] nl
diff --git a/htools/Ganeti/HTools/Luxi.hs b/htools/Ganeti/HTools/Luxi.hs
index b1f55c141ca758a03bfc80ad08ecbbd16321dc53..f7c6dee1dd873919eaf39381d60ad35a483b8cd4 100644
--- a/htools/Ganeti/HTools/Luxi.hs
+++ b/htools/Ganeti/HTools/Luxi.hs
@@ -41,6 +41,8 @@ import qualified Ganeti.HTools.Instance as Instance
import Ganeti.HTools.Utils (fromJVal, annotateResult, tryFromObj, asJSObject,
fromObj)
+{-# ANN module "HLint: ignore Eta reduce" #-}
+
-- * Utility functions
-- | Get values behind \"data\" part of the result.
@@ -148,14 +150,15 @@ parseInstance ktn [ name, disk, mem, vcpus
xname <- annotateResult "Parsing new instance" (fromJValWithStatus name)
let convert a = genericConvert "Instance" xname a
xdisk <- convert "disk_usage" disk
- xmem <- (case oram of -- FIXME: remove the "guessing"
- (_, JSRational _ _) -> convert "oper_ram" oram
- _ -> convert "be/memory" mem)
+ xmem <- case oram of -- FIXME: remove the "guessing"
+ (_, JSRational _ _) -> convert "oper_ram" oram
+ _ -> 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))
+ snode <- if null xsnodes
+ then return Node.noSecondary
+ else lookupNode ktn xname (fromJSString $ head xsnodes)
xrunning <- convert "status" status
xtags <- convert "tags" tags
xauto_balance <- convert "auto_balance" auto_balance
@@ -181,17 +184,17 @@ parseNode ktg [ name, mtotal, mnode, mfree, dtotal, dfree
xdrained <- convert "drained" drained
xvm_capable <- convert "vm_capable" vm_capable
xgdx <- convert "group.uuid" g_uuid >>= lookupGroup ktg xname
- node <- (if xoffline || xdrained || not xvm_capable
- then return $ Node.create xname 0 0 0 0 0 0 True xgdx
- else do
- xmtotal <- convert "mtotal" mtotal
- xmnode <- convert "mnode" mnode
- xmfree <- convert "mfree" mfree
- xdtotal <- convert "dtotal" dtotal
- xdfree <- convert "dfree" dfree
- xctotal <- convert "ctotal" ctotal
- return $ Node.create xname xmtotal xmnode xmfree
- xdtotal xdfree xctotal False xgdx)
+ node <- if xoffline || xdrained || not xvm_capable
+ then return $ Node.create xname 0 0 0 0 0 0 True xgdx
+ else do
+ xmtotal <- convert "mtotal" mtotal
+ xmnode <- convert "mnode" mnode
+ xmfree <- convert "mfree" mfree
+ xdtotal <- convert "dtotal" dtotal
+ xdfree <- convert "dfree" dfree
+ xctotal <- convert "ctotal" ctotal
+ return $ Node.create xname xmtotal xmnode xmfree
+ xdtotal xdfree xctotal False xgdx
return (xname, node)
parseNode _ v = fail ("Invalid node query result: " ++ show v)
diff --git a/htools/Ganeti/HTools/Node.hs b/htools/Ganeti/HTools/Node.hs
index c7dbaa7442a6f881cc12065f809501d397a34e2d..f3a749113188347e877e54901d6f2f733ef4c9ee 100644
--- a/htools/Ganeti/HTools/Node.hs
+++ b/htools/Ganeti/HTools/Node.hs
@@ -328,11 +328,10 @@ removePri t inst =
removeSec :: Node -> Instance.Instance -> Node
removeSec t inst =
let iname = Instance.idx inst
- uses_disk = Instance.usesLocalStorage inst
cur_dsk = fDsk t
pnode = Instance.pNode inst
new_slist = delete iname (sList t)
- new_dsk = if uses_disk
+ new_dsk = if Instance.usesLocalStorage inst
then cur_dsk + Instance.dsk inst
else cur_dsk
old_peers = peers t
diff --git a/htools/Ganeti/HTools/Program/Hail.hs b/htools/Ganeti/HTools/Program/Hail.hs
index 143d79e0d836c19895688eb3d599a1499af94950..bb8f1fb699476778c463e7c32414eb2769645cf1 100644
--- a/htools/Ganeti/HTools/Program/Hail.hs
+++ b/htools/Ganeti/HTools/Program/Hail.hs
@@ -26,6 +26,7 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
module Ganeti.HTools.Program.Hail (main) where
import Control.Monad
+import Data.Maybe (fromMaybe)
import System.Environment (getArgs)
import System.IO
@@ -74,7 +75,7 @@ main = do
maybeSaveData savecluster "pre-ialloc" "before iallocator run" cdata
let (maybe_ni, resp) = runIAllocator request
- (fin_nl, fin_il) = maybe (cdNodes cdata, cdInstances cdata) id maybe_ni
+ (fin_nl, fin_il) = fromMaybe (cdNodes cdata, cdInstances cdata) maybe_ni
putStrLn resp
maybePrintNodes shownodes "Final cluster" (Cluster.printNodes fin_nl)
diff --git a/htools/Ganeti/HTools/Program/Hbal.hs b/htools/Ganeti/HTools/Program/Hbal.hs
index c2cdd1a5f0fe4a0a23ca9a9950f5c08c6e6ae4c5..e7027337318355c400f294d779f12b9c427c99f7 100644
--- a/htools/Ganeti/HTools/Program/Hbal.hs
+++ b/htools/Ganeti/HTools/Program/Hbal.hs
@@ -143,14 +143,14 @@ saveBalanceCommands :: Options -> String -> IO ()
saveBalanceCommands opts cmd_data = do
let out_path = fromJust $ optShowCmds opts
putStrLn ""
- (if out_path == "-" then
- printf "Commands to run to reach the above solution:\n%s"
- (unlines . map (" " ++) .
- filter (/= " check") .
- lines $ cmd_data)
- else do
- writeFile out_path (shTemplate ++ cmd_data)
- printf "The commands have been written to file '%s'\n" out_path)
+ if out_path == "-"
+ then printf "Commands to run to reach the above solution:\n%s"
+ (unlines . map (" " ++) .
+ filter (/= " check") .
+ lines $ cmd_data)
+ else do
+ writeFile out_path (shTemplate ++ cmd_data)
+ printf "The commands have been written to file '%s'\n" out_path
-- | Polls a set of jobs at a fixed interval until all are finished
-- one way or another.
@@ -176,12 +176,12 @@ execWrapper :: String -> Node.List
execWrapper _ _ _ _ [] = return True
execWrapper master nl il cref alljss = do
cancel <- readIORef cref
- (if cancel > 0
- then do
- hPrintf stderr "Exiting early due to user request, %d\
- \ jobset(s) remaining." (length alljss)::IO ()
- return False
- else execJobSet master nl il cref alljss)
+ if cancel > 0
+ then do
+ hPrintf stderr "Exiting early due to user request, %d\
+ \ jobset(s) remaining." (length alljss)::IO ()
+ return False
+ else execJobSet master nl il cref alljss
-- | Execute an entire jobset.
execJobSet :: String -> Node.List
@@ -202,17 +202,17 @@ execJobSet master nl il cref (js:jss) = do
putStrLn $ "Got job IDs " ++ commaJoin x
waitForJobs client x
)
- (case jrs of
- Bad x -> do
- hPutStrLn stderr $ "Cannot compute job status, aborting: " ++ show x
- return False
- Ok x -> if checkJobsStatus x
- then execWrapper master nl il cref jss
- else do
- hPutStrLn stderr $ "Not all jobs completed successfully: " ++
- show x
- hPutStrLn stderr "Aborting."
- return False)
+ case jrs of
+ Bad x -> do
+ hPutStrLn stderr $ "Cannot compute job status, aborting: " ++ show x
+ return False
+ Ok x -> if checkJobsStatus x
+ then execWrapper master nl il cref jss
+ else do
+ hPutStrLn stderr $ "Not all jobs completed successfully: " ++
+ show x
+ hPutStrLn stderr "Aborting."
+ return False
-- | Executes the jobs, if possible and desired.
maybeExecJobs :: Options
@@ -279,7 +279,7 @@ selectGroup opts gl nlf ilf = do
exitWith $ ExitFailure 1
Just grp ->
case lookup (Group.idx grp) ngroups of
- Nothing -> do
+ Nothing ->
-- This will only happen if there are no nodes assigned
-- to this group
return (Group.name grp, (Container.empty, Container.empty))
@@ -375,10 +375,10 @@ main = do
checkNeedRebalance opts ini_cv
- (if verbose > 2
- then printf "Initial coefficients: overall %.8f, %s\n"
- ini_cv (Cluster.printStats nl)::IO ()
- else printf "Initial score: %.8f\n" ini_cv)
+ if verbose > 2
+ then printf "Initial coefficients: overall %.8f, %s\n"
+ ini_cv (Cluster.printStats nl)::IO ()
+ else printf "Initial score: %.8f\n" ini_cv
putStrLn "Trying to minimize the CV..."
let imlen = maximum . map (length . Instance.alias) $ Container.elems il
diff --git a/htools/Ganeti/HTools/Program/Hspace.hs b/htools/Ganeti/HTools/Program/Hspace.hs
index 054e8be1497043160be8721e5869c1554ef14af7..52118148cad1838933bf4bb8d1d64c26e432568c 100644
--- a/htools/Ganeti/HTools/Program/Hspace.hs
+++ b/htools/Ganeti/HTools/Program/Hspace.hs
@@ -268,7 +268,7 @@ printAllocationMap :: Int -> String
printAllocationMap verbose msg nl ixes =
when (verbose > 1) $ do
hPutStrLn stderr (msg ++ " map")
- hPutStr stderr . unlines . map ((:) ' ' . intercalate " ") $
+ hPutStr stderr . unlines . map ((:) ' ' . unwords) $
formatTable (map (printInstance nl) (reverse ixes))
-- This is the numberic-or-not field
-- specification; the first three fields are
@@ -315,7 +315,7 @@ printTiered :: Bool -> [(RSpec, Int)] -> Double
-> Node.List -> Node.List -> [(FailMode, Int)] -> IO ()
printTiered True spec_map m_cpu nl trl_nl _ = do
printKeys $ printStats PTiered (Cluster.totalResources trl_nl)
- printKeys [("TSPEC", intercalate " " (formatSpecMap spec_map))]
+ printKeys [("TSPEC", unwords (formatSpecMap spec_map))]
printAllocationStats m_cpu nl trl_nl
printTiered False spec_map _ ini_nl fin_nl sreason = do
@@ -433,16 +433,15 @@ main = do
-- Run the tiered allocation, if enabled
- (case optTieredSpec opts of
- Nothing -> return ()
- Just tspec -> do
- (treason, trl_nl, _, spec_map) <-
+ case optTieredSpec opts of
+ Nothing -> return ()
+ Just tspec -> do
+ (treason, trl_nl, _, spec_map) <-
runAllocation cdata stop_allocation
- (Cluster.tieredAlloc nl il alloclimit (iofspec tspec)
- allocnodes [] []) tspec SpecTiered opts
+ (Cluster.tieredAlloc nl il alloclimit (iofspec tspec)
+ allocnodes [] []) tspec SpecTiered opts
- printTiered machine_r spec_map (optMcpu opts) nl trl_nl treason
- )
+ printTiered machine_r spec_map (optMcpu opts) nl trl_nl treason
-- Run the standard (avg-mode) allocation
diff --git a/htools/Ganeti/HTools/QC.hs b/htools/Ganeti/HTools/QC.hs
index 892155dc1d33a639fba3d46a00bd3abcd1194be5..022d394365237bdd5311f7a0276eb7b45ca00a82 100644
--- a/htools/Ganeti/HTools/QC.hs
+++ b/htools/Ganeti/HTools/QC.hs
@@ -133,6 +133,13 @@ makeSmallCluster node count =
(_, nlst) = Loader.assignIndices namelst
in nlst
+-- | Make a small cluster, both nodes and instances.
+makeSmallEmptyCluster :: Node.Node -> Int -> Instance.Instance
+ -> (Node.List, Instance.List, Instance.Instance)
+makeSmallEmptyCluster node count inst =
+ (makeSmallCluster node count, Container.empty,
+ setInstanceSmallerThanNode node inst)
+
-- | Checks if a node is "big" enough.
isNodeBig :: Node.Node -> Int -> Bool
isNodeBig node size = Node.availDisk node > size * Types.unitDsk
@@ -246,19 +253,19 @@ instance Arbitrary OpCodes.OpCode where
, "OP_INSTANCE_FAILOVER"
, "OP_INSTANCE_MIGRATE"
]
- (case op_id of
- "OP_TEST_DELAY" ->
- liftM3 OpCodes.OpTestDelay arbitrary arbitrary arbitrary
- "OP_INSTANCE_REPLACE_DISKS" ->
- liftM5 OpCodes.OpInstanceReplaceDisks arbitrary arbitrary
- arbitrary arbitrary arbitrary
- "OP_INSTANCE_FAILOVER" ->
- liftM3 OpCodes.OpInstanceFailover arbitrary arbitrary
- arbitrary
- "OP_INSTANCE_MIGRATE" ->
- liftM5 OpCodes.OpInstanceMigrate arbitrary arbitrary
- arbitrary arbitrary arbitrary
- _ -> fail "Wrong opcode")
+ case op_id of
+ "OP_TEST_DELAY" ->
+ liftM3 OpCodes.OpTestDelay arbitrary arbitrary arbitrary
+ "OP_INSTANCE_REPLACE_DISKS" ->
+ liftM5 OpCodes.OpInstanceReplaceDisks arbitrary arbitrary
+ arbitrary arbitrary arbitrary
+ "OP_INSTANCE_FAILOVER" ->
+ liftM3 OpCodes.OpInstanceFailover arbitrary arbitrary
+ arbitrary
+ "OP_INSTANCE_MIGRATE" ->
+ liftM5 OpCodes.OpInstanceMigrate arbitrary arbitrary
+ arbitrary arbitrary arbitrary
+ _ -> fail "Wrong opcode"
instance Arbitrary Jobs.OpStatus where
arbitrary = elements [minBound..maxBound]
@@ -283,9 +290,9 @@ instance Arbitrary Types.FailMode where
instance Arbitrary a => Arbitrary (Types.OpResult a) where
arbitrary = arbitrary >>= \c ->
- case c of
- False -> liftM Types.OpFail arbitrary
- True -> liftM Types.OpGood arbitrary
+ if c
+ then liftM Types.OpGood arbitrary
+ else liftM Types.OpFail arbitrary
-- * Actual tests
@@ -295,7 +302,7 @@ instance Arbitrary a => Arbitrary (Types.OpResult a) where
-- not contain commas, then join+split should be idempotent.
prop_Utils_commaJoinSplit =
forAll (arbitrary `suchThat`
- (\l -> l /= [""] && all (not . elem ',') l )) $ \lst ->
+ (\l -> l /= [""] && all (notElem ',') l )) $ \lst ->
Utils.sepSplit ',' (Utils.commaJoin lst) ==? lst
-- | Split and join should always be idempotent.
@@ -323,21 +330,19 @@ prop_Utils_select :: Int -- ^ Default result
-> [Int] -- ^ List of True values
-> Gen Prop -- ^ Test result
prop_Utils_select def lst1 lst2 =
- Utils.select def cndlist ==? expectedresult
+ Utils.select def (flist ++ tlist) ==? expectedresult
where expectedresult = Utils.if' (null lst2) def (head lst2)
flist = map (\e -> (False, e)) lst1
tlist = map (\e -> (True, e)) lst2
- cndlist = flist ++ tlist
-- | Test basic select functionality with undefined default
prop_Utils_select_undefd :: [Int] -- ^ List of False values
-> NonEmptyList Int -- ^ List of True values
-> Gen Prop -- ^ Test result
prop_Utils_select_undefd lst1 (NonEmpty lst2) =
- Utils.select undefined cndlist ==? head lst2
+ Utils.select undefined (flist ++ tlist) ==? head lst2
where flist = map (\e -> (False, e)) lst1
tlist = map (\e -> (True, e)) lst2
- cndlist = flist ++ tlist
-- | Test basic select functionality with undefined list values
prop_Utils_select_undefv :: [Int] -- ^ List of False values
@@ -422,6 +427,8 @@ testSuite "PeerMap"
-- ** Container tests
+-- we silence the following due to hlint bug fixed in later versions
+{-# ANN prop_Container_addTwo "HLint: ignore Avoid lambda" #-}
prop_Container_addTwo cdata i1 i2 =
fn i1 i2 cont == fn i2 i1 cont &&
fn i1 i2 cont == fn i1 i2 (fn i1 i2 cont)
@@ -444,7 +451,7 @@ prop_Container_findByName node othername =
forAll (vector cnt) $ \ names ->
(length . nub) (map fst names ++ map snd names) ==
length names * 2 &&
- not (othername `elem` (map fst names ++ map snd names)) ==>
+ othername `notElem` (map fst names ++ map snd names) ==>
let nl = makeSmallCluster node cnt
nodes = Container.elems nl
nodes' = map (\((name, alias), nn) -> (Node.idx nn,
@@ -455,7 +462,7 @@ prop_Container_findByName node othername =
target = snd (nodes' !! fidx)
in Container.findByName nl' (Node.name target) == Just target &&
Container.findByName nl' (Node.alias target) == Just target &&
- Container.findByName nl' othername == Nothing
+ isNothing (Container.findByName nl' othername)
testSuite "Container"
[ 'prop_Container_addTwo
@@ -765,7 +772,7 @@ prop_Node_rMem inst =
-- this is not related to rMem, but as good a place to
-- test as any
inst_idx `elem` Node.sList a_ab &&
- not (inst_idx `elem` Node.sList d_ab)
+ inst_idx `notElem` Node.sList d_ab
x -> printTestCase ("Failed to add/remove instances: " ++ show x) False
-- | Check mdsk setting.
@@ -858,9 +865,7 @@ prop_ClusterAlloc_sane node inst =
&& Node.availDisk node > 0
&& Node.availMem node > 0
==>
- let nl = makeSmallCluster node count
- il = Container.empty
- inst' = setInstanceSmallerThanNode node inst
+ let (nl, il, inst') = makeSmallEmptyCluster node count inst
in case Cluster.genAllocNodes defGroupList nl 2 True >>=
Cluster.tryAlloc nl il inst' of
Types.Bad _ -> False
@@ -900,9 +905,7 @@ prop_ClusterAllocEvac node inst =
&& not (Node.failN1 node)
&& isNodeBig node 4
==>
- let nl = makeSmallCluster node count
- il = Container.empty
- inst' = setInstanceSmallerThanNode node inst
+ let (nl, il, inst') = makeSmallEmptyCluster node count inst
in case Cluster.genAllocNodes defGroupList nl 2 True >>=
Cluster.tryAlloc nl il inst' of
Types.Bad _ -> False
diff --git a/htools/Ganeti/HTools/Rapi.hs b/htools/Ganeti/HTools/Rapi.hs
index c04d87c36ee32256cd487908cd64e919ef345c8d..261609ba5fb5058ab3266272d347a88ca386580d 100644
--- a/htools/Ganeti/HTools/Rapi.hs
+++ b/htools/Ganeti/HTools/Rapi.hs
@@ -48,6 +48,8 @@ import qualified Ganeti.HTools.Node as Node
import qualified Ganeti.HTools.Instance as Instance
import qualified Ganeti.Constants as C
+{-# ANN module "HLint: ignore Eta reduce" #-}
+
-- | Read an URL via curl and return the body if successful.
getUrl :: (Monad m) => String -> IO (m String)
@@ -108,14 +110,15 @@ parseInstance ktn a = do
disk <- extract "disk_usage" a
beparams <- liftM fromJSObject (extract "beparams" a)
omem <- extract "oper_ram" a
- mem <- (case omem of
- JSRational _ _ -> annotateResult owner_name (fromJVal omem)
- _ -> extract "memory" beparams)
+ mem <- case omem of
+ JSRational _ _ -> annotateResult owner_name (fromJVal omem)
+ _ -> extract "memory" beparams
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 <- if null snodes
+ then return Node.noSecondary
+ else readEitherString (head snodes) >>= lookupNode ktn name
running <- extract "status" a
tags <- extract "tags" a
auto_balance <- extract "auto_balance" beparams
@@ -136,17 +139,17 @@ parseNode ktg a = do
let vm_cap' = fromMaybe True vm_cap
guuid <- annotateResult desc $ maybeFromObj a "group.uuid"
guuid' <- lookupGroup ktg name (fromMaybe defaultGroupID guuid)
- node <- (if offline || drained || not vm_cap'
- then return $ Node.create name 0 0 0 0 0 0 True guuid'
- else do
- mtotal <- extract "mtotal"
- mnode <- extract "mnode"
- mfree <- extract "mfree"
- dtotal <- extract "dtotal"
- dfree <- extract "dfree"
- ctotal <- extract "ctotal"
- return $ Node.create name mtotal mnode mfree
- dtotal dfree ctotal False guuid')
+ node <- if offline || drained || not vm_cap'
+ then return $ Node.create name 0 0 0 0 0 0 True guuid'
+ else do
+ mtotal <- extract "mtotal"
+ mnode <- extract "mnode"
+ mfree <- extract "mfree"
+ dtotal <- extract "dtotal"
+ dfree <- extract "dfree"
+ ctotal <- extract "ctotal"
+ return $ Node.create name mtotal mnode mfree
+ dtotal dfree ctotal False guuid'
return (name, node)
-- | Construct a group from a JSON object.
diff --git a/htools/Ganeti/HTools/Text.hs b/htools/Ganeti/HTools/Text.hs
index e16692478b275952680c3aced2b327f6db997b72..ab3d078ad48614946980e48340d926eb1be7f2fa 100644
--- a/htools/Ganeti/HTools/Text.hs
+++ b/htools/Ganeti/HTools/Text.hs
@@ -154,8 +154,9 @@ loadInst :: NameAssoc -- ^ Association list with the current nodes
loadInst ktn [ name, mem, dsk, vcpus, status, auto_bal, pnode, snode
, dt, tags ] = do
pidx <- lookupNode ktn name pnode
- sidx <- (if null snode then return Node.noSecondary
- else lookupNode ktn name snode)
+ sidx <- if null snode
+ then return Node.noSecondary
+ else lookupNode ktn name snode
vmem <- tryRead name mem
vdsk <- tryRead name dsk
vvcpus <- tryRead name vcpus
diff --git a/htools/Ganeti/Luxi.hs b/htools/Ganeti/Luxi.hs
index bdc466386e86acaee4ec021d3bb75d827b05dacd..0af433007b38de12c6b84c3e2d545209d709fe4c 100644
--- a/htools/Ganeti/Luxi.hs
+++ b/htools/Ganeti/Luxi.hs
@@ -60,9 +60,9 @@ import Ganeti.THH
withTimeout :: Int -> String -> IO a -> IO a
withTimeout secs descr action = do
result <- timeout (secs * 1000000) action
- (case result of
- Nothing -> fail $ "Timeout in " ++ descr
- Just v -> return v)
+ case result of
+ Nothing -> fail $ "Timeout in " ++ descr
+ Just v -> return v
-- * Generic protocol functionality
@@ -213,15 +213,15 @@ recvMsg s = do
nbuf <- withTimeout queryTimeout "reading luxi response" $
S.recv (socket s) 4096
let (msg, remaining) = break (eOM ==) nbuf
- (if null remaining
- then _recv (obuf ++ msg)
- else return (obuf ++ msg, tail remaining))
+ if null remaining
+ then _recv (obuf ++ msg)
+ else return (obuf ++ msg, tail remaining)
cbuf <- readIORef $ rbuf s
let (imsg, ibuf) = break (eOM ==) cbuf
(msg, nbuf) <-
- (if null ibuf -- if old buffer didn't contain a full message
- then _recv cbuf -- then we read from network
- else return (imsg, tail ibuf)) -- else we return data from our buffer
+ if null ibuf -- if old buffer didn't contain a full message
+ then _recv cbuf -- then we read from network
+ else return (imsg, tail ibuf) -- else we return data from our buffer
writeIORef (rbuf s) nbuf
return msg
@@ -244,9 +244,9 @@ validateResult s = do
let arr = J.fromJSObject oarr
status <- fromObj arr (strOfKey Success)::Result Bool
let rkey = strOfKey Result
- (if status
- then fromObj arr rkey
- else fromObj arr rkey >>= fail)
+ if status
+ then fromObj arr rkey
+ else fromObj arr rkey >>= fail
-- | Generic luxi method call.
callMethod :: LuxiOp -> Client -> IO (Result JSValue)
diff --git a/htools/test.hs b/htools/test.hs
index 7af9e8fbbfe8e6d5671816cf15b295275546afa8..3879bdb6b7ca2638fda4332575ecb19969222c50 100644
--- a/htools/test.hs
+++ b/htools/test.hs
@@ -136,9 +136,9 @@ transformTestOpts args opts = do
Nothing -> return Nothing
Just str -> do
let vs = sepSplit ',' str
- (case vs of
- [rng, size] -> return $ Just (read rng, read size)
- _ -> fail "Invalid state given")
+ case vs of
+ [rng, size] -> return $ Just (read rng, read size)
+ _ -> fail "Invalid state given"
return args { chatty = optVerbose opts > 1,
replay = r
}
@@ -149,26 +149,26 @@ main = do
let wrap = map (wrapTest errs)
cmd_args <- getArgs
(opts, args) <- parseOpts cmd_args "test" options
- tests <- (if null args
- then return allTests
- else (let args' = map lower args
- selected = filter ((`elem` args') . lower .
- extractName) allTests
- in if null selected
- then do
- hPutStrLn stderr $ "No tests matching '"
- ++ intercalate " " args ++ "', available tests: "
- ++ intercalate ", " (map extractName allTests)
- exitWith $ ExitFailure 1
- else return selected))
+ tests <- if null args
+ then return allTests
+ else let args' = map lower args
+ selected = filter ((`elem` args') . lower .
+ extractName) allTests
+ in if null selected
+ then do
+ hPutStrLn stderr $ "No tests matching '"
+ ++ unwords args ++ "', available tests: "
+ ++ intercalate ", " (map extractName allTests)
+ exitWith $ ExitFailure 1
+ else return selected
let max_count = maximum $ map (\(_, (_, t)) -> length t) tests
mapM_ (\(targs, (name, tl)) ->
transformTestOpts targs opts >>= \newargs ->
runTests name newargs (wrap tl) max_count) tests
terr <- readIORef errs
- (if terr > 0
- then do
- hPutStrLn stderr $ "A total of " ++ show terr ++ " tests failed."
- exitWith $ ExitFailure 1
- else putStrLn "All tests succeeded.")
+ if terr > 0
+ then do
+ hPutStrLn stderr $ "A total of " ++ show terr ++ " tests failed."
+ exitWith $ ExitFailure 1
+ else putStrLn "All tests succeeded."