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 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
46 -- * Display functions
49 -- * Balacing functions
56 -- * IAllocator functions
62 -- * Allocation functions
66 -- * Node group functions
72 import Data.Function (on)
74 import Data.Ord (comparing)
75 import Text.Printf (printf)
78 import qualified Ganeti.HTools.Container as Container
79 import qualified Ganeti.HTools.Instance as Instance
80 import qualified Ganeti.HTools.Node as Node
81 import qualified Ganeti.HTools.Group as Group
82 import Ganeti.HTools.Types
83 import Ganeti.HTools.Utils
84 import qualified Ganeti.OpCodes as OpCodes
88 -- | Allocation\/relocation solution.
89 data AllocSolution = AllocSolution
90 { asFailures :: [FailMode] -- ^ Failure counts
91 , asAllocs :: Int -- ^ Good allocation count
92 , asSolutions :: [Node.AllocElement] -- ^ The actual result, length
93 -- of the list depends on the
94 -- allocation/relocation mode
95 , asLog :: [String] -- ^ A list of informational messages
98 -- | The empty solution we start with when computing allocations
99 emptySolution :: AllocSolution
100 emptySolution = AllocSolution { asFailures = [], asAllocs = 0
101 , asSolutions = [], asLog = [] }
103 -- | The complete state for the balancing solution
104 data Table = Table Node.List Instance.List Score [Placement]
107 data CStats = CStats { csFmem :: Int -- ^ Cluster free mem
108 , csFdsk :: Int -- ^ Cluster free disk
109 , csAmem :: Int -- ^ Cluster allocatable mem
110 , csAdsk :: Int -- ^ Cluster allocatable disk
111 , csAcpu :: Int -- ^ Cluster allocatable cpus
112 , csMmem :: Int -- ^ Max node allocatable mem
113 , csMdsk :: Int -- ^ Max node allocatable disk
114 , csMcpu :: Int -- ^ Max node allocatable cpu
115 , csImem :: Int -- ^ Instance used mem
116 , csIdsk :: Int -- ^ Instance used disk
117 , csIcpu :: Int -- ^ Instance used cpu
118 , csTmem :: Double -- ^ Cluster total mem
119 , csTdsk :: Double -- ^ Cluster total disk
120 , csTcpu :: Double -- ^ Cluster total cpus
121 , csVcpu :: Int -- ^ Cluster virtual cpus (if
122 -- node pCpu has been set,
124 , csXmem :: Int -- ^ Unnacounted for mem
125 , csNmem :: Int -- ^ Node own memory
126 , csScore :: Score -- ^ The cluster score
127 , csNinst :: Int -- ^ The total number of instances
131 -- | Currently used, possibly to allocate, unallocable
132 type AllocStats = (RSpec, RSpec, RSpec)
134 -- * Utility functions
136 -- | Verifies the N+1 status and return the affected nodes.
137 verifyN1 :: [Node.Node] -> [Node.Node]
138 verifyN1 = filter Node.failN1
140 {-| Computes the pair of bad nodes and instances.
142 The bad node list is computed via a simple 'verifyN1' check, and the
143 bad instance list is the list of primary and secondary instances of
147 computeBadItems :: Node.List -> Instance.List ->
148 ([Node.Node], [Instance.Instance])
149 computeBadItems nl il =
150 let bad_nodes = verifyN1 $ getOnline nl
151 bad_instances = map (`Container.find` il) .
153 concatMap (\ n -> Node.sList n ++ Node.pList n) bad_nodes
155 (bad_nodes, bad_instances)
157 -- | Zero-initializer for the CStats type
158 emptyCStats :: CStats
159 emptyCStats = CStats 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
161 -- | Update stats with data from a new node
162 updateCStats :: CStats -> Node.Node -> CStats
163 updateCStats cs node =
164 let CStats { csFmem = x_fmem, csFdsk = x_fdsk,
165 csAmem = x_amem, csAcpu = x_acpu, csAdsk = x_adsk,
166 csMmem = x_mmem, csMdsk = x_mdsk, csMcpu = x_mcpu,
167 csImem = x_imem, csIdsk = x_idsk, csIcpu = x_icpu,
168 csTmem = x_tmem, csTdsk = x_tdsk, csTcpu = x_tcpu,
170 csXmem = x_xmem, csNmem = x_nmem, csNinst = x_ninst
173 inc_amem = Node.fMem node - Node.rMem node
174 inc_amem' = if inc_amem > 0 then inc_amem else 0
175 inc_adsk = Node.availDisk node
176 inc_imem = truncate (Node.tMem node) - Node.nMem node
177 - Node.xMem node - Node.fMem node
178 inc_icpu = Node.uCpu node
179 inc_idsk = truncate (Node.tDsk node) - Node.fDsk node
180 inc_vcpu = Node.hiCpu node
182 in cs { csFmem = x_fmem + Node.fMem node
183 , csFdsk = x_fdsk + Node.fDsk node
184 , csAmem = x_amem + inc_amem'
185 , csAdsk = x_adsk + inc_adsk
187 , csMmem = max x_mmem inc_amem'
188 , csMdsk = max x_mdsk inc_adsk
190 , csImem = x_imem + inc_imem
191 , csIdsk = x_idsk + inc_idsk
192 , csIcpu = x_icpu + inc_icpu
193 , csTmem = x_tmem + Node.tMem node
194 , csTdsk = x_tdsk + Node.tDsk node
195 , csTcpu = x_tcpu + Node.tCpu node
196 , csVcpu = x_vcpu + inc_vcpu
197 , csXmem = x_xmem + Node.xMem node
198 , csNmem = x_nmem + Node.nMem node
199 , csNinst = x_ninst + length (Node.pList node)
202 -- | Compute the total free disk and memory in the cluster.
203 totalResources :: Node.List -> CStats
205 let cs = foldl' updateCStats emptyCStats . Container.elems $ nl
206 in cs { csScore = compCV nl }
208 -- | Compute the delta between two cluster state.
210 -- This is used when doing allocations, to understand better the
211 -- available cluster resources. The return value is a triple of the
212 -- current used values, the delta that was still allocated, and what
213 -- was left unallocated.
214 computeAllocationDelta :: CStats -> CStats -> AllocStats
215 computeAllocationDelta cini cfin =
216 let CStats {csImem = i_imem, csIdsk = i_idsk, csIcpu = i_icpu} = cini
217 CStats {csImem = f_imem, csIdsk = f_idsk, csIcpu = f_icpu,
218 csTmem = t_mem, csTdsk = t_dsk, csVcpu = v_cpu } = cfin
219 rini = RSpec i_icpu i_imem i_idsk
220 rfin = RSpec (f_icpu - i_icpu) (f_imem - i_imem) (f_idsk - i_idsk)
221 un_cpu = v_cpu - f_icpu
222 runa = RSpec un_cpu (truncate t_mem - f_imem) (truncate t_dsk - f_idsk)
223 in (rini, rfin, runa)
225 -- | The names and weights of the individual elements in the CV list
226 detailedCVInfo :: [(Double, String)]
227 detailedCVInfo = [ (1, "free_mem_cv")
228 , (1, "free_disk_cv")
230 , (1, "reserved_mem_cv")
231 , (4, "offline_all_cnt")
232 , (16, "offline_pri_cnt")
233 , (1, "vcpu_ratio_cv")
236 , (1, "disk_load_cv")
238 , (2, "pri_tags_score")
241 detailedCVWeights :: [Double]
242 detailedCVWeights = map fst detailedCVInfo
244 -- | Compute the mem and disk covariance.
245 compDetailedCV :: Node.List -> [Double]
248 all_nodes = Container.elems nl
249 (offline, nodes) = partition Node.offline all_nodes
250 mem_l = map Node.pMem nodes
251 dsk_l = map Node.pDsk nodes
252 -- metric: memory covariance
253 mem_cv = stdDev mem_l
254 -- metric: disk covariance
255 dsk_cv = stdDev dsk_l
256 -- metric: count of instances living on N1 failing nodes
257 n1_score = fromIntegral . sum . map (\n -> length (Node.sList n) +
258 length (Node.pList n)) .
259 filter Node.failN1 $ nodes :: Double
260 res_l = map Node.pRem nodes
261 -- metric: reserved memory covariance
262 res_cv = stdDev res_l
263 -- offline instances metrics
264 offline_ipri = sum . map (length . Node.pList) $ offline
265 offline_isec = sum . map (length . Node.sList) $ offline
266 -- metric: count of instances on offline nodes
267 off_score = fromIntegral (offline_ipri + offline_isec)::Double
268 -- metric: count of primary instances on offline nodes (this
269 -- helps with evacuation/failover of primary instances on
270 -- 2-node clusters with one node offline)
271 off_pri_score = fromIntegral offline_ipri::Double
272 cpu_l = map Node.pCpu nodes
273 -- metric: covariance of vcpu/pcpu ratio
274 cpu_cv = stdDev cpu_l
275 -- metrics: covariance of cpu, memory, disk and network load
276 (c_load, m_load, d_load, n_load) = unzip4 $
278 let DynUtil c1 m1 d1 n1 = Node.utilLoad n
279 DynUtil c2 m2 d2 n2 = Node.utilPool n
280 in (c1/c2, m1/m2, d1/d2, n1/n2)
282 -- metric: conflicting instance count
283 pri_tags_inst = sum $ map Node.conflictingPrimaries nodes
284 pri_tags_score = fromIntegral pri_tags_inst::Double
285 in [ mem_cv, dsk_cv, n1_score, res_cv, off_score, off_pri_score, cpu_cv
286 , stdDev c_load, stdDev m_load , stdDev d_load, stdDev n_load
289 -- | Compute the /total/ variance.
290 compCV :: Node.List -> Double
291 compCV = sum . zipWith (*) detailedCVWeights . compDetailedCV
293 -- | Compute online nodes from a Node.List
294 getOnline :: Node.List -> [Node.Node]
295 getOnline = filter (not . Node.offline) . Container.elems
299 -- | Compute best table. Note that the ordering of the arguments is important.
300 compareTables :: Table -> Table -> Table
301 compareTables a@(Table _ _ a_cv _) b@(Table _ _ b_cv _ ) =
302 if a_cv > b_cv then b else a
304 -- | Applies an instance move to a given node list and instance.
305 applyMove :: Node.List -> Instance.Instance
306 -> IMove -> OpResult (Node.List, Instance.Instance, Ndx, Ndx)
308 applyMove nl inst Failover =
309 let old_pdx = Instance.pNode inst
310 old_sdx = Instance.sNode inst
311 old_p = Container.find old_pdx nl
312 old_s = Container.find old_sdx nl
313 int_p = Node.removePri old_p inst
314 int_s = Node.removeSec old_s inst
315 force_p = Node.offline old_p
316 new_nl = do -- Maybe monad
317 new_p <- Node.addPriEx force_p int_s inst
318 new_s <- Node.addSec int_p inst old_sdx
319 let new_inst = Instance.setBoth inst old_sdx old_pdx
320 return (Container.addTwo old_pdx new_s old_sdx new_p nl,
321 new_inst, old_sdx, old_pdx)
324 -- Replace the primary (f:, r:np, f)
325 applyMove nl inst (ReplacePrimary new_pdx) =
326 let old_pdx = Instance.pNode inst
327 old_sdx = Instance.sNode inst
328 old_p = Container.find old_pdx nl
329 old_s = Container.find old_sdx nl
330 tgt_n = Container.find new_pdx nl
331 int_p = Node.removePri old_p inst
332 int_s = Node.removeSec old_s inst
333 force_p = Node.offline old_p
334 new_nl = do -- Maybe monad
335 -- check that the current secondary can host the instance
336 -- during the migration
337 tmp_s <- Node.addPriEx force_p int_s inst
338 let tmp_s' = Node.removePri tmp_s inst
339 new_p <- Node.addPriEx force_p tgt_n inst
340 new_s <- Node.addSecEx force_p tmp_s' inst new_pdx
341 let new_inst = Instance.setPri inst new_pdx
342 return (Container.add new_pdx new_p $
343 Container.addTwo old_pdx int_p old_sdx new_s nl,
344 new_inst, new_pdx, old_sdx)
347 -- Replace the secondary (r:ns)
348 applyMove nl inst (ReplaceSecondary new_sdx) =
349 let old_pdx = Instance.pNode inst
350 old_sdx = Instance.sNode inst
351 old_s = Container.find old_sdx nl
352 tgt_n = Container.find new_sdx nl
353 int_s = Node.removeSec old_s inst
354 force_s = Node.offline old_s
355 new_inst = Instance.setSec inst new_sdx
356 new_nl = Node.addSecEx force_s tgt_n inst old_pdx >>=
357 \new_s -> return (Container.addTwo new_sdx
358 new_s old_sdx int_s nl,
359 new_inst, old_pdx, new_sdx)
362 -- Replace the secondary and failover (r:np, f)
363 applyMove nl inst (ReplaceAndFailover new_pdx) =
364 let old_pdx = Instance.pNode inst
365 old_sdx = Instance.sNode inst
366 old_p = Container.find old_pdx nl
367 old_s = Container.find old_sdx nl
368 tgt_n = Container.find new_pdx nl
369 int_p = Node.removePri old_p inst
370 int_s = Node.removeSec old_s inst
371 force_s = Node.offline old_s
372 new_nl = do -- Maybe monad
373 new_p <- Node.addPri tgt_n inst
374 new_s <- Node.addSecEx force_s int_p inst new_pdx
375 let new_inst = Instance.setBoth inst new_pdx old_pdx
376 return (Container.add new_pdx new_p $
377 Container.addTwo old_pdx new_s old_sdx int_s nl,
378 new_inst, new_pdx, old_pdx)
381 -- Failver and replace the secondary (f, r:ns)
382 applyMove nl inst (FailoverAndReplace new_sdx) =
383 let old_pdx = Instance.pNode inst
384 old_sdx = Instance.sNode inst
385 old_p = Container.find old_pdx nl
386 old_s = Container.find old_sdx nl
387 tgt_n = Container.find new_sdx nl
388 int_p = Node.removePri old_p inst
389 int_s = Node.removeSec old_s inst
390 force_p = Node.offline old_p
391 new_nl = do -- Maybe monad
392 new_p <- Node.addPriEx force_p int_s inst
393 new_s <- Node.addSecEx force_p tgt_n inst old_sdx
394 let new_inst = Instance.setBoth inst old_sdx new_sdx
395 return (Container.add new_sdx new_s $
396 Container.addTwo old_sdx new_p old_pdx int_p nl,
397 new_inst, old_sdx, new_sdx)
400 -- | Tries to allocate an instance on one given node.
401 allocateOnSingle :: Node.List -> Instance.Instance -> Node.Node
402 -> OpResult Node.AllocElement
403 allocateOnSingle nl inst p =
404 let new_pdx = Node.idx p
405 new_inst = Instance.setBoth inst new_pdx Node.noSecondary
406 in Node.addPri p inst >>= \new_p -> do
407 let new_nl = Container.add new_pdx new_p nl
408 new_score = compCV nl
409 return (new_nl, new_inst, [new_p], new_score)
411 -- | Tries to allocate an instance on a given pair of nodes.
412 allocateOnPair :: Node.List -> Instance.Instance -> Node.Node -> Node.Node
413 -> OpResult Node.AllocElement
414 allocateOnPair nl inst tgt_p tgt_s =
415 let new_pdx = Node.idx tgt_p
416 new_sdx = Node.idx tgt_s
418 new_p <- Node.addPri tgt_p inst
419 new_s <- Node.addSec tgt_s inst new_pdx
420 let new_inst = Instance.setBoth inst new_pdx new_sdx
421 new_nl = Container.addTwo new_pdx new_p new_sdx new_s nl
422 return (new_nl, new_inst, [new_p, new_s], compCV new_nl)
424 -- | Tries to perform an instance move and returns the best table
425 -- between the original one and the new one.
426 checkSingleStep :: Table -- ^ The original table
427 -> Instance.Instance -- ^ The instance to move
428 -> Table -- ^ The current best table
429 -> IMove -- ^ The move to apply
430 -> Table -- ^ The final best table
431 checkSingleStep ini_tbl target cur_tbl move =
433 Table ini_nl ini_il _ ini_plc = ini_tbl
434 tmp_resu = applyMove ini_nl target move
438 OpGood (upd_nl, new_inst, pri_idx, sec_idx) ->
439 let tgt_idx = Instance.idx target
440 upd_cvar = compCV upd_nl
441 upd_il = Container.add tgt_idx new_inst ini_il
442 upd_plc = (tgt_idx, pri_idx, sec_idx, move, upd_cvar):ini_plc
443 upd_tbl = Table upd_nl upd_il upd_cvar upd_plc
445 compareTables cur_tbl upd_tbl
447 -- | Given the status of the current secondary as a valid new node and
448 -- the current candidate target node, generate the possible moves for
450 possibleMoves :: Bool -- ^ Whether the secondary node is a valid new node
451 -> Ndx -- ^ Target node candidate
452 -> [IMove] -- ^ List of valid result moves
453 possibleMoves True tdx =
454 [ReplaceSecondary tdx,
455 ReplaceAndFailover tdx,
457 FailoverAndReplace tdx]
459 possibleMoves False tdx =
460 [ReplaceSecondary tdx,
461 ReplaceAndFailover tdx]
463 -- | Compute the best move for a given instance.
464 checkInstanceMove :: [Ndx] -- ^ Allowed target node indices
465 -> Bool -- ^ Whether disk moves are allowed
466 -> Table -- ^ Original table
467 -> Instance.Instance -- ^ Instance to move
468 -> Table -- ^ Best new table for this instance
469 checkInstanceMove nodes_idx disk_moves ini_tbl target =
471 opdx = Instance.pNode target
472 osdx = Instance.sNode target
473 nodes = filter (\idx -> idx /= opdx && idx /= osdx) nodes_idx
474 use_secondary = elem osdx nodes_idx
475 aft_failover = if use_secondary -- if allowed to failover
476 then checkSingleStep ini_tbl target ini_tbl Failover
478 all_moves = if disk_moves
479 then concatMap (possibleMoves use_secondary) nodes
482 -- iterate over the possible nodes for this instance
483 foldl' (checkSingleStep ini_tbl target) aft_failover all_moves
485 -- | Compute the best next move.
486 checkMove :: [Ndx] -- ^ Allowed target node indices
487 -> Bool -- ^ Whether disk moves are allowed
488 -> Table -- ^ The current solution
489 -> [Instance.Instance] -- ^ List of instances still to move
490 -> Table -- ^ The new solution
491 checkMove nodes_idx disk_moves ini_tbl victims =
492 let Table _ _ _ ini_plc = ini_tbl
493 -- iterate over all instances, computing the best move
497 compareTables step_tbl $
498 checkInstanceMove nodes_idx disk_moves ini_tbl em)
500 Table _ _ _ best_plc = best_tbl
501 in if length best_plc == length ini_plc
502 then ini_tbl -- no advancement
505 -- | Check if we are allowed to go deeper in the balancing
506 doNextBalance :: Table -- ^ The starting table
507 -> Int -- ^ Remaining length
508 -> Score -- ^ Score at which to stop
509 -> Bool -- ^ The resulting table and commands
510 doNextBalance ini_tbl max_rounds min_score =
511 let Table _ _ ini_cv ini_plc = ini_tbl
512 ini_plc_len = length ini_plc
513 in (max_rounds < 0 || ini_plc_len < max_rounds) && ini_cv > min_score
515 -- | Run a balance move
516 tryBalance :: Table -- ^ The starting table
517 -> Bool -- ^ Allow disk moves
518 -> Bool -- ^ Only evacuate moves
519 -> Score -- ^ Min gain threshold
520 -> Score -- ^ Min gain
521 -> Maybe Table -- ^ The resulting table and commands
522 tryBalance ini_tbl disk_moves evac_mode mg_limit min_gain =
523 let Table ini_nl ini_il ini_cv _ = ini_tbl
524 all_inst = Container.elems ini_il
525 all_inst' = if evac_mode
526 then let bad_nodes = map Node.idx . filter Node.offline $
527 Container.elems ini_nl
528 in filter (\e -> Instance.sNode e `elem` bad_nodes ||
529 Instance.pNode e `elem` bad_nodes)
532 reloc_inst = filter Instance.movable all_inst'
533 node_idx = map Node.idx . filter (not . Node.offline) $
534 Container.elems ini_nl
535 fin_tbl = checkMove node_idx disk_moves ini_tbl reloc_inst
536 (Table _ _ fin_cv _) = fin_tbl
538 if fin_cv < ini_cv && (ini_cv > mg_limit || ini_cv - fin_cv >= min_gain)
539 then Just fin_tbl -- this round made success, return the new table
542 -- * Allocation functions
544 -- | Build failure stats out of a list of failures
545 collapseFailures :: [FailMode] -> FailStats
546 collapseFailures flst =
547 map (\k -> (k, length $ filter (k ==) flst)) [minBound..maxBound]
549 -- | Update current Allocation solution and failure stats with new
551 concatAllocs :: AllocSolution -> OpResult Node.AllocElement -> AllocSolution
552 concatAllocs as (OpFail reason) = as { asFailures = reason : asFailures as }
554 concatAllocs as (OpGood ns@(_, _, _, nscore)) =
555 let -- Choose the old or new solution, based on the cluster score
557 osols = asSolutions as
558 nsols = case osols of
560 (_, _, _, oscore):[] ->
564 -- FIXME: here we simply concat to lists with more
565 -- than one element; we should instead abort, since
566 -- this is not a valid usage of this function
569 -- Note: we force evaluation of nsols here in order to keep the
570 -- memory profile low - we know that we will need nsols for sure
571 -- in the next cycle, so we force evaluation of nsols, since the
572 -- foldl' in the caller will only evaluate the tuple, but not the
573 -- elements of the tuple
574 in nsols `seq` nsuc `seq` as { asAllocs = nsuc, asSolutions = nsols }
576 -- | Given a solution, generates a reasonable description for it
577 describeSolution :: AllocSolution -> String
578 describeSolution as =
579 let fcnt = asFailures as
580 sols = asSolutions as
582 intercalate ", " . map (\(a, b) -> printf "%s: %d" (show a) b) .
583 filter ((> 0) . snd) . collapseFailures $ fcnt
585 then "No valid allocation solutions, failure reasons: " ++
587 then "unknown reasons"
589 else let (_, _, nodes, cv) = head sols
590 in printf ("score: %.8f, successes %d, failures %d (%s)" ++
591 " for node(s) %s") cv (asAllocs as) (length fcnt) freasons
592 (intercalate "/" . map Node.name $ nodes)
594 -- | Annotates a solution with the appropriate string
595 annotateSolution :: AllocSolution -> AllocSolution
596 annotateSolution as = as { asLog = describeSolution as : asLog as }
598 -- | Try to allocate an instance on the cluster.
599 tryAlloc :: (Monad m) =>
600 Node.List -- ^ The node list
601 -> Instance.List -- ^ The instance list
602 -> Instance.Instance -- ^ The instance to allocate
603 -> Int -- ^ Required number of nodes
604 -> m AllocSolution -- ^ Possible solution list
605 tryAlloc nl _ inst 2 =
606 let all_nodes = getOnline nl
607 all_pairs = liftM2 (,) all_nodes all_nodes
608 ok_pairs = filter (\(x, y) -> Node.idx x /= Node.idx y) all_pairs
609 sols = foldl' (\cstate (p, s) ->
610 concatAllocs cstate $ allocateOnPair nl inst p s
611 ) emptySolution ok_pairs
613 in if null ok_pairs -- means we have just one node
614 then fail "Not enough online nodes"
615 else return $ annotateSolution sols
617 tryAlloc nl _ inst 1 =
618 let all_nodes = getOnline nl
619 sols = foldl' (\cstate ->
620 concatAllocs cstate . allocateOnSingle nl inst
621 ) emptySolution all_nodes
623 then fail "No online nodes"
624 else return $ annotateSolution sols
626 tryAlloc _ _ _ reqn = fail $ "Unsupported number of allocation \
627 \destinations required (" ++ show reqn ++
628 "), only two supported"
630 -- | Given a group/result, describe it as a nice (list of) messages
631 solutionDescription :: Group.List -> (Gdx, Result AllocSolution) -> [String]
632 solutionDescription gl (groupId, result) =
634 Ok solution -> map (printf "Group %s (%s): %s" gname pol) (asLog solution)
635 Bad message -> [printf "Group %s: error %s" gname message]
636 where grp = Container.find groupId gl
637 gname = Group.name grp
638 pol = apolToString (Group.allocPolicy grp)
640 -- | From a list of possibly bad and possibly empty solutions, filter
641 -- only the groups with a valid result
642 filterMGResults :: Group.List
643 -> [(Gdx, Result AllocSolution)]
644 -> [(Gdx, AllocSolution)]
646 filter ((/= AllocUnallocable) . Group.allocPolicy .
647 flip Container.find gl . fst) .
648 filter (not . null . asSolutions . snd) .
649 map (\(y, Ok x) -> (y, x)) .
652 -- | Sort multigroup results based on policy and score
653 sortMGResults :: Group.List
654 -> [(Gdx, AllocSolution)]
655 -> [(Gdx, AllocSolution)]
656 sortMGResults gl sols =
657 let extractScore = \(_, _, _, x) -> x
658 solScore (gdx, sol) = (Group.allocPolicy (Container.find gdx gl),
659 (extractScore . head . asSolutions) sol)
660 in sortBy (comparing solScore) sols
662 -- | Try to allocate an instance on a multi-group cluster.
663 tryMGAlloc :: Group.List -- ^ The group list
664 -> Node.List -- ^ The node list
665 -> Instance.List -- ^ The instance list
666 -> Instance.Instance -- ^ The instance to allocate
667 -> Int -- ^ Required number of nodes
668 -> Result AllocSolution -- ^ Possible solution list
669 tryMGAlloc mggl mgnl mgil inst cnt =
670 let groups = splitCluster mgnl mgil
671 -- TODO: currently we consider all groups preferred
672 sols = map (\(gid, (nl, il)) ->
673 (gid, tryAlloc nl il inst cnt)) groups::
674 [(Gdx, Result AllocSolution)]
675 all_msgs = concatMap (solutionDescription mggl) sols
676 goodSols = filterMGResults mggl sols
677 sortedSols = sortMGResults mggl goodSols
678 in if null sortedSols
679 then Bad $ intercalate ", " all_msgs
680 else let (final_group, final_sol) = head sortedSols
681 final_name = Group.name $ Container.find final_group mggl
682 selmsg = "Selected group: " ++ final_name
683 in Ok $ final_sol { asLog = selmsg:all_msgs }
685 -- | Try to relocate an instance on the cluster.
686 tryReloc :: (Monad m) =>
687 Node.List -- ^ The node list
688 -> Instance.List -- ^ The instance list
689 -> Idx -- ^ The index of the instance to move
690 -> Int -- ^ The number of nodes required
691 -> [Ndx] -- ^ Nodes which should not be used
692 -> m AllocSolution -- ^ Solution list
693 tryReloc nl il xid 1 ex_idx =
694 let all_nodes = getOnline nl
695 inst = Container.find xid il
696 ex_idx' = Instance.pNode inst:ex_idx
697 valid_nodes = filter (not . flip elem ex_idx' . Node.idx) all_nodes
698 valid_idxes = map Node.idx valid_nodes
699 sols1 = foldl' (\cstate x ->
702 applyMove nl inst (ReplaceSecondary x)
703 return (mnl, i, [Container.find x mnl],
705 in concatAllocs cstate em
706 ) emptySolution valid_idxes
709 tryReloc _ _ _ reqn _ = fail $ "Unsupported number of relocation \
710 \destinations required (" ++ show reqn ++
711 "), only one supported"
713 -- | Try to evacuate a list of nodes.
714 tryEvac :: (Monad m) =>
715 Node.List -- ^ The node list
716 -> Instance.List -- ^ The instance list
717 -> [Ndx] -- ^ Nodes to be evacuated
718 -> m AllocSolution -- ^ Solution list
719 tryEvac nl il ex_ndx =
720 let ex_nodes = map (`Container.find` nl) ex_ndx
721 all_insts = nub . concatMap Node.sList $ ex_nodes
723 (_, sol) <- foldM (\(nl', old_as) idx -> do
724 -- FIXME: hardcoded one node here
726 new_as <- tryReloc nl' il idx 1 ex_ndx
727 case asSolutions new_as of
728 csol@(nl'', _, _, _):_ ->
729 -- an individual relocation succeeded,
730 -- we kind of compose the data from
733 new_as { asSolutions =
734 csol:asSolutions old_as })
735 -- this relocation failed, so we fail
737 _ -> fail $ "Can't evacuate instance " ++
738 Instance.name (Container.find idx il) ++
739 ": " ++ describeSolution new_as
740 ) (nl, emptySolution) all_insts
741 return $ annotateSolution sol
743 -- | Recursively place instances on the cluster until we're out of space
744 iterateAlloc :: Node.List
748 -> [Instance.Instance]
749 -> Result (FailStats, Node.List, Instance.List,
751 iterateAlloc nl il newinst nreq ixes =
752 let depth = length ixes
753 newname = printf "new-%d" depth::String
754 newidx = length (Container.elems il) + depth
755 newi2 = Instance.setIdx (Instance.setName newinst newname) newidx
756 in case tryAlloc nl il newi2 nreq of
758 Ok (AllocSolution { asFailures = errs, asSolutions = sols3 }) ->
760 [] -> Ok (collapseFailures errs, nl, il, ixes)
761 (xnl, xi, _, _):[] ->
762 iterateAlloc xnl (Container.add newidx xi il)
763 newinst nreq $! (xi:ixes)
764 _ -> Bad "Internal error: multiple solutions for single\
767 -- | The core of the tiered allocation mode
768 tieredAlloc :: Node.List
772 -> [Instance.Instance]
773 -> Result (FailStats, Node.List, Instance.List,
775 tieredAlloc nl il newinst nreq ixes =
776 case iterateAlloc nl il newinst nreq ixes of
778 Ok (errs, nl', il', ixes') ->
779 case Instance.shrinkByType newinst . fst . last $
780 sortBy (comparing snd) errs of
781 Bad _ -> Ok (errs, nl', il', ixes')
783 tieredAlloc nl' il' newinst' nreq ixes'
785 -- | Compute the tiered spec string description from a list of
786 -- allocated instances.
787 tieredSpecMap :: [Instance.Instance]
789 tieredSpecMap trl_ixes =
790 let fin_trl_ixes = reverse trl_ixes
791 ix_byspec = groupBy ((==) `on` Instance.specOf) fin_trl_ixes
792 spec_map = map (\ixs -> (Instance.specOf $ head ixs, length ixs))
794 in map (\(spec, cnt) -> printf "%d,%d,%d=%d" (rspecMem spec)
795 (rspecDsk spec) (rspecCpu spec) cnt) spec_map
797 -- * Formatting functions
799 -- | Given the original and final nodes, computes the relocation description.
800 computeMoves :: Instance.Instance -- ^ The instance to be moved
801 -> String -- ^ The instance name
802 -> IMove -- ^ The move being performed
803 -> String -- ^ New primary
804 -> String -- ^ New secondary
805 -> (String, [String])
806 -- ^ Tuple of moves and commands list; moves is containing
807 -- either @/f/@ for failover or @/r:name/@ for replace
808 -- secondary, while the command list holds gnt-instance
809 -- commands (without that prefix), e.g \"@failover instance1@\"
810 computeMoves i inam mv c d =
812 Failover -> ("f", [mig])
813 FailoverAndReplace _ -> (printf "f r:%s" d, [mig, rep d])
814 ReplaceSecondary _ -> (printf "r:%s" d, [rep d])
815 ReplaceAndFailover _ -> (printf "r:%s f" c, [rep c, mig])
816 ReplacePrimary _ -> (printf "f r:%s f" c, [mig, rep c, mig])
817 where morf = if Instance.running i then "migrate" else "failover"
818 mig = printf "%s -f %s" morf inam::String
819 rep n = printf "replace-disks -n %s %s" n inam
821 -- | Converts a placement to string format.
822 printSolutionLine :: Node.List -- ^ The node list
823 -> Instance.List -- ^ The instance list
824 -> Int -- ^ Maximum node name length
825 -> Int -- ^ Maximum instance name length
826 -> Placement -- ^ The current placement
827 -> Int -- ^ The index of the placement in
829 -> (String, [String])
830 printSolutionLine nl il nmlen imlen plc pos =
832 pmlen = (2*nmlen + 1)
833 (i, p, s, mv, c) = plc
834 inst = Container.find i il
835 inam = Instance.alias inst
836 npri = Node.alias $ Container.find p nl
837 nsec = Node.alias $ Container.find s nl
838 opri = Node.alias $ Container.find (Instance.pNode inst) nl
839 osec = Node.alias $ Container.find (Instance.sNode inst) nl
840 (moves, cmds) = computeMoves inst inam mv npri nsec
841 ostr = printf "%s:%s" opri osec::String
842 nstr = printf "%s:%s" npri nsec::String
844 (printf " %3d. %-*s %-*s => %-*s %.8f a=%s"
845 pos imlen inam pmlen ostr
849 -- | Return the instance and involved nodes in an instance move.
850 involvedNodes :: Instance.List -> Placement -> [Ndx]
851 involvedNodes il plc =
852 let (i, np, ns, _, _) = plc
853 inst = Container.find i il
854 op = Instance.pNode inst
855 os = Instance.sNode inst
856 in nub [np, ns, op, os]
858 -- | Inner function for splitJobs, that either appends the next job to
859 -- the current jobset, or starts a new jobset.
860 mergeJobs :: ([JobSet], [Ndx]) -> MoveJob -> ([JobSet], [Ndx])
861 mergeJobs ([], _) n@(ndx, _, _, _) = ([[n]], ndx)
862 mergeJobs (cjs@(j:js), nbuf) n@(ndx, _, _, _)
863 | null (ndx `intersect` nbuf) = ((n:j):js, ndx ++ nbuf)
864 | otherwise = ([n]:cjs, ndx)
866 -- | Break a list of moves into independent groups. Note that this
867 -- will reverse the order of jobs.
868 splitJobs :: [MoveJob] -> [JobSet]
869 splitJobs = fst . foldl mergeJobs ([], [])
871 -- | Given a list of commands, prefix them with @gnt-instance@ and
872 -- also beautify the display a little.
873 formatJob :: Int -> Int -> (Int, MoveJob) -> [String]
874 formatJob jsn jsl (sn, (_, _, _, cmds)) =
876 printf " echo job %d/%d" jsn sn:
878 map (" gnt-instance " ++) cmds
880 then ["", printf "echo jobset %d, %d jobs" jsn jsl] ++ out
883 -- | Given a list of commands, prefix them with @gnt-instance@ and
884 -- also beautify the display a little.
885 formatCmds :: [JobSet] -> String
888 concatMap (\(jsn, js) -> concatMap (formatJob jsn (length js))
892 -- | Print the node list.
893 printNodes :: Node.List -> [String] -> String
895 let fields = case fs of
896 [] -> Node.defaultFields
897 "+":rest -> Node.defaultFields ++ rest
899 snl = sortBy (comparing Node.idx) (Container.elems nl)
900 (header, isnum) = unzip $ map Node.showHeader fields
901 in unlines . map ((:) ' ' . intercalate " ") $
902 formatTable (header:map (Node.list fields) snl) isnum
904 -- | Print the instance list.
905 printInsts :: Node.List -> Instance.List -> String
907 let sil = sortBy (comparing Instance.idx) (Container.elems il)
908 helper inst = [ if Instance.running inst then "R" else " "
910 , Container.nameOf nl (Instance.pNode inst)
911 , let sdx = Instance.sNode inst
912 in if sdx == Node.noSecondary
914 else Container.nameOf nl sdx
915 , printf "%3d" $ Instance.vcpus inst
916 , printf "%5d" $ Instance.mem inst
917 , printf "%5d" $ Instance.dsk inst `div` 1024
923 where DynUtil lC lM lD lN = Instance.util inst
924 header = [ "F", "Name", "Pri_node", "Sec_node", "vcpu", "mem"
925 , "dsk", "lCpu", "lMem", "lDsk", "lNet" ]
926 isnum = False:False:False:False:repeat True
927 in unlines . map ((:) ' ' . intercalate " ") $
928 formatTable (header:map helper sil) isnum
930 -- | Shows statistics for a given node list.
931 printStats :: Node.List -> String
933 let dcvs = compDetailedCV nl
934 (weights, names) = unzip detailedCVInfo
935 hd = zip3 (weights ++ repeat 1) (names ++ repeat "unknown") dcvs
936 formatted = map (\(w, header, val) ->
937 printf "%s=%.8f(x%.2f)" header val w::String) hd
938 in intercalate ", " formatted
940 -- | Convert a placement into a list of OpCodes (basically a job).
941 iMoveToJob :: Node.List -> Instance.List
942 -> Idx -> IMove -> [OpCodes.OpCode]
943 iMoveToJob nl il idx move =
944 let inst = Container.find idx il
945 iname = Instance.name inst
946 lookNode = Just . Container.nameOf nl
947 opF = if Instance.running inst
948 then OpCodes.OpMigrateInstance iname True False
949 else OpCodes.OpFailoverInstance iname False
950 opR n = OpCodes.OpReplaceDisks iname (lookNode n)
951 OpCodes.ReplaceNewSecondary [] Nothing
954 ReplacePrimary np -> [ opF, opR np, opF ]
955 ReplaceSecondary ns -> [ opR ns ]
956 ReplaceAndFailover np -> [ opR np, opF ]
957 FailoverAndReplace ns -> [ opF, opR ns ]
959 -- * Node group functions
961 -- | Computes the group of an instance
962 instanceGroup :: Node.List -> Instance.Instance -> Result Gdx
964 let sidx = Instance.sNode i
965 pnode = Container.find (Instance.pNode i) nl
966 snode = if sidx == Node.noSecondary
968 else Container.find sidx nl
969 pgroup = Node.group pnode
970 sgroup = Node.group snode
971 in if pgroup /= sgroup
972 then fail ("Instance placed accross two node groups, primary " ++
973 show pgroup ++ ", secondary " ++ show sgroup)
976 -- | Compute the list of badly allocated instances (split across node
978 findSplitInstances :: Node.List -> Instance.List -> [Instance.Instance]
979 findSplitInstances nl il =
980 filter (not . isOk . instanceGroup nl) (Container.elems il)
982 -- | Splits a cluster into the component node groups
983 splitCluster :: Node.List -> Instance.List ->
984 [(Gdx, (Node.List, Instance.List))]
986 let ngroups = Node.computeGroups (Container.elems nl)
987 in map (\(guuid, nodes) ->
988 let nidxs = map Node.idx nodes
989 nodes' = zip nidxs nodes
990 instances = Container.filter ((`elem` nidxs) . Instance.pNode) il
991 in (guuid, (Container.fromAssocList nodes', instances))) ngroups