71 |
71 |
, oSaveCluster
|
72 |
72 |
, oGroup
|
73 |
73 |
, oPrintMoves
|
|
74 |
, oFullEvacuation
|
74 |
75 |
, oSkipNonRedundant
|
75 |
76 |
, oIgnoreNonRedundant
|
76 |
77 |
, oForce
|
... | ... | |
163 |
164 |
-> Result [([Ndx], (Node.List, Instance.List))]
|
164 |
165 |
partitionNonRedundant = partitionNodes clearNodes
|
165 |
166 |
|
|
167 |
-- | Compute the result of migrating an instance.
|
|
168 |
migrate :: Idx -> (Node.List, Instance.List)
|
|
169 |
-> OpResult (Node.List, Instance.List)
|
|
170 |
migrate idx (nl, il) = do
|
|
171 |
let inst = Container.find idx il
|
|
172 |
pdx = Instance.pNode inst
|
|
173 |
sdx = Instance.sNode inst
|
|
174 |
pNode = Container.find pdx nl
|
|
175 |
sNode = Container.find sdx nl
|
|
176 |
pNode' = Node.removePri pNode inst
|
|
177 |
sNode' = Node.removeSec sNode inst
|
|
178 |
sNode'' <- Node.addPriEx True sNode' inst
|
|
179 |
pNode'' <- Node.addSecEx True pNode' inst sdx
|
|
180 |
let inst' = Instance.setBoth inst sdx pdx
|
|
181 |
nl' = Container.addTwo pdx pNode'' sdx sNode'' nl
|
|
182 |
il' = Container.add idx inst' il
|
|
183 |
return (nl', il')
|
|
184 |
|
|
185 |
-- | Obtain the list of primaries for a given node.
|
|
186 |
-- This restricts to those instances that have a secondary node.
|
|
187 |
primaries :: (Node.List, Instance.List) -> Ndx -> [Idx]
|
|
188 |
primaries (nl, il) =
|
|
189 |
filter (Instance.hasSecondary . flip Container.find il)
|
|
190 |
. Node.pList . flip Container.find nl
|
|
191 |
|
|
192 |
-- | Migrate all instances of a given list of nodes.
|
|
193 |
-- The list of nodes is repeated as first argument in the result.
|
|
194 |
migrateOffNodes :: ([Ndx], (Node.List, Instance.List))
|
|
195 |
-> OpResult ([Ndx], (Node.List, Instance.List))
|
|
196 |
migrateOffNodes (ndxs, conf) = do
|
|
197 |
let instances = ndxs >>= primaries conf
|
|
198 |
conf' <- foldM (flip migrate) conf instances
|
|
199 |
return (ndxs, conf')
|
|
200 |
|
|
201 |
-- | Compute the result of replacing the secondary node of an instance.
|
|
202 |
replaceSecondary :: Idx -> Ndx -> (Node.List, Instance.List)
|
|
203 |
-> OpResult (Node.List, Instance.List)
|
|
204 |
replaceSecondary idx new_ndx (nl, il) = do
|
|
205 |
let new_secondary = Container.find new_ndx nl
|
|
206 |
inst = Container.find idx il
|
|
207 |
old_ndx = Instance.sNode inst
|
|
208 |
pdx = Instance.pNode inst
|
|
209 |
old_secondary = Container.find pdx nl
|
|
210 |
if pdx == new_ndx then Bad FailInternal else Ok ()
|
|
211 |
new_secondary' <- Node.addSecEx True new_secondary inst pdx
|
|
212 |
let old_secondary' = Node.removeSec old_secondary inst
|
|
213 |
inst' = Instance.setSec inst new_ndx
|
|
214 |
nl' = Container.addTwo old_ndx old_secondary' new_ndx new_secondary' nl
|
|
215 |
il' = Container.add idx inst' il
|
|
216 |
return (nl', il')
|
|
217 |
|
|
218 |
-- | Find a suitable secondary node for the given instance from a list of nodes.
|
|
219 |
findSecondary :: Idx -> [Ndx] -> (Node.List, Instance.List)
|
|
220 |
-> Result (Node.List, Instance.List)
|
|
221 |
findSecondary idx ndxs conf =
|
|
222 |
msum $ map (opToResult . flip (replaceSecondary idx) conf) ndxs
|
|
223 |
|
|
224 |
-- | Find suitable secondary nodes from the given nodes for a list of instances.
|
|
225 |
findSecondaries :: [Idx] -> [Ndx] -> (Node.List, Instance.List)
|
|
226 |
-> Result (Node.List, Instance.List)
|
|
227 |
findSecondaries idxs ndxs conf =
|
|
228 |
foldM (\ cf idx -> findSecondary idx ndxs cf) conf idxs
|
|
229 |
|
|
230 |
-- | Obtain the list of secondaries for a given node.
|
|
231 |
secondaries :: (Node.List, Instance.List) -> Ndx -> [Idx]
|
|
232 |
secondaries (nl, _) = Node.sList . flip Container.find nl
|
|
233 |
|
|
234 |
-- | Greedily move secondaries away from a list of nodes.
|
|
235 |
-- Returns a list of nodes that can be cleared simultaneously,
|
|
236 |
-- and the configuration after these nodes are cleared.
|
|
237 |
clearSecondaries :: [Ndx] -> [Ndx] -> (Node.List, Instance.List)
|
|
238 |
-> Result ([Ndx], (Node.List, Instance.List))
|
|
239 |
clearSecondaries = greedyClearNodes secondaries findSecondaries
|
|
240 |
|
|
241 |
-- | Partition a list of nodes into chunks according to the ability to find
|
|
242 |
-- suitable replacement secondary nodes.
|
|
243 |
partitionSecondaries :: [Ndx] -> [Ndx] -> (Node.List, Instance.List)
|
|
244 |
-> Result [([Ndx], (Node.List, Instance.List))]
|
|
245 |
partitionSecondaries = partitionNodes clearSecondaries
|
|
246 |
|
166 |
247 |
-- | Gather statistics for the coloring algorithms.
|
167 |
248 |
-- Returns a string with a summary on how each algorithm has performed,
|
168 |
249 |
-- in order of non-decreasing effectiveness, and whether it tied or lost
|
... | ... | |
212 |
293 |
map (first $ partition (not . Node.isMaster)) rebootgroups
|
213 |
294 |
|
214 |
295 |
-- | From two configurations compute the list of moved instances.
|
|
296 |
-- Do not show instances where only primary and secondary switched their
|
|
297 |
-- role, as here the instance is not moved in a proper sense.
|
215 |
298 |
getMoves :: (Node.List, Instance.List) -> (Node.List, Instance.List)
|
216 |
|
-> [(Instance.Instance, Node.Node)]
|
|
299 |
-> [(Instance.Instance, (Node.Node, Maybe Node.Node))]
|
217 |
300 |
getMoves (_, il) (nl', il') = do
|
218 |
301 |
ix <- Container.keys il
|
219 |
302 |
let inst = Container.find ix il
|
220 |
303 |
inst' = Container.find ix il'
|
|
304 |
hasSec = Instance.hasSecondary inst
|
221 |
305 |
guard $ Instance.pNode inst /= Instance.pNode inst'
|
222 |
|
return (inst', Container.find (Instance.pNode inst') nl')
|
|
306 |
|| (hasSec && Instance.sNode inst /= Instance.sNode inst')
|
|
307 |
guard . not $ Instance.pNode inst' == Instance.sNode inst
|
|
308 |
&& Instance.sNode inst' == Instance.pNode inst
|
|
309 |
return (inst', (Container.find (Instance.pNode inst') nl',
|
|
310 |
if hasSec
|
|
311 |
then Just $ Container.find (Instance.sNode inst') nl'
|
|
312 |
else Nothing))
|
223 |
313 |
|
224 |
314 |
-- | Main function.
|
225 |
315 |
main :: Options -> [String] -> IO ()
|
... | ... | |
286 |
376 |
Ok splitgroups -> return $ concat splitgroups
|
287 |
377 |
Bad _ -> exitErr "Not enough capacity to move\
|
288 |
378 |
\ non-redundant instances"
|
|
379 |
|
|
380 |
let migrated = mapM migrateOffNodes rebootGroups
|
|
381 |
rebootGroups' <- if not . optFullEvacuation $ opts
|
|
382 |
then return rebootGroups
|
|
383 |
else case migrated of
|
|
384 |
Ok migratedGroup -> return migratedGroup
|
|
385 |
Bad _ -> exitErr "Failed to migrate instances\
|
|
386 |
\ off nodes"
|
|
387 |
let splitted' = mapM (\(grp, conf) -> partitionSecondaries grp allNdx conf)
|
|
388 |
rebootGroups'
|
|
389 |
rebootGroups'' <- if optFullEvacuation opts
|
|
390 |
then case splitted' of
|
|
391 |
Ok splitgroups -> return $ concat splitgroups
|
|
392 |
Bad _ -> exitErr "Not enough capacity to move\
|
|
393 |
\ secondaries"
|
|
394 |
else return rebootGroups'
|
289 |
395 |
let idToNode = (`Container.find` nodes)
|
290 |
|
nodesRebootGroups =
|
291 |
|
map (first $ map idToNode . filter (`IntMap.member` nodes)) rebootGroups
|
|
396 |
nodesRebootGroups = map (first $ map idToNode
|
|
397 |
. filter (`IntMap.member` nodes))
|
|
398 |
rebootGroups''
|
292 |
399 |
outputRebootGroups = masterLast .
|
293 |
400 |
sortBy (flip compare `on` length . fst) $
|
294 |
401 |
nodesRebootGroups
|
295 |
|
confToMoveNames = map (Instance.name *** Node.name) . getMoves (nlf, ilf)
|
|
402 |
confToMoveNames =
|
|
403 |
map (Instance.name *** (Node.name *** flip (>>=) (return . Node.name)))
|
|
404 |
. getMoves (nlf, ilf)
|
296 |
405 |
namesAndMoves = map (map Node.name *** confToMoveNames) outputRebootGroups
|
297 |
406 |
|
298 |
407 |
when (verbose > 1) . putStrLn $ getStats colorings
|
... | ... | |
300 |
409 |
let showGroup = if optOneStepOnly opts
|
301 |
410 |
then mapM_ putStrLn
|
302 |
411 |
else putStrLn . commaJoin
|
303 |
|
showMoves :: [(String, String)] -> IO ()
|
|
412 |
showMoves :: [(String, (String, Maybe String))] -> IO ()
|
304 |
413 |
showMoves = if optPrintMoves opts
|
305 |
|
then mapM_ $ putStrLn . uncurry (printf " %s %s")
|
|
414 |
then mapM_ $ putStrLn . \(a,(b,c)) ->
|
|
415 |
maybe (printf " %s %s" a b)
|
|
416 |
(printf " %s %s %s" a b)
|
|
417 |
c
|
306 |
418 |
else const $ return ()
|
307 |
419 |
showBoth = liftM2 (>>) (showGroup . fst) (showMoves . snd)
|
308 |
420 |
|