.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...
- `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
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
(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
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
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,
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
_ -> 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.
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.
" 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
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
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)
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.
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.
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)
(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
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.
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
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)
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
module Ganeti.HTools.Program.Hail (main) where
import Control.Monad
+import Data.Maybe (fromMaybe)
import System.Environment (getArgs)
import System.IO
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)
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.
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
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
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))
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
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
-> 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
-- 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
(_, 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
, "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]
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
-- 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.
-> [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
-- ** 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)
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,
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
-- 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.
&& 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
&& 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
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)
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
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.
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
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
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
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)
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
}
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."
projects / ganeti-local / commitdiff