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