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