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, 2010, 2011, 2012 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
39 -- * Generic functions
41 , computeAllocationDelta
42 -- * First phase functions
44 -- * Second phase functions
49 -- * Display functions
52 -- * Balacing functions
61 -- * IAllocator functions
69 -- * Allocation functions
72 -- * Node group functions
78 import qualified Data.IntSet as IntSet
80 import Data.Maybe (fromJust, isNothing)
81 import Data.Ord (comparing)
82 import Text.Printf (printf)
84 import Ganeti.BasicTypes
85 import qualified Ganeti.HTools.Container as Container
86 import qualified Ganeti.HTools.Instance as Instance
87 import qualified Ganeti.HTools.Node as Node
88 import qualified Ganeti.HTools.Group as Group
89 import Ganeti.HTools.Types
91 import qualified Ganeti.OpCodes as OpCodes
93 import Ganeti.Types (mkNonEmpty)
97 -- | Allocation\/relocation solution.
98 data AllocSolution = AllocSolution
99 { asFailures :: [FailMode] -- ^ Failure counts
100 , asAllocs :: Int -- ^ Good allocation count
101 , asSolution :: Maybe Node.AllocElement -- ^ The actual allocation result
102 , asLog :: [String] -- ^ Informational messages
105 -- | Node evacuation/group change iallocator result type. This result
106 -- type consists of actual opcodes (a restricted subset) that are
107 -- transmitted back to Ganeti.
108 data EvacSolution = EvacSolution
109 { esMoved :: [(Idx, Gdx, [Ndx])] -- ^ Instances moved successfully
110 , esFailed :: [(Idx, String)] -- ^ Instances which were not
112 , esOpCodes :: [[OpCodes.OpCode]] -- ^ List of jobs
115 -- | Allocation results, as used in 'iterateAlloc' and 'tieredAlloc'.
116 type AllocResult = (FailStats, Node.List, Instance.List,
117 [Instance.Instance], [CStats])
119 -- | Type alias for easier handling.
120 type AllocSolutionList = [(Instance.Instance, AllocSolution)]
122 -- | A type denoting the valid allocation mode/pairs.
124 -- For a one-node allocation, this will be a @Left ['Ndx']@, whereas
125 -- for a two-node allocation, this will be a @Right [('Ndx',
126 -- ['Ndx'])]@. In the latter case, the list is basically an
127 -- association list, grouped by primary node and holding the potential
128 -- secondary nodes in the sub-list.
129 type AllocNodes = Either [Ndx] [(Ndx, [Ndx])]
131 -- | The empty solution we start with when computing allocations.
132 emptyAllocSolution :: AllocSolution
133 emptyAllocSolution = AllocSolution { asFailures = [], asAllocs = 0
134 , asSolution = Nothing, asLog = [] }
136 -- | The empty evac solution.
137 emptyEvacSolution :: EvacSolution
138 emptyEvacSolution = EvacSolution { esMoved = []
143 -- | The complete state for the balancing solution.
144 data Table = Table Node.List Instance.List Score [Placement]
147 -- | Cluster statistics data type.
149 { csFmem :: Integer -- ^ Cluster free mem
150 , csFdsk :: Integer -- ^ Cluster free disk
151 , csAmem :: Integer -- ^ Cluster allocatable mem
152 , csAdsk :: Integer -- ^ Cluster allocatable disk
153 , csAcpu :: Integer -- ^ Cluster allocatable cpus
154 , csMmem :: Integer -- ^ Max node allocatable mem
155 , csMdsk :: Integer -- ^ Max node allocatable disk
156 , csMcpu :: Integer -- ^ Max node allocatable cpu
157 , csImem :: Integer -- ^ Instance used mem
158 , csIdsk :: Integer -- ^ Instance used disk
159 , csIcpu :: Integer -- ^ Instance used cpu
160 , csTmem :: Double -- ^ Cluster total mem
161 , csTdsk :: Double -- ^ Cluster total disk
162 , csTcpu :: Double -- ^ Cluster total cpus
163 , csVcpu :: Integer -- ^ Cluster total virtual cpus
164 , csNcpu :: Double -- ^ Equivalent to 'csIcpu' but in terms of
165 -- physical CPUs, i.e. normalised used phys CPUs
166 , csXmem :: Integer -- ^ Unnacounted for mem
167 , csNmem :: Integer -- ^ Node own memory
168 , csScore :: Score -- ^ The cluster score
169 , csNinst :: Int -- ^ The total number of instances
172 -- | A simple type for allocation functions.
173 type AllocMethod = Node.List -- ^ Node list
174 -> Instance.List -- ^ Instance list
175 -> Maybe Int -- ^ Optional allocation limit
176 -> Instance.Instance -- ^ Instance spec for allocation
177 -> AllocNodes -- ^ Which nodes we should allocate on
178 -> [Instance.Instance] -- ^ Allocated instances
179 -> [CStats] -- ^ Running cluster stats
180 -> Result AllocResult -- ^ Allocation result
182 -- | A simple type for the running solution of evacuations.
183 type EvacInnerState =
184 Either String (Node.List, Instance.Instance, Score, Ndx)
186 -- * Utility functions
188 -- | Verifies the N+1 status and return the affected nodes.
189 verifyN1 :: [Node.Node] -> [Node.Node]
190 verifyN1 = filter Node.failN1
192 {-| Computes the pair of bad nodes and instances.
194 The bad node list is computed via a simple 'verifyN1' check, and the
195 bad instance list is the list of primary and secondary instances of
199 computeBadItems :: Node.List -> Instance.List ->
200 ([Node.Node], [Instance.Instance])
201 computeBadItems nl il =
202 let bad_nodes = verifyN1 $ getOnline nl
203 bad_instances = map (`Container.find` il) .
205 concatMap (\ n -> Node.sList n ++ Node.pList n) bad_nodes
207 (bad_nodes, bad_instances)
209 -- | Extracts the node pairs for an instance. This can fail if the
210 -- instance is single-homed. FIXME: this needs to be improved,
211 -- together with the general enhancement for handling non-DRBD moves.
212 instanceNodes :: Node.List -> Instance.Instance ->
213 (Ndx, Ndx, Node.Node, Node.Node)
214 instanceNodes nl inst =
215 let old_pdx = Instance.pNode inst
216 old_sdx = Instance.sNode inst
217 old_p = Container.find old_pdx nl
218 old_s = Container.find old_sdx nl
219 in (old_pdx, old_sdx, old_p, old_s)
221 -- | Zero-initializer for the CStats type.
222 emptyCStats :: CStats
223 emptyCStats = CStats 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
225 -- | Update stats with data from a new node.
226 updateCStats :: CStats -> Node.Node -> CStats
227 updateCStats cs node =
228 let CStats { csFmem = x_fmem, csFdsk = x_fdsk,
229 csAmem = x_amem, csAcpu = x_acpu, csAdsk = x_adsk,
230 csMmem = x_mmem, csMdsk = x_mdsk, csMcpu = x_mcpu,
231 csImem = x_imem, csIdsk = x_idsk, csIcpu = x_icpu,
232 csTmem = x_tmem, csTdsk = x_tdsk, csTcpu = x_tcpu,
233 csVcpu = x_vcpu, csNcpu = x_ncpu,
234 csXmem = x_xmem, csNmem = x_nmem, csNinst = x_ninst
237 inc_amem = Node.fMem node - Node.rMem node
238 inc_amem' = if inc_amem > 0 then inc_amem else 0
239 inc_adsk = Node.availDisk node
240 inc_imem = truncate (Node.tMem node) - Node.nMem node
241 - Node.xMem node - Node.fMem node
242 inc_icpu = Node.uCpu node
243 inc_idsk = truncate (Node.tDsk node) - Node.fDsk node
244 inc_vcpu = Node.hiCpu node
245 inc_acpu = Node.availCpu node
246 inc_ncpu = fromIntegral (Node.uCpu node) /
247 iPolicyVcpuRatio (Node.iPolicy node)
248 in cs { csFmem = x_fmem + fromIntegral (Node.fMem node)
249 , csFdsk = x_fdsk + fromIntegral (Node.fDsk node)
250 , csAmem = x_amem + fromIntegral inc_amem'
251 , csAdsk = x_adsk + fromIntegral inc_adsk
252 , csAcpu = x_acpu + fromIntegral inc_acpu
253 , csMmem = max x_mmem (fromIntegral inc_amem')
254 , csMdsk = max x_mdsk (fromIntegral inc_adsk)
255 , csMcpu = max x_mcpu (fromIntegral inc_acpu)
256 , csImem = x_imem + fromIntegral inc_imem
257 , csIdsk = x_idsk + fromIntegral inc_idsk
258 , csIcpu = x_icpu + fromIntegral inc_icpu
259 , csTmem = x_tmem + Node.tMem node
260 , csTdsk = x_tdsk + Node.tDsk node
261 , csTcpu = x_tcpu + Node.tCpu node
262 , csVcpu = x_vcpu + fromIntegral inc_vcpu
263 , csNcpu = x_ncpu + inc_ncpu
264 , csXmem = x_xmem + fromIntegral (Node.xMem node)
265 , csNmem = x_nmem + fromIntegral (Node.nMem node)
266 , csNinst = x_ninst + length (Node.pList node)
269 -- | Compute the total free disk and memory in the cluster.
270 totalResources :: Node.List -> CStats
272 let cs = foldl' updateCStats emptyCStats . Container.elems $ nl
273 in cs { csScore = compCV nl }
275 -- | Compute the delta between two cluster state.
277 -- This is used when doing allocations, to understand better the
278 -- available cluster resources. The return value is a triple of the
279 -- current used values, the delta that was still allocated, and what
280 -- was left unallocated.
281 computeAllocationDelta :: CStats -> CStats -> AllocStats
282 computeAllocationDelta cini cfin =
283 let CStats {csImem = i_imem, csIdsk = i_idsk, csIcpu = i_icpu,
284 csNcpu = i_ncpu } = cini
285 CStats {csImem = f_imem, csIdsk = f_idsk, csIcpu = f_icpu,
286 csTmem = t_mem, csTdsk = t_dsk, csVcpu = f_vcpu,
287 csNcpu = f_ncpu, csTcpu = f_tcpu } = cfin
288 rini = AllocInfo { allocInfoVCpus = fromIntegral i_icpu
289 , allocInfoNCpus = i_ncpu
290 , allocInfoMem = fromIntegral i_imem
291 , allocInfoDisk = fromIntegral i_idsk
293 rfin = AllocInfo { allocInfoVCpus = fromIntegral (f_icpu - i_icpu)
294 , allocInfoNCpus = f_ncpu - i_ncpu
295 , allocInfoMem = fromIntegral (f_imem - i_imem)
296 , allocInfoDisk = fromIntegral (f_idsk - i_idsk)
298 runa = AllocInfo { allocInfoVCpus = fromIntegral (f_vcpu - f_icpu)
299 , allocInfoNCpus = f_tcpu - f_ncpu
300 , allocInfoMem = truncate t_mem - fromIntegral f_imem
301 , allocInfoDisk = truncate t_dsk - fromIntegral f_idsk
303 in (rini, rfin, runa)
305 -- | The names and weights of the individual elements in the CV list.
306 detailedCVInfo :: [(Double, String)]
307 detailedCVInfo = [ (1, "free_mem_cv")
308 , (1, "free_disk_cv")
310 , (1, "reserved_mem_cv")
311 , (4, "offline_all_cnt")
312 , (16, "offline_pri_cnt")
313 , (1, "vcpu_ratio_cv")
316 , (1, "disk_load_cv")
318 , (2, "pri_tags_score")
322 -- | Holds the weights used by 'compCVNodes' for each metric.
323 detailedCVWeights :: [Double]
324 detailedCVWeights = map fst detailedCVInfo
326 -- | Compute the mem and disk covariance.
327 compDetailedCV :: [Node.Node] -> [Double]
328 compDetailedCV all_nodes =
329 let (offline, nodes) = partition Node.offline all_nodes
330 mem_l = map Node.pMem nodes
331 dsk_l = map Node.pDsk nodes
332 -- metric: memory covariance
333 mem_cv = stdDev mem_l
334 -- metric: disk covariance
335 dsk_cv = stdDev dsk_l
336 -- metric: count of instances living on N1 failing nodes
337 n1_score = fromIntegral . sum . map (\n -> length (Node.sList n) +
338 length (Node.pList n)) .
339 filter Node.failN1 $ nodes :: Double
340 res_l = map Node.pRem nodes
341 -- metric: reserved memory covariance
342 res_cv = stdDev res_l
343 -- offline instances metrics
344 offline_ipri = sum . map (length . Node.pList) $ offline
345 offline_isec = sum . map (length . Node.sList) $ offline
346 -- metric: count of instances on offline nodes
347 off_score = fromIntegral (offline_ipri + offline_isec)::Double
348 -- metric: count of primary instances on offline nodes (this
349 -- helps with evacuation/failover of primary instances on
350 -- 2-node clusters with one node offline)
351 off_pri_score = fromIntegral offline_ipri::Double
352 cpu_l = map Node.pCpu nodes
353 -- metric: covariance of vcpu/pcpu ratio
354 cpu_cv = stdDev cpu_l
355 -- metrics: covariance of cpu, memory, disk and network load
356 (c_load, m_load, d_load, n_load) =
358 let DynUtil c1 m1 d1 n1 = Node.utilLoad n
359 DynUtil c2 m2 d2 n2 = Node.utilPool n
360 in (c1/c2, m1/m2, d1/d2, n1/n2)) nodes
361 -- metric: conflicting instance count
362 pri_tags_inst = sum $ map Node.conflictingPrimaries nodes
363 pri_tags_score = fromIntegral pri_tags_inst::Double
364 -- metric: spindles %
365 spindles_cv = map (\n -> Node.instSpindles n / Node.hiSpindles n) nodes
366 in [ mem_cv, dsk_cv, n1_score, res_cv, off_score, off_pri_score, cpu_cv
367 , stdDev c_load, stdDev m_load , stdDev d_load, stdDev n_load
368 , pri_tags_score, stdDev spindles_cv ]
370 -- | Compute the /total/ variance.
371 compCVNodes :: [Node.Node] -> Double
372 compCVNodes = sum . zipWith (*) detailedCVWeights . compDetailedCV
374 -- | Wrapper over 'compCVNodes' for callers that have a 'Node.List'.
375 compCV :: Node.List -> Double
376 compCV = compCVNodes . Container.elems
378 -- | Compute online nodes from a 'Node.List'.
379 getOnline :: Node.List -> [Node.Node]
380 getOnline = filter (not . Node.offline) . Container.elems
382 -- * Balancing functions
384 -- | Compute best table. Note that the ordering of the arguments is important.
385 compareTables :: Table -> Table -> Table
386 compareTables a@(Table _ _ a_cv _) b@(Table _ _ b_cv _ ) =
387 if a_cv > b_cv then b else a
389 -- | Applies an instance move to a given node list and instance.
390 applyMove :: Node.List -> Instance.Instance
391 -> IMove -> OpResult (Node.List, Instance.Instance, Ndx, Ndx)
393 applyMove nl inst Failover =
394 let (old_pdx, old_sdx, old_p, old_s) = instanceNodes nl inst
395 int_p = Node.removePri old_p inst
396 int_s = Node.removeSec old_s inst
397 new_nl = do -- Maybe monad
398 new_p <- Node.addPriEx (Node.offline old_p) int_s inst
399 new_s <- Node.addSec int_p inst old_sdx
400 let new_inst = Instance.setBoth inst old_sdx old_pdx
401 return (Container.addTwo old_pdx new_s old_sdx new_p nl,
402 new_inst, old_sdx, old_pdx)
405 -- Failover to any (fa)
406 applyMove nl inst (FailoverToAny new_pdx) = do
407 let (old_pdx, old_sdx, old_pnode, _) = instanceNodes nl inst
408 new_pnode = Container.find new_pdx nl
409 force_failover = Node.offline old_pnode
410 new_pnode' <- Node.addPriEx force_failover new_pnode inst
411 let old_pnode' = Node.removePri old_pnode inst
412 inst' = Instance.setPri inst new_pdx
413 nl' = Container.addTwo old_pdx old_pnode' new_pdx new_pnode' nl
414 return (nl', inst', new_pdx, old_sdx)
416 -- Replace the primary (f:, r:np, f)
417 applyMove nl inst (ReplacePrimary new_pdx) =
418 let (old_pdx, old_sdx, old_p, old_s) = instanceNodes nl inst
419 tgt_n = Container.find new_pdx nl
420 int_p = Node.removePri old_p inst
421 int_s = Node.removeSec old_s inst
422 force_p = Node.offline old_p
423 new_nl = do -- Maybe monad
424 -- check that the current secondary can host the instance
425 -- during the migration
426 tmp_s <- Node.addPriEx force_p int_s inst
427 let tmp_s' = Node.removePri tmp_s inst
428 new_p <- Node.addPriEx force_p tgt_n inst
429 new_s <- Node.addSecEx force_p tmp_s' inst new_pdx
430 let new_inst = Instance.setPri inst new_pdx
431 return (Container.add new_pdx new_p $
432 Container.addTwo old_pdx int_p old_sdx new_s nl,
433 new_inst, new_pdx, old_sdx)
436 -- Replace the secondary (r:ns)
437 applyMove nl inst (ReplaceSecondary new_sdx) =
438 let old_pdx = Instance.pNode inst
439 old_sdx = Instance.sNode inst
440 old_s = Container.find old_sdx nl
441 tgt_n = Container.find new_sdx nl
442 int_s = Node.removeSec old_s inst
443 force_s = Node.offline old_s
444 new_inst = Instance.setSec inst new_sdx
445 new_nl = Node.addSecEx force_s tgt_n inst old_pdx >>=
446 \new_s -> return (Container.addTwo new_sdx
447 new_s old_sdx int_s nl,
448 new_inst, old_pdx, new_sdx)
451 -- Replace the secondary and failover (r:np, f)
452 applyMove nl inst (ReplaceAndFailover new_pdx) =
453 let (old_pdx, old_sdx, old_p, old_s) = instanceNodes nl inst
454 tgt_n = Container.find new_pdx nl
455 int_p = Node.removePri old_p inst
456 int_s = Node.removeSec old_s inst
457 force_s = Node.offline old_s
458 new_nl = do -- Maybe monad
459 new_p <- Node.addPri tgt_n inst
460 new_s <- Node.addSecEx force_s int_p inst new_pdx
461 let new_inst = Instance.setBoth inst new_pdx old_pdx
462 return (Container.add new_pdx new_p $
463 Container.addTwo old_pdx new_s old_sdx int_s nl,
464 new_inst, new_pdx, old_pdx)
467 -- Failver and replace the secondary (f, r:ns)
468 applyMove nl inst (FailoverAndReplace new_sdx) =
469 let (old_pdx, old_sdx, old_p, old_s) = instanceNodes nl inst
470 tgt_n = Container.find new_sdx nl
471 int_p = Node.removePri old_p inst
472 int_s = Node.removeSec old_s inst
473 force_p = Node.offline old_p
474 new_nl = do -- Maybe monad
475 new_p <- Node.addPriEx force_p int_s inst
476 new_s <- Node.addSecEx force_p tgt_n inst old_sdx
477 let new_inst = Instance.setBoth inst old_sdx new_sdx
478 return (Container.add new_sdx new_s $
479 Container.addTwo old_sdx new_p old_pdx int_p nl,
480 new_inst, old_sdx, new_sdx)
483 -- | Tries to allocate an instance on one given node.
484 allocateOnSingle :: Node.List -> Instance.Instance -> Ndx
485 -> OpResult Node.AllocElement
486 allocateOnSingle nl inst new_pdx =
487 let p = Container.find new_pdx nl
488 new_inst = Instance.setBoth inst new_pdx Node.noSecondary
490 Instance.instMatchesPolicy inst (Node.iPolicy p)
491 new_p <- Node.addPri p inst
492 let new_nl = Container.add new_pdx new_p nl
493 new_score = compCV new_nl
494 return (new_nl, new_inst, [new_p], new_score)
496 -- | Tries to allocate an instance on a given pair of nodes.
497 allocateOnPair :: Node.List -> Instance.Instance -> Ndx -> Ndx
498 -> OpResult Node.AllocElement
499 allocateOnPair nl inst new_pdx new_sdx =
500 let tgt_p = Container.find new_pdx nl
501 tgt_s = Container.find new_sdx nl
503 Instance.instMatchesPolicy inst (Node.iPolicy tgt_p)
504 new_p <- Node.addPri tgt_p inst
505 new_s <- Node.addSec tgt_s inst new_pdx
506 let new_inst = Instance.setBoth inst new_pdx new_sdx
507 new_nl = Container.addTwo new_pdx new_p new_sdx new_s nl
508 return (new_nl, new_inst, [new_p, new_s], compCV new_nl)
510 -- | Tries to perform an instance move and returns the best table
511 -- between the original one and the new one.
512 checkSingleStep :: Table -- ^ The original table
513 -> Instance.Instance -- ^ The instance to move
514 -> Table -- ^ The current best table
515 -> IMove -- ^ The move to apply
516 -> Table -- ^ The final best table
517 checkSingleStep ini_tbl target cur_tbl move =
518 let Table ini_nl ini_il _ ini_plc = ini_tbl
519 tmp_resu = applyMove ini_nl target move
522 Ok (upd_nl, new_inst, pri_idx, sec_idx) ->
523 let tgt_idx = Instance.idx target
524 upd_cvar = compCV upd_nl
525 upd_il = Container.add tgt_idx new_inst ini_il
526 upd_plc = (tgt_idx, pri_idx, sec_idx, move, upd_cvar):ini_plc
527 upd_tbl = Table upd_nl upd_il upd_cvar upd_plc
528 in compareTables cur_tbl upd_tbl
530 -- | Given the status of the current secondary as a valid new node and
531 -- the current candidate target node, generate the possible moves for
533 possibleMoves :: MirrorType -- ^ The mirroring type of the instance
534 -> Bool -- ^ Whether the secondary node is a valid new node
535 -> Bool -- ^ Whether we can change the primary node
536 -> Ndx -- ^ Target node candidate
537 -> [IMove] -- ^ List of valid result moves
539 possibleMoves MirrorNone _ _ _ = []
541 possibleMoves MirrorExternal _ False _ = []
543 possibleMoves MirrorExternal _ True tdx =
544 [ FailoverToAny tdx ]
546 possibleMoves MirrorInternal _ False tdx =
547 [ ReplaceSecondary tdx ]
549 possibleMoves MirrorInternal True True tdx =
550 [ ReplaceSecondary tdx
551 , ReplaceAndFailover tdx
553 , FailoverAndReplace tdx
556 possibleMoves MirrorInternal False True tdx =
557 [ ReplaceSecondary tdx
558 , ReplaceAndFailover tdx
561 -- | Compute the best move for a given instance.
562 checkInstanceMove :: [Ndx] -- ^ Allowed target node indices
563 -> Bool -- ^ Whether disk moves are allowed
564 -> Bool -- ^ Whether instance moves are allowed
565 -> Table -- ^ Original table
566 -> Instance.Instance -- ^ Instance to move
567 -> Table -- ^ Best new table for this instance
568 checkInstanceMove nodes_idx disk_moves inst_moves ini_tbl target =
569 let opdx = Instance.pNode target
570 osdx = Instance.sNode target
571 bad_nodes = [opdx, osdx]
572 nodes = filter (`notElem` bad_nodes) nodes_idx
573 mir_type = Instance.mirrorType target
574 use_secondary = elem osdx nodes_idx && inst_moves
575 aft_failover = if mir_type == MirrorInternal && use_secondary
576 -- if drbd and allowed to failover
577 then checkSingleStep ini_tbl target ini_tbl Failover
581 then concatMap (possibleMoves mir_type use_secondary inst_moves)
585 -- iterate over the possible nodes for this instance
586 foldl' (checkSingleStep ini_tbl target) aft_failover all_moves
588 -- | Compute the best next move.
589 checkMove :: [Ndx] -- ^ Allowed target node indices
590 -> Bool -- ^ Whether disk moves are allowed
591 -> Bool -- ^ Whether instance moves are allowed
592 -> Table -- ^ The current solution
593 -> [Instance.Instance] -- ^ List of instances still to move
594 -> Table -- ^ The new solution
595 checkMove nodes_idx disk_moves inst_moves ini_tbl victims =
596 let Table _ _ _ ini_plc = ini_tbl
597 -- we're using rwhnf from the Control.Parallel.Strategies
598 -- package; we don't need to use rnf as that would force too
599 -- much evaluation in single-threaded cases, and in
600 -- multi-threaded case the weak head normal form is enough to
601 -- spark the evaluation
602 tables = parMap rwhnf (checkInstanceMove nodes_idx disk_moves
605 -- iterate over all instances, computing the best move
606 best_tbl = foldl' compareTables ini_tbl tables
607 Table _ _ _ best_plc = best_tbl
608 in if length best_plc == length ini_plc
609 then ini_tbl -- no advancement
612 -- | Check if we are allowed to go deeper in the balancing.
613 doNextBalance :: Table -- ^ The starting table
614 -> Int -- ^ Remaining length
615 -> Score -- ^ Score at which to stop
616 -> Bool -- ^ The resulting table and commands
617 doNextBalance ini_tbl max_rounds min_score =
618 let Table _ _ ini_cv ini_plc = ini_tbl
619 ini_plc_len = length ini_plc
620 in (max_rounds < 0 || ini_plc_len < max_rounds) && ini_cv > min_score
622 -- | Run a balance move.
623 tryBalance :: Table -- ^ The starting table
624 -> Bool -- ^ Allow disk moves
625 -> Bool -- ^ Allow instance moves
626 -> Bool -- ^ Only evacuate moves
627 -> Score -- ^ Min gain threshold
628 -> Score -- ^ Min gain
629 -> Maybe Table -- ^ The resulting table and commands
630 tryBalance ini_tbl disk_moves inst_moves evac_mode mg_limit min_gain =
631 let Table ini_nl ini_il ini_cv _ = ini_tbl
632 all_inst = Container.elems ini_il
633 all_nodes = Container.elems ini_nl
634 (offline_nodes, online_nodes) = partition Node.offline all_nodes
635 all_inst' = if evac_mode
636 then let bad_nodes = map Node.idx offline_nodes
637 in filter (any (`elem` bad_nodes) .
638 Instance.allNodes) all_inst
640 reloc_inst = filter Instance.movable all_inst'
641 node_idx = map Node.idx online_nodes
642 fin_tbl = checkMove node_idx disk_moves inst_moves ini_tbl reloc_inst
643 (Table _ _ fin_cv _) = fin_tbl
645 if fin_cv < ini_cv && (ini_cv > mg_limit || ini_cv - fin_cv >= min_gain)
646 then Just fin_tbl -- this round made success, return the new table
649 -- * Allocation functions
651 -- | Build failure stats out of a list of failures.
652 collapseFailures :: [FailMode] -> FailStats
653 collapseFailures flst =
654 map (\k -> (k, foldl' (\a e -> if e == k then a + 1 else a) 0 flst))
657 -- | Compares two Maybe AllocElement and chooses the besst score.
658 bestAllocElement :: Maybe Node.AllocElement
659 -> Maybe Node.AllocElement
660 -> Maybe Node.AllocElement
661 bestAllocElement a Nothing = a
662 bestAllocElement Nothing b = b
663 bestAllocElement a@(Just (_, _, _, ascore)) b@(Just (_, _, _, bscore)) =
664 if ascore < bscore then a else b
666 -- | Update current Allocation solution and failure stats with new
668 concatAllocs :: AllocSolution -> OpResult Node.AllocElement -> AllocSolution
669 concatAllocs as (Bad reason) = as { asFailures = reason : asFailures as }
671 concatAllocs as (Ok ns) =
672 let -- Choose the old or new solution, based on the cluster score
674 osols = asSolution as
675 nsols = bestAllocElement osols (Just ns)
677 -- Note: we force evaluation of nsols here in order to keep the
678 -- memory profile low - we know that we will need nsols for sure
679 -- in the next cycle, so we force evaluation of nsols, since the
680 -- foldl' in the caller will only evaluate the tuple, but not the
681 -- elements of the tuple
682 in nsols `seq` nsuc `seq` as { asAllocs = nsuc, asSolution = nsols }
684 -- | Sums two 'AllocSolution' structures.
685 sumAllocs :: AllocSolution -> AllocSolution -> AllocSolution
686 sumAllocs (AllocSolution aFails aAllocs aSols aLog)
687 (AllocSolution bFails bAllocs bSols bLog) =
688 -- note: we add b first, since usually it will be smaller; when
689 -- fold'ing, a will grow and grow whereas b is the per-group
690 -- result, hence smaller
691 let nFails = bFails ++ aFails
692 nAllocs = aAllocs + bAllocs
693 nSols = bestAllocElement aSols bSols
695 in AllocSolution nFails nAllocs nSols nLog
697 -- | Given a solution, generates a reasonable description for it.
698 describeSolution :: AllocSolution -> String
699 describeSolution as =
700 let fcnt = asFailures as
703 intercalate ", " . map (\(a, b) -> printf "%s: %d" (show a) b) .
704 filter ((> 0) . snd) . collapseFailures $ fcnt
706 Nothing -> "No valid allocation solutions, failure reasons: " ++
707 (if null fcnt then "unknown reasons" else freasons)
708 Just (_, _, nodes, cv) ->
709 printf ("score: %.8f, successes %d, failures %d (%s)" ++
710 " for node(s) %s") cv (asAllocs as) (length fcnt) freasons
711 (intercalate "/" . map Node.name $ nodes)
713 -- | Annotates a solution with the appropriate string.
714 annotateSolution :: AllocSolution -> AllocSolution
715 annotateSolution as = as { asLog = describeSolution as : asLog as }
717 -- | Reverses an evacuation solution.
719 -- Rationale: we always concat the results to the top of the lists, so
720 -- for proper jobset execution, we should reverse all lists.
721 reverseEvacSolution :: EvacSolution -> EvacSolution
722 reverseEvacSolution (EvacSolution f m o) =
723 EvacSolution (reverse f) (reverse m) (reverse o)
725 -- | Generate the valid node allocation singles or pairs for a new instance.
726 genAllocNodes :: Group.List -- ^ Group list
727 -> Node.List -- ^ The node map
728 -> Int -- ^ The number of nodes required
729 -> Bool -- ^ Whether to drop or not
731 -> Result AllocNodes -- ^ The (monadic) result
732 genAllocNodes gl nl count drop_unalloc =
733 let filter_fn = if drop_unalloc
734 then filter (Group.isAllocable .
735 flip Container.find gl . Node.group)
737 all_nodes = filter_fn $ getOnline nl
738 all_pairs = [(Node.idx p,
739 [Node.idx s | s <- all_nodes,
740 Node.idx p /= Node.idx s,
741 Node.group p == Node.group s]) |
744 1 -> Ok (Left (map Node.idx all_nodes))
745 2 -> Ok (Right (filter (not . null . snd) all_pairs))
746 _ -> Bad "Unsupported number of nodes, only one or two supported"
748 -- | Try to allocate an instance on the cluster.
749 tryAlloc :: (Monad m) =>
750 Node.List -- ^ The node list
751 -> Instance.List -- ^ The instance list
752 -> Instance.Instance -- ^ The instance to allocate
753 -> AllocNodes -- ^ The allocation targets
754 -> m AllocSolution -- ^ Possible solution list
755 tryAlloc _ _ _ (Right []) = fail "Not enough online nodes"
756 tryAlloc nl _ inst (Right ok_pairs) =
757 let psols = parMap rwhnf (\(p, ss) ->
759 concatAllocs cstate .
760 allocateOnPair nl inst p)
761 emptyAllocSolution ss) ok_pairs
762 sols = foldl' sumAllocs emptyAllocSolution psols
763 in return $ annotateSolution sols
765 tryAlloc _ _ _ (Left []) = fail "No online nodes"
766 tryAlloc nl _ inst (Left all_nodes) =
767 let sols = foldl' (\cstate ->
768 concatAllocs cstate . allocateOnSingle nl inst
769 ) emptyAllocSolution all_nodes
770 in return $ annotateSolution sols
772 -- | Given a group/result, describe it as a nice (list of) messages.
773 solutionDescription :: Group.List -> (Gdx, Result AllocSolution) -> [String]
774 solutionDescription gl (groupId, result) =
776 Ok solution -> map (printf "Group %s (%s): %s" gname pol) (asLog solution)
777 Bad message -> [printf "Group %s: error %s" gname message]
778 where grp = Container.find groupId gl
779 gname = Group.name grp
780 pol = allocPolicyToRaw (Group.allocPolicy grp)
782 -- | From a list of possibly bad and possibly empty solutions, filter
783 -- only the groups with a valid result. Note that the result will be
784 -- reversed compared to the original list.
785 filterMGResults :: Group.List
786 -> [(Gdx, Result AllocSolution)]
787 -> [(Gdx, AllocSolution)]
788 filterMGResults gl = foldl' fn []
789 where unallocable = not . Group.isAllocable . flip Container.find gl
790 fn accu (gdx, rasol) =
793 Ok sol | isNothing (asSolution sol) -> accu
794 | unallocable gdx -> accu
795 | otherwise -> (gdx, sol):accu
797 -- | Sort multigroup results based on policy and score.
798 sortMGResults :: Group.List
799 -> [(Gdx, AllocSolution)]
800 -> [(Gdx, AllocSolution)]
801 sortMGResults gl sols =
802 let extractScore (_, _, _, x) = x
803 solScore (gdx, sol) = (Group.allocPolicy (Container.find gdx gl),
804 (extractScore . fromJust . asSolution) sol)
805 in sortBy (comparing solScore) sols
807 -- | Finds the best group for an instance on a multi-group cluster.
809 -- Only solutions in @preferred@ and @last_resort@ groups will be
810 -- accepted as valid, and additionally if the allowed groups parameter
811 -- is not null then allocation will only be run for those group
813 findBestAllocGroup :: Group.List -- ^ The group list
814 -> Node.List -- ^ The node list
815 -> Instance.List -- ^ The instance list
816 -> Maybe [Gdx] -- ^ The allowed groups
817 -> Instance.Instance -- ^ The instance to allocate
818 -> Int -- ^ Required number of nodes
819 -> Result (Gdx, AllocSolution, [String])
820 findBestAllocGroup mggl mgnl mgil allowed_gdxs inst cnt =
821 let groups = splitCluster mgnl mgil
822 groups' = maybe groups (\gs -> filter ((`elem` gs) . fst) groups)
824 sols = map (\(gid, (nl, il)) ->
825 (gid, genAllocNodes mggl nl cnt False >>=
826 tryAlloc nl il inst))
827 groups'::[(Gdx, Result AllocSolution)]
828 all_msgs = concatMap (solutionDescription mggl) sols
829 goodSols = filterMGResults mggl sols
830 sortedSols = sortMGResults mggl goodSols
831 in if null sortedSols
832 then Bad $ if null groups'
833 then "no groups for evacuation: allowed groups was" ++
834 show allowed_gdxs ++ ", all groups: " ++
835 show (map fst groups)
836 else intercalate ", " all_msgs
837 else let (final_group, final_sol) = head sortedSols
838 in return (final_group, final_sol, all_msgs)
840 -- | Try to allocate an instance on a multi-group cluster.
841 tryMGAlloc :: Group.List -- ^ The group list
842 -> Node.List -- ^ The node list
843 -> Instance.List -- ^ The instance list
844 -> Instance.Instance -- ^ The instance to allocate
845 -> Int -- ^ Required number of nodes
846 -> Result AllocSolution -- ^ Possible solution list
847 tryMGAlloc mggl mgnl mgil inst cnt = do
848 (best_group, solution, all_msgs) <-
849 findBestAllocGroup mggl mgnl mgil Nothing inst cnt
850 let group_name = Group.name $ Container.find best_group mggl
851 selmsg = "Selected group: " ++ group_name
852 return $ solution { asLog = selmsg:all_msgs }
854 -- | Calculate the new instance list after allocation solution.
855 updateIl :: Instance.List -- ^ The original instance list
856 -> Maybe Node.AllocElement -- ^ The result of the allocation attempt
857 -> Instance.List -- ^ The updated instance list
858 updateIl il Nothing = il
859 updateIl il (Just (_, xi, _, _)) = Container.add (Container.size il) xi il
861 -- | Extract the the new node list from the allocation solution.
862 extractNl :: Node.List -- ^ The original node list
863 -> Maybe Node.AllocElement -- ^ The result of the allocation attempt
864 -> Node.List -- ^ The new node list
865 extractNl nl Nothing = nl
866 extractNl _ (Just (xnl, _, _, _)) = xnl
868 -- | Try to allocate a list of instances on a multi-group cluster.
869 allocList :: Group.List -- ^ The group list
870 -> Node.List -- ^ The node list
871 -> Instance.List -- ^ The instance list
872 -> [(Instance.Instance, Int)] -- ^ The instance to allocate
873 -> AllocSolutionList -- ^ Possible solution list
874 -> Result (Node.List, Instance.List,
875 AllocSolutionList) -- ^ The final solution list
876 allocList _ nl il [] result = Ok (nl, il, result)
877 allocList gl nl il ((xi, xicnt):xies) result = do
878 ares <- tryMGAlloc gl nl il xi xicnt
879 let sol = asSolution ares
880 nl' = extractNl nl sol
881 il' = updateIl il sol
882 allocList gl nl' il' xies ((xi, ares):result)
884 -- | Function which fails if the requested mode is change secondary.
886 -- This is useful since except DRBD, no other disk template can
887 -- execute change secondary; thus, we can just call this function
888 -- instead of always checking for secondary mode. After the call to
889 -- this function, whatever mode we have is just a primary change.
890 failOnSecondaryChange :: (Monad m) => EvacMode -> DiskTemplate -> m ()
891 failOnSecondaryChange ChangeSecondary dt =
892 fail $ "Instances with disk template '" ++ diskTemplateToRaw dt ++
893 "' can't execute change secondary"
894 failOnSecondaryChange _ _ = return ()
896 -- | Run evacuation for a single instance.
898 -- /Note:/ this function should correctly execute both intra-group
899 -- evacuations (in all modes) and inter-group evacuations (in the
900 -- 'ChangeAll' mode). Of course, this requires that the correct list
901 -- of target nodes is passed.
902 nodeEvacInstance :: Node.List -- ^ The node list (cluster-wide)
903 -> Instance.List -- ^ Instance list (cluster-wide)
904 -> EvacMode -- ^ The evacuation mode
905 -> Instance.Instance -- ^ The instance to be evacuated
906 -> Gdx -- ^ The group we're targetting
907 -> [Ndx] -- ^ The list of available nodes
909 -> Result (Node.List, Instance.List, [OpCodes.OpCode])
910 nodeEvacInstance nl il mode inst@(Instance.Instance
911 {Instance.diskTemplate = dt@DTDiskless})
913 failOnSecondaryChange mode dt >>
914 evacOneNodeOnly nl il inst gdx avail_nodes
916 nodeEvacInstance _ _ _ (Instance.Instance
917 {Instance.diskTemplate = DTPlain}) _ _ =
918 fail "Instances of type plain cannot be relocated"
920 nodeEvacInstance _ _ _ (Instance.Instance
921 {Instance.diskTemplate = DTFile}) _ _ =
922 fail "Instances of type file cannot be relocated"
924 nodeEvacInstance nl il mode inst@(Instance.Instance
925 {Instance.diskTemplate = dt@DTSharedFile})
927 failOnSecondaryChange mode dt >>
928 evacOneNodeOnly nl il inst gdx avail_nodes
930 nodeEvacInstance nl il mode inst@(Instance.Instance
931 {Instance.diskTemplate = dt@DTBlock})
933 failOnSecondaryChange mode dt >>
934 evacOneNodeOnly nl il inst gdx avail_nodes
936 nodeEvacInstance nl il mode inst@(Instance.Instance
937 {Instance.diskTemplate = dt@DTRbd})
939 failOnSecondaryChange mode dt >>
940 evacOneNodeOnly nl il inst gdx avail_nodes
942 nodeEvacInstance nl il ChangePrimary
943 inst@(Instance.Instance {Instance.diskTemplate = DTDrbd8})
946 (nl', inst', _, _) <- opToResult $ applyMove nl inst Failover
947 let idx = Instance.idx inst
948 il' = Container.add idx inst' il
949 ops = iMoveToJob nl' il' idx Failover
950 return (nl', il', ops)
952 nodeEvacInstance nl il ChangeSecondary
953 inst@(Instance.Instance {Instance.diskTemplate = DTDrbd8})
955 evacOneNodeOnly nl il inst gdx avail_nodes
957 -- The algorithm for ChangeAll is as follows:
959 -- * generate all (primary, secondary) node pairs for the target groups
960 -- * for each pair, execute the needed moves (r:s, f, r:s) and compute
961 -- the final node list state and group score
962 -- * select the best choice via a foldl that uses the same Either
963 -- String solution as the ChangeSecondary mode
964 nodeEvacInstance nl il ChangeAll
965 inst@(Instance.Instance {Instance.diskTemplate = DTDrbd8})
968 let no_nodes = Left "no nodes available"
969 node_pairs = [(p,s) | p <- avail_nodes, s <- avail_nodes, p /= s]
970 (nl', il', ops, _) <-
971 annotateResult "Can't find any good nodes for relocation" .
974 (\accu nodes -> case evacDrbdAllInner nl il inst gdx nodes of
978 -- we don't need more details (which
979 -- nodes, etc.) as we only selected
980 -- this group if we can allocate on
981 -- it, hence failures will not
982 -- propagate out of this fold loop
983 Left _ -> Left $ "Allocation failed: " ++ msg
984 Ok result@(_, _, _, new_cv) ->
985 let new_accu = Right result in
988 Right (_, _, _, old_cv) ->
992 ) no_nodes node_pairs
994 return (nl', il', ops)
996 -- | Generic function for changing one node of an instance.
998 -- This is similar to 'nodeEvacInstance' but will be used in a few of
999 -- its sub-patterns. It folds the inner function 'evacOneNodeInner'
1000 -- over the list of available nodes, which results in the best choice
1002 evacOneNodeOnly :: Node.List -- ^ The node list (cluster-wide)
1003 -> Instance.List -- ^ Instance list (cluster-wide)
1004 -> Instance.Instance -- ^ The instance to be evacuated
1005 -> Gdx -- ^ The group we're targetting
1006 -> [Ndx] -- ^ The list of available nodes
1008 -> Result (Node.List, Instance.List, [OpCodes.OpCode])
1009 evacOneNodeOnly nl il inst gdx avail_nodes = do
1010 op_fn <- case Instance.mirrorType inst of
1011 MirrorNone -> Bad "Can't relocate/evacuate non-mirrored instances"
1012 MirrorInternal -> Ok ReplaceSecondary
1013 MirrorExternal -> Ok FailoverToAny
1014 (nl', inst', _, ndx) <- annotateResult "Can't find any good node" .
1016 foldl' (evacOneNodeInner nl inst gdx op_fn)
1017 (Left "no nodes available") avail_nodes
1018 let idx = Instance.idx inst
1019 il' = Container.add idx inst' il
1020 ops = iMoveToJob nl' il' idx (op_fn ndx)
1021 return (nl', il', ops)
1023 -- | Inner fold function for changing one node of an instance.
1025 -- Depending on the instance disk template, this will either change
1026 -- the secondary (for DRBD) or the primary node (for shared
1027 -- storage). However, the operation is generic otherwise.
1029 -- The running solution is either a @Left String@, which means we
1030 -- don't have yet a working solution, or a @Right (...)@, which
1031 -- represents a valid solution; it holds the modified node list, the
1032 -- modified instance (after evacuation), the score of that solution,
1033 -- and the new secondary node index.
1034 evacOneNodeInner :: Node.List -- ^ Cluster node list
1035 -> Instance.Instance -- ^ Instance being evacuated
1036 -> Gdx -- ^ The group index of the instance
1037 -> (Ndx -> IMove) -- ^ Operation constructor
1038 -> EvacInnerState -- ^ Current best solution
1039 -> Ndx -- ^ Node we're evaluating as target
1040 -> EvacInnerState -- ^ New best solution
1041 evacOneNodeInner nl inst gdx op_fn accu ndx =
1042 case applyMove nl inst (op_fn ndx) of
1043 Bad fm -> let fail_msg = "Node " ++ Container.nameOf nl ndx ++
1044 " failed: " ++ show fm
1045 in either (const $ Left fail_msg) (const accu) accu
1046 Ok (nl', inst', _, _) ->
1047 let nodes = Container.elems nl'
1048 -- The fromJust below is ugly (it can fail nastily), but
1049 -- at this point we should have any internal mismatches,
1050 -- and adding a monad here would be quite involved
1051 grpnodes = fromJust (gdx `lookup` Node.computeGroups nodes)
1052 new_cv = compCVNodes grpnodes
1053 new_accu = Right (nl', inst', new_cv, ndx)
1056 Right (_, _, old_cv, _) ->
1061 -- | Compute result of changing all nodes of a DRBD instance.
1063 -- Given the target primary and secondary node (which might be in a
1064 -- different group or not), this function will 'execute' all the
1065 -- required steps and assuming all operations succceed, will return
1066 -- the modified node and instance lists, the opcodes needed for this
1067 -- and the new group score.
1068 evacDrbdAllInner :: Node.List -- ^ Cluster node list
1069 -> Instance.List -- ^ Cluster instance list
1070 -> Instance.Instance -- ^ The instance to be moved
1071 -> Gdx -- ^ The target group index
1072 -- (which can differ from the
1073 -- current group of the
1075 -> (Ndx, Ndx) -- ^ Tuple of new
1076 -- primary\/secondary nodes
1077 -> Result (Node.List, Instance.List, [OpCodes.OpCode], Score)
1078 evacDrbdAllInner nl il inst gdx (t_pdx, t_sdx) = do
1079 let primary = Container.find (Instance.pNode inst) nl
1080 idx = Instance.idx inst
1081 -- if the primary is offline, then we first failover
1082 (nl1, inst1, ops1) <-
1083 if Node.offline primary
1085 (nl', inst', _, _) <-
1086 annotateResult "Failing over to the secondary" .
1087 opToResult $ applyMove nl inst Failover
1088 return (nl', inst', [Failover])
1089 else return (nl, inst, [])
1090 let (o1, o2, o3) = (ReplaceSecondary t_pdx,
1092 ReplaceSecondary t_sdx)
1093 -- we now need to execute a replace secondary to the future
1095 (nl2, inst2, _, _) <-
1096 annotateResult "Changing secondary to new primary" .
1098 applyMove nl1 inst1 o1
1100 -- we now execute another failover, the primary stays fixed now
1101 (nl3, inst3, _, _) <- annotateResult "Failing over to new primary" .
1102 opToResult $ applyMove nl2 inst2 o2
1104 -- and finally another replace secondary, to the final secondary
1105 (nl4, inst4, _, _) <-
1106 annotateResult "Changing secondary to final secondary" .
1108 applyMove nl3 inst3 o3
1110 il' = Container.add idx inst4 il
1111 ops = concatMap (iMoveToJob nl4 il' idx) $ reverse ops4
1112 let nodes = Container.elems nl4
1113 -- The fromJust below is ugly (it can fail nastily), but
1114 -- at this point we should have any internal mismatches,
1115 -- and adding a monad here would be quite involved
1116 grpnodes = fromJust (gdx `lookup` Node.computeGroups nodes)
1117 new_cv = compCVNodes grpnodes
1118 return (nl4, il', ops, new_cv)
1120 -- | Computes the nodes in a given group which are available for
1122 availableGroupNodes :: [(Gdx, [Ndx])] -- ^ Group index/node index assoc list
1123 -> IntSet.IntSet -- ^ Nodes that are excluded
1124 -> Gdx -- ^ The group for which we
1126 -> Result [Ndx] -- ^ List of available node indices
1127 availableGroupNodes group_nodes excl_ndx gdx = do
1128 local_nodes <- maybe (Bad $ "Can't find group with index " ++ show gdx)
1129 Ok (lookup gdx group_nodes)
1130 let avail_nodes = filter (not . flip IntSet.member excl_ndx) local_nodes
1133 -- | Updates the evac solution with the results of an instance
1135 updateEvacSolution :: (Node.List, Instance.List, EvacSolution)
1137 -> Result (Node.List, Instance.List, [OpCodes.OpCode])
1138 -> (Node.List, Instance.List, EvacSolution)
1139 updateEvacSolution (nl, il, es) idx (Bad msg) =
1140 (nl, il, es { esFailed = (idx, msg):esFailed es})
1141 updateEvacSolution (_, _, es) idx (Ok (nl, il, opcodes)) =
1142 (nl, il, es { esMoved = new_elem:esMoved es
1143 , esOpCodes = opcodes:esOpCodes es })
1144 where inst = Container.find idx il
1146 instancePriGroup nl inst,
1147 Instance.allNodes inst)
1149 -- | Node-evacuation IAllocator mode main function.
1150 tryNodeEvac :: Group.List -- ^ The cluster groups
1151 -> Node.List -- ^ The node list (cluster-wide, not per group)
1152 -> Instance.List -- ^ Instance list (cluster-wide)
1153 -> EvacMode -- ^ The evacuation mode
1154 -> [Idx] -- ^ List of instance (indices) to be evacuated
1155 -> Result (Node.List, Instance.List, EvacSolution)
1156 tryNodeEvac _ ini_nl ini_il mode idxs =
1157 let evac_ndx = nodesToEvacuate ini_il mode idxs
1158 offline = map Node.idx . filter Node.offline $ Container.elems ini_nl
1159 excl_ndx = foldl' (flip IntSet.insert) evac_ndx offline
1160 group_ndx = map (\(gdx, (nl, _)) -> (gdx, map Node.idx
1161 (Container.elems nl))) $
1162 splitCluster ini_nl ini_il
1163 (fin_nl, fin_il, esol) =
1164 foldl' (\state@(nl, il, _) inst ->
1165 let gdx = instancePriGroup nl inst
1166 pdx = Instance.pNode inst in
1167 updateEvacSolution state (Instance.idx inst) $
1168 availableGroupNodes group_ndx
1169 (IntSet.insert pdx excl_ndx) gdx >>=
1170 nodeEvacInstance nl il mode inst gdx
1172 (ini_nl, ini_il, emptyEvacSolution)
1173 (map (`Container.find` ini_il) idxs)
1174 in return (fin_nl, fin_il, reverseEvacSolution esol)
1176 -- | Change-group IAllocator mode main function.
1178 -- This is very similar to 'tryNodeEvac', the only difference is that
1179 -- we don't choose as target group the current instance group, but
1182 -- 1. at the start of the function, we compute which are the target
1183 -- groups; either no groups were passed in, in which case we choose
1184 -- all groups out of which we don't evacuate instance, or there were
1185 -- some groups passed, in which case we use those
1187 -- 2. for each instance, we use 'findBestAllocGroup' to choose the
1188 -- best group to hold the instance, and then we do what
1189 -- 'tryNodeEvac' does, except for this group instead of the current
1192 -- Note that the correct behaviour of this function relies on the
1193 -- function 'nodeEvacInstance' to be able to do correctly both
1194 -- intra-group and inter-group moves when passed the 'ChangeAll' mode.
1195 tryChangeGroup :: Group.List -- ^ The cluster groups
1196 -> Node.List -- ^ The node list (cluster-wide)
1197 -> Instance.List -- ^ Instance list (cluster-wide)
1198 -> [Gdx] -- ^ Target groups; if empty, any
1199 -- groups not being evacuated
1200 -> [Idx] -- ^ List of instance (indices) to be evacuated
1201 -> Result (Node.List, Instance.List, EvacSolution)
1202 tryChangeGroup gl ini_nl ini_il gdxs idxs =
1203 let evac_gdxs = nub $ map (instancePriGroup ini_nl .
1204 flip Container.find ini_il) idxs
1205 target_gdxs = (if null gdxs
1206 then Container.keys gl
1207 else gdxs) \\ evac_gdxs
1208 offline = map Node.idx . filter Node.offline $ Container.elems ini_nl
1209 excl_ndx = foldl' (flip IntSet.insert) IntSet.empty offline
1210 group_ndx = map (\(gdx, (nl, _)) -> (gdx, map Node.idx
1211 (Container.elems nl))) $
1212 splitCluster ini_nl ini_il
1213 (fin_nl, fin_il, esol) =
1214 foldl' (\state@(nl, il, _) inst ->
1216 let ncnt = Instance.requiredNodes $
1217 Instance.diskTemplate inst
1218 (gdx, _, _) <- findBestAllocGroup gl nl il
1219 (Just target_gdxs) inst ncnt
1220 av_nodes <- availableGroupNodes group_ndx
1222 nodeEvacInstance nl il ChangeAll inst gdx av_nodes
1223 in updateEvacSolution state (Instance.idx inst) solution
1225 (ini_nl, ini_il, emptyEvacSolution)
1226 (map (`Container.find` ini_il) idxs)
1227 in return (fin_nl, fin_il, reverseEvacSolution esol)
1229 -- | Standard-sized allocation method.
1231 -- This places instances of the same size on the cluster until we're
1232 -- out of space. The result will be a list of identically-sized
1234 iterateAlloc :: AllocMethod
1235 iterateAlloc nl il limit newinst allocnodes ixes cstats =
1236 let depth = length ixes
1237 newname = printf "new-%d" depth::String
1238 newidx = Container.size il
1239 newi2 = Instance.setIdx (Instance.setName newinst newname) newidx
1240 newlimit = fmap (flip (-) 1) limit
1241 in case tryAlloc nl il newi2 allocnodes of
1243 Ok (AllocSolution { asFailures = errs, asSolution = sols3 }) ->
1244 let newsol = Ok (collapseFailures errs, nl, il, ixes, cstats) in
1247 Just (xnl, xi, _, _) ->
1250 else iterateAlloc xnl (Container.add newidx xi il)
1251 newlimit newinst allocnodes (xi:ixes)
1252 (totalResources xnl:cstats)
1254 -- | Tiered allocation method.
1256 -- This places instances on the cluster, and decreases the spec until
1257 -- we can allocate again. The result will be a list of decreasing
1259 tieredAlloc :: AllocMethod
1260 tieredAlloc nl il limit newinst allocnodes ixes cstats =
1261 case iterateAlloc nl il limit newinst allocnodes ixes cstats of
1263 Ok (errs, nl', il', ixes', cstats') ->
1264 let newsol = Ok (errs, nl', il', ixes', cstats')
1265 ixes_cnt = length ixes'
1266 (stop, newlimit) = case limit of
1267 Nothing -> (False, Nothing)
1268 Just n -> (n <= ixes_cnt,
1269 Just (n - ixes_cnt)) in
1270 if stop then newsol else
1271 case Instance.shrinkByType newinst . fst . last $
1272 sortBy (comparing snd) errs of
1274 Ok newinst' -> tieredAlloc nl' il' newlimit
1275 newinst' allocnodes ixes' cstats'
1277 -- * Formatting functions
1279 -- | Given the original and final nodes, computes the relocation description.
1280 computeMoves :: Instance.Instance -- ^ The instance to be moved
1281 -> String -- ^ The instance name
1282 -> IMove -- ^ The move being performed
1283 -> String -- ^ New primary
1284 -> String -- ^ New secondary
1285 -> (String, [String])
1286 -- ^ Tuple of moves and commands list; moves is containing
1287 -- either @/f/@ for failover or @/r:name/@ for replace
1288 -- secondary, while the command list holds gnt-instance
1289 -- commands (without that prefix), e.g \"@failover instance1@\"
1290 computeMoves i inam mv c d =
1292 Failover -> ("f", [mig])
1293 FailoverToAny _ -> (printf "fa:%s" c, [mig_any])
1294 FailoverAndReplace _ -> (printf "f r:%s" d, [mig, rep d])
1295 ReplaceSecondary _ -> (printf "r:%s" d, [rep d])
1296 ReplaceAndFailover _ -> (printf "r:%s f" c, [rep c, mig])
1297 ReplacePrimary _ -> (printf "f r:%s f" c, [mig, rep c, mig])
1298 where morf = if Instance.isRunning i then "migrate" else "failover"
1299 mig = printf "%s -f %s" morf inam::String
1300 mig_any = printf "%s -f -n %s %s" morf c inam::String
1301 rep n = printf "replace-disks -n %s %s" n inam::String
1303 -- | Converts a placement to string format.
1304 printSolutionLine :: Node.List -- ^ The node list
1305 -> Instance.List -- ^ The instance list
1306 -> Int -- ^ Maximum node name length
1307 -> Int -- ^ Maximum instance name length
1308 -> Placement -- ^ The current placement
1309 -> Int -- ^ The index of the placement in
1311 -> (String, [String])
1312 printSolutionLine nl il nmlen imlen plc pos =
1313 let pmlen = (2*nmlen + 1)
1314 (i, p, s, mv, c) = plc
1315 old_sec = Instance.sNode inst
1316 inst = Container.find i il
1317 inam = Instance.alias inst
1318 npri = Node.alias $ Container.find p nl
1319 nsec = Node.alias $ Container.find s nl
1320 opri = Node.alias $ Container.find (Instance.pNode inst) nl
1321 osec = Node.alias $ Container.find old_sec nl
1322 (moves, cmds) = computeMoves inst inam mv npri nsec
1323 -- FIXME: this should check instead/also the disk template
1324 ostr = if old_sec == Node.noSecondary
1325 then printf "%s" opri::String
1326 else printf "%s:%s" opri osec::String
1327 nstr = if s == Node.noSecondary
1328 then printf "%s" npri::String
1329 else printf "%s:%s" npri nsec::String
1330 in (printf " %3d. %-*s %-*s => %-*s %12.8f a=%s"
1331 pos imlen inam pmlen ostr pmlen nstr c moves,
1334 -- | Return the instance and involved nodes in an instance move.
1336 -- Note that the output list length can vary, and is not required nor
1337 -- guaranteed to be of any specific length.
1338 involvedNodes :: Instance.List -- ^ Instance list, used for retrieving
1339 -- the instance from its index; note
1340 -- that this /must/ be the original
1341 -- instance list, so that we can
1342 -- retrieve the old nodes
1343 -> Placement -- ^ The placement we're investigating,
1344 -- containing the new nodes and
1346 -> [Ndx] -- ^ Resulting list of node indices
1347 involvedNodes il plc =
1348 let (i, np, ns, _, _) = plc
1349 inst = Container.find i il
1350 in nub $ [np, ns] ++ Instance.allNodes inst
1352 -- | Inner function for splitJobs, that either appends the next job to
1353 -- the current jobset, or starts a new jobset.
1354 mergeJobs :: ([JobSet], [Ndx]) -> MoveJob -> ([JobSet], [Ndx])
1355 mergeJobs ([], _) n@(ndx, _, _, _) = ([[n]], ndx)
1356 mergeJobs (cjs@(j:js), nbuf) n@(ndx, _, _, _)
1357 | null (ndx `intersect` nbuf) = ((n:j):js, ndx ++ nbuf)
1358 | otherwise = ([n]:cjs, ndx)
1360 -- | Break a list of moves into independent groups. Note that this
1361 -- will reverse the order of jobs.
1362 splitJobs :: [MoveJob] -> [JobSet]
1363 splitJobs = fst . foldl mergeJobs ([], [])
1365 -- | Given a list of commands, prefix them with @gnt-instance@ and
1366 -- also beautify the display a little.
1367 formatJob :: Int -> Int -> (Int, MoveJob) -> [String]
1368 formatJob jsn jsl (sn, (_, _, _, cmds)) =
1370 printf " echo job %d/%d" jsn sn:
1372 map (" gnt-instance " ++) cmds
1374 then ["", printf "echo jobset %d, %d jobs" jsn jsl] ++ out
1377 -- | Given a list of commands, prefix them with @gnt-instance@ and
1378 -- also beautify the display a little.
1379 formatCmds :: [JobSet] -> String
1382 concatMap (\(jsn, js) -> concatMap (formatJob jsn (length js))
1386 -- | Print the node list.
1387 printNodes :: Node.List -> [String] -> String
1389 let fields = case fs of
1390 [] -> Node.defaultFields
1391 "+":rest -> Node.defaultFields ++ rest
1393 snl = sortBy (comparing Node.idx) (Container.elems nl)
1394 (header, isnum) = unzip $ map Node.showHeader fields
1395 in printTable "" header (map (Node.list fields) snl) isnum
1397 -- | Print the instance list.
1398 printInsts :: Node.List -> Instance.List -> String
1400 let sil = sortBy (comparing Instance.idx) (Container.elems il)
1401 helper inst = [ if Instance.isRunning inst then "R" else " "
1402 , Instance.name inst
1403 , Container.nameOf nl (Instance.pNode inst)
1404 , let sdx = Instance.sNode inst
1405 in if sdx == Node.noSecondary
1407 else Container.nameOf nl sdx
1408 , if Instance.autoBalance inst then "Y" else "N"
1409 , printf "%3d" $ Instance.vcpus inst
1410 , printf "%5d" $ Instance.mem inst
1411 , printf "%5d" $ Instance.dsk inst `div` 1024
1417 where DynUtil lC lM lD lN = Instance.util inst
1418 header = [ "F", "Name", "Pri_node", "Sec_node", "Auto_bal"
1419 , "vcpu", "mem" , "dsk", "lCpu", "lMem", "lDsk", "lNet" ]
1420 isnum = False:False:False:False:False:repeat True
1421 in printTable "" header (map helper sil) isnum
1423 -- | Shows statistics for a given node list.
1424 printStats :: String -> Node.List -> String
1426 let dcvs = compDetailedCV $ Container.elems nl
1427 (weights, names) = unzip detailedCVInfo
1428 hd = zip3 (weights ++ repeat 1) (names ++ repeat "unknown") dcvs
1429 header = [ "Field", "Value", "Weight" ]
1430 formatted = map (\(w, h, val) ->
1435 in printTable lp header formatted $ False:repeat True
1437 -- | Convert a placement into a list of OpCodes (basically a job).
1438 iMoveToJob :: Node.List -- ^ The node list; only used for node
1439 -- names, so any version is good
1440 -- (before or after the operation)
1441 -> Instance.List -- ^ The instance list; also used for
1443 -> Idx -- ^ The index of the instance being
1445 -> IMove -- ^ The actual move to be described
1446 -> [OpCodes.OpCode] -- ^ The list of opcodes equivalent to
1448 iMoveToJob nl il idx move =
1449 let inst = Container.find idx il
1450 iname = Instance.name inst
1451 lookNode n = case mkNonEmpty (Container.nameOf nl n) of
1452 -- FIXME: convert htools codebase to non-empty strings
1453 Bad msg -> error $ "Empty node name for idx " ++
1454 show n ++ ": " ++ msg ++ "??"
1457 opF = OpCodes.OpInstanceMigrate iname live False True Nothing
1458 opFA n = OpCodes.OpInstanceMigrate iname live False True (lookNode n)
1459 opR n = OpCodes.OpInstanceReplaceDisks iname (lookNode n)
1460 OpCodes.ReplaceNewSecondary [] Nothing
1463 FailoverToAny np -> [ opFA np ]
1464 ReplacePrimary np -> [ opF, opR np, opF ]
1465 ReplaceSecondary ns -> [ opR ns ]
1466 ReplaceAndFailover np -> [ opR np, opF ]
1467 FailoverAndReplace ns -> [ opF, opR ns ]
1469 -- * Node group functions
1471 -- | Computes the group of an instance.
1472 instanceGroup :: Node.List -> Instance.Instance -> Result Gdx
1473 instanceGroup nl i =
1474 let sidx = Instance.sNode i
1475 pnode = Container.find (Instance.pNode i) nl
1476 snode = if sidx == Node.noSecondary
1478 else Container.find sidx nl
1479 pgroup = Node.group pnode
1480 sgroup = Node.group snode
1481 in if pgroup /= sgroup
1482 then fail ("Instance placed accross two node groups, primary " ++
1483 show pgroup ++ ", secondary " ++ show sgroup)
1486 -- | Computes the group of an instance per the primary node.
1487 instancePriGroup :: Node.List -> Instance.Instance -> Gdx
1488 instancePriGroup nl i =
1489 let pnode = Container.find (Instance.pNode i) nl
1492 -- | Compute the list of badly allocated instances (split across node
1494 findSplitInstances :: Node.List -> Instance.List -> [Instance.Instance]
1495 findSplitInstances nl =
1496 filter (not . isOk . instanceGroup nl) . Container.elems
1498 -- | Splits a cluster into the component node groups.
1499 splitCluster :: Node.List -> Instance.List ->
1500 [(Gdx, (Node.List, Instance.List))]
1501 splitCluster nl il =
1502 let ngroups = Node.computeGroups (Container.elems nl)
1503 in map (\(guuid, nodes) ->
1504 let nidxs = map Node.idx nodes
1505 nodes' = zip nidxs nodes
1506 instances = Container.filter ((`elem` nidxs) . Instance.pNode) il
1507 in (guuid, (Container.fromList nodes', instances))) ngroups
1509 -- | Compute the list of nodes that are to be evacuated, given a list
1510 -- of instances and an evacuation mode.
1511 nodesToEvacuate :: Instance.List -- ^ The cluster-wide instance list
1512 -> EvacMode -- ^ The evacuation mode we're using
1513 -> [Idx] -- ^ List of instance indices being evacuated
1514 -> IntSet.IntSet -- ^ Set of node indices
1515 nodesToEvacuate il mode =
1516 IntSet.delete Node.noSecondary .
1518 let i = Container.find idx il
1519 pdx = Instance.pNode i
1520 sdx = Instance.sNode i
1521 dt = Instance.diskTemplate i
1522 withSecondary = case dt of
1523 DTDrbd8 -> IntSet.insert sdx ns
1526 ChangePrimary -> IntSet.insert pdx ns
1527 ChangeSecondary -> withSecondary
1528 ChangeAll -> IntSet.insert pdx withSecondary