X-Git-Url: https://code.grnet.gr/git/ganeti-local/blobdiff_plain/1977763827b865f098a573b48459ddaaf882890e..608efcce95d93c1228f526c5f3ed192650b6f2b7:/Ganeti/HTools/Cluster.hs diff --git a/Ganeti/HTools/Cluster.hs b/Ganeti/HTools/Cluster.hs index b44cc3b..1bf6524 100644 --- a/Ganeti/HTools/Cluster.hs +++ b/Ganeti/HTools/Cluster.hs @@ -8,12 +8,13 @@ goes into the "Main" module for the individual binaries. module Ganeti.HTools.Cluster ( -- * Types - NodeList - , InstanceList + NameList , Placement , Solution(..) , Table(..) , Removal + , Score + , IMove(..) -- * Generic functions , totalResources -- * First phase functions @@ -26,30 +27,32 @@ module Ganeti.HTools.Cluster , formatCmds , printNodes -- * Balacing functions + , applyMove , checkMove , compCV , printStats - -- * Loading functions - , loadData + -- * IAllocator functions + , allocateOnSingle + , allocateOnPair ) 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 -- | 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. @@ -65,18 +68,18 @@ solutionDelta sol = case sol of _ -> -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 @@ -98,8 +101,8 @@ 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 +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 @@ -111,7 +114,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 @@ -123,7 +126,7 @@ 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. @@ -143,7 +146,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), @@ -195,10 +198,10 @@ bad instance list is the list of primary and secondary instances of those nodes. -} -computeBadItems :: NodeList -> InstanceList -> +computeBadItems :: Node.List -> Instance.List -> ([Node.Node], [Instance.Instance]) computeBadItems nl il = - let bad_nodes = verifyN1 $ Container.elems nl + 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 @@ -213,7 +216,7 @@ 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) @@ -225,7 +228,7 @@ checkRemoval nl victims = -- | Computes the removals list for a given depth -computeRemovals :: NodeList +computeRemovals :: Node.List -> [Instance.Instance] -> Int -> [Maybe Removal] @@ -235,7 +238,7 @@ computeRemovals nl bad_instances depth = -- Second phase functions -- | Single-node relocation cost -nodeDelta :: Int -> Int -> Int -> Int +nodeDelta :: Ndx -> Ndx -> Ndx -> Int nodeDelta i p s = if i == p || i == s then 0 @@ -276,7 +279,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 @@ -329,8 +332,8 @@ checkPlacement nl victims current current_delta prev_sol max_delta = ) prev_sol nodes -- | Apply a move -applyMove :: NodeList -> Instance.Instance - -> IMove -> (Maybe NodeList, Instance.Instance, Int, Int) +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 @@ -339,11 +342,10 @@ applyMove nl inst Failover = old_s = Container.find old_sdx nl int_p = Node.removePri old_p inst int_s = Node.removeSec old_s inst - new_p = Node.addPri int_s inst - new_s = Node.addSec int_p inst old_sdx - new_nl = if isNothing(new_p) || isNothing(new_s) then Nothing - else Just $ Container.addTwo old_pdx (fromJust new_s) - old_sdx (fromJust new_p) nl + new_nl = do -- Maybe monad + new_p <- Node.addPri int_s inst + new_s <- Node.addSec int_p inst old_sdx + return $ Container.addTwo old_pdx new_s old_sdx new_p nl in (new_nl, Instance.setBoth inst old_sdx old_pdx, old_sdx, old_pdx) -- Replace the primary (f:, r:np, f) @@ -355,12 +357,11 @@ applyMove nl inst (ReplacePrimary new_pdx) = tgt_n = Container.find new_pdx nl int_p = Node.removePri old_p inst int_s = Node.removeSec old_s inst - new_p = Node.addPri tgt_n inst - new_s = Node.addSec int_s inst new_pdx - new_nl = if isNothing(new_p) || isNothing(new_s) then Nothing - else Just $ Container.add new_pdx (fromJust new_p) $ - Container.addTwo old_pdx int_p - old_sdx (fromJust new_s) nl + new_nl = do -- Maybe monad + new_p <- Node.addPri tgt_n inst + new_s <- Node.addSec int_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) -- Replace the secondary (r:ns) @@ -370,10 +371,9 @@ applyMove nl inst (ReplaceSecondary new_sdx) = old_s = Container.find old_sdx nl tgt_n = Container.find new_sdx nl int_s = Node.removeSec old_s inst - new_s = Node.addSec tgt_n inst old_pdx - new_nl = if isNothing(new_s) then Nothing - else Just $ Container.addTwo new_sdx (fromJust new_s) - old_sdx int_s nl + new_nl = Node.addSec tgt_n inst old_pdx >>= + \new_s -> return $ Container.addTwo new_sdx + new_s old_sdx int_s nl in (new_nl, Instance.setSec inst new_sdx, old_pdx, new_sdx) -- Replace the secondary and failover (r:np, f) @@ -385,12 +385,11 @@ applyMove nl inst (ReplaceAndFailover new_pdx) = tgt_n = Container.find new_pdx nl int_p = Node.removePri old_p inst int_s = Node.removeSec old_s inst - new_p = Node.addPri tgt_n inst - new_s = Node.addSec int_p inst new_pdx - new_nl = if isNothing(new_p) || isNothing(new_s) then Nothing - else Just $ Container.add new_pdx (fromJust new_p) $ - Container.addTwo old_pdx (fromJust new_s) - old_sdx int_s nl + new_nl = do -- Maybe monad + new_p <- Node.addPri tgt_n inst + new_s <- Node.addSec int_p inst new_pdx + return $ Container.add new_pdx new_p $ + Container.addTwo old_pdx new_s old_sdx int_s nl in (new_nl, Instance.setBoth inst new_pdx old_pdx, new_pdx, old_pdx) -- Failver and replace the secondary (f, r:ns) @@ -402,14 +401,32 @@ applyMove nl inst (FailoverAndReplace new_sdx) = tgt_n = Container.find new_sdx nl int_p = Node.removePri old_p inst int_s = Node.removeSec old_s inst - new_p = Node.addPri int_s inst - new_s = Node.addSec tgt_n inst old_sdx - new_nl = if isNothing(new_p) || isNothing(new_s) then Nothing - else Just $ Container.add new_sdx (fromJust new_s) $ - Container.addTwo old_sdx (fromJust new_p) - old_pdx int_p nl + new_nl = do -- Maybe monad + new_p <- Node.addPri int_s inst + new_s <- Node.addSec tgt_n inst old_sdx + return $ Container.add new_sdx new_s $ + 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) +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) + +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) + checkSingleStep :: Table -- ^ The original table -> Instance.Instance -- ^ The instance to move -> Table -- ^ The current best table @@ -434,7 +451,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 +463,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 +482,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 +491,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 @@ -522,7 +541,7 @@ This is a wrapper over both computeRemovals and solutionFromRemovals. In case we have no solution, we return Nothing. -} -computeSolution :: NodeList -- ^ The original node data +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 @@ -559,48 +578,47 @@ computeMoves i a b c d = else if c == b then {- Failover and ... -} if d == a then {- that's all -} - ("f", [printf "migrate %s" i]) + ("f", [printf "migrate -f %s" i]) else (printf "f r:%s" d, - [printf "migrate %s" i, + [printf "migrate -f %s" i, printf "replace-disks -n %s %s" d i]) else if d == a then {- ... and keep primary as secondary -} (printf "r:%s f" c, [printf "replace-disks -n %s %s" c i, - printf "migrate %s" i]) + printf "migrate -f %s" i]) else if d == b then {- ... keep same secondary -} (printf "f r:%s f" c, - [printf "migrate %s" i, + [printf "migrate -f %s" i, printf "replace-disks -n %s %s" c i, - printf "migrate %s" i]) + printf "migrate -f %s" i]) else {- Nothing in common -} (printf "r:%s f r:%s" c d, [printf "replace-disks -n %s %s" c i, - printf "migrate %s" i, + printf "migrate -f %s" i, printf "replace-disks -n %s %s" d i]) {-| Converts a placement to string format -} -printSolutionLine :: InstanceList - -> [(Int, String)] - -> [(Int, String)] - -> Int - -> Int - -> Placement - -> Int - -> (String, [String]) -printSolutionLine il ktn kti nmlen imlen plc pos = +printSolutionLine :: Node.List + -> Instance.List + -> Int + -> Int + -> Placement + -> Int + -> (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 @@ -612,41 +630,42 @@ printSolutionLine il ktn kti nmlen imlen plc pos = formatCmds :: [[String]] -> String formatCmds cmd_strs = - unlines $ map (" echo " ++) $ + unlines $ concat $ map (\(a, b) -> - (printf "step %d" (a::Int)):(map ("gnt-instance " ++) b)) $ + (printf "echo step %d" (a::Int)): + (printf "check"): + (map ("gnt-instance " ++) b)) $ zip [1..] cmd_strs {-| Converts a solution to string format -} -printSolution :: InstanceList - -> [(Int, String)] - -> [(Int, String)] +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 :: [(Int, String)] -> 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 %3s %3s %7s %7s" - " F" m_name "Name" "t_mem" "f_mem" "r_mem" + header = printf + "%2s %-*s %5s %5s %5s %5s %5s %5s %5s %5s %3s %3s %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') + in unlines $ (header:map helper snl) -- | Compute the mem and disk covariance. -compDetailedCV :: NodeList -> (Double, Double, Double, Double, Double) +compDetailedCV :: Node.List -> (Double, Double, Double, Double, Double) compDetailedCV nl = let all_nodes = Container.elems nl @@ -668,104 +687,13 @@ compDetailedCV nl = in (mem_cv, dsk_cv, n1_score, res_cv, off_score) -- | Compute the 'total' variance. -compCV :: NodeList -> Double +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 -printStats :: NodeList -> String +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 [(Int, String)] list that --- | starts with a dot -longestDomain :: [(Int, String)] -> 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 -> [(Int, String)] -> [(Int, String)] -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 - -> (Container.Container Node.Node, - Container.Container Instance.Instance, - String, [(Int, String)], [(Int, String)]) -loadData ndata idata = - let - {- node file: name mem disk -} - (ktn, nl) = loadTabular ndata - (\ (i:jt:jf:kt:kf:[]) -> (i, Node.create jt jf kt kf)) - Node.setIdx - {- instance file: name mem disk -} - (kti, il) = loadTabular idata - (\ (i:j:k:l:m:[]) -> (i, - Instance.create j k - (fromJust $ lookup l ktn) - (fromJust $ lookup m 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 - (nl3, il3, common_suffix, stn, sti)