From 3603605abbc93e1d6dc3be60f118726d621f5377 Mon Sep 17 00:00:00 2001
From: Iustin Pop <iustin@google.com>
Date: Wed, 7 Dec 2011 18:28:01 +0100
Subject: [PATCH] Cleanup hlint errors
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
First, we update the recommended hlint version to what I used to get a
clean output (1.8.15). Most of the changes are:
- remove unneeded parentheses
- some simplifications (intercalate " " β unwords, maybe β¦ id β
fromMaybe, etc.)
- removal of some duplicate code (in previous patches)
There are still some warnings which I didn't clean out but plain
ignored:
- 'Eta reduce' in some specific files, because the type inference
specialises the function on the first call, and annotating the type
properly would be too verbose
- use of 'first', 'comparing', and 'on', since these don't seem to be
widely or consistently used (outside ganeti/htools, I mean)
- use of Control.Exception.catch, as we only care about I/O errors; at
one point yes, we will need to transition to this new API
- 'Reduce duplication', since hlint warns even for 3 duplicate lines,
and abstracting that away seems overkill to me
After this patch, make hlint is clean and doesn't exit with an error
anymore; we could enable it automatically on 'make lint' if hlint is
detected (future patch).
Note that we explicitly skip the THH.hs file from checking because it
seems that hlint doesn't parse correctly for now the splice notation.
Signed-off-by: Iustin Pop <iustin@google.com>
Reviewed-by: Agata Murawska <agatamurawska@google.com>
---
Makefile.am | 8 +++-
doc/devnotes.rst | 9 ++--
htools/Ganeti/HTools/CLI.hs | 16 +++----
htools/Ganeti/HTools/Cluster.hs | 10 ++--
htools/Ganeti/HTools/ExtLoader.hs | 29 ++++++------
htools/Ganeti/HTools/IAlloc.hs | 41 +++++++++--------
htools/Ganeti/HTools/Loader.hs | 7 ++-
htools/Ganeti/HTools/Luxi.hs | 35 +++++++-------
htools/Ganeti/HTools/Node.hs | 3 +-
htools/Ganeti/HTools/Program/Hail.hs | 3 +-
htools/Ganeti/HTools/Program/Hbal.hs | 60 ++++++++++++------------
htools/Ganeti/HTools/Program/Hspace.hs | 19 ++++----
htools/Ganeti/HTools/QC.hs | 63 ++++++++++++++------------
htools/Ganeti/HTools/Rapi.hs | 35 +++++++-------
htools/Ganeti/HTools/Text.hs | 5 +-
htools/Ganeti/Luxi.hs | 24 +++++-----
htools/test.hs | 40 ++++++++--------
17 files changed, 211 insertions(+), 196 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 57bc27e91..417c2766b 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 9c11eb99b..2d2a2cf18 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 d8d310a5e..85ac4ecdb 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 70dcb5ec7..d3b1bc71c 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 210c888dc..f5db7f5b7 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 faefa526c..8c4a415cf 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 875436660..a9c9e0ebf 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 b1f55c141..f7c6dee1d 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 c7dbaa744..f3a749113 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 143d79e0d..bb8f1fb69 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 c2cdd1a5f..e70273373 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 054e8be14..52118148c 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 892155dc1..022d39436 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 c04d87c36..261609ba5 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 e16692478..ab3d078ad 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 bdc466386..0af433007 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 7af9e8fbb..3879bdb6b 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."
--
GitLab