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