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