1 {-| Implementation of cluster-wide logic.
3 This module holds all pure cluster-logic; I\/O related functionality
4 goes into the "Main" module for the individual binaries.
10 Copyright (C) 2009 Google Inc.
12 This program is free software; you can redistribute it and/or modify
13 it under the terms of the GNU General Public License as published by
14 the Free Software Foundation; either version 2 of the License, or
15 (at your option) any later version.
17 This program is distributed in the hope that it will be useful, but
18 WITHOUT ANY WARRANTY; without even the implied warranty of
19 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20 General Public License for more details.
22 You should have received a copy of the GNU General Public License
23 along with this program; if not, write to the Free Software
24 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
29 module Ganeti.HTools.Cluster
36 -- * Generic functions
38 , computeAllocationDelta
39 -- * First phase functions
41 -- * Second phase functions
47 -- * Display functions
50 -- * Balacing functions
57 -- * IAllocator functions
62 -- * Allocation functions
68 import Data.Ord (comparing)
69 import Text.Printf (printf)
72 import qualified Ganeti.HTools.Container as Container
73 import qualified Ganeti.HTools.Instance as Instance
74 import qualified Ganeti.HTools.Node as Node
75 import Ganeti.HTools.Types
76 import Ganeti.HTools.Utils
77 import qualified Ganeti.OpCodes as OpCodes
81 -- | Allocation\/relocation solution.
82 type AllocSolution = ([FailMode], Int, [(Score, Node.AllocElement)])
84 -- | The complete state for the balancing solution
85 data Table = Table Node.List Instance.List Score [Placement]
88 data CStats = CStats { csFmem :: Int -- ^ Cluster free mem
89 , csFdsk :: Int -- ^ Cluster free disk
90 , csAmem :: Int -- ^ Cluster allocatable mem
91 , csAdsk :: Int -- ^ Cluster allocatable disk
92 , csAcpu :: Int -- ^ Cluster allocatable cpus
93 , csMmem :: Int -- ^ Max node allocatable mem
94 , csMdsk :: Int -- ^ Max node allocatable disk
95 , csMcpu :: Int -- ^ Max node allocatable cpu
96 , csImem :: Int -- ^ Instance used mem
97 , csIdsk :: Int -- ^ Instance used disk
98 , csIcpu :: Int -- ^ Instance used cpu
99 , csTmem :: Double -- ^ Cluster total mem
100 , csTdsk :: Double -- ^ Cluster total disk
101 , csTcpu :: Double -- ^ Cluster total cpus
102 , csVcpu :: Int -- ^ Cluster virtual cpus (if
103 -- node pCpu has been set,
105 , csXmem :: Int -- ^ Unnacounted for mem
106 , csNmem :: Int -- ^ Node own memory
107 , csScore :: Score -- ^ The cluster score
108 , csNinst :: Int -- ^ The total number of instances
112 -- | Currently used, possibly to allocate, unallocable
113 type AllocStats = (RSpec, RSpec, RSpec)
115 -- * Utility functions
117 -- | Verifies the N+1 status and return the affected nodes.
118 verifyN1 :: [Node.Node] -> [Node.Node]
119 verifyN1 = filter Node.failN1
121 {-| Computes the pair of bad nodes and instances.
123 The bad node list is computed via a simple 'verifyN1' check, and the
124 bad instance list is the list of primary and secondary instances of
128 computeBadItems :: Node.List -> Instance.List ->
129 ([Node.Node], [Instance.Instance])
130 computeBadItems nl il =
131 let bad_nodes = verifyN1 $ getOnline nl
132 bad_instances = map (`Container.find` il) .
134 concatMap (\ n -> Node.sList n ++ Node.pList n) bad_nodes
136 (bad_nodes, bad_instances)
138 -- | Zero-initializer for the CStats type
139 emptyCStats :: CStats
140 emptyCStats = CStats 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
142 -- | Update stats with data from a new node
143 updateCStats :: CStats -> Node.Node -> CStats
144 updateCStats cs node =
145 let CStats { csFmem = x_fmem, csFdsk = x_fdsk,
146 csAmem = x_amem, csAcpu = x_acpu, csAdsk = x_adsk,
147 csMmem = x_mmem, csMdsk = x_mdsk, csMcpu = x_mcpu,
148 csImem = x_imem, csIdsk = x_idsk, csIcpu = x_icpu,
149 csTmem = x_tmem, csTdsk = x_tdsk, csTcpu = x_tcpu,
151 csXmem = x_xmem, csNmem = x_nmem, csNinst = x_ninst
154 inc_amem = Node.fMem node - Node.rMem node
155 inc_amem' = if inc_amem > 0 then inc_amem else 0
156 inc_adsk = Node.availDisk node
157 inc_imem = truncate (Node.tMem node) - Node.nMem node
158 - Node.xMem node - Node.fMem node
159 inc_icpu = Node.uCpu node
160 inc_idsk = truncate (Node.tDsk node) - Node.fDsk node
161 inc_vcpu = Node.hiCpu node
163 in cs { csFmem = x_fmem + Node.fMem node
164 , csFdsk = x_fdsk + Node.fDsk node
165 , csAmem = x_amem + inc_amem'
166 , csAdsk = x_adsk + inc_adsk
168 , csMmem = max x_mmem inc_amem'
169 , csMdsk = max x_mdsk inc_adsk
171 , csImem = x_imem + inc_imem
172 , csIdsk = x_idsk + inc_idsk
173 , csIcpu = x_icpu + inc_icpu
174 , csTmem = x_tmem + Node.tMem node
175 , csTdsk = x_tdsk + Node.tDsk node
176 , csTcpu = x_tcpu + Node.tCpu node
177 , csVcpu = x_vcpu + inc_vcpu
178 , csXmem = x_xmem + Node.xMem node
179 , csNmem = x_nmem + Node.nMem node
180 , csNinst = x_ninst + length (Node.pList node)
183 -- | Compute the total free disk and memory in the cluster.
184 totalResources :: Node.List -> CStats
186 let cs = foldl' updateCStats emptyCStats . Container.elems $ nl
187 in cs { csScore = compCV nl }
189 -- | Compute the delta between two cluster state.
191 -- This is used when doing allocations, to understand better the
192 -- available cluster resources. The return value is a triple of the
193 -- current used values, the delta that was still allocated, and what
194 -- was left unallocated.
195 computeAllocationDelta :: CStats -> CStats -> AllocStats
196 computeAllocationDelta cini cfin =
197 let CStats {csImem = i_imem, csIdsk = i_idsk, csIcpu = i_icpu} = cini
198 CStats {csImem = f_imem, csIdsk = f_idsk, csIcpu = f_icpu,
199 csTmem = t_mem, csTdsk = t_dsk, csVcpu = v_cpu } = cfin
200 rini = RSpec i_icpu i_imem i_idsk
201 rfin = RSpec (f_icpu - i_icpu) (f_imem - i_imem) (f_idsk - i_idsk)
202 un_cpu = v_cpu - f_icpu
203 runa = RSpec un_cpu (truncate t_mem - f_imem) (truncate t_dsk - f_idsk)
204 in (rini, rfin, runa)
206 -- | The names of the individual elements in the CV list
207 detailedCVNames :: [String]
208 detailedCVNames = [ "free_mem_cv"
222 -- | Compute the mem and disk covariance.
223 compDetailedCV :: Node.List -> [Double]
226 all_nodes = Container.elems nl
227 (offline, nodes) = partition Node.offline all_nodes
228 mem_l = map Node.pMem nodes
229 dsk_l = map Node.pDsk nodes
230 -- metric: memory covariance
231 mem_cv = varianceCoeff mem_l
232 -- metric: disk covariance
233 dsk_cv = varianceCoeff dsk_l
234 n1_l = length $ filter Node.failN1 nodes
235 -- metric: count of failN1 nodes
236 n1_score = fromIntegral n1_l::Double
237 res_l = map Node.pRem nodes
238 -- metric: reserved memory covariance
239 res_cv = varianceCoeff res_l
240 -- offline instances metrics
241 offline_ipri = sum . map (length . Node.pList) $ offline
242 offline_isec = sum . map (length . Node.sList) $ offline
243 -- metric: count of instances on offline nodes
244 off_score = fromIntegral (offline_ipri + offline_isec)::Double
245 -- metric: count of primary instances on offline nodes (this
246 -- helps with evacuation/failover of primary instances on
247 -- 2-node clusters with one node offline)
248 off_pri_score = fromIntegral offline_ipri::Double
249 cpu_l = map Node.pCpu nodes
250 -- metric: covariance of vcpu/pcpu ratio
251 cpu_cv = varianceCoeff cpu_l
252 -- metrics: covariance of cpu, memory, disk and network load
253 (c_load, m_load, d_load, n_load) = unzip4 $
255 let DynUtil c1 m1 d1 n1 = Node.utilLoad n
256 DynUtil c2 m2 d2 n2 = Node.utilPool n
257 in (c1/c2, m1/m2, d1/d2, n1/n2)
259 -- metric: conflicting instance count
260 pri_tags_inst = sum $ map Node.conflictingPrimaries nodes
261 pri_tags_score = fromIntegral pri_tags_inst::Double
262 in [ mem_cv, dsk_cv, n1_score, res_cv, off_score, off_pri_score, cpu_cv
263 , varianceCoeff c_load, varianceCoeff m_load
264 , varianceCoeff d_load, varianceCoeff n_load
267 -- | Compute the /total/ variance.
268 compCV :: Node.List -> Double
269 compCV = sum . compDetailedCV
271 -- | Compute online nodes from a Node.List
272 getOnline :: Node.List -> [Node.Node]
273 getOnline = filter (not . Node.offline) . Container.elems
277 -- | Compute best table. Note that the ordering of the arguments is important.
278 compareTables :: Table -> Table -> Table
279 compareTables a@(Table _ _ a_cv _) b@(Table _ _ b_cv _ ) =
280 if a_cv > b_cv then b else a
282 -- | Applies an instance move to a given node list and instance.
283 applyMove :: Node.List -> Instance.Instance
284 -> IMove -> OpResult (Node.List, Instance.Instance, Ndx, Ndx)
286 applyMove nl inst Failover =
287 let old_pdx = Instance.pNode inst
288 old_sdx = Instance.sNode inst
289 old_p = Container.find old_pdx nl
290 old_s = Container.find old_sdx nl
291 int_p = Node.removePri old_p inst
292 int_s = Node.removeSec old_s inst
293 new_nl = do -- Maybe monad
294 new_p <- Node.addPri int_s inst
295 new_s <- Node.addSec int_p inst old_sdx
296 let new_inst = Instance.setBoth inst old_sdx old_pdx
297 return (Container.addTwo old_pdx new_s old_sdx new_p nl,
298 new_inst, old_sdx, old_pdx)
301 -- Replace the primary (f:, r:np, f)
302 applyMove nl inst (ReplacePrimary new_pdx) =
303 let old_pdx = Instance.pNode inst
304 old_sdx = Instance.sNode inst
305 old_p = Container.find old_pdx nl
306 old_s = Container.find old_sdx nl
307 tgt_n = Container.find new_pdx nl
308 int_p = Node.removePri old_p inst
309 int_s = Node.removeSec old_s inst
310 new_nl = do -- Maybe monad
311 -- check that the current secondary can host the instance
312 -- during the migration
313 tmp_s <- Node.addPri int_s inst
314 let tmp_s' = Node.removePri tmp_s inst
315 new_p <- Node.addPri tgt_n inst
316 new_s <- Node.addSec tmp_s' inst new_pdx
317 let new_inst = Instance.setPri inst new_pdx
318 return (Container.add new_pdx new_p $
319 Container.addTwo old_pdx int_p old_sdx new_s nl,
320 new_inst, new_pdx, old_sdx)
323 -- Replace the secondary (r:ns)
324 applyMove nl inst (ReplaceSecondary new_sdx) =
325 let old_pdx = Instance.pNode inst
326 old_sdx = Instance.sNode inst
327 old_s = Container.find old_sdx nl
328 tgt_n = Container.find new_sdx nl
329 int_s = Node.removeSec old_s inst
330 new_inst = Instance.setSec inst new_sdx
331 new_nl = Node.addSec tgt_n inst old_pdx >>=
332 \new_s -> return (Container.addTwo new_sdx
333 new_s old_sdx int_s nl,
334 new_inst, old_pdx, new_sdx)
337 -- Replace the secondary and failover (r:np, f)
338 applyMove nl inst (ReplaceAndFailover new_pdx) =
339 let old_pdx = Instance.pNode inst
340 old_sdx = Instance.sNode inst
341 old_p = Container.find old_pdx nl
342 old_s = Container.find old_sdx nl
343 tgt_n = Container.find new_pdx nl
344 int_p = Node.removePri old_p inst
345 int_s = Node.removeSec old_s inst
346 new_nl = do -- Maybe monad
347 new_p <- Node.addPri tgt_n inst
348 new_s <- Node.addSec int_p inst new_pdx
349 let new_inst = Instance.setBoth inst new_pdx old_pdx
350 return (Container.add new_pdx new_p $
351 Container.addTwo old_pdx new_s old_sdx int_s nl,
352 new_inst, new_pdx, old_pdx)
355 -- Failver and replace the secondary (f, r:ns)
356 applyMove nl inst (FailoverAndReplace new_sdx) =
357 let old_pdx = Instance.pNode inst
358 old_sdx = Instance.sNode inst
359 old_p = Container.find old_pdx nl
360 old_s = Container.find old_sdx nl
361 tgt_n = Container.find new_sdx nl
362 int_p = Node.removePri old_p inst
363 int_s = Node.removeSec old_s inst
364 new_nl = do -- Maybe monad
365 new_p <- Node.addPri int_s inst
366 new_s <- Node.addSec tgt_n inst old_sdx
367 let new_inst = Instance.setBoth inst old_sdx new_sdx
368 return (Container.add new_sdx new_s $
369 Container.addTwo old_sdx new_p old_pdx int_p nl,
370 new_inst, old_sdx, new_sdx)
373 -- | Tries to allocate an instance on one given node.
374 allocateOnSingle :: Node.List -> Instance.Instance -> Node.Node
375 -> OpResult Node.AllocElement
376 allocateOnSingle nl inst p =
377 let new_pdx = Node.idx p
378 new_inst = Instance.setBoth inst new_pdx Node.noSecondary
379 new_nl = Node.addPri p inst >>= \new_p ->
380 return (Container.add new_pdx new_p nl, new_inst, [new_p])
383 -- | Tries to allocate an instance on a given pair of nodes.
384 allocateOnPair :: Node.List -> Instance.Instance -> Node.Node -> Node.Node
385 -> OpResult Node.AllocElement
386 allocateOnPair nl inst tgt_p tgt_s =
387 let new_pdx = Node.idx tgt_p
388 new_sdx = Node.idx tgt_s
389 new_nl = do -- Maybe monad
390 new_p <- Node.addPri tgt_p inst
391 new_s <- Node.addSec tgt_s inst new_pdx
392 let new_inst = Instance.setBoth inst new_pdx new_sdx
393 return (Container.addTwo new_pdx new_p new_sdx new_s nl, new_inst,
397 -- | Tries to perform an instance move and returns the best table
398 -- between the original one and the new one.
399 checkSingleStep :: Table -- ^ The original table
400 -> Instance.Instance -- ^ The instance to move
401 -> Table -- ^ The current best table
402 -> IMove -- ^ The move to apply
403 -> Table -- ^ The final best table
404 checkSingleStep ini_tbl target cur_tbl move =
406 Table ini_nl ini_il _ ini_plc = ini_tbl
407 tmp_resu = applyMove ini_nl target move
411 OpGood (upd_nl, new_inst, pri_idx, sec_idx) ->
412 let tgt_idx = Instance.idx target
413 upd_cvar = compCV upd_nl
414 upd_il = Container.add tgt_idx new_inst ini_il
415 upd_plc = (tgt_idx, pri_idx, sec_idx, move, upd_cvar):ini_plc
416 upd_tbl = Table upd_nl upd_il upd_cvar upd_plc
418 compareTables cur_tbl upd_tbl
420 -- | Given the status of the current secondary as a valid new node and
421 -- the current candidate target node, generate the possible moves for
423 possibleMoves :: Bool -- ^ Whether the secondary node is a valid new node
424 -> Ndx -- ^ Target node candidate
425 -> [IMove] -- ^ List of valid result moves
426 possibleMoves True tdx =
427 [ReplaceSecondary tdx,
428 ReplaceAndFailover tdx,
430 FailoverAndReplace tdx]
432 possibleMoves False tdx =
433 [ReplaceSecondary tdx,
434 ReplaceAndFailover tdx]
436 -- | Compute the best move for a given instance.
437 checkInstanceMove :: [Ndx] -- ^ Allowed target node indices
438 -> Bool -- ^ Whether disk moves are allowed
439 -> Table -- ^ Original table
440 -> Instance.Instance -- ^ Instance to move
441 -> Table -- ^ Best new table for this instance
442 checkInstanceMove nodes_idx disk_moves ini_tbl target =
444 opdx = Instance.pNode target
445 osdx = Instance.sNode target
446 nodes = filter (\idx -> idx /= opdx && idx /= osdx) nodes_idx
447 use_secondary = elem osdx nodes_idx
448 aft_failover = if use_secondary -- if allowed to failover
449 then checkSingleStep ini_tbl target ini_tbl Failover
451 all_moves = if disk_moves
452 then concatMap (possibleMoves use_secondary) nodes
455 -- iterate over the possible nodes for this instance
456 foldl' (checkSingleStep ini_tbl target) aft_failover all_moves
458 -- | Compute the best next move.
459 checkMove :: [Ndx] -- ^ Allowed target node indices
460 -> Bool -- ^ Whether disk moves are allowed
461 -> Table -- ^ The current solution
462 -> [Instance.Instance] -- ^ List of instances still to move
463 -> Table -- ^ The new solution
464 checkMove nodes_idx disk_moves ini_tbl victims =
465 let Table _ _ _ ini_plc = ini_tbl
466 -- iterate over all instances, computing the best move
470 compareTables step_tbl $
471 checkInstanceMove nodes_idx disk_moves ini_tbl em)
473 Table _ _ _ best_plc = best_tbl
474 in if length best_plc == length ini_plc
475 then ini_tbl -- no advancement
478 -- | Check if we are allowed to go deeper in the balancing
479 doNextBalance :: Table -- ^ The starting table
480 -> Int -- ^ Remaining length
481 -> Score -- ^ Score at which to stop
482 -> Bool -- ^ The resulting table and commands
483 doNextBalance ini_tbl max_rounds min_score =
484 let Table _ _ ini_cv ini_plc = ini_tbl
485 ini_plc_len = length ini_plc
486 in (max_rounds < 0 || ini_plc_len < max_rounds) && ini_cv > min_score
488 -- | Run a balance move
489 tryBalance :: Table -- ^ The starting table
490 -> Bool -- ^ Allow disk moves
491 -> Bool -- ^ Only evacuate moves
492 -> Maybe Table -- ^ The resulting table and commands
493 tryBalance ini_tbl disk_moves evac_mode =
494 let Table ini_nl ini_il ini_cv _ = ini_tbl
495 all_inst = Container.elems ini_il
496 all_inst' = if evac_mode
497 then let bad_nodes = map Node.idx . filter Node.offline $
498 Container.elems ini_nl
499 in filter (\e -> Instance.sNode e `elem` bad_nodes ||
500 Instance.pNode e `elem` bad_nodes)
503 reloc_inst = filter Instance.movable all_inst'
504 node_idx = map Node.idx . filter (not . Node.offline) $
505 Container.elems ini_nl
506 fin_tbl = checkMove node_idx disk_moves ini_tbl reloc_inst
507 (Table _ _ fin_cv _) = fin_tbl
510 then Just fin_tbl -- this round made success, return the new table
513 -- * Allocation functions
515 -- | Build failure stats out of a list of failures
516 collapseFailures :: [FailMode] -> FailStats
517 collapseFailures flst =
518 map (\k -> (k, length $ filter (k ==) flst)) [minBound..maxBound]
520 -- | Update current Allocation solution and failure stats with new
522 concatAllocs :: AllocSolution -> OpResult Node.AllocElement -> AllocSolution
523 concatAllocs (flst, cntok, sols) (OpFail reason) = (reason:flst, cntok, sols)
525 concatAllocs (flst, cntok, osols) (OpGood ns@(nl, _, _)) =
526 let nscore = compCV nl
527 -- Choose the old or new solution, based on the cluster score
528 nsols = case osols of
534 -- FIXME: here we simply concat to lists with more
535 -- than one element; we should instead abort, since
536 -- this is not a valid usage of this function
537 xs -> (nscore, ns):xs
539 -- Note: we force evaluation of nsols here in order to keep the
540 -- memory profile low - we know that we will need nsols for sure
541 -- in the next cycle, so we force evaluation of nsols, since the
542 -- foldl' in the caller will only evaluate the tuple, but not the
543 -- elements of the tuple
544 in nsols `seq` nsuc `seq` (flst, nsuc, nsols)
546 -- | Try to allocate an instance on the cluster.
547 tryAlloc :: (Monad m) =>
548 Node.List -- ^ The node list
549 -> Instance.List -- ^ The instance list
550 -> Instance.Instance -- ^ The instance to allocate
551 -> Int -- ^ Required number of nodes
552 -> m AllocSolution -- ^ Possible solution list
553 tryAlloc nl _ inst 2 =
554 let all_nodes = getOnline nl
555 all_pairs = liftM2 (,) all_nodes all_nodes
556 ok_pairs = filter (\(x, y) -> Node.idx x /= Node.idx y) all_pairs
557 sols = foldl' (\cstate (p, s) ->
558 concatAllocs cstate $ allocateOnPair nl inst p s
559 ) ([], 0, []) ok_pairs
562 tryAlloc nl _ inst 1 =
563 let all_nodes = getOnline nl
564 sols = foldl' (\cstate ->
565 concatAllocs cstate . allocateOnSingle nl inst
566 ) ([], 0, []) all_nodes
569 tryAlloc _ _ _ reqn = fail $ "Unsupported number of allocation \
570 \destinations required (" ++ show reqn ++
571 "), only two supported"
573 -- | Try to allocate an instance on the cluster.
574 tryReloc :: (Monad m) =>
575 Node.List -- ^ The node list
576 -> Instance.List -- ^ The instance list
577 -> Idx -- ^ The index of the instance to move
578 -> Int -- ^ The number of nodes required
579 -> [Ndx] -- ^ Nodes which should not be used
580 -> m AllocSolution -- ^ Solution list
581 tryReloc nl il xid 1 ex_idx =
582 let all_nodes = getOnline nl
583 inst = Container.find xid il
584 ex_idx' = Instance.pNode inst:ex_idx
585 valid_nodes = filter (not . flip elem ex_idx' . Node.idx) all_nodes
586 valid_idxes = map Node.idx valid_nodes
587 sols1 = foldl' (\cstate x ->
590 applyMove nl inst (ReplaceSecondary x)
591 return (mnl, i, [Container.find x mnl])
592 in concatAllocs cstate em
593 ) ([], 0, []) valid_idxes
596 tryReloc _ _ _ reqn _ = fail $ "Unsupported number of relocation \
597 \destinations required (" ++ show reqn ++
598 "), only one supported"
600 -- | Try to evacuate a list of nodes.
601 tryEvac :: (Monad m) =>
602 Node.List -- ^ The node list
603 -> Instance.List -- ^ The instance list
604 -> [Ndx] -- ^ Nodes to be evacuated
605 -> m AllocSolution -- ^ Solution list
606 tryEvac nl il ex_ndx =
607 let ex_nodes = map (`Container.find` nl) ex_ndx
608 all_insts = nub . concatMap Node.sList $ ex_nodes
610 (_, sol) <- foldM (\(nl', (_, _, rsols)) idx -> do
611 -- FIXME: hardcoded one node here
612 (fm, cs, aes) <- tryReloc nl' il idx 1 ex_ndx
614 csol@(_, (nl'', _, _)):_ ->
615 return (nl'', (fm, cs, csol:rsols))
616 _ -> fail $ "Can't evacuate instance " ++
618 ) (nl, ([], 0, [])) all_insts
621 -- | Recursively place instances on the cluster until we're out of space
622 iterateAlloc :: Node.List
626 -> [Instance.Instance]
627 -> Result (FailStats, Node.List, [Instance.Instance])
628 iterateAlloc nl il newinst nreq ixes =
629 let depth = length ixes
630 newname = printf "new-%d" depth::String
631 newidx = length (Container.elems il) + depth
632 newi2 = Instance.setIdx (Instance.setName newinst newname) newidx
633 in case tryAlloc nl il newi2 nreq of
635 Ok (errs, _, sols3) ->
637 [] -> Ok (collapseFailures errs, nl, ixes)
638 (_, (xnl, xi, _)):[] ->
639 iterateAlloc xnl il newinst nreq $! (xi:ixes)
640 _ -> Bad "Internal error: multiple solutions for single\
643 tieredAlloc :: Node.List
647 -> [Instance.Instance]
648 -> Result (FailStats, Node.List, [Instance.Instance])
649 tieredAlloc nl il newinst nreq ixes =
650 case iterateAlloc nl il newinst nreq ixes of
652 Ok (errs, nl', ixes') ->
653 case Instance.shrinkByType newinst . fst . last $
654 sortBy (comparing snd) errs of
655 Bad _ -> Ok (errs, nl', ixes')
657 tieredAlloc nl' il newinst' nreq ixes'
659 -- * Formatting functions
661 -- | Given the original and final nodes, computes the relocation description.
662 computeMoves :: Instance.Instance -- ^ The instance to be moved
663 -> String -- ^ The instance name
664 -> IMove -- ^ The move being performed
665 -> String -- ^ New primary
666 -> String -- ^ New secondary
667 -> (String, [String])
668 -- ^ Tuple of moves and commands list; moves is containing
669 -- either @/f/@ for failover or @/r:name/@ for replace
670 -- secondary, while the command list holds gnt-instance
671 -- commands (without that prefix), e.g \"@failover instance1@\"
672 computeMoves i inam mv c d =
674 Failover -> ("f", [mig])
675 FailoverAndReplace _ -> (printf "f r:%s" d, [mig, rep d])
676 ReplaceSecondary _ -> (printf "r:%s" d, [rep d])
677 ReplaceAndFailover _ -> (printf "r:%s f" c, [rep c, mig])
678 ReplacePrimary _ -> (printf "f r:%s f" c, [mig, rep c, mig])
679 where morf = if Instance.running i then "migrate" else "failover"
680 mig = printf "%s -f %s" morf inam::String
681 rep n = printf "replace-disks -n %s %s" n inam
683 -- | Converts a placement to string format.
684 printSolutionLine :: Node.List -- ^ The node list
685 -> Instance.List -- ^ The instance list
686 -> Int -- ^ Maximum node name length
687 -> Int -- ^ Maximum instance name length
688 -> Placement -- ^ The current placement
689 -> Int -- ^ The index of the placement in
691 -> (String, [String])
692 printSolutionLine nl il nmlen imlen plc pos =
694 pmlen = (2*nmlen + 1)
695 (i, p, s, mv, c) = plc
696 inst = Container.find i il
697 inam = Instance.name inst
698 npri = Container.nameOf nl p
699 nsec = Container.nameOf nl s
700 opri = Container.nameOf nl $ Instance.pNode inst
701 osec = Container.nameOf nl $ Instance.sNode inst
702 (moves, cmds) = computeMoves inst inam mv npri nsec
703 ostr = printf "%s:%s" opri osec::String
704 nstr = printf "%s:%s" npri nsec::String
706 (printf " %3d. %-*s %-*s => %-*s %.8f a=%s"
707 pos imlen inam pmlen ostr
711 -- | Return the instance and involved nodes in an instance move.
712 involvedNodes :: Instance.List -> Placement -> [Ndx]
713 involvedNodes il plc =
714 let (i, np, ns, _, _) = plc
715 inst = Container.find i il
716 op = Instance.pNode inst
717 os = Instance.sNode inst
718 in nub [np, ns, op, os]
720 -- | Inner function for splitJobs, that either appends the next job to
721 -- the current jobset, or starts a new jobset.
722 mergeJobs :: ([JobSet], [Ndx]) -> MoveJob -> ([JobSet], [Ndx])
723 mergeJobs ([], _) n@(ndx, _, _, _) = ([[n]], ndx)
724 mergeJobs (cjs@(j:js), nbuf) n@(ndx, _, _, _)
725 | null (ndx `intersect` nbuf) = ((n:j):js, ndx ++ nbuf)
726 | otherwise = ([n]:cjs, ndx)
728 -- | Break a list of moves into independent groups. Note that this
729 -- will reverse the order of jobs.
730 splitJobs :: [MoveJob] -> [JobSet]
731 splitJobs = fst . foldl mergeJobs ([], [])
733 -- | Given a list of commands, prefix them with @gnt-instance@ and
734 -- also beautify the display a little.
735 formatJob :: Int -> Int -> (Int, MoveJob) -> [String]
736 formatJob jsn jsl (sn, (_, _, _, cmds)) =
738 printf " echo job %d/%d" jsn sn:
740 map (" gnt-instance " ++) cmds
742 then ["", printf "echo jobset %d, %d jobs" jsn jsl] ++ out
745 -- | Given a list of commands, prefix them with @gnt-instance@ and
746 -- also beautify the display a little.
747 formatCmds :: [JobSet] -> String
750 concatMap (\(jsn, js) -> concatMap (formatJob jsn (length js))
754 -- | Converts a solution to string format.
755 printSolution :: Node.List
758 -> ([String], [[String]])
759 printSolution nl il sol =
761 nmlen = Container.maxNameLen nl
762 imlen = Container.maxNameLen il
764 unzip $ zipWith (printSolutionLine nl il nmlen imlen) sol [1..]
766 -- | Print the node list.
767 printNodes :: Node.List -> [String] -> String
769 let fields = if null fs
770 then Node.defaultFields
772 snl = sortBy (comparing Node.idx) (Container.elems nl)
773 (header, isnum) = unzip $ map Node.showHeader fields
774 in unlines . map ((:) ' ' . intercalate " ") $
775 formatTable (header:map (Node.list fields) snl) isnum
777 -- | Print the instance list.
778 printInsts :: Node.List -> Instance.List -> String
780 let sil = sortBy (comparing Instance.idx) (Container.elems il)
781 helper inst = [ if Instance.running inst then "R" else " "
783 , Container.nameOf nl (Instance.pNode inst)
784 , let sdx = Instance.sNode inst
785 in if sdx == Node.noSecondary
787 else Container.nameOf nl sdx
788 , printf "%3d" $ Instance.vcpus inst
789 , printf "%5d" $ Instance.mem inst
790 , printf "%5d" $ Instance.dsk inst `div` 1024
796 where DynUtil lC lM lD lN = Instance.util inst
797 header = [ "F", "Name", "Pri_node", "Sec_node", "vcpu", "mem"
798 , "dsk", "lCpu", "lMem", "lDsk", "lNet" ]
799 isnum = False:False:False:False:repeat True
800 in unlines . map ((:) ' ' . intercalate " ") $
801 formatTable (header:map helper sil) isnum
803 -- | Shows statistics for a given node list.
804 printStats :: Node.List -> String
806 let dcvs = compDetailedCV nl
807 hd = zip (detailedCVNames ++ repeat "unknown") dcvs
808 formatted = map (\(header, val) ->
809 printf "%s=%.8f" header val::String) hd
810 in intercalate ", " formatted
812 -- | Convert a placement into a list of OpCodes (basically a job).
813 iMoveToJob :: Node.List -> Instance.List
814 -> Idx -> IMove -> [OpCodes.OpCode]
815 iMoveToJob nl il idx move =
816 let inst = Container.find idx il
817 iname = Instance.name inst
818 lookNode = Just . Container.nameOf nl
819 opF = if Instance.running inst
820 then OpCodes.OpMigrateInstance iname True False
821 else OpCodes.OpFailoverInstance iname False
822 opR n = OpCodes.OpReplaceDisks iname (lookNode n)
823 OpCodes.ReplaceNewSecondary [] Nothing
826 ReplacePrimary np -> [ opF, opR np, opF ]
827 ReplaceSecondary ns -> [ opR ns ]
828 ReplaceAndFailover np -> [ opR np, opF ]
829 FailoverAndReplace ns -> [ opF, opR ns ]