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