) where
import Control.Applicative
+import Control.Arrow
import Control.Monad
+import Data.Function
import Data.List
import Data.Ord
+import Text.Printf
import qualified Data.IntMap as IntMap
import qualified Ganeti.HTools.Container as Container
import qualified Ganeti.HTools.Node as Node
+import qualified Ganeti.HTools.Instance as Instance
import qualified Ganeti.HTools.Group as Group
+import Ganeti.BasicTypes
import Ganeti.Common
import Ganeti.HTools.CLI
import Ganeti.HTools.ExtLoader
import Ganeti.HTools.Graph
import Ganeti.HTools.Loader
+import Ganeti.HTools.Types
import Ganeti.Utils
-- | Options list and functions.
, oDataFile
, oIAllocSrc
, oOfflineNode
+ , oOfflineMaintenance
, oVerbose
, oQuiet
, oNoHeaders
, oNodeTags
, oSaveCluster
, oGroup
+ , oPrintMoves
+ , oSkipNonRedundant
+ , oIgnoreNonRedundant
, oForce
+ , oOneStepOnly
]
-- | The list of arguments supported by the program.
arguments :: [ArgCompletion]
arguments = []
+-- | Compute the result of moving an instance to a different node.
+move :: Idx -> Ndx -> (Node.List, Instance.List)
+ -> OpResult (Node.List, Instance.List)
+move idx new_ndx (nl, il) = do
+ let new_node = Container.find new_ndx nl
+ inst = Container.find idx il
+ old_ndx = Instance.pNode inst
+ old_node = Container.find old_ndx nl
+ new_node' <- Node.addPriEx True new_node inst
+ let old_node' = Node.removePri old_node inst
+ inst' = Instance.setPri inst new_ndx
+ nl' = Container.addTwo old_ndx old_node' new_ndx new_node' nl
+ il' = Container.add idx inst' il
+ return (nl', il')
+
+-- | Move an instance to one of the candidate nodes mentioned.
+locateInstance :: Idx -> [Ndx] -> (Node.List, Instance.List)
+ -> Result (Node.List, Instance.List)
+locateInstance idx ndxs conf =
+ msum $ map (opToResult . flip (move idx) conf) ndxs
+
+-- | Move a list of instances to some of the candidate nodes mentioned.
+locateInstances :: [Idx] -> [Ndx] -> (Node.List, Instance.List)
+ -> Result (Node.List, Instance.List)
+locateInstances idxs ndxs conf =
+ foldM (\ cf idx -> locateInstance idx ndxs cf) conf idxs
+
+-- | Greedily move the non-redundant instances away from a list of nodes.
+-- The arguments are the list of nodes to be cleared, a list of nodes the
+-- instances can be moved to, and an initial configuration. Returned is a
+-- list of nodes that can be cleared simultaneously and the configuration
+-- after these nodes are cleared.
+clearNodes :: [Ndx] -> [Ndx] -> (Node.List, Instance.List)
+ -> Result ([Ndx], (Node.List, Instance.List))
+clearNodes [] _ conf = return ([], conf)
+clearNodes (ndx:ndxs) targets conf@(nl, _) =
+ withFirst `mplus` withoutFirst where
+ withFirst = do
+ let othernodes = delete ndx targets
+ grp = Node.group $ Container.find ndx nl
+ othernodesSameGroup =
+ filter ((==) grp . Node.group . flip Container.find nl) othernodes
+ conf' <- locateInstances (nonRedundant conf ndx) othernodesSameGroup conf
+ (ndxs', conf'') <- clearNodes ndxs othernodes conf'
+ return (ndx:ndxs', conf'')
+ withoutFirst = clearNodes ndxs targets conf
+
+-- | Parition a list of nodes into chunks according cluster capacity.
+partitionNonRedundant :: [Ndx] -> [Ndx] -> (Node.List, Instance.List)
+ -> Result [([Ndx], (Node.List, Instance.List))]
+partitionNonRedundant [] _ _ = return []
+partitionNonRedundant ndxs targets conf = do
+ (grp, conf') <- clearNodes ndxs targets conf
+ guard . not . null $ grp
+ let remaining = ndxs \\ grp
+ part <- partitionNonRedundant remaining targets conf
+ return $ (grp, conf') : part
+
-- | Gather statistics for the coloring algorithms.
-- Returns a string with a summary on how each algorithm has performed,
-- in order of non-decreasing effectiveness, and whether it tied or lost
-- | Predicate of belonging to a given group restriction.
hasGroup :: Maybe Group.Group -> Node.Node -> Bool
hasGroup Nothing _ = True
-hasGroup (Just grp) node = Node.group node == Group.idx grp
+hasGroup (Just grp) node = Node.group node == Group.idx grp
-- | Predicate of having at least one tag in a given set.
hasTag :: Maybe [String] -> Node.Node -> Bool
hasTag Nothing _ = True
hasTag (Just tags) node = not . null $ Node.nTags node `intersect` tags
+-- | From a cluster configuration, get the list of non-redundant instances
+-- of a node.
+nonRedundant :: (Node.List, Instance.List) -> Ndx -> [Idx]
+nonRedundant (nl, il) ndx =
+ filter (not . Instance.hasSecondary . flip Container.find il) $
+ Node.pList (Container.find ndx nl)
+
+-- | Within a cluster configuration, decide if the node hosts non-redundant
+-- Instances.
+noNonRedundant :: (Node.List, Instance.List) -> Node.Node -> Bool
+noNonRedundant conf = null . nonRedundant conf . Node.idx
+
-- | Put the master node last.
--- Reorder a list of lists of nodes such that the master node (if present)
--- is the last node of the last group.
-masterLast :: [[Node.Node]] -> [[Node.Node]]
+-- Reorder a list groups of nodes (with additional information) such that the
+-- master node (if present) is the last node of the last group.
+masterLast :: [([Node.Node], a)] -> [([Node.Node], a)]
masterLast rebootgroups =
- map (uncurry (++)) . uncurry (++) . partition (null . snd) $
- map (partition (not . Node.isMaster)) rebootgroups
+ map (first $ uncurry (++)) . uncurry (++) . partition (null . snd . fst) $
+ map (first $ partition (not . Node.isMaster)) rebootgroups
+
+-- | From two configurations compute the list of moved instances.
+getMoves :: (Node.List, Instance.List) -> (Node.List, Instance.List)
+ -> [(Instance.Instance, Node.Node)]
+getMoves (_, il) (nl', il') = do
+ ix <- Container.keys il
+ let inst = Container.find ix il
+ inst' = Container.find ix il'
+ guard $ Instance.pNode inst /= Instance.pNode inst'
+ return (inst', Container.find (Instance.pNode inst') nl')
-- | Main function.
main :: Options -> [String] -> IO ()
Just grp -> return (Just grp)
let nodes = IntMap.filter (foldl (liftA2 (&&)) (const True)
- [ (not . Node.offline)
- , (hasTag $ optNodeTags opts)
+ [ not . Node.offline
+ , if optSkipNonRedundant opts
+ then noNonRedundant (nlf, ilf)
+ else const True
+ , hasTag $ optNodeTags opts
, hasGroup wantedGroup ])
nlf
+ mkGraph = if optOfflineMaintenance opts
+ then Node.mkNodeGraph
+ else Node.mkRebootNodeGraph nlf
- -- TODO: fail if instances are running (with option to warn only)
-
- nodeGraph <- case Node.mkNodeGraph nodes ilf of
+ nodeGraph <- case mkGraph nodes ilf of
Nothing -> exitErr "Cannot create node graph"
Just g -> return g
, ("Dcolor", colorDcolor)
]
colorings = map (\(v,a) -> (v,(colorVertMap.a) nodeGraph)) colorAlgorithms
- smallestColoring =
+ smallestColoring = IntMap.elems $
(snd . minimumBy (comparing (IntMap.size . snd))) colorings
- idToNode = (`Container.find` nodes)
+ allNdx = map Node.idx $ Container.elems nlf
+ splitted = mapM (\ grp -> partitionNonRedundant grp allNdx (nlf,ilf))
+ smallestColoring
+ rebootGroups <- if optIgnoreNonRedundant opts
+ then return $ zip smallestColoring (repeat (nlf, ilf))
+ else case splitted of
+ Ok splitgroups -> return $ concat splitgroups
+ Bad _ -> exitErr "Not enough capacity to move\
+ \ non-redundant instances"
+ let idToNode = (`Container.find` nodes)
nodesRebootGroups =
- map (map idToNode . filter (`IntMap.member` nodes)) $
- IntMap.elems smallestColoring
- outputRebootGroups = masterLast nodesRebootGroups
- outputRebootNames = map (map Node.name) outputRebootGroups
+ map (first $ map idToNode . filter (`IntMap.member` nodes)) rebootGroups
+ outputRebootGroups = masterLast .
+ sortBy (flip compare `on` length . fst) $
+ nodesRebootGroups
+ confToMoveNames = map (Instance.name *** Node.name) . getMoves (nlf, ilf)
+ namesAndMoves = map (map Node.name *** confToMoveNames) outputRebootGroups
when (verbose > 1) . putStrLn $ getStats colorings
- unless (optNoHeaders opts) $
- putStrLn "'Node Reboot Groups'"
- mapM_ (putStrLn . commaJoin) outputRebootNames
+ let showGroup = if optOneStepOnly opts
+ then mapM_ putStrLn
+ else putStrLn . commaJoin
+ showMoves :: [(String, String)] -> IO ()
+ showMoves = if optPrintMoves opts
+ then mapM_ $ putStrLn . uncurry (printf " %s %s")
+ else const $ return ()
+ showBoth = liftM2 (>>) (showGroup . fst) (showMoves . snd)
+
+
+ if optOneStepOnly opts
+ then do
+ unless (optNoHeaders opts) $
+ putStrLn "'First Reboot Group'"
+ case namesAndMoves of
+ [] -> return ()
+ y : _ -> showBoth y
+ else do
+ unless (optNoHeaders opts) $
+ putStrLn "'Node Reboot Groups'"
+ mapM_ showBoth namesAndMoves
projects / ganeti-local / blobdiff