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     , AllocSolution
  34     , Table(..)
  35     , CStats(..)
  36     -- * Generic functions
  37     , totalResources
  38     -- * First phase functions
  39     , computeBadItems
  40     -- * Second phase functions
  41     , printSolution
  42     , printSolutionLine
  43     , formatCmds
  44     , printNodes
  45     , involvedNodes
  46     , splitJobs
  47     -- * Balacing functions
  48     , checkMove
  49     , tryBalance
  50     , compCV
  51     , printStats
  52     , iMoveToJob
  53     -- * IAllocator functions
  54     , tryAlloc
  55     , tryReloc
  56     , collapseFailures
  57     ) where
  58
  59 import Data.List
  60 import Text.Printf (printf)
  61 import Data.Function
  62 import Control.Monad
  63
  64 import qualified Ganeti.HTools.Container as Container
  65 import qualified Ganeti.HTools.Instance as Instance
  66 import qualified Ganeti.HTools.Node as Node
  67 import Ganeti.HTools.Types
  68 import Ganeti.HTools.Utils
  69 import qualified Ganeti.OpCodes as OpCodes
  70
  71 -- * Types
  72
  73 -- | Allocation\/relocation solution.
  74 type AllocSolution = ([FailMode], Int, Maybe (Score, AllocElement))
  75
  76 -- | Allocation\/relocation element.
  77 type AllocElement = (Node.List, Instance.Instance, [Node.Node])
  78
  79
  80 -- | The complete state for the balancing solution
  81 data Table = Table Node.List Instance.List Score [Placement]
  82              deriving (Show)
  83
  84 data CStats = CStats { cs_fmem :: Int    -- ^ Cluster free mem
  85                      , cs_fdsk :: Int    -- ^ Cluster free disk
  86                      , cs_amem :: Int    -- ^ Cluster allocatable mem
  87                      , cs_adsk :: Int    -- ^ Cluster allocatable disk
  88                      , cs_acpu :: Int    -- ^ Cluster allocatable cpus
  89                      , cs_mmem :: Int    -- ^ Max node allocatable mem
  90                      , cs_mdsk :: Int    -- ^ Max node allocatable disk
  91                      , cs_mcpu :: Int    -- ^ Max node allocatable cpu
  92                      , cs_imem :: Int    -- ^ Instance used mem
  93                      , cs_idsk :: Int    -- ^ Instance used disk
  94                      , cs_icpu :: Int    -- ^ Instance used cpu
  95                      , cs_tmem :: Double -- ^ Cluster total mem
  96                      , cs_tdsk :: Double -- ^ Cluster total disk
  97                      , cs_tcpu :: Double -- ^ Cluster total cpus
  98                      , cs_xmem :: Int    -- ^ Unnacounted for mem
  99                      , cs_nmem :: Int    -- ^ Node own memory
 100                      , cs_score :: Score -- ^ The cluster score
 101                      , cs_ninst :: Int   -- ^ The total number of instances
 102                      }
 103
 104 -- * Utility functions
 105
 106 -- | Verifies the N+1 status and return the affected nodes.
 107 verifyN1 :: [Node.Node] -> [Node.Node]
 108 verifyN1 = filter Node.failN1
 109
 110 {-| Computes the pair of bad nodes and instances.
 111
 112 The bad node list is computed via a simple 'verifyN1' check, and the
 113 bad instance list is the list of primary and secondary instances of
 114 those nodes.
 115
 116 -}
 117 computeBadItems :: Node.List -> Instance.List ->
 118                    ([Node.Node], [Instance.Instance])
 119 computeBadItems nl il =
 120   let bad_nodes = verifyN1 $ getOnline nl
 121       bad_instances = map (\idx -> Container.find idx il) .
 122                       sort . nub $
 123                       concatMap (\ n -> Node.slist n ++ Node.plist n) bad_nodes
 124   in
 125     (bad_nodes, bad_instances)
 126
 127 emptyCStats :: CStats
 128 emptyCStats = CStats { cs_fmem = 0
 129                      , cs_fdsk = 0
 130                      , cs_amem = 0
 131                      , cs_adsk = 0
 132                      , cs_acpu = 0
 133                      , cs_mmem = 0
 134                      , cs_mdsk = 0
 135                      , cs_mcpu = 0
 136                      , cs_imem = 0
 137                      , cs_idsk = 0
 138                      , cs_icpu = 0
 139                      , cs_tmem = 0
 140                      , cs_tdsk = 0
 141                      , cs_tcpu = 0
 142                      , cs_xmem = 0
 143                      , cs_nmem = 0
 144                      , cs_score = 0
 145                      , cs_ninst = 0
 146                      }
 147
 148 updateCStats :: CStats -> Node.Node -> CStats
 149 updateCStats cs node =
 150     let CStats { cs_fmem = x_fmem, cs_fdsk = x_fdsk,
 151                  cs_amem = x_amem, cs_acpu = x_acpu, cs_adsk = x_adsk,
 152                  cs_mmem = x_mmem, cs_mdsk = x_mdsk, cs_mcpu = x_mcpu,
 153                  cs_imem = x_imem, cs_idsk = x_idsk, cs_icpu = x_icpu,
 154                  cs_tmem = x_tmem, cs_tdsk = x_tdsk, cs_tcpu = x_tcpu,
 155                  cs_xmem = x_xmem, cs_nmem = x_nmem, cs_ninst = x_ninst
 156                }
 157             = cs
 158         inc_amem = Node.f_mem node - Node.r_mem node
 159         inc_amem' = if inc_amem > 0 then inc_amem else 0
 160         inc_adsk = Node.availDisk node
 161         inc_imem = truncate (Node.t_mem node) - Node.n_mem node
 162                    - Node.x_mem node - Node.f_mem node
 163         inc_icpu = Node.u_cpu node
 164         inc_idsk = truncate (Node.t_dsk node) - Node.f_dsk node
 165
 166     in cs { cs_fmem = x_fmem + Node.f_mem node
 167           , cs_fdsk = x_fdsk + Node.f_dsk node
 168           , cs_amem = x_amem + inc_amem'
 169           , cs_adsk = x_adsk + inc_adsk
 170           , cs_acpu = x_acpu
 171           , cs_mmem = max x_mmem inc_amem'
 172           , cs_mdsk = max x_mdsk inc_adsk
 173           , cs_mcpu = x_mcpu
 174           , cs_imem = x_imem + inc_imem
 175           , cs_idsk = x_idsk + inc_idsk
 176           , cs_icpu = x_icpu + inc_icpu
 177           , cs_tmem = x_tmem + Node.t_mem node
 178           , cs_tdsk = x_tdsk + Node.t_dsk node
 179           , cs_tcpu = x_tcpu + Node.t_cpu node
 180           , cs_xmem = x_xmem + Node.x_mem node
 181           , cs_nmem = x_nmem + Node.n_mem node
 182           , cs_ninst = x_ninst + length (Node.plist node)
 183           }
 184
 185 -- | Compute the total free disk and memory in the cluster.
 186 totalResources :: Node.List -> CStats
 187 totalResources nl =
 188     let cs = foldl' updateCStats emptyCStats . Container.elems $ nl
 189     in cs { cs_score = compCV nl }
 190
 191 -- | Compute the mem and disk covariance.
 192 compDetailedCV :: Node.List -> (Double, Double, Double, Double, Double, Double)
 193 compDetailedCV nl =
 194     let
 195         all_nodes = Container.elems nl
 196         (offline, nodes) = partition Node.offline all_nodes
 197         mem_l = map Node.p_mem nodes
 198         dsk_l = map Node.p_dsk nodes
 199         mem_cv = varianceCoeff mem_l
 200         dsk_cv = varianceCoeff dsk_l
 201         n1_l = length $ filter Node.failN1 nodes
 202         n1_score = fromIntegral n1_l /
 203                    fromIntegral (length nodes)::Double
 204         res_l = map Node.p_rem nodes
 205         res_cv = varianceCoeff res_l
 206         offline_inst = sum . map (\n -> (length . Node.plist $ n) +
 207                                         (length . Node.slist $ n)) $ offline
 208         online_inst = sum . map (\n -> (length . Node.plist $ n) +
 209                                        (length . Node.slist $ n)) $ nodes
 210         off_score = if offline_inst == 0
 211                     then 0::Double
 212                     else fromIntegral offline_inst /
 213                          fromIntegral (offline_inst + online_inst)::Double
 214         cpu_l = map Node.p_cpu nodes
 215         cpu_cv = varianceCoeff cpu_l
 216     in (mem_cv, dsk_cv, n1_score, res_cv, off_score, cpu_cv)
 217
 218 -- | Compute the /total/ variance.
 219 compCV :: Node.List -> Double
 220 compCV nl =
 221     let (mem_cv, dsk_cv, n1_score, res_cv, off_score, cpu_cv) =
 222             compDetailedCV nl
 223     in mem_cv + dsk_cv + n1_score + res_cv + off_score + cpu_cv
 224
 225 -- | Compute online nodes from a Node.List
 226 getOnline :: Node.List -> [Node.Node]
 227 getOnline = filter (not . Node.offline) . Container.elems
 228
 229 -- * hbal functions
 230
 231 -- | Compute best table. Note that the ordering of the arguments is important.
 232 compareTables :: Table -> Table -> Table
 233 compareTables a@(Table _ _ a_cv _) b@(Table _ _ b_cv _ ) =
 234     if a_cv > b_cv then b else a
 235
 236 -- | Applies an instance move to a given node list and instance.
 237 applyMove :: Node.List -> Instance.Instance
 238           -> IMove -> OpResult (Node.List, Instance.Instance, Ndx, Ndx)
 239 -- Failover (f)
 240 applyMove nl inst Failover =
 241     let old_pdx = Instance.pnode inst
 242         old_sdx = Instance.snode inst
 243         old_p = Container.find old_pdx nl
 244         old_s = Container.find old_sdx nl
 245         int_p = Node.removePri old_p inst
 246         int_s = Node.removeSec old_s inst
 247         new_nl = do -- Maybe monad
 248           new_p <- Node.addPri int_s inst
 249           new_s <- Node.addSec int_p inst old_sdx
 250           let new_inst = Instance.setBoth inst old_sdx old_pdx
 251           return (Container.addTwo old_pdx new_s old_sdx new_p nl,
 252                   new_inst, old_sdx, old_pdx)
 253     in new_nl
 254
 255 -- Replace the primary (f:, r:np, f)
 256 applyMove nl inst (ReplacePrimary new_pdx) =
 257     let old_pdx = Instance.pnode inst
 258         old_sdx = Instance.snode inst
 259         old_p = Container.find old_pdx nl
 260         old_s = Container.find old_sdx nl
 261         tgt_n = Container.find new_pdx nl
 262         int_p = Node.removePri old_p inst
 263         int_s = Node.removeSec old_s inst
 264         new_nl = do -- Maybe monad
 265           -- check that the current secondary can host the instance
 266           -- during the migration
 267           tmp_s <- Node.addPri int_s inst
 268           let tmp_s' = Node.removePri tmp_s inst
 269           new_p <- Node.addPri tgt_n inst
 270           new_s <- Node.addSec tmp_s' inst new_pdx
 271           let new_inst = Instance.setPri inst new_pdx
 272           return (Container.add new_pdx new_p $
 273                   Container.addTwo old_pdx int_p old_sdx new_s nl,
 274                   new_inst, new_pdx, old_sdx)
 275     in new_nl
 276
 277 -- Replace the secondary (r:ns)
 278 applyMove nl inst (ReplaceSecondary new_sdx) =
 279     let old_pdx = Instance.pnode inst
 280         old_sdx = Instance.snode inst
 281         old_s = Container.find old_sdx nl
 282         tgt_n = Container.find new_sdx nl
 283         int_s = Node.removeSec old_s inst
 284         new_inst = Instance.setSec inst new_sdx
 285         new_nl = Node.addSec tgt_n inst old_pdx >>=
 286                  \new_s -> return (Container.addTwo new_sdx
 287                                    new_s old_sdx int_s nl,
 288                                    new_inst, old_pdx, new_sdx)
 289     in new_nl
 290
 291 -- Replace the secondary and failover (r:np, f)
 292 applyMove nl inst (ReplaceAndFailover new_pdx) =
 293     let old_pdx = Instance.pnode inst
 294         old_sdx = Instance.snode inst
 295         old_p = Container.find old_pdx nl
 296         old_s = Container.find old_sdx nl
 297         tgt_n = Container.find new_pdx nl
 298         int_p = Node.removePri old_p inst
 299         int_s = Node.removeSec old_s inst
 300         new_nl = do -- Maybe monad
 301           new_p <- Node.addPri tgt_n inst
 302           new_s <- Node.addSec int_p inst new_pdx
 303           let new_inst = Instance.setBoth inst new_pdx old_pdx
 304           return (Container.add new_pdx new_p $
 305                   Container.addTwo old_pdx new_s old_sdx int_s nl,
 306                   new_inst, new_pdx, old_pdx)
 307     in new_nl
 308
 309 -- Failver and replace the secondary (f, r:ns)
 310 applyMove nl inst (FailoverAndReplace new_sdx) =
 311     let old_pdx = Instance.pnode inst
 312         old_sdx = Instance.snode inst
 313         old_p = Container.find old_pdx nl
 314         old_s = Container.find old_sdx nl
 315         tgt_n = Container.find new_sdx nl
 316         int_p = Node.removePri old_p inst
 317         int_s = Node.removeSec old_s inst
 318         new_nl = do -- Maybe monad
 319           new_p <- Node.addPri int_s inst
 320           new_s <- Node.addSec tgt_n inst old_sdx
 321           let new_inst = Instance.setBoth inst old_sdx new_sdx
 322           return (Container.add new_sdx new_s $
 323                   Container.addTwo old_sdx new_p old_pdx int_p nl,
 324                   new_inst, old_sdx, new_sdx)
 325     in new_nl
 326
 327 -- | Tries to allocate an instance on one given node.
 328 allocateOnSingle :: Node.List -> Instance.Instance -> Node.Node
 329                  -> OpResult AllocElement
 330 allocateOnSingle nl inst p =
 331     let new_pdx = Node.idx p
 332         new_inst = Instance.setBoth inst new_pdx Node.noSecondary
 333         new_nl = Node.addPri p inst >>= \new_p ->
 334                  return (Container.add new_pdx new_p nl, new_inst, [new_p])
 335     in new_nl
 336
 337 -- | Tries to allocate an instance on a given pair of nodes.
 338 allocateOnPair :: Node.List -> Instance.Instance -> Node.Node -> Node.Node
 339                -> OpResult AllocElement
 340 allocateOnPair nl inst tgt_p tgt_s =
 341     let new_pdx = Node.idx tgt_p
 342         new_sdx = Node.idx tgt_s
 343         new_nl = do -- Maybe monad
 344           new_p <- Node.addPri tgt_p inst
 345           new_s <- Node.addSec tgt_s inst new_pdx
 346           let new_inst = Instance.setBoth inst new_pdx new_sdx
 347           return (Container.addTwo new_pdx new_p new_sdx new_s nl, new_inst,
 348                  [new_p, new_s])
 349     in new_nl
 350
 351 -- | Tries to perform an instance move and returns the best table
 352 -- between the original one and the new one.
 353 checkSingleStep :: Table -- ^ The original table
 354                 -> Instance.Instance -- ^ The instance to move
 355                 -> Table -- ^ The current best table
 356                 -> IMove -- ^ The move to apply
 357                 -> Table -- ^ The final best table
 358 checkSingleStep ini_tbl target cur_tbl move =
 359     let
 360         Table ini_nl ini_il _ ini_plc = ini_tbl
 361         tmp_resu = applyMove ini_nl target move
 362     in
 363       case tmp_resu of
 364         OpFail _ -> cur_tbl
 365         OpGood (upd_nl, new_inst, pri_idx, sec_idx) ->
 366             let tgt_idx = Instance.idx target
 367                 upd_cvar = compCV upd_nl
 368                 upd_il = Container.add tgt_idx new_inst ini_il
 369                 upd_plc = (tgt_idx, pri_idx, sec_idx, move, upd_cvar):ini_plc
 370                 upd_tbl = Table upd_nl upd_il upd_cvar upd_plc
 371             in
 372               compareTables cur_tbl upd_tbl
 373
 374 -- | Given the status of the current secondary as a valid new node and
 375 -- the current candidate target node, generate the possible moves for
 376 -- a instance.
 377 possibleMoves :: Bool      -- ^ Whether the secondary node is a valid new node
 378               -> Ndx       -- ^ Target node candidate
 379               -> [IMove]   -- ^ List of valid result moves
 380 possibleMoves True tdx =
 381     [ReplaceSecondary tdx,
 382      ReplaceAndFailover tdx,
 383      ReplacePrimary tdx,
 384      FailoverAndReplace tdx]
 385
 386 possibleMoves False tdx =
 387     [ReplaceSecondary tdx,
 388      ReplaceAndFailover tdx]
 389
 390 -- | Compute the best move for a given instance.
 391 checkInstanceMove :: [Ndx]             -- ^ Allowed target node indices
 392                   -> Bool              -- ^ Whether disk moves are allowed
 393                   -> Table             -- ^ Original table
 394                   -> Instance.Instance -- ^ Instance to move
 395                   -> Table             -- ^ Best new table for this instance
 396 checkInstanceMove nodes_idx disk_moves ini_tbl target =
 397     let
 398         opdx = Instance.pnode target
 399         osdx = Instance.snode target
 400         nodes = filter (\idx -> idx /= opdx && idx /= osdx) nodes_idx
 401         use_secondary = elem osdx nodes_idx
 402         aft_failover = if use_secondary -- if allowed to failover
 403                        then checkSingleStep ini_tbl target ini_tbl Failover
 404                        else ini_tbl
 405         all_moves = if disk_moves
 406                     then concatMap (possibleMoves use_secondary) nodes
 407                     else []
 408     in
 409       -- iterate over the possible nodes for this instance
 410       foldl' (checkSingleStep ini_tbl target) aft_failover all_moves
 411
 412 -- | Compute the best next move.
 413 checkMove :: [Ndx]               -- ^ Allowed target node indices
 414           -> Bool                -- ^ Whether disk moves are allowed
 415           -> Table               -- ^ The current solution
 416           -> [Instance.Instance] -- ^ List of instances still to move
 417           -> Table               -- ^ The new solution
 418 checkMove nodes_idx disk_moves ini_tbl victims =
 419     let Table _ _ _ ini_plc = ini_tbl
 420         -- iterate over all instances, computing the best move
 421         best_tbl =
 422             foldl'
 423             (\ step_tbl em ->
 424                  if Instance.snode em == Node.noSecondary then step_tbl
 425                     else compareTables step_tbl $
 426                          checkInstanceMove nodes_idx disk_moves ini_tbl em)
 427             ini_tbl victims
 428         Table _ _ _ best_plc = best_tbl
 429     in
 430       if length best_plc == length ini_plc then -- no advancement
 431           ini_tbl
 432       else
 433           best_tbl
 434
 435 -- | Run a balance move
 436
 437 tryBalance :: Table       -- ^ The starting table
 438            -> Int         -- ^ Remaining length
 439            -> Bool        -- ^ Allow disk moves
 440            -> Score       -- ^ Score at which to stop
 441            -> Maybe Table -- ^ The resulting table and commands
 442 tryBalance ini_tbl max_rounds disk_moves min_score =
 443     let Table ini_nl ini_il ini_cv ini_plc = ini_tbl
 444         ini_plc_len = length ini_plc
 445         allowed_next = (max_rounds < 0 || ini_plc_len < max_rounds) &&
 446                        ini_cv > min_score
 447     in
 448       if allowed_next
 449       then let all_inst = Container.elems ini_il
 450                node_idx = map Node.idx . filter (not . Node.offline) $
 451                           Container.elems ini_nl
 452                fin_tbl = checkMove node_idx disk_moves ini_tbl all_inst
 453                (Table _ _ fin_cv _) = fin_tbl
 454            in
 455              if fin_cv < ini_cv
 456              then Just fin_tbl -- this round made success, try deeper
 457              else Nothing
 458       else Nothing
 459
 460 -- * Allocation functions
 461
 462 -- | Build failure stats out of a list of failures
 463 collapseFailures :: [FailMode] -> FailStats
 464 collapseFailures flst =
 465     map (\k -> (k, length $ filter ((==) k) flst)) [minBound..maxBound]
 466
 467 -- | Update current Allocation solution and failure stats with new
 468 -- elements
 469 concatAllocs :: AllocSolution -> OpResult AllocElement -> AllocSolution
 470 concatAllocs (flst, cntok, sols) (OpFail reason) = (reason:flst, cntok, sols)
 471
 472 concatAllocs (flst, cntok, osols) (OpGood ns@(nl, _, _)) =
 473     let nscore = compCV nl
 474         -- Choose the old or new solution, based on the cluster score
 475         nsols = case osols of
 476                   Nothing -> Just (nscore, ns)
 477                   Just (oscore, _) ->
 478                       if oscore < nscore
 479                       then osols
 480                       else Just (nscore, ns)
 481         nsuc = cntok + 1
 482     -- Note: we force evaluation of nsols here in order to keep the
 483     -- memory profile low - we know that we will need nsols for sure
 484     -- in the next cycle, so we force evaluation of nsols, since the
 485     -- foldl' in the caller will only evaluate the tuple, but not the
 486     -- elements of the tuple
 487     in nsols `seq` nsuc `seq` (flst, nsuc, nsols)
 488
 489 -- | Try to allocate an instance on the cluster.
 490 tryAlloc :: (Monad m) =>
 491             Node.List         -- ^ The node list
 492          -> Instance.List     -- ^ The instance list
 493          -> Instance.Instance -- ^ The instance to allocate
 494          -> Int               -- ^ Required number of nodes
 495          -> m AllocSolution   -- ^ Possible solution list
 496 tryAlloc nl _ inst 2 =
 497     let all_nodes = getOnline nl
 498         all_pairs = liftM2 (,) all_nodes all_nodes
 499         ok_pairs = filter (\(x, y) -> Node.idx x /= Node.idx y) all_pairs
 500         sols = foldl' (\cstate (p, s) ->
 501                            concatAllocs cstate $ allocateOnPair nl inst p s
 502                       ) ([], 0, Nothing) ok_pairs
 503     in return sols
 504
 505 tryAlloc nl _ inst 1 =
 506     let all_nodes = getOnline nl
 507         sols = foldl' (\cstate ->
 508                            concatAllocs cstate . allocateOnSingle nl inst
 509                       ) ([], 0, Nothing) all_nodes
 510     in return sols
 511
 512 tryAlloc _ _ _ reqn = fail $ "Unsupported number of allocation \
 513                              \destinations required (" ++ show reqn ++
 514                                                "), only two supported"
 515
 516 -- | Try to allocate an instance on the cluster.
 517 tryReloc :: (Monad m) =>
 518             Node.List       -- ^ The node list
 519          -> Instance.List   -- ^ The instance list
 520          -> Idx             -- ^ The index of the instance to move
 521          -> Int             -- ^ The number of nodes required
 522          -> [Ndx]           -- ^ Nodes which should not be used
 523          -> m AllocSolution -- ^ Solution list
 524 tryReloc nl il xid 1 ex_idx =
 525     let all_nodes = getOnline nl
 526         inst = Container.find xid il
 527         ex_idx' = Instance.pnode inst:ex_idx
 528         valid_nodes = filter (not . flip elem ex_idx' . Node.idx) all_nodes
 529         valid_idxes = map Node.idx valid_nodes
 530         sols1 = foldl' (\cstate x ->
 531                             let em = do
 532                                   (mnl, i, _, _) <-
 533                                       applyMove nl inst (ReplaceSecondary x)
 534                                   return (mnl, i, [Container.find x mnl])
 535                             in concatAllocs cstate em
 536                        ) ([], 0, Nothing) valid_idxes
 537     in return sols1
 538
 539 tryReloc _ _ _ reqn _  = fail $ "Unsupported number of relocation \
 540                                 \destinations required (" ++ show reqn ++
 541                                                   "), only one supported"
 542
 543 -- * Formatting functions
 544
 545 -- | Given the original and final nodes, computes the relocation description.
 546 computeMoves :: Instance.Instance -- ^ The instance to be moved
 547              -> String -- ^ The instance name
 548              -> String -- ^ Original primary
 549              -> String -- ^ Original secondary
 550              -> String -- ^ New primary
 551              -> String -- ^ New secondary
 552              -> (String, [String])
 553                 -- ^ Tuple of moves and commands list; moves is containing
 554                 -- either @/f/@ for failover or @/r:name/@ for replace
 555                 -- secondary, while the command list holds gnt-instance
 556                 -- commands (without that prefix), e.g \"@failover instance1@\"
 557 computeMoves i inam a b c d
 558     -- same primary
 559     | c == a =
 560         if d == b
 561         then {- Same sec??! -} ("-", [])
 562         else {- Change of secondary -}
 563             (printf "r:%s" d, [rep d])
 564     -- failover and ...
 565     | c == b =
 566         if d == a
 567         then {- that's all -} ("f", [mig])
 568         else (printf "f r:%s" d, [mig, rep d])
 569     -- ... and keep primary as secondary
 570     | d == a =
 571         (printf "r:%s f" c, [rep c, mig])
 572     -- ... keep same secondary
 573     | d == b =
 574         (printf "f r:%s f" c, [mig, rep c, mig])
 575     -- nothing in common -
 576     | otherwise =
 577         (printf "r:%s f r:%s" c d, [rep c, mig, rep d])
 578     where morf = if Instance.running i then "migrate" else "failover"
 579           mig = printf "%s -f %s" morf inam::String
 580           rep n = printf "replace-disks -n %s %s" n inam
 581
 582 -- | Converts a placement to string format.
 583 printSolutionLine :: Node.List     -- ^ The node list
 584                   -> Instance.List -- ^ The instance list
 585                   -> Int           -- ^ Maximum node name length
 586                   -> Int           -- ^ Maximum instance name length
 587                   -> Placement     -- ^ The current placement
 588                   -> Int           -- ^ The index of the placement in
 589                                    -- the solution
 590                   -> (String, [String])
 591 printSolutionLine nl il nmlen imlen plc pos =
 592     let
 593         pmlen = (2*nmlen + 1)
 594         (i, p, s, _, c) = plc
 595         inst = Container.find i il
 596         inam = Instance.name inst
 597         npri = Container.nameOf nl p
 598         nsec = Container.nameOf nl s
 599         opri = Container.nameOf nl $ Instance.pnode inst
 600         osec = Container.nameOf nl $ Instance.snode inst
 601         (moves, cmds) =  computeMoves inst inam opri osec npri nsec
 602         ostr = printf "%s:%s" opri osec::String
 603         nstr = printf "%s:%s" npri nsec::String
 604     in
 605       (printf "  %3d. %-*s %-*s => %-*s %.8f a=%s"
 606        pos imlen inam pmlen ostr
 607        pmlen nstr c moves,
 608        cmds)
 609
 610 -- | Return the instance and involved nodes in an instance move.
 611 involvedNodes :: Instance.List -> Placement -> [Ndx]
 612 involvedNodes il plc =
 613     let (i, np, ns, _, _) = plc
 614         inst = Container.find i il
 615         op = Instance.pnode inst
 616         os = Instance.snode inst
 617     in nub [np, ns, op, os]
 618
 619 -- | Inner function for splitJobs, that either appends the next job to
 620 -- the current jobset, or starts a new jobset.
 621 mergeJobs :: ([JobSet], [Ndx]) -> MoveJob -> ([JobSet], [Ndx])
 622 mergeJobs ([], _) n@(ndx, _, _, _) = ([[n]], ndx)
 623 mergeJobs (cjs@(j:js), nbuf) n@(ndx, _, _, _)
 624     | null (ndx `intersect` nbuf) = ((n:j):js, ndx ++ nbuf)
 625     | otherwise = ([n]:cjs, ndx)
 626
 627 -- | Break a list of moves into independent groups. Note that this
 628 -- will reverse the order of jobs.
 629 splitJobs :: [MoveJob] -> [JobSet]
 630 splitJobs = fst . foldl mergeJobs ([], [])
 631
 632 -- | Given a list of commands, prefix them with @gnt-instance@ and
 633 -- also beautify the display a little.
 634 formatJob :: Int -> Int -> (Int, MoveJob) -> [String]
 635 formatJob jsn jsl (sn, (_, _, _, cmds)) =
 636     let out =
 637             printf "  echo job %d/%d" jsn sn:
 638             printf "  check":
 639             map ("  gnt-instance " ++) cmds
 640     in if sn == 1
 641        then ["", printf "echo jobset %d, %d jobs" jsn jsl] ++ out
 642        else out
 643
 644 -- | Given a list of commands, prefix them with @gnt-instance@ and
 645 -- also beautify the display a little.
 646 formatCmds :: [JobSet] -> String
 647 formatCmds =
 648     unlines .
 649     concatMap (\(jsn, js) -> concatMap (formatJob jsn (length js))
 650                              (zip [1..] js)) .
 651     zip [1..]
 652
 653 -- | Converts a solution to string format.
 654 printSolution :: Node.List
 655               -> Instance.List
 656               -> [Placement]
 657               -> ([String], [[String]])
 658 printSolution nl il sol =
 659     let
 660         nmlen = Container.maxNameLen nl
 661         imlen = Container.maxNameLen il
 662     in
 663       unzip $ zipWith (printSolutionLine nl il nmlen imlen) sol [1..]
 664
 665 -- | Print the node list.
 666 printNodes :: Node.List -> String
 667 printNodes nl =
 668     let snl = sortBy (compare `on` Node.idx) (Container.elems nl)
 669         m_name = maximum . map (length . Node.name) $ snl
 670         helper = Node.list m_name
 671         header = printf
 672                  "%2s %-*s %5s %5s %5s %5s %5s %5s %5s %5s %4s %4s \
 673                  \%3s %3s %6s %6s %5s"
 674                  " F" m_name "Name"
 675                  "t_mem" "n_mem" "i_mem" "x_mem" "f_mem" "r_mem"
 676                  "t_dsk" "f_dsk" "pcpu" "vcpu"
 677                  "pri" "sec" "p_fmem" "p_fdsk" "r_cpu"::String
 678     in unlines (header:map helper snl)
 679
 680 -- | Shows statistics for a given node list.
 681 printStats :: Node.List -> String
 682 printStats nl =
 683     let (mem_cv, dsk_cv, n1_score, res_cv, off_score, cpu_cv) =
 684             compDetailedCV nl
 685     in printf "f_mem=%.8f, r_mem=%.8f, f_dsk=%.8f, n1=%.3f, \
 686               \uf=%.3f, r_cpu=%.3f"
 687        mem_cv res_cv dsk_cv n1_score off_score cpu_cv
 688
 689 -- | Convert a placement into a list of OpCodes (basically a job).
 690 iMoveToJob :: String -> Node.List -> Instance.List
 691           -> Idx -> IMove -> [OpCodes.OpCode]
 692 iMoveToJob csf nl il idx move =
 693     let inst = Container.find idx il
 694         iname = Instance.name inst ++ csf
 695         lookNode n = Just (Container.nameOf nl n ++ csf)
 696         opF = if Instance.running inst
 697               then OpCodes.OpMigrateInstance iname True False
 698               else OpCodes.OpFailoverInstance iname False
 699         opR n = OpCodes.OpReplaceDisks iname (lookNode n)
 700                 OpCodes.ReplaceNewSecondary [] Nothing
 701     in case move of
 702          Failover -> [ opF ]
 703          ReplacePrimary np -> [ opF, opR np, opF ]
 704          ReplaceSecondary ns -> [ opR ns ]
 705          ReplaceAndFailover np -> [ opR np, opF ]
 706          FailoverAndReplace ns -> [ opF, opR ns ]