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           -- check that the current secondary can host the instance
 471           -- during the migration
 472           tmp_s <- Node.addPri int_s inst
 473           let tmp_s' = Node.removePri tmp_s inst
 474           new_p <- Node.addPri tgt_n inst
 475           new_s <- Node.addSec tmp_s' inst new_pdx
 476           return $ Container.add new_pdx new_p $
 477                  Container.addTwo old_pdx int_p old_sdx new_s nl
 478     in (new_nl, Instance.setPri inst new_pdx, new_pdx, old_sdx)
 479
 480 -- Replace the secondary (r:ns)
 481 applyMove nl inst (ReplaceSecondary new_sdx) =
 482     let old_pdx = Instance.pnode inst
 483         old_sdx = Instance.snode inst
 484         old_s = Container.find old_sdx nl
 485         tgt_n = Container.find new_sdx nl
 486         int_s = Node.removeSec old_s inst
 487         new_nl = Node.addSec tgt_n inst old_pdx >>=
 488                  \new_s -> return $ Container.addTwo new_sdx
 489                            new_s old_sdx int_s nl
 490     in (new_nl, Instance.setSec inst new_sdx, old_pdx, new_sdx)
 491
 492 -- Replace the secondary and failover (r:np, f)
 493 applyMove nl inst (ReplaceAndFailover new_pdx) =
 494     let old_pdx = Instance.pnode inst
 495         old_sdx = Instance.snode inst
 496         old_p = Container.find old_pdx nl
 497         old_s = Container.find old_sdx nl
 498         tgt_n = Container.find new_pdx nl
 499         int_p = Node.removePri old_p inst
 500         int_s = Node.removeSec old_s inst
 501         new_nl = do -- Maybe monad
 502           new_p <- Node.addPri tgt_n inst
 503           new_s <- Node.addSec int_p inst new_pdx
 504           return $ Container.add new_pdx new_p $
 505                  Container.addTwo old_pdx new_s old_sdx int_s nl
 506     in (new_nl, Instance.setBoth inst new_pdx old_pdx, new_pdx, old_pdx)
 507
 508 -- Failver and replace the secondary (f, r:ns)
 509 applyMove nl inst (FailoverAndReplace new_sdx) =
 510     let old_pdx = Instance.pnode inst
 511         old_sdx = Instance.snode inst
 512         old_p = Container.find old_pdx nl
 513         old_s = Container.find old_sdx nl
 514         tgt_n = Container.find new_sdx nl
 515         int_p = Node.removePri old_p inst
 516         int_s = Node.removeSec old_s inst
 517         new_nl = do -- Maybe monad
 518           new_p <- Node.addPri int_s inst
 519           new_s <- Node.addSec tgt_n inst old_sdx
 520           return $ Container.add new_sdx new_s $
 521                  Container.addTwo old_sdx new_p old_pdx int_p nl
 522     in (new_nl, Instance.setBoth inst old_sdx new_sdx, old_sdx, new_sdx)
 523
 524 -- | Tries to allocate an instance on one given node.
 525 allocateOnSingle :: Node.List -> Instance.Instance -> Node.Node
 526                  -> (Maybe Node.List, Instance.Instance)
 527 allocateOnSingle nl inst p =
 528     let new_pdx = Node.idx p
 529         new_nl = Node.addPri p inst >>= \new_p ->
 530                  return $ Container.add new_pdx new_p nl
 531     in (new_nl, Instance.setBoth inst new_pdx Node.noSecondary)
 532
 533 -- | Tries to allocate an instance on a given pair of nodes.
 534 allocateOnPair :: Node.List -> Instance.Instance -> Node.Node -> Node.Node
 535                -> (Maybe Node.List, Instance.Instance)
 536 allocateOnPair nl inst tgt_p tgt_s =
 537     let new_pdx = Node.idx tgt_p
 538         new_sdx = Node.idx tgt_s
 539         new_nl = do -- Maybe monad
 540           new_p <- Node.addPri tgt_p inst
 541           new_s <- Node.addSec tgt_s inst new_pdx
 542           return $ Container.addTwo new_pdx new_p new_sdx new_s nl
 543     in (new_nl, Instance.setBoth inst new_pdx new_sdx)
 544
 545 -- | Tries to perform an instance move and returns the best table
 546 -- between the original one and the new one.
 547 checkSingleStep :: Table -- ^ The original table
 548                 -> Instance.Instance -- ^ The instance to move
 549                 -> Table -- ^ The current best table
 550                 -> IMove -- ^ The move to apply
 551                 -> Table -- ^ The final best table
 552 checkSingleStep ini_tbl target cur_tbl move =
 553     let
 554         Table ini_nl ini_il _ ini_plc = ini_tbl
 555         (tmp_nl, new_inst, pri_idx, sec_idx) = applyMove ini_nl target move
 556     in
 557       if isNothing tmp_nl then cur_tbl
 558       else
 559           let tgt_idx = Instance.idx target
 560               upd_nl = fromJust tmp_nl
 561               upd_cvar = compCV upd_nl
 562               upd_il = Container.add tgt_idx new_inst ini_il
 563               upd_plc = (tgt_idx, pri_idx, sec_idx, upd_cvar):ini_plc
 564               upd_tbl = Table upd_nl upd_il upd_cvar upd_plc
 565           in
 566             compareTables cur_tbl upd_tbl
 567
 568 -- | Given the status of the current secondary as a valid new node
 569 -- and the current candidate target node,
 570 -- generate the possible moves for a instance.
 571 possibleMoves :: Bool -> Ndx -> [IMove]
 572 possibleMoves True tdx =
 573     [ReplaceSecondary tdx,
 574      ReplaceAndFailover tdx,
 575      ReplacePrimary tdx,
 576      FailoverAndReplace tdx]
 577
 578 possibleMoves False tdx =
 579     [ReplaceSecondary tdx,
 580      ReplaceAndFailover tdx]
 581
 582 -- | Compute the best move for a given instance.
 583 checkInstanceMove :: [Ndx]             -- Allowed target node indices
 584                   -> Table             -- Original table
 585                   -> Instance.Instance -- Instance to move
 586                   -> Table             -- Best new table for this instance
 587 checkInstanceMove nodes_idx ini_tbl target =
 588     let
 589         opdx = Instance.pnode target
 590         osdx = Instance.snode target
 591         nodes = filter (\idx -> idx /= opdx && idx /= osdx) nodes_idx
 592         use_secondary = elem osdx nodes_idx
 593         aft_failover = if use_secondary -- if allowed to failover
 594                        then checkSingleStep ini_tbl target ini_tbl Failover
 595                        else ini_tbl
 596         all_moves = concatMap (possibleMoves use_secondary) nodes
 597     in
 598       -- iterate over the possible nodes for this instance
 599       foldl' (checkSingleStep ini_tbl target) aft_failover all_moves
 600
 601 -- | Compute the best next move.
 602 checkMove :: [Ndx]               -- ^ Allowed target node indices
 603           -> Table               -- ^ The current solution
 604           -> [Instance.Instance] -- ^ List of instances still to move
 605           -> Table               -- ^ The new solution
 606 checkMove nodes_idx ini_tbl victims =
 607     let Table _ _ _ ini_plc = ini_tbl
 608         -- iterate over all instances, computing the best move
 609         best_tbl =
 610             foldl'
 611             (\ step_tbl elem ->
 612                  if Instance.snode elem == Node.noSecondary then step_tbl
 613                     else compareTables step_tbl $
 614                          checkInstanceMove nodes_idx ini_tbl elem)
 615             ini_tbl victims
 616         Table _ _ _ best_plc = best_tbl
 617     in
 618       if length best_plc == length ini_plc then -- no advancement
 619           ini_tbl
 620       else
 621           best_tbl
 622
 623 -- * Alocation functions
 624
 625 -- | Try to allocate an instance on the cluster.
 626 tryAlloc :: (Monad m) =>
 627             Node.List         -- ^ The node list
 628          -> Instance.List     -- ^ The instance list
 629          -> Instance.Instance -- ^ The instance to allocate
 630          -> Int               -- ^ Required number of nodes
 631          -> m [(Maybe Node.List, Instance.Instance, [Node.Node])]
 632                               -- ^ Possible solution list
 633 tryAlloc nl _ inst 2 =
 634     let all_nodes = getOnline nl
 635         all_pairs = liftM2 (,) all_nodes all_nodes
 636         ok_pairs = filter (\(x, y) -> Node.idx x /= Node.idx y) all_pairs
 637         sols = map (\(p, s) -> let (mnl, i) = allocateOnPair nl inst p s
 638                                in (mnl, i, [p, s]))
 639                ok_pairs
 640     in return sols
 641
 642 tryAlloc nl _ inst 1 =
 643     let all_nodes = getOnline nl
 644         sols = map (\p -> let (mnl, i) = allocateOnSingle nl inst p
 645                           in (mnl, i, [p]))
 646                all_nodes
 647     in return sols
 648
 649 tryAlloc _ _ _ reqn = fail $ "Unsupported number of alllocation \
 650                              \destinations required (" ++ (show reqn) ++
 651                                                "), only two supported"
 652
 653 -- | Try to allocate an instance on the cluster.
 654 tryReloc :: (Monad m) =>
 655             Node.List     -- ^ The node list
 656          -> Instance.List -- ^ The instance list
 657          -> Idx           -- ^ The index of the instance to move
 658          -> Int           -- ^ The numver of nodes required
 659          -> [Ndx]         -- ^ Nodes which should not be used
 660          -> m [(Maybe Node.List, Instance.Instance, [Node.Node])]
 661                           -- ^ Solution list
 662 tryReloc nl il xid 1 ex_idx =
 663     let all_nodes = getOnline nl
 664         inst = Container.find xid il
 665         ex_idx' = (Instance.pnode inst):ex_idx
 666         valid_nodes = filter (not . flip elem ex_idx' . Node.idx) all_nodes
 667         valid_idxes = map Node.idx valid_nodes
 668         sols1 = map (\x -> let (mnl, i, _, _) =
 669                                    applyMove nl inst (ReplaceSecondary x)
 670                            in (mnl, i, [Container.find x nl])
 671                      ) valid_idxes
 672     in return sols1
 673
 674 tryReloc _ _ _ reqn _  = fail $ "Unsupported number of relocation \
 675                                 \destinations required (" ++ (show reqn) ++
 676                                                   "), only one supported"
 677
 678 -- * Formatting functions
 679
 680 -- | Given the original and final nodes, computes the relocation description.
 681 computeMoves :: String -- ^ The instance name
 682              -> String -- ^ Original primary
 683              -> String -- ^ Original secondary
 684              -> String -- ^ New primary
 685              -> String -- ^ New secondary
 686              -> (String, [String])
 687                 -- ^ Tuple of moves and commands list; moves is containing
 688                 -- either @/f/@ for failover or @/r:name/@ for replace
 689                 -- secondary, while the command list holds gnt-instance
 690                 -- commands (without that prefix), e.g \"@failover instance1@\"
 691 computeMoves i a b c d =
 692     if c == a then {- Same primary -}
 693         if d == b then {- Same sec??! -}
 694             ("-", [])
 695         else {- Change of secondary -}
 696             (printf "r:%s" d,
 697              [printf "replace-disks -n %s %s" d i])
 698     else
 699         if c == b then {- Failover and ... -}
 700             if d == a then {- that's all -}
 701                 ("f", [printf "migrate -f %s" i])
 702             else
 703                 (printf "f r:%s" d,
 704                  [printf "migrate -f %s" i,
 705                   printf "replace-disks -n %s %s" d i])
 706         else
 707             if d == a then {- ... and keep primary as secondary -}
 708                 (printf "r:%s f" c,
 709                  [printf "replace-disks -n %s %s" c i,
 710                   printf "migrate -f %s" i])
 711             else
 712                 if d == b then {- ... keep same secondary -}
 713                     (printf "f r:%s f" c,
 714                      [printf "migrate -f %s" i,
 715                       printf "replace-disks -n %s %s" c i,
 716                       printf "migrate -f %s" i])
 717
 718                 else {- Nothing in common -}
 719                     (printf "r:%s f r:%s" c d,
 720                      [printf "replace-disks -n %s %s" c i,
 721                       printf "migrate -f %s" i,
 722                       printf "replace-disks -n %s %s" d i])
 723
 724 -- | Converts a placement to string format.
 725 printSolutionLine :: Node.List     -- ^ The node list
 726                   -> Instance.List -- ^ The instance list
 727                   -> Int           -- ^ Maximum node name length
 728                   -> Int           -- ^ Maximum instance name length
 729                   -> Placement     -- ^ The current placement
 730                   -> Int           -- ^ The index of the placement in
 731                                    -- the solution
 732                   -> (String, [String])
 733 printSolutionLine nl il nmlen imlen plc pos =
 734     let
 735         pmlen = (2*nmlen + 1)
 736         (i, p, s, c) = plc
 737         inst = Container.find i il
 738         inam = Instance.name inst
 739         npri = Container.nameOf nl p
 740         nsec = Container.nameOf nl s
 741         opri = Container.nameOf nl $ Instance.pnode inst
 742         osec = Container.nameOf nl $ Instance.snode inst
 743         (moves, cmds) =  computeMoves inam opri osec npri nsec
 744         ostr = (printf "%s:%s" opri osec)::String
 745         nstr = (printf "%s:%s" npri nsec)::String
 746     in
 747       (printf "  %3d. %-*s %-*s => %-*s %.8f a=%s"
 748        pos imlen inam pmlen ostr
 749        pmlen nstr c moves,
 750        cmds)
 751
 752 -- | Given a list of commands, prefix them with @gnt-instance@ and
 753 -- also beautify the display a little.
 754 formatCmds :: [[String]] -> String
 755 formatCmds cmd_strs =
 756     unlines $
 757     concat $ map (\(a, b) ->
 758         (printf "echo step %d" (a::Int)):
 759         (printf "check"):
 760         (map ("gnt-instance " ++) b)) $
 761         zip [1..] cmd_strs
 762
 763 -- | Converts a solution to string format.
 764 printSolution :: Node.List
 765               -> Instance.List
 766               -> [Placement]
 767               -> ([String], [[String]])
 768 printSolution nl il sol =
 769     let
 770         nmlen = Container.maxNameLen nl
 771         imlen = Container.maxNameLen il
 772     in
 773       unzip $ map (uncurry $ printSolutionLine nl il nmlen imlen) $
 774             zip sol [1..]
 775
 776 -- | Print the node list.
 777 printNodes :: Node.List -> String
 778 printNodes nl =
 779     let snl = sortBy (compare `on` Node.idx) (Container.elems nl)
 780         m_name = maximum . map (length . Node.name) $ snl
 781         helper = Node.list m_name
 782         header = printf
 783                  "%2s %-*s %5s %5s %5s %5s %5s %5s %5s %5s %3s %3s %7s %7s"
 784                  " F" m_name "Name"
 785                  "t_mem" "n_mem" "i_mem" "x_mem" "f_mem" "r_mem"
 786                  "t_dsk" "f_dsk"
 787                  "pri" "sec" "p_fmem" "p_fdsk"
 788     in unlines $ (header:map helper snl)
 789
 790 -- | Shows statistics for a given node list.
 791 printStats :: Node.List -> String
 792 printStats nl =
 793     let (mem_cv, dsk_cv, n1_score, res_cv, off_score) = compDetailedCV nl
 794     in printf "f_mem=%.8f, r_mem=%.8f, f_dsk=%.8f, n1=%.3f, uf=%.3f"
 795        mem_cv res_cv dsk_cv n1_score off_score