Revision 30ce253e src/Ganeti/HTools/Program/Hroller.hs
| b/src/Ganeti/HTools/Program/Hroller.hs | ||
|---|---|---|
| 30 | 30 |
) where |
| 31 | 31 |
|
| 32 | 32 |
import Control.Applicative |
| 33 |
import Control.Arrow |
|
| 33 | 34 |
import Control.Monad |
| 34 | 35 |
import Data.Function |
| 35 | 36 |
import Data.List |
| 36 | 37 |
import Data.Ord |
| 38 |
import Text.Printf |
|
| 37 | 39 |
|
| 38 | 40 |
import qualified Data.IntMap as IntMap |
| 39 | 41 |
|
| ... | ... | |
| 68 | 70 |
, oNodeTags |
| 69 | 71 |
, oSaveCluster |
| 70 | 72 |
, oGroup |
| 73 |
, oPrintMoves |
|
| 71 | 74 |
, oSkipNonRedundant |
| 72 | 75 |
, oIgnoreNonRedundant |
| 73 | 76 |
, oForce |
| ... | ... | |
| 127 | 130 |
|
| 128 | 131 |
-- | Parition a list of nodes into chunks according cluster capacity. |
| 129 | 132 |
partitionNonRedundant :: [Ndx] -> [Ndx] -> (Node.List, Instance.List) |
| 130 |
-> Result [[Ndx]]
|
|
| 133 |
-> Result [([Ndx], (Node.List, Instance.List))]
|
|
| 131 | 134 |
partitionNonRedundant [] _ _ = return [] |
| 132 | 135 |
partitionNonRedundant ndxs targets conf = do |
| 133 |
(grp, _) <- clearNodes ndxs targets conf
|
|
| 136 |
(grp, conf') <- clearNodes ndxs targets conf
|
|
| 134 | 137 |
guard . not . null $ grp |
| 135 | 138 |
let remaining = ndxs \\ grp |
| 136 | 139 |
part <- partitionNonRedundant remaining targets conf |
| 137 |
return $ grp : part
|
|
| 140 |
return $ (grp, conf') : part
|
|
| 138 | 141 |
|
| 139 | 142 |
-- | Gather statistics for the coloring algorithms. |
| 140 | 143 |
-- Returns a string with a summary on how each algorithm has performed, |
| ... | ... | |
| 177 | 180 |
noNonRedundant conf = null . nonRedundant conf . Node.idx |
| 178 | 181 |
|
| 179 | 182 |
-- | Put the master node last. |
| 180 |
-- Reorder a list of lists of nodes such that the master node (if present)
|
|
| 181 |
-- is the last node of the last group. |
|
| 182 |
masterLast :: [[Node.Node]] -> [[Node.Node]]
|
|
| 183 |
-- Reorder a list groups of nodes (with additional information) such that the
|
|
| 184 |
-- master node (if present) is the last node of the last group.
|
|
| 185 |
masterLast :: [([Node.Node], a)] -> [([Node.Node], a)]
|
|
| 183 | 186 |
masterLast rebootgroups = |
| 184 |
map (uncurry (++)) . uncurry (++) . partition (null . snd) $ |
|
| 185 |
map (partition (not . Node.isMaster)) rebootgroups |
|
| 187 |
map (first $ uncurry (++)) . uncurry (++) . partition (null . snd . fst) $ |
|
| 188 |
map (first $ partition (not . Node.isMaster)) rebootgroups |
|
| 189 |
|
|
| 190 |
-- | From two configurations compute the list of moved instances. |
|
| 191 |
getMoves :: (Node.List, Instance.List) -> (Node.List, Instance.List) |
|
| 192 |
-> [(Instance.Instance, Node.Node)] |
|
| 193 |
getMoves (_, il) (nl', il') = do |
|
| 194 |
ix <- Container.keys il |
|
| 195 |
let inst = Container.find ix il |
|
| 196 |
inst' = Container.find ix il' |
|
| 197 |
guard $ Instance.pNode inst /= Instance.pNode inst' |
|
| 198 |
return (inst', Container.find (Instance.pNode inst') nl') |
|
| 186 | 199 |
|
| 187 | 200 |
-- | Main function. |
| 188 | 201 |
main :: Options -> [String] -> IO () |
| ... | ... | |
| 245 | 258 |
splitted = mapM (\ grp -> partitionNonRedundant grp allNdx (nlf,ilf)) |
| 246 | 259 |
smallestColoring |
| 247 | 260 |
rebootGroups <- if optIgnoreNonRedundant opts |
| 248 |
then return smallestColoring
|
|
| 261 |
then return $ zip smallestColoring (repeat (nlf, ilf))
|
|
| 249 | 262 |
else case splitted of |
| 250 | 263 |
Ok splitgroups -> return $ concat splitgroups |
| 251 | 264 |
Bad _ -> exitErr "Not enough capacity to move\ |
| 252 | 265 |
\ non-redundant instances" |
| 253 | 266 |
let idToNode = (`Container.find` nodes) |
| 254 | 267 |
nodesRebootGroups = |
| 255 |
map (map idToNode . filter (`IntMap.member` nodes)) rebootGroups |
|
| 268 |
map (first $ map idToNode . filter (`IntMap.member` nodes)) rebootGroups
|
|
| 256 | 269 |
outputRebootGroups = masterLast . |
| 257 |
sortBy (flip compare `on` length) $ |
|
| 270 |
sortBy (flip compare `on` length . fst) $
|
|
| 258 | 271 |
nodesRebootGroups |
| 259 |
outputRebootNames = map (map Node.name) outputRebootGroups |
|
| 272 |
confToMoveNames = map (Instance.name *** Node.name) . getMoves (nlf, ilf) |
|
| 273 |
namesAndMoves = map (map Node.name *** confToMoveNames) outputRebootGroups |
|
| 260 | 274 |
|
| 261 | 275 |
when (verbose > 1) . putStrLn $ getStats colorings |
| 262 | 276 |
|
| 277 |
let showGroup = if optOneStepOnly opts |
|
| 278 |
then mapM_ putStrLn |
|
| 279 |
else putStrLn . commaJoin |
|
| 280 |
showMoves = if optPrintMoves opts |
|
| 281 |
then mapM_ $ putStrLn . uncurry (printf " %s %s") |
|
| 282 |
else const $ return () |
|
| 283 |
showBoth = liftM2 (>>) (showGroup . fst) (showMoves . snd) |
|
| 284 |
|
|
| 285 |
|
|
| 263 | 286 |
if optOneStepOnly opts |
| 264 | 287 |
then do |
| 265 | 288 |
unless (optNoHeaders opts) $ |
| 266 | 289 |
putStrLn "'First Reboot Group'" |
| 267 |
case outputRebootNames of
|
|
| 290 |
case namesAndMoves of
|
|
| 268 | 291 |
[] -> return () |
| 269 |
y : _ -> mapM_ putStrLn y
|
|
| 292 |
y : _ -> showBoth y
|
|
| 270 | 293 |
else do |
| 271 | 294 |
unless (optNoHeaders opts) $ |
| 272 | 295 |
putStrLn "'Node Reboot Groups'" |
| 273 |
mapM_ (putStrLn . commaJoin) outputRebootNames |
|
| 296 |
mapM_ showBoth namesAndMoves |
|
Also available in: Unified diff