code.grnet.gr Git - ganeti-local/blob - Ganeti/HTools/Cluster.hs

   1 {-| Implementation of cluster-wide logic.
   2
   3 This module holds all pure cluster-logic; I\/O related functionality
   4 goes into the "Main" module for the individual binaries.
   5
   6 -}
   7
   8 module Ganeti.HTools.Cluster
   9     (
  10      -- * Types
  11       Placement
  12     , Solution(..)
  13     , Table(..)
  14     , Removal
  15     , Score
  16     , IMove(..)
  17     -- * Generic functions
  18     , totalResources
  19     -- * First phase functions
  20     , computeBadItems
  21     -- * Second phase functions
  22     , computeSolution
  23     , applySolution
  24     , printSolution
  25     , printSolutionLine
  26     , formatCmds
  27     , printNodes
  28     -- * Balacing functions
  29     , applyMove
  30     , checkMove
  31     , compCV
  32     , printStats
  33     -- * IAllocator functions
  34     , allocateOnSingle
  35     , allocateOnPair
  36     , tryAlloc
  37     , tryReloc
  38     ) where
  39
  40 import Data.List
  41 import Data.Maybe (isNothing, fromJust)
  42 import Text.Printf (printf)
  43 import Data.Function
  44 import Control.Monad
  45
  46 import qualified Ganeti.HTools.Container as Container
  47 import qualified Ganeti.HTools.Instance as Instance
  48 import qualified Ganeti.HTools.Node as Node
  49 import Ganeti.HTools.Types
  50 import Ganeti.HTools.Utils
  51
  52 -- * Types
  53
  54 -- | A separate name for the cluster score type.
  55 type Score = Double
  56
  57 -- | The description of an instance placement.
  58 type Placement = (Idx, Ndx, Ndx, Score)
  59
  60 -- | A cluster solution described as the solution delta and the list
  61 -- of placements.
  62 data Solution = Solution Int [Placement]
  63                 deriving (Eq, Ord, Show)
  64
  65 -- | A removal set.
  66 data Removal = Removal Node.List [Instance.Instance]
  67
  68 -- | An instance move definition
  69 data IMove = Failover                -- ^ Failover the instance (f)
  70            | ReplacePrimary Ndx      -- ^ Replace primary (f, r:np, f)
  71            | ReplaceSecondary Ndx    -- ^ Replace secondary (r:ns)
  72            | ReplaceAndFailover Ndx  -- ^ Replace secondary, failover (r:np, f)
  73            | FailoverAndReplace Ndx  -- ^ Failover, replace secondary (f, r:ns)
  74              deriving (Show)
  75
  76 -- | The complete state for the balancing solution
  77 data Table = Table Node.List Instance.List Score [Placement]
  78              deriving (Show)
  79
  80 -- * Utility functions
  81
  82 -- | Returns the delta of a solution or -1 for Nothing.
  83 solutionDelta :: Maybe Solution -> Int
  84 solutionDelta sol = case sol of
  85                       Just (Solution d _) -> d
  86                       _ -> -1
  87
  88 -- | Cap the removal list if needed.
  89 capRemovals :: [a] -> Int -> [a]
  90 capRemovals removals max_removals =
  91     if max_removals > 0 then
  92         take max_removals removals
  93     else
  94         removals
  95
  96 -- | Check if the given node list fails the N+1 check.
  97 verifyN1Check :: [Node.Node] -> Bool
  98 verifyN1Check nl = any Node.failN1 nl
  99
 100 -- | Verifies the N+1 status and return the affected nodes.
 101 verifyN1 :: [Node.Node] -> [Node.Node]
 102 verifyN1 nl = filter Node.failN1 nl
 103
 104 {-| Computes the pair of bad nodes and instances.
 105
 106 The bad node list is computed via a simple 'verifyN1' check, and the
 107 bad instance list is the list of primary and secondary instances of
 108 those nodes.
 109
 110 -}
 111 computeBadItems :: Node.List -> Instance.List ->
 112                    ([Node.Node], [Instance.Instance])
 113 computeBadItems nl il =
 114   let bad_nodes = verifyN1 $ getOnline nl
 115       bad_instances = map (\idx -> Container.find idx il) $
 116                       sort $ nub $ concat $
 117                       map (\ n -> (Node.slist n) ++ (Node.plist n)) bad_nodes
 118   in
 119     (bad_nodes, bad_instances)
 120
 121 -- | Compute the total free disk and memory in the cluster.
 122 totalResources :: Node.List -> (Int, Int)
 123 totalResources nl =
 124     foldl'
 125     (\ (mem, dsk) node -> (mem + (Node.f_mem node),
 126                            dsk + (Node.f_dsk node)))
 127     (0, 0) (Container.elems nl)
 128
 129 -- | Compute the mem and disk covariance.
 130 compDetailedCV :: Node.List -> (Double, Double, Double, Double, Double)
 131 compDetailedCV nl =
 132     let
 133         all_nodes = Container.elems nl
 134         (offline, nodes) = partition Node.offline all_nodes
 135         mem_l = map Node.p_mem nodes
 136         dsk_l = map Node.p_dsk nodes
 137         mem_cv = varianceCoeff mem_l
 138         dsk_cv = varianceCoeff dsk_l
 139         n1_l = length $ filter Node.failN1 nodes
 140         n1_score = (fromIntegral n1_l) / (fromIntegral $ length nodes)
 141         res_l = map Node.p_rem nodes
 142         res_cv = varianceCoeff res_l
 143         offline_inst = sum . map (\n -> (length . Node.plist $ n) +
 144                                         (length . Node.slist $ n)) $ offline
 145         online_inst = sum . map (\n -> (length . Node.plist $ n) +
 146                                        (length . Node.slist $ n)) $ nodes
 147         off_score = (fromIntegral offline_inst) /
 148                     (fromIntegral $ online_inst + offline_inst)
 149     in (mem_cv, dsk_cv, n1_score, res_cv, off_score)
 150
 151 -- | Compute the /total/ variance.
 152 compCV :: Node.List -> Double
 153 compCV nl =
 154     let (mem_cv, dsk_cv, n1_score, res_cv, off_score) = compDetailedCV nl
 155     in mem_cv + dsk_cv + n1_score + res_cv + off_score
 156
 157 -- | Compute online nodes from a Node.List
 158 getOnline :: Node.List -> [Node.Node]
 159 getOnline = filter (not . Node.offline) . Container.elems
 160
 161 -- * hn1 functions
 162
 163 -- | Add an instance and return the new node and instance maps.
 164 addInstance :: Node.List -> Instance.Instance ->
 165                Node.Node -> Node.Node -> Maybe Node.List
 166 addInstance nl idata pri sec =
 167   let pdx = Node.idx pri
 168       sdx = Node.idx sec
 169   in do
 170       pnode <- Node.addPri pri idata
 171       snode <- Node.addSec sec idata pdx
 172       new_nl <- return $ Container.addTwo sdx snode
 173                          pdx pnode nl
 174       return new_nl
 175
 176 -- | Remove an instance and return the new node and instance maps.
 177 removeInstance :: Node.List -> Instance.Instance -> Node.List
 178 removeInstance nl idata =
 179   let pnode = Instance.pnode idata
 180       snode = Instance.snode idata
 181       pn = Container.find pnode nl
 182       sn = Container.find snode nl
 183       new_nl = Container.addTwo
 184                pnode (Node.removePri pn idata)
 185                snode (Node.removeSec sn idata) nl in
 186   new_nl
 187
 188 -- | Remove an instance and return the new node map.
 189 removeInstances :: Node.List -> [Instance.Instance] -> Node.List
 190 removeInstances = foldl' removeInstance
 191
 192
 193 {-| Compute a new version of a cluster given a solution.
 194
 195 This is not used for computing the solutions, but for applying a
 196 (known-good) solution to the original cluster for final display.
 197
 198 It first removes the relocated instances after which it places them on
 199 their new nodes.
 200
 201  -}
 202 applySolution :: Node.List -> Instance.List -> [Placement] -> Node.List
 203 applySolution nl il sol =
 204     let odxes = map (\ (a, b, c, _) -> (Container.find a il,
 205                                         Node.idx (Container.find b nl),
 206                                         Node.idx (Container.find c nl))
 207                     ) sol
 208         idxes = (\ (x, _, _) -> x) (unzip3 odxes)
 209         nc = removeInstances nl idxes
 210     in
 211       foldl' (\ nz (a, b, c) ->
 212                  let new_p = Container.find b nz
 213                      new_s = Container.find c nz in
 214                  fromJust (addInstance nz a new_p new_s)
 215            ) nc odxes
 216
 217
 218 -- ** First phase functions
 219
 220 {-| Given a list 1,2,3..n build a list of pairs [(1, [2..n]), (2,
 221     [3..n]), ...]
 222
 223 -}
 224 genParts :: [a] -> Int -> [(a, [a])]
 225 genParts l count =
 226     case l of
 227       [] -> []
 228       x:xs ->
 229           if length l < count then
 230               []
 231           else
 232               (x, xs) : (genParts xs count)
 233
 234 -- | Generates combinations of count items from the names list.
 235 genNames :: Int -> [b] -> [[b]]
 236 genNames count1 names1 =
 237   let aux_fn count names current =
 238           case count of
 239             0 -> [current]
 240             _ ->
 241                 concatMap
 242                 (\ (x, xs) -> aux_fn (count - 1) xs (x:current))
 243                 (genParts names count)
 244   in
 245     aux_fn count1 names1 []
 246
 247 {-| Checks if removal of instances results in N+1 pass.
 248
 249 Note: the check removal cannot optimize by scanning only the affected
 250 nodes, since the cluster is known to be not healthy; only the check
 251 placement can make this shortcut.
 252
 253 -}
 254 checkRemoval :: Node.List -> [Instance.Instance] -> Maybe Removal
 255 checkRemoval nl victims =
 256   let nx = removeInstances nl victims
 257       failN1 = verifyN1Check (Container.elems nx)
 258   in
 259     if failN1 then
 260       Nothing
 261     else
 262       Just $ Removal nx victims
 263
 264
 265 -- | Computes the removals list for a given depth.
 266 computeRemovals :: Node.List
 267                  -> [Instance.Instance]
 268                  -> Int
 269                  -> [Maybe Removal]
 270 computeRemovals nl bad_instances depth =
 271     map (checkRemoval nl) $ genNames depth bad_instances
 272
 273 -- ** Second phase functions
 274
 275 -- | Single-node relocation cost.
 276 nodeDelta :: Ndx -> Ndx -> Ndx -> Int
 277 nodeDelta i p s =
 278     if i == p || i == s then
 279         0
 280     else
 281         1
 282
 283 -- | Compute best solution.
 284 --
 285 -- This function compares two solutions, choosing the minimum valid
 286 -- solution.
 287 compareSolutions :: Maybe Solution -> Maybe Solution -> Maybe Solution
 288 compareSolutions a b = case (a, b) of
 289   (Nothing, x) -> x
 290   (x, Nothing) -> x
 291   (x, y) -> min x y
 292
 293 -- | Check if a given delta is worse then an existing solution.
 294 tooHighDelta :: Maybe Solution -> Int -> Int -> Bool
 295 tooHighDelta sol new_delta max_delta =
 296     if new_delta > max_delta && max_delta >=0 then
 297         True
 298     else
 299         case sol of
 300           Nothing -> False
 301           Just (Solution old_delta _) -> old_delta <= new_delta
 302
 303 {-| Check if placement of instances still keeps the cluster N+1 compliant.
 304
 305     This is the workhorse of the allocation algorithm: given the
 306     current node and instance maps, the list of instances to be
 307     placed, and the current solution, this will return all possible
 308     solution by recursing until all target instances are placed.
 309
 310 -}
 311 checkPlacement :: Node.List            -- ^ The current node list
 312                -> [Instance.Instance] -- ^ List of instances still to place
 313                -> [Placement]         -- ^ Partial solution until now
 314                -> Int                 -- ^ The delta of the partial solution
 315                -> Maybe Solution      -- ^ The previous solution
 316                -> Int                 -- ^ Abort if the we go above this delta
 317                -> Maybe Solution      -- ^ The new solution
 318 checkPlacement nl victims current current_delta prev_sol max_delta =
 319   let target = head victims
 320       opdx = Instance.pnode target
 321       osdx = Instance.snode target
 322       vtail = tail victims
 323       have_tail = (length vtail) > 0
 324       nodes = Container.elems nl
 325       iidx = Instance.idx target
 326   in
 327     foldl'
 328     (\ accu_p pri ->
 329          let
 330              pri_idx = Node.idx pri
 331              upri_delta = current_delta + nodeDelta pri_idx opdx osdx
 332              new_pri = Node.addPri pri target
 333              fail_delta1 = tooHighDelta accu_p upri_delta max_delta
 334          in
 335            if fail_delta1 || isNothing(new_pri) then accu_p
 336            else let pri_nl = Container.add pri_idx (fromJust new_pri) nl in
 337                 foldl'
 338                 (\ accu sec ->
 339                      let
 340                          sec_idx = Node.idx sec
 341                          upd_delta = upri_delta +
 342                                      nodeDelta sec_idx opdx osdx
 343                          fail_delta2 = tooHighDelta accu upd_delta max_delta
 344                          new_sec = Node.addSec sec target pri_idx
 345                      in
 346                        if sec_idx == pri_idx || fail_delta2 ||
 347                           isNothing new_sec then accu
 348                        else let
 349                            nx = Container.add sec_idx (fromJust new_sec) pri_nl
 350                            upd_cv = compCV nx
 351                            plc = (iidx, pri_idx, sec_idx, upd_cv)
 352                            c2 = plc:current
 353                            result =
 354                                if have_tail then
 355                                    checkPlacement nx vtail c2 upd_delta
 356                                                   accu max_delta
 357                                else
 358                                    Just (Solution upd_delta c2)
 359                       in compareSolutions accu result
 360                 ) accu_p nodes
 361     ) prev_sol nodes
 362
 363 {-| Auxiliary function for solution computation.
 364
 365 We write this in an explicit recursive fashion in order to control
 366 early-abort in case we have met the min delta. We can't use foldr
 367 instead of explicit recursion since we need the accumulator for the
 368 abort decision.
 369
 370 -}
 371 advanceSolution :: [Maybe Removal] -- ^ The removal to process
 372                 -> Int             -- ^ Minimum delta parameter
 373                 -> Int             -- ^ Maximum delta parameter
 374                 -> Maybe Solution  -- ^ Current best solution
 375                 -> Maybe Solution  -- ^ New best solution
 376 advanceSolution [] _ _ sol = sol
 377 advanceSolution (Nothing:xs) m n sol = advanceSolution xs m n sol
 378 advanceSolution ((Just (Removal nx removed)):xs) min_d max_d prev_sol =
 379     let new_sol = checkPlacement nx removed [] 0 prev_sol max_d
 380         new_delta = solutionDelta $! new_sol
 381     in
 382       if new_delta >= 0 && new_delta <= min_d then
 383           new_sol
 384       else
 385           advanceSolution xs min_d max_d new_sol
 386
 387 -- | Computes the placement solution.
 388 solutionFromRemovals :: [Maybe Removal] -- ^ The list of (possible) removals
 389                      -> Int             -- ^ Minimum delta parameter
 390                      -> Int             -- ^ Maximum delta parameter
 391                      -> Maybe Solution  -- ^ The best solution found
 392 solutionFromRemovals removals min_delta max_delta =
 393     advanceSolution removals min_delta max_delta Nothing
 394
 395 {-| Computes the solution at the given depth.
 396
 397 This is a wrapper over both computeRemovals and
 398 solutionFromRemovals. In case we have no solution, we return Nothing.
 399
 400 -}
 401 computeSolution :: Node.List        -- ^ The original node data
 402                 -> [Instance.Instance] -- ^ The list of /bad/ instances
 403                 -> Int             -- ^ The /depth/ of removals
 404                 -> Int             -- ^ Maximum number of removals to process
 405                 -> Int             -- ^ Minimum delta parameter
 406                 -> Int             -- ^ Maximum delta parameter
 407                 -> Maybe Solution  -- ^ The best solution found (or Nothing)
 408 computeSolution nl bad_instances depth max_removals min_delta max_delta =
 409   let
 410       removals = computeRemovals nl bad_instances depth
 411       removals' = capRemovals removals max_removals
 412   in
 413     solutionFromRemovals removals' min_delta max_delta
 414
 415 -- * hbal functions
 416
 417 -- | Compute best table. Note that the ordering of the arguments is important.
 418 compareTables :: Table -> Table -> Table
 419 compareTables a@(Table _ _ a_cv _) b@(Table _ _ b_cv _ ) =
 420     if a_cv > b_cv then b else a
 421
 422 -- | Applies an instance move to a given node list and instance.
 423 applyMove :: Node.List -> Instance.Instance
 424           -> IMove -> (Maybe Node.List, Instance.Instance, Ndx, Ndx)
 425 -- Failover (f)
 426 applyMove nl inst Failover =
 427     let old_pdx = Instance.pnode inst
 428         old_sdx = Instance.snode inst
 429         old_p = Container.find old_pdx nl
 430         old_s = Container.find old_sdx nl
 431         int_p = Node.removePri old_p inst
 432         int_s = Node.removeSec old_s inst
 433         new_nl = do -- Maybe monad
 434           new_p <- Node.addPri int_s inst
 435           new_s <- Node.addSec int_p inst old_sdx
 436           return $ Container.addTwo old_pdx new_s old_sdx new_p nl
 437     in (new_nl, Instance.setBoth inst old_sdx old_pdx, old_sdx, old_pdx)
 438
 439 -- Replace the primary (f:, r:np, f)
 440 applyMove nl inst (ReplacePrimary new_pdx) =
 441     let old_pdx = Instance.pnode inst
 442         old_sdx = Instance.snode inst
 443         old_p = Container.find old_pdx nl
 444         old_s = Container.find old_sdx nl
 445         tgt_n = Container.find new_pdx nl
 446         int_p = Node.removePri old_p inst
 447         int_s = Node.removeSec old_s inst
 448         new_nl = do -- Maybe monad
 449           new_p <- Node.addPri tgt_n inst
 450           new_s <- Node.addSec int_s inst new_pdx
 451           return $ Container.add new_pdx new_p $
 452                  Container.addTwo old_pdx int_p old_sdx new_s nl
 453     in (new_nl, Instance.setPri inst new_pdx, new_pdx, old_sdx)
 454
 455 -- Replace the secondary (r:ns)
 456 applyMove nl inst (ReplaceSecondary new_sdx) =
 457     let old_pdx = Instance.pnode inst
 458         old_sdx = Instance.snode inst
 459         old_s = Container.find old_sdx nl
 460         tgt_n = Container.find new_sdx nl
 461         int_s = Node.removeSec old_s inst
 462         new_nl = Node.addSec tgt_n inst old_pdx >>=
 463                  \new_s -> return $ Container.addTwo new_sdx
 464                            new_s old_sdx int_s nl
 465     in (new_nl, Instance.setSec inst new_sdx, old_pdx, new_sdx)
 466
 467 -- Replace the secondary and failover (r:np, f)
 468 applyMove nl inst (ReplaceAndFailover new_pdx) =
 469     let old_pdx = Instance.pnode inst
 470         old_sdx = Instance.snode inst
 471         old_p = Container.find old_pdx nl
 472         old_s = Container.find old_sdx nl
 473         tgt_n = Container.find new_pdx nl
 474         int_p = Node.removePri old_p inst
 475         int_s = Node.removeSec old_s inst
 476         new_nl = do -- Maybe monad
 477           new_p <- Node.addPri tgt_n inst
 478           new_s <- Node.addSec int_p inst new_pdx
 479           return $ Container.add new_pdx new_p $
 480                  Container.addTwo old_pdx new_s old_sdx int_s nl
 481     in (new_nl, Instance.setBoth inst new_pdx old_pdx, new_pdx, old_pdx)
 482
 483 -- Failver and replace the secondary (f, r:ns)
 484 applyMove nl inst (FailoverAndReplace new_sdx) =
 485     let old_pdx = Instance.pnode inst
 486         old_sdx = Instance.snode inst
 487         old_p = Container.find old_pdx nl
 488         old_s = Container.find old_sdx nl
 489         tgt_n = Container.find new_sdx nl
 490         int_p = Node.removePri old_p inst
 491         int_s = Node.removeSec old_s inst
 492         new_nl = do -- Maybe monad
 493           new_p <- Node.addPri int_s inst
 494           new_s <- Node.addSec tgt_n inst old_sdx
 495           return $ Container.add new_sdx new_s $
 496                  Container.addTwo old_sdx new_p old_pdx int_p nl
 497     in (new_nl, Instance.setBoth inst old_sdx new_sdx, old_sdx, new_sdx)
 498
 499 -- | Tries to allocate an instance on one given node.
 500 allocateOnSingle :: Node.List -> Instance.Instance -> Node.Node
 501                  -> (Maybe Node.List, Instance.Instance)
 502 allocateOnSingle nl inst p =
 503     let new_pdx = Node.idx p
 504         new_nl = Node.addPri p inst >>= \new_p ->
 505                  return $ Container.add new_pdx new_p nl
 506     in (new_nl, Instance.setBoth inst new_pdx Node.noSecondary)
 507
 508 -- | Tries to allocate an instance on a given pair of nodes.
 509 allocateOnPair :: Node.List -> Instance.Instance -> Node.Node -> Node.Node
 510                -> (Maybe Node.List, Instance.Instance)
 511 allocateOnPair nl inst tgt_p tgt_s =
 512     let new_pdx = Node.idx tgt_p
 513         new_sdx = Node.idx tgt_s
 514         new_nl = do -- Maybe monad
 515           new_p <- Node.addPri tgt_p inst
 516           new_s <- Node.addSec tgt_s inst new_pdx
 517           return $ Container.addTwo new_pdx new_p new_sdx new_s nl
 518     in (new_nl, Instance.setBoth inst new_pdx new_sdx)
 519
 520 -- | Tries to perform an instance move and returns the best table
 521 -- between the original one and the new one.
 522 checkSingleStep :: Table -- ^ The original table
 523                 -> Instance.Instance -- ^ The instance to move
 524                 -> Table -- ^ The current best table
 525                 -> IMove -- ^ The move to apply
 526                 -> Table -- ^ The final best table
 527 checkSingleStep ini_tbl target cur_tbl move =
 528     let
 529         Table ini_nl ini_il _ ini_plc = ini_tbl
 530         (tmp_nl, new_inst, pri_idx, sec_idx) = applyMove ini_nl target move
 531     in
 532       if isNothing tmp_nl then cur_tbl
 533       else
 534           let tgt_idx = Instance.idx target
 535               upd_nl = fromJust tmp_nl
 536               upd_cvar = compCV upd_nl
 537               upd_il = Container.add tgt_idx new_inst ini_il
 538               upd_plc = (tgt_idx, pri_idx, sec_idx, upd_cvar):ini_plc
 539               upd_tbl = Table upd_nl upd_il upd_cvar upd_plc
 540           in
 541             compareTables cur_tbl upd_tbl
 542
 543 -- | Given the status of the current secondary as a valid new node
 544 -- and the current candidate target node,
 545 -- generate the possible moves for a instance.
 546 possibleMoves :: Bool -> Ndx -> [IMove]
 547 possibleMoves True tdx =
 548     [ReplaceSecondary tdx,
 549      ReplaceAndFailover tdx,
 550      ReplacePrimary tdx,
 551      FailoverAndReplace tdx]
 552
 553 possibleMoves False tdx =
 554     [ReplaceSecondary tdx,
 555      ReplaceAndFailover tdx]
 556
 557 -- | Compute the best move for a given instance.
 558 checkInstanceMove :: [Ndx]             -- Allowed target node indices
 559                   -> Table             -- Original table
 560                   -> Instance.Instance -- Instance to move
 561                   -> Table             -- Best new table for this instance
 562 checkInstanceMove nodes_idx ini_tbl target =
 563     let
 564         opdx = Instance.pnode target
 565         osdx = Instance.snode target
 566         nodes = filter (\idx -> idx /= opdx && idx /= osdx) nodes_idx
 567         use_secondary = elem osdx nodes_idx
 568         aft_failover = if use_secondary -- if allowed to failover
 569                        then checkSingleStep ini_tbl target ini_tbl Failover
 570                        else ini_tbl
 571         all_moves = concatMap (possibleMoves use_secondary) nodes
 572     in
 573       -- iterate over the possible nodes for this instance
 574       foldl' (checkSingleStep ini_tbl target) aft_failover all_moves
 575
 576 -- | Compute the best next move.
 577 checkMove :: [Ndx]               -- ^ Allowed target node indices
 578           -> Table               -- ^ The current solution
 579           -> [Instance.Instance] -- ^ List of instances still to move
 580           -> Table               -- ^ The new solution
 581 checkMove nodes_idx ini_tbl victims =
 582     let Table _ _ _ ini_plc = ini_tbl
 583         -- iterate over all instances, computing the best move
 584         best_tbl =
 585             foldl'
 586             (\ step_tbl elem ->
 587                  if Instance.snode elem == Node.noSecondary then step_tbl
 588                     else compareTables step_tbl $
 589                          checkInstanceMove nodes_idx ini_tbl elem)
 590             ini_tbl victims
 591         Table _ _ _ best_plc = best_tbl
 592     in
 593       if length best_plc == length ini_plc then -- no advancement
 594           ini_tbl
 595       else
 596           best_tbl
 597
 598 -- * Alocation functions
 599
 600 -- | Try to allocate an instance on the cluster.
 601 tryAlloc :: (Monad m) =>
 602             Node.List         -- ^ The node list
 603          -> Instance.List     -- ^ The instance list
 604          -> Instance.Instance -- ^ The instance to allocate
 605          -> Int               -- ^ Required number of nodes
 606          -> m [(Maybe Node.List, [Node.Node])] -- ^ Possible solution list
 607 tryAlloc nl _ inst 2 =
 608     let all_nodes = getOnline nl
 609         all_pairs = liftM2 (,) all_nodes all_nodes
 610         ok_pairs = filter (\(x, y) -> Node.idx x /= Node.idx y) all_pairs
 611         sols = map (\(p, s) ->
 612                         (fst $ allocateOnPair nl inst p s, [p, s]))
 613                ok_pairs
 614     in return sols
 615
 616 tryAlloc nl _ inst 1 =
 617     let all_nodes = getOnline nl
 618         sols = map (\p -> (fst $ allocateOnSingle nl inst p, [p]))
 619                all_nodes
 620     in return sols
 621
 622 tryAlloc _ _ _ reqn = fail $ "Unsupported number of alllocation \
 623                              \destinations required (" ++ (show reqn) ++
 624                                                "), only two supported"
 625
 626 -- | Try to allocate an instance on the cluster.
 627 tryReloc :: (Monad m) =>
 628             Node.List     -- ^ The node list
 629          -> Instance.List -- ^ The instance list
 630          -> Idx           -- ^ The index of the instance to move
 631          -> Int           -- ^ The numver of nodes required
 632          -> [Ndx]         -- ^ Nodes which should not be used
 633          -> m [(Maybe Node.List, [Node.Node])] -- ^ Solution list
 634 tryReloc nl il xid 1 ex_idx =
 635     let all_nodes = getOnline nl
 636         inst = Container.find xid il
 637         ex_idx' = (Instance.pnode inst):ex_idx
 638         valid_nodes = filter (not . flip elem ex_idx' . Node.idx) all_nodes
 639         valid_idxes = map Node.idx valid_nodes
 640         sols1 = map (\x -> let (mnl, _, _, _) =
 641                                     applyMove nl inst (ReplaceSecondary x)
 642                            in (mnl, [Container.find x nl])
 643                      ) valid_idxes
 644     in return sols1
 645
 646 tryReloc _ _ _ reqn _  = fail $ "Unsupported number of relocation \
 647                                 \destinations required (" ++ (show reqn) ++
 648                                                   "), only one supported"
 649
 650 -- * Formatting functions
 651
 652 -- | Given the original and final nodes, computes the relocation description.
 653 computeMoves :: String -- ^ The instance name
 654              -> String -- ^ Original primary
 655              -> String -- ^ Original secondary
 656              -> String -- ^ New primary
 657              -> String -- ^ New secondary
 658              -> (String, [String])
 659                 -- ^ Tuple of moves and commands list; moves is containing
 660                 -- either @/f/@ for failover or @/r:name/@ for replace
 661                 -- secondary, while the command list holds gnt-instance
 662                 -- commands (without that prefix), e.g \"@failover instance1@\"
 663 computeMoves i a b c d =
 664     if c == a then {- Same primary -}
 665         if d == b then {- Same sec??! -}
 666             ("-", [])
 667         else {- Change of secondary -}
 668             (printf "r:%s" d,
 669              [printf "replace-disks -n %s %s" d i])
 670     else
 671         if c == b then {- Failover and ... -}
 672             if d == a then {- that's all -}
 673                 ("f", [printf "migrate -f %s" i])
 674             else
 675                 (printf "f r:%s" d,
 676                  [printf "migrate -f %s" i,
 677                   printf "replace-disks -n %s %s" d i])
 678         else
 679             if d == a then {- ... and keep primary as secondary -}
 680                 (printf "r:%s f" c,
 681                  [printf "replace-disks -n %s %s" c i,
 682                   printf "migrate -f %s" i])
 683             else
 684                 if d == b then {- ... keep same secondary -}
 685                     (printf "f r:%s f" c,
 686                      [printf "migrate -f %s" i,
 687                       printf "replace-disks -n %s %s" c i,
 688                       printf "migrate -f %s" i])
 689
 690                 else {- Nothing in common -}
 691                     (printf "r:%s f r:%s" c d,
 692                      [printf "replace-disks -n %s %s" c i,
 693                       printf "migrate -f %s" i,
 694                       printf "replace-disks -n %s %s" d i])
 695
 696 -- | Converts a placement to string format.
 697 printSolutionLine :: Node.List     -- ^ The node list
 698                   -> Instance.List -- ^ The instance list
 699                   -> Int           -- ^ Maximum node name length
 700                   -> Int           -- ^ Maximum instance name length
 701                   -> Placement     -- ^ The current placement
 702                   -> Int           -- ^ The index of the placement in
 703                                    -- the solution
 704                   -> (String, [String])
 705 printSolutionLine nl il nmlen imlen plc pos =
 706     let
 707         pmlen = (2*nmlen + 1)
 708         (i, p, s, c) = plc
 709         inst = Container.find i il
 710         inam = Instance.name inst
 711         npri = Container.nameOf nl p
 712         nsec = Container.nameOf nl s
 713         opri = Container.nameOf nl $ Instance.pnode inst
 714         osec = Container.nameOf nl $ Instance.snode inst
 715         (moves, cmds) =  computeMoves inam opri osec npri nsec
 716         ostr = (printf "%s:%s" opri osec)::String
 717         nstr = (printf "%s:%s" npri nsec)::String
 718     in
 719       (printf "  %3d. %-*s %-*s => %-*s %.8f a=%s"
 720        pos imlen inam pmlen ostr
 721        pmlen nstr c moves,
 722        cmds)
 723
 724 -- | Given a list of commands, prefix them with @gnt-instance@ and
 725 -- also beautify the display a little.
 726 formatCmds :: [[String]] -> String
 727 formatCmds cmd_strs =
 728     unlines $
 729     concat $ map (\(a, b) ->
 730         (printf "echo step %d" (a::Int)):
 731         (printf "check"):
 732         (map ("gnt-instance " ++) b)) $
 733         zip [1..] cmd_strs
 734
 735 -- | Converts a solution to string format.
 736 printSolution :: Node.List
 737               -> Instance.List
 738               -> [Placement]
 739               -> ([String], [[String]])
 740 printSolution nl il sol =
 741     let
 742         nmlen = Container.maxNameLen nl
 743         imlen = Container.maxNameLen il
 744     in
 745       unzip $ map (uncurry $ printSolutionLine nl il nmlen imlen) $
 746             zip sol [1..]
 747
 748 -- | Print the node list.
 749 printNodes :: Node.List -> String
 750 printNodes nl =
 751     let snl = sortBy (compare `on` Node.idx) (Container.elems nl)
 752         m_name = maximum . map (length . Node.name) $ snl
 753         helper = Node.list m_name
 754         header = printf
 755                  "%2s %-*s %5s %5s %5s %5s %5s %5s %5s %5s %3s %3s %7s %7s"
 756                  " F" m_name "Name"
 757                  "t_mem" "n_mem" "i_mem" "x_mem" "f_mem" "r_mem"
 758                  "t_dsk" "f_dsk"
 759                  "pri" "sec" "p_fmem" "p_fdsk"
 760     in unlines $ (header:map helper snl)
 761
 762 -- | Shows statistics for a given node list.
 763 printStats :: Node.List -> String
 764 printStats nl =
 765     let (mem_cv, dsk_cv, n1_score, res_cv, off_score) = compDetailedCV nl
 766     in printf "f_mem=%.8f, r_mem=%.8f, f_dsk=%.8f, n1=%.3f, uf=%.3f"
 767        mem_cv res_cv dsk_cv n1_score off_score