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