X-Git-Url: https://code.grnet.gr/git/ganeti-local/blobdiff_plain/fd22ce8ef81cf23858a0446dcc0c4781a9427b65..1a82215d952e916f7fef933827d07bca22c04063:/Ganeti/HTools/Cluster.hs diff --git a/Ganeti/HTools/Cluster.hs b/Ganeti/HTools/Cluster.hs index 73060a1..dc316e4 100644 --- a/Ganeti/HTools/Cluster.hs +++ b/Ganeti/HTools/Cluster.hs @@ -5,17 +5,36 @@ goes into the "Main" module for the individual binaries. -} +{- + +Copyright (C) 2009 Google Inc. + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +02110-1301, USA. + +-} + module Ganeti.HTools.Cluster ( -- * Types - NodeList - , InstanceList - , NameList - , Placement + Placement , Solution(..) , Table(..) , Removal , Score + , IMove(..) -- * Generic functions , totalResources -- * First phase functions @@ -28,63 +47,64 @@ module Ganeti.HTools.Cluster , formatCmds , printNodes -- * Balacing functions + , applyMove , checkMove , compCV , printStats - -- * Loading functions - , loadData - , checkData + -- * IAllocator functions + , allocateOnSingle + , allocateOnPair + , tryAlloc + , tryReloc ) where import Data.List import Data.Maybe (isNothing, fromJust) import Text.Printf (printf) import Data.Function +import Control.Monad import qualified Ganeti.HTools.Container as Container import qualified Ganeti.HTools.Instance as Instance import qualified Ganeti.HTools.Node as Node +import Ganeti.HTools.Types import Ganeti.HTools.Utils -type NodeList = Container.Container Node.Node -type InstanceList = Container.Container Instance.Instance --- | The type used to hold idx-to-name mappings -type NameList = [(Int, String)] --- | A separate name for the cluster score type +-- * Types + +-- | A separate name for the cluster score type. type Score = Double -- | The description of an instance placement. -type Placement = (Int, Int, Int, Score) +type Placement = (Idx, Ndx, Ndx, Score) -{- | A cluster solution described as the solution delta and the list -of placements. - --} +-- | A cluster solution described as the solution delta and the list +-- of placements. data Solution = Solution Int [Placement] deriving (Eq, Ord, Show) --- | Returns the delta of a solution or -1 for Nothing -solutionDelta :: Maybe Solution -> Int -solutionDelta sol = case sol of - Just (Solution d _) -> d - _ -> -1 - -- | A removal set. -data Removal = Removal NodeList [Instance.Instance] +data Removal = Removal Node.List [Instance.Instance] -- | An instance move definition data IMove = Failover -- ^ Failover the instance (f) - | ReplacePrimary Int -- ^ Replace primary (f, r:np, f) - | ReplaceSecondary Int -- ^ Replace secondary (r:ns) - | ReplaceAndFailover Int -- ^ Replace secondary, failover (r:np, f) - | FailoverAndReplace Int -- ^ Failover, replace secondary (f, r:ns) + | ReplacePrimary Ndx -- ^ Replace primary (f, r:np, f) + | ReplaceSecondary Ndx -- ^ Replace secondary (r:ns) + | ReplaceAndFailover Ndx -- ^ Replace secondary, failover (r:np, f) + | FailoverAndReplace Ndx -- ^ Failover, replace secondary (f, r:ns) deriving (Show) -- | The complete state for the balancing solution -data Table = Table NodeList InstanceList Score [Placement] +data Table = Table Node.List Instance.List Score [Placement] deriving (Show) --- General functions +-- * Utility functions + +-- | Returns the delta of a solution or -1 for Nothing. +solutionDelta :: Maybe Solution -> Int +solutionDelta sol = case sol of + Just (Solution d _) -> d + _ -> -1 -- | Cap the removal list if needed. capRemovals :: [a] -> Int -> [a] @@ -102,9 +122,68 @@ verifyN1Check nl = any Node.failN1 nl verifyN1 :: [Node.Node] -> [Node.Node] verifyN1 nl = filter Node.failN1 nl -{-| Add an instance and return the new node and instance maps. -} -addInstance :: NodeList -> Instance.Instance -> - Node.Node -> Node.Node -> Maybe NodeList +{-| Computes the pair of bad nodes and instances. + +The bad node list is computed via a simple 'verifyN1' check, and the +bad instance list is the list of primary and secondary instances of +those nodes. + +-} +computeBadItems :: Node.List -> Instance.List -> + ([Node.Node], [Instance.Instance]) +computeBadItems nl il = + let bad_nodes = verifyN1 $ getOnline nl + bad_instances = map (\idx -> Container.find idx il) $ + sort $ nub $ concat $ + map (\ n -> (Node.slist n) ++ (Node.plist n)) bad_nodes + in + (bad_nodes, bad_instances) + +-- | Compute the total free disk and memory in the cluster. +totalResources :: Node.List -> (Int, Int) +totalResources nl = + foldl' + (\ (mem, dsk) node -> (mem + (Node.f_mem node), + dsk + (Node.f_dsk node))) + (0, 0) (Container.elems nl) + +-- | Compute the mem and disk covariance. +compDetailedCV :: Node.List -> (Double, Double, Double, Double, Double) +compDetailedCV nl = + let + all_nodes = Container.elems nl + (offline, nodes) = partition Node.offline all_nodes + mem_l = map Node.p_mem nodes + dsk_l = map Node.p_dsk nodes + 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) + 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) + in (mem_cv, dsk_cv, n1_score, res_cv, off_score) + +-- | Compute the /total/ variance. +compCV :: Node.List -> Double +compCV nl = + let (mem_cv, dsk_cv, n1_score, res_cv, off_score) = compDetailedCV nl + in mem_cv + dsk_cv + n1_score + res_cv + off_score + +-- | Compute online nodes from a Node.List +getOnline :: Node.List -> [Node.Node] +getOnline = filter (not . Node.offline) . Container.elems + +-- * hn1 functions + +-- | Add an instance and return the new node and instance maps. +addInstance :: Node.List -> Instance.Instance -> + Node.Node -> Node.Node -> Maybe Node.List addInstance nl idata pri sec = let pdx = Node.idx pri sdx = Node.idx sec @@ -116,7 +195,7 @@ addInstance nl idata pri sec = return new_nl -- | Remove an instance and return the new node and instance maps. -removeInstance :: NodeList -> Instance.Instance -> NodeList +removeInstance :: Node.List -> Instance.Instance -> Node.List removeInstance nl idata = let pnode = Instance.pnode idata snode = Instance.snode idata @@ -128,18 +207,11 @@ removeInstance nl idata = new_nl -- | Remove an instance and return the new node map. -removeInstances :: NodeList -> [Instance.Instance] -> NodeList +removeInstances :: Node.List -> [Instance.Instance] -> Node.List removeInstances = foldl' removeInstance --- | Compute the total free disk and memory in the cluster. -totalResources :: Container.Container Node.Node -> (Int, Int) -totalResources nl = - foldl' - (\ (mem, dsk) node -> (mem + (Node.f_mem node), - dsk + (Node.f_dsk node))) - (0, 0) (Container.elems nl) -{- | Compute a new version of a cluster given a solution. +{-| Compute a new version of a cluster given a solution. This is not used for computing the solutions, but for applying a (known-good) solution to the original cluster for final display. @@ -148,7 +220,7 @@ It first removes the relocated instances after which it places them on their new nodes. -} -applySolution :: NodeList -> InstanceList -> [Placement] -> NodeList +applySolution :: Node.List -> Instance.List -> [Placement] -> Node.List applySolution nl il sol = let odxes = map (\ (a, b, c, _) -> (Container.find a il, Node.idx (Container.find b nl), @@ -164,9 +236,9 @@ applySolution nl il sol = ) nc odxes --- First phase functions +-- ** First phase functions -{- | Given a list 1,2,3..n build a list of pairs [(1, [2..n]), (2, +{-| Given a list 1,2,3..n build a list of pairs [(1, [2..n]), (2, [3..n]), ...] -} @@ -193,32 +265,14 @@ genNames count1 names1 = in aux_fn count1 names1 [] -{- | Computes the pair of bad nodes and instances. - -The bad node list is computed via a simple 'verifyN1' check, and the -bad instance list is the list of primary and secondary instances of -those nodes. - --} -computeBadItems :: NodeList -> InstanceList -> - ([Node.Node], [Instance.Instance]) -computeBadItems nl il = - let bad_nodes = verifyN1 $ filter (not . Node.offline) $ Container.elems nl - bad_instances = map (\idx -> Container.find idx il) $ - sort $ nub $ concat $ - map (\ n -> (Node.slist n) ++ (Node.plist n)) bad_nodes - in - (bad_nodes, bad_instances) - - -{- | Checks if removal of instances results in N+1 pass. +{-| Checks if removal of instances results in N+1 pass. Note: the check removal cannot optimize by scanning only the affected nodes, since the cluster is known to be not healthy; only the check placement can make this shortcut. -} -checkRemoval :: NodeList -> [Instance.Instance] -> Maybe Removal +checkRemoval :: Node.List -> [Instance.Instance] -> Maybe Removal checkRemoval nl victims = let nx = removeInstances nl victims failN1 = verifyN1Check (Container.elems nx) @@ -229,40 +283,34 @@ checkRemoval nl victims = Just $ Removal nx victims --- | Computes the removals list for a given depth -computeRemovals :: NodeList +-- | Computes the removals list for a given depth. +computeRemovals :: Node.List -> [Instance.Instance] -> Int -> [Maybe Removal] computeRemovals nl bad_instances depth = map (checkRemoval nl) $ genNames depth bad_instances --- Second phase functions +-- ** Second phase functions --- | Single-node relocation cost -nodeDelta :: Int -> Int -> Int -> Int +-- | Single-node relocation cost. +nodeDelta :: Ndx -> Ndx -> Ndx -> Int nodeDelta i p s = if i == p || i == s then 0 else 1 -{-| Compute best solution. - - This function compares two solutions, choosing the minimum valid - solution. --} +-- | Compute best solution. +-- +-- This function compares two solutions, choosing the minimum valid +-- solution. compareSolutions :: Maybe Solution -> Maybe Solution -> Maybe Solution compareSolutions a b = case (a, b) of (Nothing, x) -> x (x, Nothing) -> x (x, y) -> min x y --- | Compute best table. Note that the ordering of the arguments is important. -compareTables :: Table -> Table -> Table -compareTables a@(Table _ _ a_cv _) b@(Table _ _ b_cv _ ) = - if a_cv > b_cv then b else a - -- | Check if a given delta is worse then an existing solution. tooHighDelta :: Maybe Solution -> Int -> Int -> Bool tooHighDelta sol new_delta max_delta = @@ -281,7 +329,7 @@ tooHighDelta sol new_delta max_delta = solution by recursing until all target instances are placed. -} -checkPlacement :: NodeList -- ^ The current node list +checkPlacement :: Node.List -- ^ The current node list -> [Instance.Instance] -- ^ List of instances still to place -> [Placement] -- ^ Partial solution until now -> Int -- ^ The delta of the partial solution @@ -333,9 +381,68 @@ checkPlacement nl victims current current_delta prev_sol max_delta = ) accu_p nodes ) prev_sol nodes --- | Apply a move -applyMove :: NodeList -> Instance.Instance - -> IMove -> (Maybe NodeList, Instance.Instance, Int, Int) +{-| Auxiliary function for solution computation. + +We write this in an explicit recursive fashion in order to control +early-abort in case we have met the min delta. We can't use foldr +instead of explicit recursion since we need the accumulator for the +abort decision. + +-} +advanceSolution :: [Maybe Removal] -- ^ The removal to process + -> Int -- ^ Minimum delta parameter + -> Int -- ^ Maximum delta parameter + -> Maybe Solution -- ^ Current best solution + -> Maybe Solution -- ^ New best solution +advanceSolution [] _ _ sol = sol +advanceSolution (Nothing:xs) m n sol = advanceSolution xs m n sol +advanceSolution ((Just (Removal nx removed)):xs) min_d max_d prev_sol = + let new_sol = checkPlacement nx removed [] 0 prev_sol max_d + new_delta = solutionDelta $! new_sol + in + if new_delta >= 0 && new_delta <= min_d then + new_sol + else + advanceSolution xs min_d max_d new_sol + +-- | Computes the placement solution. +solutionFromRemovals :: [Maybe Removal] -- ^ The list of (possible) removals + -> Int -- ^ Minimum delta parameter + -> Int -- ^ Maximum delta parameter + -> Maybe Solution -- ^ The best solution found +solutionFromRemovals removals min_delta max_delta = + advanceSolution removals min_delta max_delta Nothing + +{-| Computes the solution at the given depth. + +This is a wrapper over both computeRemovals and +solutionFromRemovals. In case we have no solution, we return Nothing. + +-} +computeSolution :: Node.List -- ^ The original node data + -> [Instance.Instance] -- ^ The list of /bad/ instances + -> Int -- ^ The /depth/ of removals + -> Int -- ^ Maximum number of removals to process + -> Int -- ^ Minimum delta parameter + -> Int -- ^ Maximum delta parameter + -> Maybe Solution -- ^ The best solution found (or Nothing) +computeSolution nl bad_instances depth max_removals min_delta max_delta = + let + removals = computeRemovals nl bad_instances depth + removals' = capRemovals removals max_removals + in + solutionFromRemovals removals' min_delta max_delta + +-- * hbal functions + +-- | Compute best table. Note that the ordering of the arguments is important. +compareTables :: Table -> Table -> Table +compareTables a@(Table _ _ a_cv _) b@(Table _ _ b_cv _ ) = + if a_cv > b_cv then b else a + +-- | Applies an instance move to a given node list and instance. +applyMove :: Node.List -> Instance.Instance + -> IMove -> (Maybe Node.List, Instance.Instance, Ndx, Ndx) -- Failover (f) applyMove nl inst Failover = let old_pdx = Instance.pnode inst @@ -360,8 +467,12 @@ applyMove nl inst (ReplacePrimary new_pdx) = int_p = Node.removePri old_p inst int_s = Node.removeSec old_s inst new_nl = do -- Maybe monad + -- check that the current secondary can host the instance + -- during the migration + tmp_s <- Node.addPri int_s inst + let tmp_s' = Node.removePri tmp_s inst new_p <- Node.addPri tgt_n inst - new_s <- Node.addSec int_s inst new_pdx + new_s <- Node.addSec tmp_s' inst new_pdx return $ Container.add new_pdx new_p $ Container.addTwo old_pdx int_p old_sdx new_s nl in (new_nl, Instance.setPri inst new_pdx, new_pdx, old_sdx) @@ -410,6 +521,29 @@ applyMove nl inst (FailoverAndReplace new_sdx) = Container.addTwo old_sdx new_p old_pdx int_p nl in (new_nl, Instance.setBoth inst old_sdx new_sdx, old_sdx, new_sdx) +-- | Tries to allocate an instance on one given node. +allocateOnSingle :: Node.List -> Instance.Instance -> Node.Node + -> (Maybe Node.List, Instance.Instance) +allocateOnSingle nl inst p = + let new_pdx = Node.idx p + new_nl = Node.addPri p inst >>= \new_p -> + return $ Container.add new_pdx new_p nl + in (new_nl, Instance.setBoth inst new_pdx Node.noSecondary) + +-- | Tries to allocate an instance on a given pair of nodes. +allocateOnPair :: Node.List -> Instance.Instance -> Node.Node -> Node.Node + -> (Maybe Node.List, Instance.Instance) +allocateOnPair nl inst tgt_p tgt_s = + let new_pdx = Node.idx tgt_p + new_sdx = Node.idx tgt_s + new_nl = do -- Maybe monad + new_p <- Node.addPri tgt_p inst + new_s <- Node.addSec tgt_s inst new_pdx + return $ Container.addTwo new_pdx new_p new_sdx new_s nl + in (new_nl, Instance.setBoth inst new_pdx new_sdx) + +-- | Tries to perform an instance move and returns the best table +-- between the original one and the new one. checkSingleStep :: Table -- ^ The original table -> Instance.Instance -- ^ The instance to move -> Table -- ^ The current best table @@ -434,7 +568,7 @@ checkSingleStep ini_tbl target cur_tbl move = -- | Given the status of the current secondary as a valid new node -- and the current candidate target node, -- generate the possible moves for a instance. -possibleMoves :: Bool -> Int -> [IMove] +possibleMoves :: Bool -> Ndx -> [IMove] possibleMoves True tdx = [ReplaceSecondary tdx, ReplaceAndFailover tdx, @@ -446,7 +580,7 @@ possibleMoves False tdx = ReplaceAndFailover tdx] -- | Compute the best move for a given instance. -checkInstanceMove :: [Int] -- Allowed target node indices +checkInstanceMove :: [Ndx] -- Allowed target node indices -> Table -- Original table -> Instance.Instance -- Instance to move -> Table -- Best new table for this instance @@ -465,7 +599,7 @@ checkInstanceMove nodes_idx ini_tbl target = foldl' (checkSingleStep ini_tbl target) aft_failover all_moves -- | Compute the best next move. -checkMove :: [Int] -- ^ Allowed target node indices +checkMove :: [Ndx] -- ^ Allowed target node indices -> Table -- ^ The current solution -> [Instance.Instance] -- ^ List of instances still to move -> Table -- ^ The new solution @@ -474,8 +608,10 @@ checkMove nodes_idx ini_tbl victims = -- iterate over all instances, computing the best move best_tbl = foldl' - (\ step_tbl elem -> compareTables step_tbl $ - checkInstanceMove nodes_idx ini_tbl elem) + (\ step_tbl elem -> + if Instance.snode elem == Node.noSecondary then step_tbl + else compareTables step_tbl $ + checkInstanceMove nodes_idx ini_tbl elem) ini_tbl victims Table _ _ _ best_plc = best_tbl in @@ -484,59 +620,62 @@ checkMove nodes_idx ini_tbl victims = else best_tbl -{- | Auxiliary function for solution computation. - -We write this in an explicit recursive fashion in order to control -early-abort in case we have met the min delta. We can't use foldr -instead of explicit recursion since we need the accumulator for the -abort decision. - --} -advanceSolution :: [Maybe Removal] -- ^ The removal to process - -> Int -- ^ Minimum delta parameter - -> Int -- ^ Maximum delta parameter - -> Maybe Solution -- ^ Current best solution - -> Maybe Solution -- ^ New best solution -advanceSolution [] _ _ sol = sol -advanceSolution (Nothing:xs) m n sol = advanceSolution xs m n sol -advanceSolution ((Just (Removal nx removed)):xs) min_d max_d prev_sol = - let new_sol = checkPlacement nx removed [] 0 prev_sol max_d - new_delta = solutionDelta $! new_sol - in - if new_delta >= 0 && new_delta <= min_d then - new_sol - else - advanceSolution xs min_d max_d new_sol - --- | Computes the placement solution. -solutionFromRemovals :: [Maybe Removal] -- ^ The list of (possible) removals - -> Int -- ^ Minimum delta parameter - -> Int -- ^ Maximum delta parameter - -> Maybe Solution -- ^ The best solution found -solutionFromRemovals removals min_delta max_delta = - advanceSolution removals min_delta max_delta Nothing - -{- | Computes the solution at the given depth. - -This is a wrapper over both computeRemovals and -solutionFromRemovals. In case we have no solution, we return Nothing. - --} -computeSolution :: NodeList -- ^ The original node data - -> [Instance.Instance] -- ^ The list of /bad/ instances - -> Int -- ^ The /depth/ of removals - -> Int -- ^ Maximum number of removals to process - -> Int -- ^ Minimum delta parameter - -> Int -- ^ Maximum delta parameter - -> Maybe Solution -- ^ The best solution found (or Nothing) -computeSolution nl bad_instances depth max_removals min_delta max_delta = - let - removals = computeRemovals nl bad_instances depth - removals' = capRemovals removals max_removals - in - solutionFromRemovals removals' min_delta max_delta - --- Solution display functions (pure) +-- * Alocation functions + +-- | Try to allocate an instance on the cluster. +tryAlloc :: (Monad m) => + Node.List -- ^ The node list + -> 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 +tryAlloc nl _ inst 2 = + let all_nodes = getOnline nl + all_pairs = liftM2 (,) all_nodes all_nodes + ok_pairs = filter (\(x, y) -> Node.idx x /= Node.idx y) all_pairs + sols = map (\(p, s) -> let (mnl, i) = allocateOnPair nl inst p s + in (mnl, i, [p, s])) + ok_pairs + in return sols + +tryAlloc nl _ inst 1 = + let all_nodes = getOnline nl + sols = map (\p -> let (mnl, i) = allocateOnSingle nl inst p + in (mnl, i, [p])) + all_nodes + in return sols + +tryAlloc _ _ _ reqn = fail $ "Unsupported number of alllocation \ + \destinations required (" ++ (show reqn) ++ + "), only two supported" + +-- | 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 +tryReloc nl il xid 1 ex_idx = + let all_nodes = getOnline nl + inst = Container.find xid il + ex_idx' = (Instance.pnode inst):ex_idx + valid_nodes = filter (not . flip elem ex_idx' . Node.idx) all_nodes + valid_idxes = map Node.idx valid_nodes + sols1 = map (\x -> let (mnl, i, _, _) = + applyMove nl inst (ReplaceSecondary x) + in (mnl, i, [Container.find x nl]) + ) valid_idxes + in return sols1 + +tryReloc _ _ _ reqn _ = fail $ "Unsupported number of relocation \ + \destinations required (" ++ (show reqn) ++ + "), only one supported" + +-- * Formatting functions -- | Given the original and final nodes, computes the relocation description. computeMoves :: String -- ^ The instance name @@ -582,25 +721,25 @@ computeMoves i a b c d = printf "migrate -f %s" i, printf "replace-disks -n %s %s" d i]) -{-| Converts a placement to string format -} -printSolutionLine :: InstanceList - -> NameList - -> NameList - -> Int - -> Int - -> Placement - -> Int - -> (String, [String]) -printSolutionLine il ktn kti nmlen imlen plc pos = +-- | Converts a placement to string format. +printSolutionLine :: Node.List -- ^ The node list + -> Instance.List -- ^ The instance list + -> Int -- ^ Maximum node name length + -> Int -- ^ Maximum instance name length + -> Placement -- ^ The current placement + -> Int -- ^ The index of the placement in + -- the solution + -> (String, [String]) +printSolutionLine nl il nmlen imlen plc pos = let pmlen = (2*nmlen + 1) (i, p, s, c) = plc inst = Container.find i il - inam = fromJust $ lookup (Instance.idx inst) kti - npri = fromJust $ lookup p ktn - nsec = fromJust $ lookup s ktn - opri = fromJust $ lookup (Instance.pnode inst) ktn - osec = fromJust $ lookup (Instance.snode inst) ktn + inam = Instance.name inst + npri = Container.nameOf nl p + nsec = Container.nameOf nl s + opri = Container.nameOf nl $ Instance.pnode inst + osec = Container.nameOf nl $ Instance.snode inst (moves, cmds) = computeMoves inam opri osec npri nsec ostr = (printf "%s:%s" opri osec)::String nstr = (printf "%s:%s" npri nsec)::String @@ -610,6 +749,8 @@ printSolutionLine il ktn kti nmlen imlen plc pos = pmlen nstr c moves, cmds) +-- | Given a list of commands, prefix them with @gnt-instance@ and +-- also beautify the display a little. formatCmds :: [[String]] -> String formatCmds cmd_strs = unlines $ @@ -619,210 +760,36 @@ formatCmds cmd_strs = (map ("gnt-instance " ++) b)) $ zip [1..] cmd_strs -{-| Converts a solution to string format -} -printSolution :: InstanceList - -> NameList - -> NameList +-- | Converts a solution to string format. +printSolution :: Node.List + -> Instance.List -> [Placement] -> ([String], [[String]]) -printSolution il ktn kti sol = +printSolution nl il sol = let - mlen_fn = maximum . (map length) . snd . unzip - imlen = mlen_fn kti - nmlen = mlen_fn ktn + nmlen = Container.maxNameLen nl + imlen = Container.maxNameLen il in - unzip $ map (uncurry $ printSolutionLine il ktn kti nmlen imlen) $ + unzip $ map (uncurry $ printSolutionLine nl il nmlen imlen) $ zip sol [1..] -- | Print the node list. -printNodes :: NameList -> NodeList -> String -printNodes ktn nl = +printNodes :: Node.List -> String +printNodes nl = let snl = sortBy (compare `on` Node.idx) (Container.elems nl) - snl' = map (\ n -> ((fromJust $ lookup (Node.idx n) ktn), n)) snl - m_name = maximum . (map length) . fst . unzip $ snl' + 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 %3s %3s %7s %7s" + "%2s %-*s %5s %5s %5s %5s %5s %5s %5s %5s %3s %3s %7s %7s %7s" " F" m_name "Name" "t_mem" "n_mem" "i_mem" "x_mem" "f_mem" "r_mem" "t_dsk" "f_dsk" - "pri" "sec" "p_fmem" "p_fdsk" - in unlines $ (header:map (uncurry helper) snl') + "pri" "sec" "p_fmem" "p_fdsk" "r_cpu" + in unlines $ (header:map helper snl) --- | Compute the mem and disk covariance. -compDetailedCV :: NodeList -> (Double, Double, Double, Double, Double) -compDetailedCV nl = - let - all_nodes = Container.elems nl - (offline, nodes) = partition Node.offline all_nodes - mem_l = map Node.p_mem nodes - dsk_l = map Node.p_dsk nodes - 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) - 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) - in (mem_cv, dsk_cv, n1_score, res_cv, off_score) - --- | Compute the 'total' variance. -compCV :: NodeList -> Double -compCV nl = - let (mem_cv, dsk_cv, n1_score, res_cv, off_score) = compDetailedCV nl - in mem_cv + dsk_cv + n1_score + res_cv + off_score - -printStats :: NodeList -> String +-- | Shows statistics for a given node list. +printStats :: Node.List -> String printStats nl = let (mem_cv, dsk_cv, n1_score, res_cv, off_score) = compDetailedCV nl in printf "f_mem=%.8f, r_mem=%.8f, f_dsk=%.8f, n1=%.3f, uf=%.3f" mem_cv res_cv dsk_cv n1_score off_score - --- Balancing functions - --- Loading functions - -{- | Convert newline and delimiter-separated text. - -This function converts a text in tabular format as generated by -@gnt-instance list@ and @gnt-node list@ to a list of objects using a -supplied conversion function. - --} -loadTabular :: String -> ([String] -> (String, a)) - -> (a -> Int -> a) -> ([(String, Int)], [(Int, a)]) -loadTabular text_data convert_fn set_fn = - let lines_data = lines text_data - rows = map (sepSplit '|') lines_data - kerows = (map convert_fn rows) - idxrows = map (\ (idx, (k, v)) -> ((k, idx), (idx, set_fn v idx))) - (zip [0..] kerows) - in unzip idxrows - --- | For each instance, add its index to its primary and secondary nodes -fixNodes :: [(Int, Node.Node)] - -> [(Int, Instance.Instance)] - -> [(Int, 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 - sold = fromJust $ lookup sdx accu - pnew = Node.setPri pold idx - snew = Node.setSec sold idx - ac1 = deleteBy assocEqual (pdx, pold) accu - ac2 = deleteBy assocEqual (sdx, sold) ac1 - ac3 = (pdx, pnew):(sdx, snew):ac2 - in ac3) nl il - --- | Compute the longest common suffix of a NameList list that --- | starts with a dot -longestDomain :: NameList -> String -longestDomain [] = "" -longestDomain ((_,x):xs) = - let - onlyStrings = snd $ unzip xs - in - foldr (\ suffix accu -> if all (isSuffixOf suffix) onlyStrings - then suffix - else accu) - "" $ filter (isPrefixOf ".") (tails x) - --- | Remove tails from the (Int, String) lists -stripSuffix :: String -> NameList -> NameList -stripSuffix suffix lst = - let sflen = length suffix in - map (\ (key, name) -> (key, take ((length name) - sflen) name)) lst - -{-| Initializer function that loads the data from a node and list file - and massages it into the correct format. -} -loadData :: String -- ^ Node data in text format - -> String -- ^ Instance data in text format - -> Result (Container.Container Node.Node, - Container.Container Instance.Instance, - String, NameList, NameList) -loadData ndata idata = - let - {- node file: name t_mem n_mem f_mem t_disk f_disk -} - (ktn, nl) = loadTabular ndata - (\ (name:tm:nm:fm:td:fd:fo:[]) -> - (name, - if any (== "?") [tm,nm,fm,td,fd] || fo == "Y" then - Node.create 0 0 0 0 0 True - else - Node.create (read tm) (read nm) (read fm) - (read td) (read fd) False - )) - Node.setIdx - {- instance file: name mem disk status pnode snode -} - (kti, il) = loadTabular idata - (\ (name:mem:dsk:status:pnode:snode:[]) -> - (name, - Instance.create (read mem) (read dsk) - status - (fromJust $ lookup pnode ktn) - (fromJust $ lookup snode ktn))) - Instance.setIdx - nl2 = fixNodes nl il - il3 = Container.fromAssocList il - nl3 = Container.fromAssocList - (map (\ (k, v) -> (k, Node.buildPeers v il3 (length nl2))) nl2) - xtn = swapPairs ktn - xti = swapPairs kti - common_suffix = longestDomain (xti ++ xtn) - stn = stripSuffix common_suffix xtn - sti = stripSuffix common_suffix xti - in - Ok (nl3, il3, common_suffix, stn, sti) - --- | Compute the amount of memory used by primary instances on a node. -nodeImem :: Node.Node -> InstanceList -> Int -nodeImem node il = - let rfind = flip Container.find $ il - in sum . map Instance.mem . - map rfind $ Node.plist node - --- | Compute the amount of disk used by instances on a node (either primary --- or secondary). -nodeIdsk :: Node.Node -> InstanceList -> Int -nodeIdsk node il = - let rfind = flip Container.find $ il - in sum . map Instance.dsk . - map rfind $ (Node.plist node) ++ (Node.slist node) - - --- | Check cluster data for consistency -checkData :: NodeList -> InstanceList -> NameList -> NameList - -> ([String], NodeList) -checkData nl il ktn _ = - Container.mapAccum - (\ msgs node -> - let nname = fromJust $ lookup (Node.idx node) ktn - nilst = map (flip Container.find $ il) (Node.plist node) - dilst = filter (not . Instance.running) nilst - adj_mem = sum . map Instance.mem $ dilst - delta_mem = (truncate $ Node.t_mem node) - - (Node.n_mem node) - - (Node.f_mem node) - - (nodeImem node il) - + adj_mem - delta_dsk = (truncate $ Node.t_dsk node) - - (Node.f_dsk node) - - (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 [] - in (msgs ++ umsg1, newn) - ) [] nl