Commit 78694255 authored by Iustin Pop's avatar Iustin Pop
Browse files

Fix the various monomorphism warning

In a few places (e.g. tryRead or any printf call) it's a little bit hard
to add the correct type signatures, but in the it is possible to fix
these warnings (which can bite one in subtle cases).
parent 3c64b5aa
......@@ -76,6 +76,12 @@ class EToolOptions a where
-- | Whether to be less verbose.
silent :: a -> Bool
-- | Usage info
usageHelp :: (CLIOptions a) => String -> [OptDescr (a -> a)] -> String
usageHelp progname options =
usageInfo (printf "%s %s\nUsage: %s [OPTION...]"
progname Version.version progname) options
-- | Command line parser, using the 'options' structure.
parseOpts :: (CLIOptions b) =>
[String] -- ^ The command line arguments
......@@ -90,7 +96,7 @@ parseOpts argv progname options defaultOptions =
do
let resu@(po, _) = (foldl (flip id) defaultOptions o, n)
when (showHelp po) $ do
putStr $ usageInfo header options
putStr $ usageHelp progname options
exitWith ExitSuccess
when (showVersion po) $ do
printf "%s %s\ncompiled with %s %s\nrunning on %s %s\n"
......@@ -100,9 +106,7 @@ parseOpts argv progname options defaultOptions =
exitWith ExitSuccess
return resu
(_, _, errs) ->
ioError (userError (concat errs ++ usageInfo header options))
where header = printf "%s %s\nUsage: %s [OPTION...]"
progname Version.version progname
ioError (userError (concat errs ++ usageHelp progname options))
-- | Parse the environment and return the node\/instance names.
--
......
......@@ -30,6 +30,7 @@ module Ganeti.HTools.Cluster
(
-- * Types
Placement
, AllocSolution
, Solution(..)
, Table(..)
, Removal
......@@ -78,6 +79,9 @@ type Score = Double
-- | The description of an instance placement.
type Placement = (Idx, Ndx, Ndx, Score)
-- | Allocation/relocation solution.
type AllocSolution = [(Maybe Node.List, Instance.Instance, [Node.Node])]
-- | A cluster solution described as the solution delta and the list
-- of placements.
data Solution = Solution Int [Placement]
......@@ -158,15 +162,16 @@ compDetailedCV nl =
mem_cv = varianceCoeff mem_l
dsk_cv = varianceCoeff dsk_l
n1_l = length $ filter Node.failN1 nodes
n1_score = (fromIntegral n1_l) / (fromIntegral $ length nodes)
n1_score = ((fromIntegral n1_l) /
(fromIntegral $ length nodes))::Double
res_l = map Node.p_rem nodes
res_cv = varianceCoeff res_l
offline_inst = sum . map (\n -> (length . Node.plist $ n) +
(length . Node.slist $ n)) $ offline
online_inst = sum . map (\n -> (length . Node.plist $ n) +
(length . Node.slist $ n)) $ nodes
off_score = (fromIntegral offline_inst) /
(fromIntegral $ online_inst + offline_inst)
off_score = ((fromIntegral offline_inst) /
(fromIntegral $ online_inst + offline_inst))::Double
cpu_l = map Node.p_cpu nodes
cpu_cv = varianceCoeff cpu_l
in (mem_cv, dsk_cv, n1_score, res_cv, off_score, cpu_cv)
......@@ -631,8 +636,7 @@ tryAlloc :: (Monad m) =>
-> Instance.List -- ^ The instance list
-> Instance.Instance -- ^ The instance to allocate
-> Int -- ^ Required number of nodes
-> m [(Maybe Node.List, Instance.Instance, [Node.Node])]
-- ^ Possible solution list
-> m AllocSolution -- ^ Possible solution list
tryAlloc nl _ inst 2 =
let all_nodes = getOnline nl
all_pairs = liftM2 (,) all_nodes all_nodes
......@@ -655,13 +659,12 @@ tryAlloc _ _ _ reqn = fail $ "Unsupported number of alllocation \
-- | Try to allocate an instance on the cluster.
tryReloc :: (Monad m) =>
Node.List -- ^ The node list
-> Instance.List -- ^ The instance list
-> Idx -- ^ The index of the instance to move
-> Int -- ^ The numver of nodes required
-> [Ndx] -- ^ Nodes which should not be used
-> m [(Maybe Node.List, Instance.Instance, [Node.Node])]
-- ^ Solution list
Node.List -- ^ The node list
-> Instance.List -- ^ The instance list
-> Idx -- ^ The index of the instance to move
-> Int -- ^ The numver of nodes required
-> [Ndx] -- ^ Nodes which should not be used
-> m AllocSolution -- ^ Solution list
tryReloc nl il xid 1 ex_idx =
let all_nodes = getOnline nl
inst = Container.find xid il
......@@ -782,13 +785,13 @@ printNodes nl =
let snl = sortBy (compare `on` Node.idx) (Container.elems nl)
m_name = maximum . map (length . Node.name) $ snl
helper = Node.list m_name
header = printf
"%2s %-*s %5s %5s %5s %5s %5s %5s %5s %5s %4s %4s \
\%3s %3s %6s %6s %5s"
" F" m_name "Name"
"t_mem" "n_mem" "i_mem" "x_mem" "f_mem" "r_mem"
"t_dsk" "f_dsk" "pcpu" "vcpu"
"pri" "sec" "p_fmem" "p_fdsk" "r_cpu"
header = (printf
"%2s %-*s %5s %5s %5s %5s %5s %5s %5s %5s %4s %4s \
\%3s %3s %6s %6s %5s"
" F" m_name "Name"
"t_mem" "n_mem" "i_mem" "x_mem" "f_mem" "r_mem"
"t_dsk" "f_dsk" "pcpu" "vcpu"
"pri" "sec" "p_fmem" "p_fdsk" "r_cpu")::String
in unlines $ (header:map helper snl)
-- | Shows statistics for a given node list.
......
......@@ -36,6 +36,7 @@ module Ganeti.HTools.Loader
, Request(..)
) where
import Data.Function (on)
import Data.List
import Data.Maybe (fromJust)
import Text.Printf (printf)
......@@ -88,6 +89,10 @@ assignIndices =
unzip . map (\ (idx, (k, v)) -> ((k, idx), (idx, setIdx v idx)))
. zip [0..]
-- | Assoc element comparator
assocEqual :: (Eq a) => (a, b) -> (a, b) -> Bool
assocEqual = (==) `on` fst
-- | For each instance, add its index to its primary and secondary nodes.
fixNodes :: [(Ndx, Node.Node)]
-> [(Idx, Instance.Instance)]
......@@ -95,7 +100,6 @@ fixNodes :: [(Ndx, Node.Node)]
fixNodes nl il =
foldl' (\accu (idx, inst) ->
let
assocEqual = (\ (i, _) (j, _) -> i == j)
pdx = Instance.pnode inst
sdx = Instance.snode inst
pold = fromJust $ lookup pdx accu
......@@ -169,11 +173,11 @@ checkData nl il =
- (nodeIdsk node il)
newn = Node.setFmem (Node.setXmem node delta_mem)
(Node.f_mem 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)]
else []
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)]
else [])::[String]
in (msgs ++ umsg1, newn)
) [] nl
......
......@@ -37,15 +37,17 @@ import Ganeti.HTools.Types
import qualified Ganeti.HTools.Node as Node
import qualified Ganeti.HTools.Instance as Instance
-- | Parse results from readsPrec
parseChoices :: (Monad m, Read a) => String -> String -> [(a, String)] -> m a
parseChoices _ _ ((v, ""):[]) = return v
parseChoices name s ((_, e):[]) =
fail $ name ++ ": leftover characters when parsing '"
++ s ++ "': '" ++ e ++ "'"
parseChoices name s _ = fail $ name ++ ": cannot parse string '" ++ s ++ "'"
-- | Safe 'read' function returning data encapsulated in a Result.
tryRead :: (Monad m, Read a) => String -> String -> m a
tryRead name s =
let sols = readsPrec 0 s
in case sols of
(v, ""):[] -> return v
(_, e):[] -> fail $ name ++ ": leftover characters when parsing '"
++ s ++ "': '" ++ e ++ "'"
_ -> fail $ name ++ ": cannot parse string '" ++ s ++ "'"
tryRead name s = parseChoices name s $ readsPrec 0 s
-- | Load a node from a field list.
loadNode :: (Monad m) => [String] -> m (String, Node.Node)
......
......@@ -85,11 +85,14 @@ fst3 (a, _, _) = a
meanValue :: Floating a => [a] -> a
meanValue lst = (sum lst) / (fromIntegral $ length lst)
-- | Squaring function
square :: (Num a) => a -> a
square = (^ 2)
-- | Standard deviation.
stdDev :: Floating a => [a] -> a
stdDev lst =
let mv = meanValue lst
square = (^ (2::Int)) -- silences "defaulting the constraint..."
av = sum $ map square $ map (\e -> e - mv) lst
bv = sqrt (av / (fromIntegral $ length lst))
in bv
......
......@@ -92,12 +92,22 @@ processResults sols =
sols'' = sortBy (compare `on` fst) sols'
(best, w) = head sols''
(worst, l) = last sols''
info = printf "Valid results: %d, best score: %.8f for node(s) %s, \
\worst score: %.8f for node(s) %s" (length sols'')
best (intercalate "/" . map Node.name $ w)
worst (intercalate "/" . map Node.name $ l)
info = (printf "Valid results: %d, best score: %.8f for node(s) %s, \
\worst score: %.8f for node(s) %s" (length sols'')
best (intercalate "/" . map Node.name $ w)
worst (intercalate "/" . map Node.name $ l))::String
in return (info, w)
-- | Process a request and return new node lists
processRequest ::
Request
-> Result [(Maybe Node.List, Instance.Instance, [Node.Node])]
processRequest request =
let Request rqtype nl il _ = request
in case rqtype of
Allocate xi reqn -> Cluster.tryAlloc nl il xi reqn
Relocate idx reqn exnodes -> Cluster.tryReloc nl il idx reqn exnodes
-- | Main function.
main :: IO ()
main = do
......@@ -117,12 +127,8 @@ main = do
exitWith $ ExitFailure 1
Ok rq -> return rq
let Request rqtype nl il csf = request
new_nodes = case rqtype of
Allocate xi reqn -> Cluster.tryAlloc nl il xi reqn
Relocate idx reqn exnodes ->
Cluster.tryReloc nl il idx reqn exnodes
let sols = new_nodes >>= filterFails >>= processResults
let Request _ _ _ csf = request
sols = processRequest request >>= filterFails >>= processResults
let (ok, info, rn) = case sols of
Ok (info, sn) -> (True, "Request successful: " ++ info,
map ((++ csf) . Node.name) sn)
......
......@@ -272,14 +272,14 @@ main = do
nmlen imlen [] oneline min_cv
let (Cluster.Table fin_nl _ fin_cv fin_plc) = fin_tbl
ord_plc = reverse fin_plc
sol_msg = if null fin_plc
then printf "No solution found\n"
else (if verbose > 2
then printf "Final coefficients: overall %.8f, %s\n"
fin_cv (Cluster.printStats fin_nl)
else printf "Cluster score improved from %.8f to %.8f\n"
ini_cv fin_cv
)
sol_msg = (if null fin_plc
then printf "No solution found\n"
else (if verbose > 2
then printf "Final coefficients: overall %.8f, %s\n"
fin_cv (Cluster.printStats fin_nl)
else printf "Cluster score improved from %.8f to %.8f\n"
ini_cv fin_cv
))::String
unless oneline $ putStr sol_msg
......
......@@ -93,43 +93,40 @@ options =
"show help"
]
-- | Serialize a single node
serializeNode :: String -> Node.Node -> String
serializeNode csf node =
let name = Node.name node ++ csf
t_mem = (truncate $ Node.t_mem node)::Int
t_dsk = (truncate $ Node.t_dsk node)::Int
in
printf "%s|%d|%d|%d|%d|%d|%c" name
t_mem (Node.n_mem node) (Node.f_mem node)
t_dsk (Node.f_dsk node)
(if Node.offline node then 'Y' else 'N')
-- | Generate node file data from node objects
serializeNodes :: Node.List -> String -> String
serializeNodes nl csf =
let nodes = Container.elems nl
nlines = map
(\node ->
let name = Node.name node ++ csf
t_mem = (truncate $ Node.t_mem node)::Int
t_dsk = (truncate $ Node.t_dsk node)::Int
in
printf "%s|%d|%d|%d|%d|%d|%c" name
t_mem (Node.n_mem node) (Node.f_mem node)
t_dsk (Node.f_dsk node)
(if Node.offline node then 'Y' else 'N')
)
nodes
in unlines nlines
serializeNodes :: String -> Node.List -> String
serializeNodes csf =
unlines . map (serializeNode csf) . Container.elems
-- | Serialize a single instance
serializeInstance :: String -> Node.List -> Instance.Instance -> String
serializeInstance csf nl inst =
let
iname = Instance.name inst ++ csf
pnode = Container.nameOf nl $ Instance.pnode inst
snode = Container.nameOf nl $ Instance.snode inst
in
printf "%s|%d|%d|%s|%s|%s"
iname (Instance.mem inst) (Instance.dsk inst)
(Instance.run_st inst)
pnode snode
-- | Generate instance file data from instance objects
serializeInstances :: Node.List -> Instance.List
-> String -> String
serializeInstances nl il csf =
let instances = Container.elems il
nlines = map
(\inst ->
let
iname = Instance.name inst ++ csf
pnode = Container.nameOf nl $ Instance.pnode inst
snode = Container.nameOf nl $ Instance.snode inst
in
printf "%s|%d|%d|%s|%s|%s"
iname (Instance.mem inst) (Instance.dsk inst)
(Instance.run_st inst)
pnode snode
)
instances
in unlines nlines
serializeInstances :: String -> Node.List -> Instance.List -> String
serializeInstances csf nl =
unlines . map (serializeInstance csf nl) . Container.elems
-- | Return a one-line summary of cluster state
printCluster :: Node.List -> Instance.List
......@@ -139,16 +136,16 @@ printCluster nl il =
ccv = Cluster.compCV nl
nodes = Container.elems nl
insts = Container.elems il
t_ram = truncate . sum . map Node.t_mem $ nodes
t_dsk = truncate . sum . map Node.t_dsk $ nodes
t_ram = sum . map Node.t_mem $ nodes
t_dsk = sum . map Node.t_dsk $ nodes
f_ram = sum . map Node.f_mem $ nodes
f_dsk = sum . map Node.f_dsk $ nodes
in
printf "%5d %5d %5d %5d %6d %6d %6d %6d %.8f"
printf "%5d %5d %5d %5d %6.0f %6d %6.0f %6d %.8f"
(length nodes) (length insts)
(length bad_nodes) (length bad_instances)
(t_ram::Integer) f_ram
((t_dsk::Integer) `div` 1024) (f_dsk `div` 1024)
t_ram f_ram
(t_dsk / 1024) (f_dsk `div` 1024)
ccv
......@@ -187,8 +184,8 @@ main = do
putStrLn $ printCluster fix_nl il
when (optShowNodes opts) $ do
putStr $ Cluster.printNodes fix_nl
let ndata = serializeNodes nl csf
idata = serializeInstances nl il csf
let ndata = serializeNodes csf nl
idata = serializeInstances csf nl il
oname = odir </> (fixSlash name)
writeFile (oname <.> "nodes") ndata
writeFile (oname <.> "instances") idata)
......
......@@ -137,13 +137,13 @@ options =
"show help"
]
filterFails :: (Monad m) => [(Maybe Node.List, Instance.Instance, [Node.Node])]
-> m [(Node.List, Instance.Instance, [Node.Node])]
filterFails :: Cluster.AllocSolution
-> Maybe [(Node.List, Instance.Instance, [Node.Node])]
filterFails sols =
if null sols then fail "No nodes onto which to allocate at all"
if null sols then Nothing -- No nodes onto which to allocate at all
else let sols' = filter (isJust . fst3) sols
in if null sols' then
fail "No valid allocation solutions"
Nothing -- No valid allocation solutions
else
return $ map (\(x, y, z) -> (fromJust x, y, z)) sols'
......@@ -162,10 +162,11 @@ iterateDepth :: Node.List
-> (Node.List, [Instance.Instance])
iterateDepth nl il newinst nreq ixes =
let depth = length ixes
newname = printf "new-%d" depth
newname = (printf "new-%d" depth)::String
newidx = (length $ Container.elems il) + depth
newi2 = Instance.setIdx (Instance.setName newinst newname) newidx
sols = Cluster.tryAlloc nl il newi2 nreq
sols = (Cluster.tryAlloc nl il newi2 nreq)::
Maybe Cluster.AllocSolution
orig = (nl, ixes)
in
if isNothing sols then orig
......
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