diff --git a/Ganeti/HTools/CLI.hs b/Ganeti/HTools/CLI.hs index a5316bb1b91614fe88bd3a8bdc1a655ee98496e6..578237b7593aaeb8a67bdeedbe331977d28d7928 100644 --- a/Ganeti/HTools/CLI.hs +++ b/Ganeti/HTools/CLI.hs @@ -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. -- diff --git a/Ganeti/HTools/Cluster.hs b/Ganeti/HTools/Cluster.hs index fc5992cc97df98fe2994d8f8f48960594246146f..a6fffe9a76a2dae0c70368f7600a38c51059af21 100644 --- a/Ganeti/HTools/Cluster.hs +++ b/Ganeti/HTools/Cluster.hs @@ -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. diff --git a/Ganeti/HTools/Loader.hs b/Ganeti/HTools/Loader.hs index 0971fb31fd6a6346ef962209d462c84d225c6d78..5eab69df0f3695e8426301556624e63256d3ac8a 100644 --- a/Ganeti/HTools/Loader.hs +++ b/Ganeti/HTools/Loader.hs @@ -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 diff --git a/Ganeti/HTools/Text.hs b/Ganeti/HTools/Text.hs index ebdefc439efffa85346b45ae5285952bc45bc91c..ce2a00863bb40a54355609e6c2ba6b513eb675d1 100644 --- a/Ganeti/HTools/Text.hs +++ b/Ganeti/HTools/Text.hs @@ -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) diff --git a/Ganeti/HTools/Utils.hs b/Ganeti/HTools/Utils.hs index 993b044ade480cd1fd7d51f01b53baae66814b6c..d877c1a4d314e8f94709103b08d3e0d76d0f7354 100644 --- a/Ganeti/HTools/Utils.hs +++ b/Ganeti/HTools/Utils.hs @@ -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 diff --git a/hail.hs b/hail.hs index 5c7f71ec0f00347ab14402aa563b099652b47d57..dfb62f04b94f546f6060c3fcb5bf249ac046a208 100644 --- a/hail.hs +++ b/hail.hs @@ -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) diff --git a/hbal.hs b/hbal.hs index 0cebe2be3b28d401e21da6b5ca4ccd19e7c2b3e0..daf3c9ee2d70a2a1fc22af7ba6bf700331f1f72c 100644 --- a/hbal.hs +++ b/hbal.hs @@ -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 diff --git a/hscan.hs b/hscan.hs index 2a6981d0882b28d40dcf66d196323e7bd7203094..080d2c406341e29152d9f2b0c35b730e81fa7fb5 100644 --- a/hscan.hs +++ b/hscan.hs @@ -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) diff --git a/hspace.hs b/hspace.hs index 57de4ec56cbcaf9bc2cd4cd7eabf2eb85babffc7..02d39fe09b953b8e41d27e7c9da147c17e8353d7 100644 --- a/hspace.hs +++ b/hspace.hs @@ -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