code.grnet.gr Git - ganeti-local/blob - htools/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, 2011, 2012 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   , EvacSolution(..)
  34   , Table(..)
  35   , CStats(..)
  36   , AllocResult
  37   , AllocMethod
  38   , AllocSolutionList
  39   -- * Generic functions
  40   , totalResources
  41   , computeAllocationDelta
  42   -- * First phase functions
  43   , computeBadItems
  44   -- * Second phase functions
  45   , printSolutionLine
  46   , formatCmds
  47   , involvedNodes
  48   , splitJobs
  49   -- * Display functions
  50   , printNodes
  51   , printInsts
  52   -- * Balacing functions
  53   , checkMove
  54   , doNextBalance
  55   , tryBalance
  56   , compCV
  57   , compCVNodes
  58   , compDetailedCV
  59   , printStats
  60   , iMoveToJob
  61   -- * IAllocator functions
  62   , genAllocNodes
  63   , tryAlloc
  64   , tryMGAlloc
  65   , tryNodeEvac
  66   , tryChangeGroup
  67   , collapseFailures
  68   , allocList
  69   -- * Allocation functions
  70   , iterateAlloc
  71   , tieredAlloc
  72   -- * Node group functions
  73   , instanceGroup
  74   , findSplitInstances
  75   , splitCluster
  76   ) where
  77
  78 import qualified Data.IntSet as IntSet
  79 import Data.List
  80 import Data.Maybe (fromJust, isNothing)
  81 import Data.Ord (comparing)
  82 import Text.Printf (printf)
  83
  84 import Ganeti.BasicTypes
  85 import qualified Ganeti.HTools.Container as Container
  86 import qualified Ganeti.HTools.Instance as Instance
  87 import qualified Ganeti.HTools.Node as Node
  88 import qualified Ganeti.HTools.Group as Group
  89 import Ganeti.HTools.Types
  90 import Ganeti.Compat
  91 import qualified Ganeti.OpCodes as OpCodes
  92 import Ganeti.Utils
  93 import Ganeti.Types (mkNonEmpty)
  94
  95 -- * Types
  96
  97 -- | Allocation\/relocation solution.
  98 data AllocSolution = AllocSolution
  99   { asFailures :: [FailMode]              -- ^ Failure counts
 100   , asAllocs   :: Int                     -- ^ Good allocation count
 101   , asSolution :: Maybe Node.AllocElement -- ^ The actual allocation result
 102   , asLog      :: [String]                -- ^ Informational messages
 103   }
 104
 105 -- | Node evacuation/group change iallocator result type. This result
 106 -- type consists of actual opcodes (a restricted subset) that are
 107 -- transmitted back to Ganeti.
 108 data EvacSolution = EvacSolution
 109   { esMoved   :: [(Idx, Gdx, [Ndx])]  -- ^ Instances moved successfully
 110   , esFailed  :: [(Idx, String)]      -- ^ Instances which were not
 111                                       -- relocated
 112   , esOpCodes :: [[OpCodes.OpCode]]   -- ^ List of jobs
 113   } deriving (Show)
 114
 115 -- | Allocation results, as used in 'iterateAlloc' and 'tieredAlloc'.
 116 type AllocResult = (FailStats, Node.List, Instance.List,
 117                     [Instance.Instance], [CStats])
 118
 119 -- | Type alias for easier handling.
 120 type AllocSolutionList = [(Instance.Instance, AllocSolution)]
 121
 122 -- | A type denoting the valid allocation mode/pairs.
 123 --
 124 -- For a one-node allocation, this will be a @Left ['Ndx']@, whereas
 125 -- for a two-node allocation, this will be a @Right [('Ndx',
 126 -- ['Ndx'])]@. In the latter case, the list is basically an
 127 -- association list, grouped by primary node and holding the potential
 128 -- secondary nodes in the sub-list.
 129 type AllocNodes = Either [Ndx] [(Ndx, [Ndx])]
 130
 131 -- | The empty solution we start with when computing allocations.
 132 emptyAllocSolution :: AllocSolution
 133 emptyAllocSolution = AllocSolution { asFailures = [], asAllocs = 0
 134                                    , asSolution = Nothing, asLog = [] }
 135
 136 -- | The empty evac solution.
 137 emptyEvacSolution :: EvacSolution
 138 emptyEvacSolution = EvacSolution { esMoved = []
 139                                  , esFailed = []
 140                                  , esOpCodes = []
 141                                  }
 142
 143 -- | The complete state for the balancing solution.
 144 data Table = Table Node.List Instance.List Score [Placement]
 145              deriving (Show)
 146
 147 -- | Cluster statistics data type.
 148 data CStats = CStats
 149   { csFmem :: Integer -- ^ Cluster free mem
 150   , csFdsk :: Integer -- ^ Cluster free disk
 151   , csAmem :: Integer -- ^ Cluster allocatable mem
 152   , csAdsk :: Integer -- ^ Cluster allocatable disk
 153   , csAcpu :: Integer -- ^ Cluster allocatable cpus
 154   , csMmem :: Integer -- ^ Max node allocatable mem
 155   , csMdsk :: Integer -- ^ Max node allocatable disk
 156   , csMcpu :: Integer -- ^ Max node allocatable cpu
 157   , csImem :: Integer -- ^ Instance used mem
 158   , csIdsk :: Integer -- ^ Instance used disk
 159   , csIcpu :: Integer -- ^ Instance used cpu
 160   , csTmem :: Double  -- ^ Cluster total mem
 161   , csTdsk :: Double  -- ^ Cluster total disk
 162   , csTcpu :: Double  -- ^ Cluster total cpus
 163   , csVcpu :: Integer -- ^ Cluster total virtual cpus
 164   , csNcpu :: Double  -- ^ Equivalent to 'csIcpu' but in terms of
 165                       -- physical CPUs, i.e. normalised used phys CPUs
 166   , csXmem :: Integer -- ^ Unnacounted for mem
 167   , csNmem :: Integer -- ^ Node own memory
 168   , csScore :: Score  -- ^ The cluster score
 169   , csNinst :: Int    -- ^ The total number of instances
 170   } deriving (Show)
 171
 172 -- | A simple type for allocation functions.
 173 type AllocMethod =  Node.List           -- ^ Node list
 174                  -> Instance.List       -- ^ Instance list
 175                  -> Maybe Int           -- ^ Optional allocation limit
 176                  -> Instance.Instance   -- ^ Instance spec for allocation
 177                  -> AllocNodes          -- ^ Which nodes we should allocate on
 178                  -> [Instance.Instance] -- ^ Allocated instances
 179                  -> [CStats]            -- ^ Running cluster stats
 180                  -> Result AllocResult  -- ^ Allocation result
 181
 182 -- | A simple type for the running solution of evacuations.
 183 type EvacInnerState =
 184   Either String (Node.List, Instance.Instance, Score, Ndx)
 185
 186 -- * Utility functions
 187
 188 -- | Verifies the N+1 status and return the affected nodes.
 189 verifyN1 :: [Node.Node] -> [Node.Node]
 190 verifyN1 = filter Node.failN1
 191
 192 {-| Computes the pair of bad nodes and instances.
 193
 194 The bad node list is computed via a simple 'verifyN1' check, and the
 195 bad instance list is the list of primary and secondary instances of
 196 those nodes.
 197
 198 -}
 199 computeBadItems :: Node.List -> Instance.List ->
 200                    ([Node.Node], [Instance.Instance])
 201 computeBadItems nl il =
 202   let bad_nodes = verifyN1 $ getOnline nl
 203       bad_instances = map (`Container.find` il) .
 204                       sort . nub $
 205                       concatMap (\ n -> Node.sList n ++ Node.pList n) bad_nodes
 206   in
 207     (bad_nodes, bad_instances)
 208
 209 -- | Extracts the node pairs for an instance. This can fail if the
 210 -- instance is single-homed. FIXME: this needs to be improved,
 211 -- together with the general enhancement for handling non-DRBD moves.
 212 instanceNodes :: Node.List -> Instance.Instance ->
 213                  (Ndx, Ndx, Node.Node, Node.Node)
 214 instanceNodes nl inst =
 215   let old_pdx = Instance.pNode inst
 216       old_sdx = Instance.sNode inst
 217       old_p = Container.find old_pdx nl
 218       old_s = Container.find old_sdx nl
 219   in (old_pdx, old_sdx, old_p, old_s)
 220
 221 -- | Zero-initializer for the CStats type.
 222 emptyCStats :: CStats
 223 emptyCStats = CStats 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
 224
 225 -- | Update stats with data from a new node.
 226 updateCStats :: CStats -> Node.Node -> CStats
 227 updateCStats cs node =
 228   let CStats { csFmem = x_fmem, csFdsk = x_fdsk,
 229                csAmem = x_amem, csAcpu = x_acpu, csAdsk = x_adsk,
 230                csMmem = x_mmem, csMdsk = x_mdsk, csMcpu = x_mcpu,
 231                csImem = x_imem, csIdsk = x_idsk, csIcpu = x_icpu,
 232                csTmem = x_tmem, csTdsk = x_tdsk, csTcpu = x_tcpu,
 233                csVcpu = x_vcpu, csNcpu = x_ncpu,
 234                csXmem = x_xmem, csNmem = x_nmem, csNinst = x_ninst
 235              }
 236         = cs
 237       inc_amem = Node.fMem node - Node.rMem node
 238       inc_amem' = if inc_amem > 0 then inc_amem else 0
 239       inc_adsk = Node.availDisk node
 240       inc_imem = truncate (Node.tMem node) - Node.nMem node
 241                  - Node.xMem node - Node.fMem node
 242       inc_icpu = Node.uCpu node
 243       inc_idsk = truncate (Node.tDsk node) - Node.fDsk node
 244       inc_vcpu = Node.hiCpu node
 245       inc_acpu = Node.availCpu node
 246       inc_ncpu = fromIntegral (Node.uCpu node) /
 247                  iPolicyVcpuRatio (Node.iPolicy node)
 248   in cs { csFmem = x_fmem + fromIntegral (Node.fMem node)
 249         , csFdsk = x_fdsk + fromIntegral (Node.fDsk node)
 250         , csAmem = x_amem + fromIntegral inc_amem'
 251         , csAdsk = x_adsk + fromIntegral inc_adsk
 252         , csAcpu = x_acpu + fromIntegral inc_acpu
 253         , csMmem = max x_mmem (fromIntegral inc_amem')
 254         , csMdsk = max x_mdsk (fromIntegral inc_adsk)
 255         , csMcpu = max x_mcpu (fromIntegral inc_acpu)
 256         , csImem = x_imem + fromIntegral inc_imem
 257         , csIdsk = x_idsk + fromIntegral inc_idsk
 258         , csIcpu = x_icpu + fromIntegral inc_icpu
 259         , csTmem = x_tmem + Node.tMem node
 260         , csTdsk = x_tdsk + Node.tDsk node
 261         , csTcpu = x_tcpu + Node.tCpu node
 262         , csVcpu = x_vcpu + fromIntegral inc_vcpu
 263         , csNcpu = x_ncpu + inc_ncpu
 264         , csXmem = x_xmem + fromIntegral (Node.xMem node)
 265         , csNmem = x_nmem + fromIntegral (Node.nMem node)
 266         , csNinst = x_ninst + length (Node.pList node)
 267         }
 268
 269 -- | Compute the total free disk and memory in the cluster.
 270 totalResources :: Node.List -> CStats
 271 totalResources nl =
 272   let cs = foldl' updateCStats emptyCStats . Container.elems $ nl
 273   in cs { csScore = compCV nl }
 274
 275 -- | Compute the delta between two cluster state.
 276 --
 277 -- This is used when doing allocations, to understand better the
 278 -- available cluster resources. The return value is a triple of the
 279 -- current used values, the delta that was still allocated, and what
 280 -- was left unallocated.
 281 computeAllocationDelta :: CStats -> CStats -> AllocStats
 282 computeAllocationDelta cini cfin =
 283   let CStats {csImem = i_imem, csIdsk = i_idsk, csIcpu = i_icpu,
 284               csNcpu = i_ncpu } = cini
 285       CStats {csImem = f_imem, csIdsk = f_idsk, csIcpu = f_icpu,
 286               csTmem = t_mem, csTdsk = t_dsk, csVcpu = f_vcpu,
 287               csNcpu = f_ncpu, csTcpu = f_tcpu } = cfin
 288       rini = AllocInfo { allocInfoVCpus = fromIntegral i_icpu
 289                        , allocInfoNCpus = i_ncpu
 290                        , allocInfoMem   = fromIntegral i_imem
 291                        , allocInfoDisk  = fromIntegral i_idsk
 292                        }
 293       rfin = AllocInfo { allocInfoVCpus = fromIntegral (f_icpu - i_icpu)
 294                        , allocInfoNCpus = f_ncpu - i_ncpu
 295                        , allocInfoMem   = fromIntegral (f_imem - i_imem)
 296                        , allocInfoDisk  = fromIntegral (f_idsk - i_idsk)
 297                        }
 298       runa = AllocInfo { allocInfoVCpus = fromIntegral (f_vcpu - f_icpu)
 299                        , allocInfoNCpus = f_tcpu - f_ncpu
 300                        , allocInfoMem   = truncate t_mem - fromIntegral f_imem
 301                        , allocInfoDisk  = truncate t_dsk - fromIntegral f_idsk
 302                        }
 303   in (rini, rfin, runa)
 304
 305 -- | The names and weights of the individual elements in the CV list.
 306 detailedCVInfo :: [(Double, String)]
 307 detailedCVInfo = [ (1,  "free_mem_cv")
 308                  , (1,  "free_disk_cv")
 309                  , (1,  "n1_cnt")
 310                  , (1,  "reserved_mem_cv")
 311                  , (4,  "offline_all_cnt")
 312                  , (16, "offline_pri_cnt")
 313                  , (1,  "vcpu_ratio_cv")
 314                  , (1,  "cpu_load_cv")
 315                  , (1,  "mem_load_cv")
 316                  , (1,  "disk_load_cv")
 317                  , (1,  "net_load_cv")
 318                  , (2,  "pri_tags_score")
 319                  , (1,  "spindles_cv")
 320                  ]
 321
 322 -- | Holds the weights used by 'compCVNodes' for each metric.
 323 detailedCVWeights :: [Double]
 324 detailedCVWeights = map fst detailedCVInfo
 325
 326 -- | Compute the mem and disk covariance.
 327 compDetailedCV :: [Node.Node] -> [Double]
 328 compDetailedCV all_nodes =
 329   let (offline, nodes) = partition Node.offline all_nodes
 330       mem_l = map Node.pMem nodes
 331       dsk_l = map Node.pDsk nodes
 332       -- metric: memory covariance
 333       mem_cv = stdDev mem_l
 334       -- metric: disk covariance
 335       dsk_cv = stdDev dsk_l
 336       -- metric: count of instances living on N1 failing nodes
 337       n1_score = fromIntegral . sum . map (\n -> length (Node.sList n) +
 338                                                  length (Node.pList n)) .
 339                  filter Node.failN1 $ nodes :: Double
 340       res_l = map Node.pRem nodes
 341       -- metric: reserved memory covariance
 342       res_cv = stdDev res_l
 343       -- offline instances metrics
 344       offline_ipri = sum . map (length . Node.pList) $ offline
 345       offline_isec = sum . map (length . Node.sList) $ offline
 346       -- metric: count of instances on offline nodes
 347       off_score = fromIntegral (offline_ipri + offline_isec)::Double
 348       -- metric: count of primary instances on offline nodes (this
 349       -- helps with evacuation/failover of primary instances on
 350       -- 2-node clusters with one node offline)
 351       off_pri_score = fromIntegral offline_ipri::Double
 352       cpu_l = map Node.pCpu nodes
 353       -- metric: covariance of vcpu/pcpu ratio
 354       cpu_cv = stdDev cpu_l
 355       -- metrics: covariance of cpu, memory, disk and network load
 356       (c_load, m_load, d_load, n_load) =
 357         unzip4 $ map (\n ->
 358                       let DynUtil c1 m1 d1 n1 = Node.utilLoad n
 359                           DynUtil c2 m2 d2 n2 = Node.utilPool n
 360                       in (c1/c2, m1/m2, d1/d2, n1/n2)) nodes
 361       -- metric: conflicting instance count
 362       pri_tags_inst = sum $ map Node.conflictingPrimaries nodes
 363       pri_tags_score = fromIntegral pri_tags_inst::Double
 364       -- metric: spindles %
 365       spindles_cv = map (\n -> Node.instSpindles n / Node.hiSpindles n) nodes
 366   in [ mem_cv, dsk_cv, n1_score, res_cv, off_score, off_pri_score, cpu_cv
 367      , stdDev c_load, stdDev m_load , stdDev d_load, stdDev n_load
 368      , pri_tags_score, stdDev spindles_cv ]
 369
 370 -- | Compute the /total/ variance.
 371 compCVNodes :: [Node.Node] -> Double
 372 compCVNodes = sum . zipWith (*) detailedCVWeights . compDetailedCV
 373
 374 -- | Wrapper over 'compCVNodes' for callers that have a 'Node.List'.
 375 compCV :: Node.List -> Double
 376 compCV = compCVNodes . Container.elems
 377
 378 -- | Compute online nodes from a 'Node.List'.
 379 getOnline :: Node.List -> [Node.Node]
 380 getOnline = filter (not . Node.offline) . Container.elems
 381
 382 -- * Balancing functions
 383
 384 -- | Compute best table. Note that the ordering of the arguments is important.
 385 compareTables :: Table -> Table -> Table
 386 compareTables a@(Table _ _ a_cv _) b@(Table _ _ b_cv _ ) =
 387   if a_cv > b_cv then b else a
 388
 389 -- | Applies an instance move to a given node list and instance.
 390 applyMove :: Node.List -> Instance.Instance
 391           -> IMove -> OpResult (Node.List, Instance.Instance, Ndx, Ndx)
 392 -- Failover (f)
 393 applyMove nl inst Failover =
 394   let (old_pdx, old_sdx, old_p, old_s) = instanceNodes nl inst
 395       int_p = Node.removePri old_p inst
 396       int_s = Node.removeSec old_s inst
 397       new_nl = do -- Maybe monad
 398         new_p <- Node.addPriEx (Node.offline old_p) int_s inst
 399         new_s <- Node.addSec int_p inst old_sdx
 400         let new_inst = Instance.setBoth inst old_sdx old_pdx
 401         return (Container.addTwo old_pdx new_s old_sdx new_p nl,
 402                 new_inst, old_sdx, old_pdx)
 403   in new_nl
 404
 405 -- Failover to any (fa)
 406 applyMove nl inst (FailoverToAny new_pdx) = do
 407   let (old_pdx, old_sdx, old_pnode, _) = instanceNodes nl inst
 408       new_pnode = Container.find new_pdx nl
 409       force_failover = Node.offline old_pnode
 410   new_pnode' <- Node.addPriEx force_failover new_pnode inst
 411   let old_pnode' = Node.removePri old_pnode inst
 412       inst' = Instance.setPri inst new_pdx
 413       nl' = Container.addTwo old_pdx old_pnode' new_pdx new_pnode' nl
 414   return (nl', inst', new_pdx, old_sdx)
 415
 416 -- Replace the primary (f:, r:np, f)
 417 applyMove nl inst (ReplacePrimary new_pdx) =
 418   let (old_pdx, old_sdx, old_p, old_s) = instanceNodes nl inst
 419       tgt_n = Container.find new_pdx nl
 420       int_p = Node.removePri old_p inst
 421       int_s = Node.removeSec old_s inst
 422       force_p = Node.offline old_p
 423       new_nl = do -- Maybe monad
 424                   -- check that the current secondary can host the instance
 425                   -- during the migration
 426         tmp_s <- Node.addPriEx force_p int_s inst
 427         let tmp_s' = Node.removePri tmp_s inst
 428         new_p <- Node.addPriEx force_p tgt_n inst
 429         new_s <- Node.addSecEx force_p tmp_s' inst new_pdx
 430         let new_inst = Instance.setPri inst new_pdx
 431         return (Container.add new_pdx new_p $
 432                 Container.addTwo old_pdx int_p old_sdx new_s nl,
 433                 new_inst, new_pdx, old_sdx)
 434   in new_nl
 435
 436 -- Replace the secondary (r:ns)
 437 applyMove nl inst (ReplaceSecondary new_sdx) =
 438   let old_pdx = Instance.pNode inst
 439       old_sdx = Instance.sNode inst
 440       old_s = Container.find old_sdx nl
 441       tgt_n = Container.find new_sdx nl
 442       int_s = Node.removeSec old_s inst
 443       force_s = Node.offline old_s
 444       new_inst = Instance.setSec inst new_sdx
 445       new_nl = Node.addSecEx force_s tgt_n inst old_pdx >>=
 446                \new_s -> return (Container.addTwo new_sdx
 447                                  new_s old_sdx int_s nl,
 448                                  new_inst, old_pdx, new_sdx)
 449   in new_nl
 450
 451 -- Replace the secondary and failover (r:np, f)
 452 applyMove nl inst (ReplaceAndFailover new_pdx) =
 453   let (old_pdx, old_sdx, old_p, old_s) = instanceNodes nl inst
 454       tgt_n = Container.find new_pdx nl
 455       int_p = Node.removePri old_p inst
 456       int_s = Node.removeSec old_s inst
 457       force_s = Node.offline old_s
 458       new_nl = do -- Maybe monad
 459         new_p <- Node.addPri tgt_n inst
 460         new_s <- Node.addSecEx force_s int_p inst new_pdx
 461         let new_inst = Instance.setBoth inst new_pdx old_pdx
 462         return (Container.add new_pdx new_p $
 463                 Container.addTwo old_pdx new_s old_sdx int_s nl,
 464                 new_inst, new_pdx, old_pdx)
 465   in new_nl
 466
 467 -- Failver and replace the secondary (f, r:ns)
 468 applyMove nl inst (FailoverAndReplace new_sdx) =
 469   let (old_pdx, old_sdx, old_p, old_s) = instanceNodes nl inst
 470       tgt_n = Container.find new_sdx nl
 471       int_p = Node.removePri old_p inst
 472       int_s = Node.removeSec old_s inst
 473       force_p = Node.offline old_p
 474       new_nl = do -- Maybe monad
 475         new_p <- Node.addPriEx force_p int_s inst
 476         new_s <- Node.addSecEx force_p tgt_n inst old_sdx
 477         let new_inst = Instance.setBoth inst old_sdx new_sdx
 478         return (Container.add new_sdx new_s $
 479                 Container.addTwo old_sdx new_p old_pdx int_p nl,
 480                 new_inst, old_sdx, new_sdx)
 481   in new_nl
 482
 483 -- | Tries to allocate an instance on one given node.
 484 allocateOnSingle :: Node.List -> Instance.Instance -> Ndx
 485                  -> OpResult Node.AllocElement
 486 allocateOnSingle nl inst new_pdx =
 487   let p = Container.find new_pdx nl
 488       new_inst = Instance.setBoth inst new_pdx Node.noSecondary
 489   in do
 490     Instance.instMatchesPolicy inst (Node.iPolicy p)
 491     new_p <- Node.addPri p inst
 492     let new_nl = Container.add new_pdx new_p nl
 493         new_score = compCV new_nl
 494     return (new_nl, new_inst, [new_p], new_score)
 495
 496 -- | Tries to allocate an instance on a given pair of nodes.
 497 allocateOnPair :: Node.List -> Instance.Instance -> Ndx -> Ndx
 498                -> OpResult Node.AllocElement
 499 allocateOnPair nl inst new_pdx new_sdx =
 500   let tgt_p = Container.find new_pdx nl
 501       tgt_s = Container.find new_sdx nl
 502   in do
 503     Instance.instMatchesPolicy inst (Node.iPolicy tgt_p)
 504     new_p <- Node.addPri tgt_p inst
 505     new_s <- Node.addSec tgt_s inst new_pdx
 506     let new_inst = Instance.setBoth inst new_pdx new_sdx
 507         new_nl = Container.addTwo new_pdx new_p new_sdx new_s nl
 508     return (new_nl, new_inst, [new_p, new_s], compCV new_nl)
 509
 510 -- | Tries to perform an instance move and returns the best table
 511 -- between the original one and the new one.
 512 checkSingleStep :: Table -- ^ The original table
 513                 -> Instance.Instance -- ^ The instance to move
 514                 -> Table -- ^ The current best table
 515                 -> IMove -- ^ The move to apply
 516                 -> Table -- ^ The final best table
 517 checkSingleStep ini_tbl target cur_tbl move =
 518   let Table ini_nl ini_il _ ini_plc = ini_tbl
 519       tmp_resu = applyMove ini_nl target move
 520   in case tmp_resu of
 521        Bad _ -> cur_tbl
 522        Ok (upd_nl, new_inst, pri_idx, sec_idx) ->
 523          let tgt_idx = Instance.idx target
 524              upd_cvar = compCV upd_nl
 525              upd_il = Container.add tgt_idx new_inst ini_il
 526              upd_plc = (tgt_idx, pri_idx, sec_idx, move, upd_cvar):ini_plc
 527              upd_tbl = Table upd_nl upd_il upd_cvar upd_plc
 528          in compareTables cur_tbl upd_tbl
 529
 530 -- | Given the status of the current secondary as a valid new node and
 531 -- the current candidate target node, generate the possible moves for
 532 -- a instance.
 533 possibleMoves :: MirrorType -- ^ The mirroring type of the instance
 534               -> Bool       -- ^ Whether the secondary node is a valid new node
 535               -> Bool       -- ^ Whether we can change the primary node
 536               -> Ndx        -- ^ Target node candidate
 537               -> [IMove]    -- ^ List of valid result moves
 538
 539 possibleMoves MirrorNone _ _ _ = []
 540
 541 possibleMoves MirrorExternal _ False _ = []
 542
 543 possibleMoves MirrorExternal _ True tdx =
 544   [ FailoverToAny tdx ]
 545
 546 possibleMoves MirrorInternal _ False tdx =
 547   [ ReplaceSecondary tdx ]
 548
 549 possibleMoves MirrorInternal True True tdx =
 550   [ ReplaceSecondary tdx
 551   , ReplaceAndFailover tdx
 552   , ReplacePrimary tdx
 553   , FailoverAndReplace tdx
 554   ]
 555
 556 possibleMoves MirrorInternal False True tdx =
 557   [ ReplaceSecondary tdx
 558   , ReplaceAndFailover tdx
 559   ]
 560
 561 -- | Compute the best move for a given instance.
 562 checkInstanceMove :: [Ndx]             -- ^ Allowed target node indices
 563                   -> Bool              -- ^ Whether disk moves are allowed
 564                   -> Bool              -- ^ Whether instance moves are allowed
 565                   -> Table             -- ^ Original table
 566                   -> Instance.Instance -- ^ Instance to move
 567                   -> Table             -- ^ Best new table for this instance
 568 checkInstanceMove nodes_idx disk_moves inst_moves ini_tbl target =
 569   let opdx = Instance.pNode target
 570       osdx = Instance.sNode target
 571       bad_nodes = [opdx, osdx]
 572       nodes = filter (`notElem` bad_nodes) nodes_idx
 573       mir_type = Instance.mirrorType target
 574       use_secondary = elem osdx nodes_idx && inst_moves
 575       aft_failover = if mir_type == MirrorInternal && use_secondary
 576                        -- if drbd and allowed to failover
 577                        then checkSingleStep ini_tbl target ini_tbl Failover
 578                        else ini_tbl
 579       all_moves =
 580         if disk_moves
 581           then concatMap (possibleMoves mir_type use_secondary inst_moves)
 582                nodes
 583           else []
 584     in
 585       -- iterate over the possible nodes for this instance
 586       foldl' (checkSingleStep ini_tbl target) aft_failover all_moves
 587
 588 -- | Compute the best next move.
 589 checkMove :: [Ndx]               -- ^ Allowed target node indices
 590           -> Bool                -- ^ Whether disk moves are allowed
 591           -> Bool                -- ^ Whether instance moves are allowed
 592           -> Table               -- ^ The current solution
 593           -> [Instance.Instance] -- ^ List of instances still to move
 594           -> Table               -- ^ The new solution
 595 checkMove nodes_idx disk_moves inst_moves ini_tbl victims =
 596   let Table _ _ _ ini_plc = ini_tbl
 597       -- we're using rwhnf from the Control.Parallel.Strategies
 598       -- package; we don't need to use rnf as that would force too
 599       -- much evaluation in single-threaded cases, and in
 600       -- multi-threaded case the weak head normal form is enough to
 601       -- spark the evaluation
 602       tables = parMap rwhnf (checkInstanceMove nodes_idx disk_moves
 603                              inst_moves ini_tbl)
 604                victims
 605       -- iterate over all instances, computing the best move
 606       best_tbl = foldl' compareTables ini_tbl tables
 607       Table _ _ _ best_plc = best_tbl
 608   in if length best_plc == length ini_plc
 609        then ini_tbl -- no advancement
 610        else best_tbl
 611
 612 -- | Check if we are allowed to go deeper in the balancing.
 613 doNextBalance :: Table     -- ^ The starting table
 614               -> Int       -- ^ Remaining length
 615               -> Score     -- ^ Score at which to stop
 616               -> Bool      -- ^ The resulting table and commands
 617 doNextBalance ini_tbl max_rounds min_score =
 618   let Table _ _ ini_cv ini_plc = ini_tbl
 619       ini_plc_len = length ini_plc
 620   in (max_rounds < 0 || ini_plc_len < max_rounds) && ini_cv > min_score
 621
 622 -- | Run a balance move.
 623 tryBalance :: Table       -- ^ The starting table
 624            -> Bool        -- ^ Allow disk moves
 625            -> Bool        -- ^ Allow instance moves
 626            -> Bool        -- ^ Only evacuate moves
 627            -> Score       -- ^ Min gain threshold
 628            -> Score       -- ^ Min gain
 629            -> Maybe Table -- ^ The resulting table and commands
 630 tryBalance ini_tbl disk_moves inst_moves evac_mode mg_limit min_gain =
 631     let Table ini_nl ini_il ini_cv _ = ini_tbl
 632         all_inst = Container.elems ini_il
 633         all_nodes = Container.elems ini_nl
 634         (offline_nodes, online_nodes) = partition Node.offline all_nodes
 635         all_inst' = if evac_mode
 636                       then let bad_nodes = map Node.idx offline_nodes
 637                            in filter (any (`elem` bad_nodes) .
 638                                           Instance.allNodes) all_inst
 639                       else all_inst
 640         reloc_inst = filter Instance.movable all_inst'
 641         node_idx = map Node.idx online_nodes
 642         fin_tbl = checkMove node_idx disk_moves inst_moves ini_tbl reloc_inst
 643         (Table _ _ fin_cv _) = fin_tbl
 644     in
 645       if fin_cv < ini_cv && (ini_cv > mg_limit || ini_cv - fin_cv >= min_gain)
 646       then Just fin_tbl -- this round made success, return the new table
 647       else Nothing
 648
 649 -- * Allocation functions
 650
 651 -- | Build failure stats out of a list of failures.
 652 collapseFailures :: [FailMode] -> FailStats
 653 collapseFailures flst =
 654     map (\k -> (k, foldl' (\a e -> if e == k then a + 1 else a) 0 flst))
 655             [minBound..maxBound]
 656
 657 -- | Compares two Maybe AllocElement and chooses the besst score.
 658 bestAllocElement :: Maybe Node.AllocElement
 659                  -> Maybe Node.AllocElement
 660                  -> Maybe Node.AllocElement
 661 bestAllocElement a Nothing = a
 662 bestAllocElement Nothing b = b
 663 bestAllocElement a@(Just (_, _, _, ascore)) b@(Just (_, _, _, bscore)) =
 664   if ascore < bscore then a else b
 665
 666 -- | Update current Allocation solution and failure stats with new
 667 -- elements.
 668 concatAllocs :: AllocSolution -> OpResult Node.AllocElement -> AllocSolution
 669 concatAllocs as (Bad reason) = as { asFailures = reason : asFailures as }
 670
 671 concatAllocs as (Ok ns) =
 672   let -- Choose the old or new solution, based on the cluster score
 673     cntok = asAllocs as
 674     osols = asSolution as
 675     nsols = bestAllocElement osols (Just ns)
 676     nsuc = cntok + 1
 677     -- Note: we force evaluation of nsols here in order to keep the
 678     -- memory profile low - we know that we will need nsols for sure
 679     -- in the next cycle, so we force evaluation of nsols, since the
 680     -- foldl' in the caller will only evaluate the tuple, but not the
 681     -- elements of the tuple
 682   in nsols `seq` nsuc `seq` as { asAllocs = nsuc, asSolution = nsols }
 683
 684 -- | Sums two 'AllocSolution' structures.
 685 sumAllocs :: AllocSolution -> AllocSolution -> AllocSolution
 686 sumAllocs (AllocSolution aFails aAllocs aSols aLog)
 687           (AllocSolution bFails bAllocs bSols bLog) =
 688   -- note: we add b first, since usually it will be smaller; when
 689   -- fold'ing, a will grow and grow whereas b is the per-group
 690   -- result, hence smaller
 691   let nFails  = bFails ++ aFails
 692       nAllocs = aAllocs + bAllocs
 693       nSols   = bestAllocElement aSols bSols
 694       nLog    = bLog ++ aLog
 695   in AllocSolution nFails nAllocs nSols nLog
 696
 697 -- | Given a solution, generates a reasonable description for it.
 698 describeSolution :: AllocSolution -> String
 699 describeSolution as =
 700   let fcnt = asFailures as
 701       sols = asSolution as
 702       freasons =
 703         intercalate ", " . map (\(a, b) -> printf "%s: %d" (show a) b) .
 704         filter ((> 0) . snd) . collapseFailures $ fcnt
 705   in case sols of
 706      Nothing -> "No valid allocation solutions, failure reasons: " ++
 707                 (if null fcnt then "unknown reasons" else freasons)
 708      Just (_, _, nodes, cv) ->
 709          printf ("score: %.8f, successes %d, failures %d (%s)" ++
 710                  " for node(s) %s") cv (asAllocs as) (length fcnt) freasons
 711                (intercalate "/" . map Node.name $ nodes)
 712
 713 -- | Annotates a solution with the appropriate string.
 714 annotateSolution :: AllocSolution -> AllocSolution
 715 annotateSolution as = as { asLog = describeSolution as : asLog as }
 716
 717 -- | Reverses an evacuation solution.
 718 --
 719 -- Rationale: we always concat the results to the top of the lists, so
 720 -- for proper jobset execution, we should reverse all lists.
 721 reverseEvacSolution :: EvacSolution -> EvacSolution
 722 reverseEvacSolution (EvacSolution f m o) =
 723   EvacSolution (reverse f) (reverse m) (reverse o)
 724
 725 -- | Generate the valid node allocation singles or pairs for a new instance.
 726 genAllocNodes :: Group.List        -- ^ Group list
 727               -> Node.List         -- ^ The node map
 728               -> Int               -- ^ The number of nodes required
 729               -> Bool              -- ^ Whether to drop or not
 730                                    -- unallocable nodes
 731               -> Result AllocNodes -- ^ The (monadic) result
 732 genAllocNodes gl nl count drop_unalloc =
 733   let filter_fn = if drop_unalloc
 734                     then filter (Group.isAllocable .
 735                                  flip Container.find gl . Node.group)
 736                     else id
 737       all_nodes = filter_fn $ getOnline nl
 738       all_pairs = [(Node.idx p,
 739                     [Node.idx s | s <- all_nodes,
 740                                        Node.idx p /= Node.idx s,
 741                                        Node.group p == Node.group s]) |
 742                    p <- all_nodes]
 743   in case count of
 744        1 -> Ok (Left (map Node.idx all_nodes))
 745        2 -> Ok (Right (filter (not . null . snd) all_pairs))
 746        _ -> Bad "Unsupported number of nodes, only one or two  supported"
 747
 748 -- | Try to allocate an instance on the cluster.
 749 tryAlloc :: (Monad m) =>
 750             Node.List         -- ^ The node list
 751          -> Instance.List     -- ^ The instance list
 752          -> Instance.Instance -- ^ The instance to allocate
 753          -> AllocNodes        -- ^ The allocation targets
 754          -> m AllocSolution   -- ^ Possible solution list
 755 tryAlloc _  _ _    (Right []) = fail "Not enough online nodes"
 756 tryAlloc nl _ inst (Right ok_pairs) =
 757   let psols = parMap rwhnf (\(p, ss) ->
 758                               foldl' (\cstate ->
 759                                         concatAllocs cstate .
 760                                         allocateOnPair nl inst p)
 761                               emptyAllocSolution ss) ok_pairs
 762       sols = foldl' sumAllocs emptyAllocSolution psols
 763   in return $ annotateSolution sols
 764
 765 tryAlloc _  _ _    (Left []) = fail "No online nodes"
 766 tryAlloc nl _ inst (Left all_nodes) =
 767   let sols = foldl' (\cstate ->
 768                        concatAllocs cstate . allocateOnSingle nl inst
 769                     ) emptyAllocSolution all_nodes
 770   in return $ annotateSolution sols
 771
 772 -- | Given a group/result, describe it as a nice (list of) messages.
 773 solutionDescription :: Group.List -> (Gdx, Result AllocSolution) -> [String]
 774 solutionDescription gl (groupId, result) =
 775   case result of
 776     Ok solution -> map (printf "Group %s (%s): %s" gname pol) (asLog solution)
 777     Bad message -> [printf "Group %s: error %s" gname message]
 778   where grp = Container.find groupId gl
 779         gname = Group.name grp
 780         pol = allocPolicyToRaw (Group.allocPolicy grp)
 781
 782 -- | From a list of possibly bad and possibly empty solutions, filter
 783 -- only the groups with a valid result. Note that the result will be
 784 -- reversed compared to the original list.
 785 filterMGResults :: Group.List
 786                 -> [(Gdx, Result AllocSolution)]
 787                 -> [(Gdx, AllocSolution)]
 788 filterMGResults gl = foldl' fn []
 789   where unallocable = not . Group.isAllocable . flip Container.find gl
 790         fn accu (gdx, rasol) =
 791           case rasol of
 792             Bad _ -> accu
 793             Ok sol | isNothing (asSolution sol) -> accu
 794                    | unallocable gdx -> accu
 795                    | otherwise -> (gdx, sol):accu
 796
 797 -- | Sort multigroup results based on policy and score.
 798 sortMGResults :: Group.List
 799              -> [(Gdx, AllocSolution)]
 800              -> [(Gdx, AllocSolution)]
 801 sortMGResults gl sols =
 802   let extractScore (_, _, _, x) = x
 803       solScore (gdx, sol) = (Group.allocPolicy (Container.find gdx gl),
 804                              (extractScore . fromJust . asSolution) sol)
 805   in sortBy (comparing solScore) sols
 806
 807 -- | Finds the best group for an instance on a multi-group cluster.
 808 --
 809 -- Only solutions in @preferred@ and @last_resort@ groups will be
 810 -- accepted as valid, and additionally if the allowed groups parameter
 811 -- is not null then allocation will only be run for those group
 812 -- indices.
 813 findBestAllocGroup :: Group.List           -- ^ The group list
 814                    -> Node.List            -- ^ The node list
 815                    -> Instance.List        -- ^ The instance list
 816                    -> Maybe [Gdx]          -- ^ The allowed groups
 817                    -> Instance.Instance    -- ^ The instance to allocate
 818                    -> Int                  -- ^ Required number of nodes
 819                    -> Result (Gdx, AllocSolution, [String])
 820 findBestAllocGroup mggl mgnl mgil allowed_gdxs inst cnt =
 821   let groups = splitCluster mgnl mgil
 822       groups' = maybe groups (\gs -> filter ((`elem` gs) . fst) groups)
 823                 allowed_gdxs
 824       sols = map (\(gid, (nl, il)) ->
 825                    (gid, genAllocNodes mggl nl cnt False >>=
 826                        tryAlloc nl il inst))
 827              groups'::[(Gdx, Result AllocSolution)]
 828       all_msgs = concatMap (solutionDescription mggl) sols
 829       goodSols = filterMGResults mggl sols
 830       sortedSols = sortMGResults mggl goodSols
 831   in if null sortedSols
 832        then Bad $ if null groups'
 833                     then "no groups for evacuation: allowed groups was" ++
 834                          show allowed_gdxs ++ ", all groups: " ++
 835                          show (map fst groups)
 836                     else intercalate ", " all_msgs
 837        else let (final_group, final_sol) = head sortedSols
 838             in return (final_group, final_sol, all_msgs)
 839
 840 -- | Try to allocate an instance on a multi-group cluster.
 841 tryMGAlloc :: Group.List           -- ^ The group list
 842            -> Node.List            -- ^ The node list
 843            -> Instance.List        -- ^ The instance list
 844            -> Instance.Instance    -- ^ The instance to allocate
 845            -> Int                  -- ^ Required number of nodes
 846            -> Result AllocSolution -- ^ Possible solution list
 847 tryMGAlloc mggl mgnl mgil inst cnt = do
 848   (best_group, solution, all_msgs) <-
 849       findBestAllocGroup mggl mgnl mgil Nothing inst cnt
 850   let group_name = Group.name $ Container.find best_group mggl
 851       selmsg = "Selected group: " ++ group_name
 852   return $ solution { asLog = selmsg:all_msgs }
 853
 854 -- | Calculate the new instance list after allocation solution.
 855 updateIl :: Instance.List           -- ^ The original instance list
 856          -> Maybe Node.AllocElement -- ^ The result of the allocation attempt
 857          -> Instance.List           -- ^ The updated instance list
 858 updateIl il Nothing = il
 859 updateIl il (Just (_, xi, _, _)) = Container.add (Container.size il) xi il
 860
 861 -- | Extract the the new node list from the allocation solution.
 862 extractNl :: Node.List               -- ^ The original node list
 863           -> Maybe Node.AllocElement -- ^ The result of the allocation attempt
 864           -> Node.List               -- ^ The new node list
 865 extractNl nl Nothing = nl
 866 extractNl _ (Just (xnl, _, _, _)) = xnl
 867
 868 -- | Try to allocate a list of instances on a multi-group cluster.
 869 allocList :: Group.List                  -- ^ The group list
 870           -> Node.List                   -- ^ The node list
 871           -> Instance.List               -- ^ The instance list
 872           -> [(Instance.Instance, Int)]  -- ^ The instance to allocate
 873           -> AllocSolutionList           -- ^ Possible solution list
 874           -> Result (Node.List, Instance.List,
 875                      AllocSolutionList)  -- ^ The final solution list
 876 allocList _  nl il [] result = Ok (nl, il, result)
 877 allocList gl nl il ((xi, xicnt):xies) result = do
 878   ares <- tryMGAlloc gl nl il xi xicnt
 879   let sol = asSolution ares
 880       nl' = extractNl nl sol
 881       il' = updateIl il sol
 882   allocList gl nl' il' xies ((xi, ares):result)
 883
 884 -- | Function which fails if the requested mode is change secondary.
 885 --
 886 -- This is useful since except DRBD, no other disk template can
 887 -- execute change secondary; thus, we can just call this function
 888 -- instead of always checking for secondary mode. After the call to
 889 -- this function, whatever mode we have is just a primary change.
 890 failOnSecondaryChange :: (Monad m) => EvacMode -> DiskTemplate -> m ()
 891 failOnSecondaryChange ChangeSecondary dt =
 892   fail $ "Instances with disk template '" ++ diskTemplateToRaw dt ++
 893          "' can't execute change secondary"
 894 failOnSecondaryChange _ _ = return ()
 895
 896 -- | Run evacuation for a single instance.
 897 --
 898 -- /Note:/ this function should correctly execute both intra-group
 899 -- evacuations (in all modes) and inter-group evacuations (in the
 900 -- 'ChangeAll' mode). Of course, this requires that the correct list
 901 -- of target nodes is passed.
 902 nodeEvacInstance :: Node.List         -- ^ The node list (cluster-wide)
 903                  -> Instance.List     -- ^ Instance list (cluster-wide)
 904                  -> EvacMode          -- ^ The evacuation mode
 905                  -> Instance.Instance -- ^ The instance to be evacuated
 906                  -> Gdx               -- ^ The group we're targetting
 907                  -> [Ndx]             -- ^ The list of available nodes
 908                                       -- for allocation
 909                  -> Result (Node.List, Instance.List, [OpCodes.OpCode])
 910 nodeEvacInstance nl il mode inst@(Instance.Instance
 911                                   {Instance.diskTemplate = dt@DTDiskless})
 912                  gdx avail_nodes =
 913                    failOnSecondaryChange mode dt >>
 914                    evacOneNodeOnly nl il inst gdx avail_nodes
 915
 916 nodeEvacInstance _ _ _ (Instance.Instance
 917                         {Instance.diskTemplate = DTPlain}) _ _ =
 918                   fail "Instances of type plain cannot be relocated"
 919
 920 nodeEvacInstance _ _ _ (Instance.Instance
 921                         {Instance.diskTemplate = DTFile}) _ _ =
 922                   fail "Instances of type file cannot be relocated"
 923
 924 nodeEvacInstance nl il mode inst@(Instance.Instance
 925                                   {Instance.diskTemplate = dt@DTSharedFile})
 926                  gdx avail_nodes =
 927                    failOnSecondaryChange mode dt >>
 928                    evacOneNodeOnly nl il inst gdx avail_nodes
 929
 930 nodeEvacInstance nl il mode inst@(Instance.Instance
 931                                   {Instance.diskTemplate = dt@DTBlock})
 932                  gdx avail_nodes =
 933                    failOnSecondaryChange mode dt >>
 934                    evacOneNodeOnly nl il inst gdx avail_nodes
 935
 936 nodeEvacInstance nl il mode inst@(Instance.Instance
 937                                   {Instance.diskTemplate = dt@DTRbd})
 938                  gdx avail_nodes =
 939                    failOnSecondaryChange mode dt >>
 940                    evacOneNodeOnly nl il inst gdx avail_nodes
 941
 942 nodeEvacInstance nl il ChangePrimary
 943                  inst@(Instance.Instance {Instance.diskTemplate = DTDrbd8})
 944                  _ _ =
 945   do
 946     (nl', inst', _, _) <- opToResult $ applyMove nl inst Failover
 947     let idx = Instance.idx inst
 948         il' = Container.add idx inst' il
 949         ops = iMoveToJob nl' il' idx Failover
 950     return (nl', il', ops)
 951
 952 nodeEvacInstance nl il ChangeSecondary
 953                  inst@(Instance.Instance {Instance.diskTemplate = DTDrbd8})
 954                  gdx avail_nodes =
 955   evacOneNodeOnly nl il inst gdx avail_nodes
 956
 957 -- The algorithm for ChangeAll is as follows:
 958 --
 959 -- * generate all (primary, secondary) node pairs for the target groups
 960 -- * for each pair, execute the needed moves (r:s, f, r:s) and compute
 961 --   the final node list state and group score
 962 -- * select the best choice via a foldl that uses the same Either
 963 --   String solution as the ChangeSecondary mode
 964 nodeEvacInstance nl il ChangeAll
 965                  inst@(Instance.Instance {Instance.diskTemplate = DTDrbd8})
 966                  gdx avail_nodes =
 967   do
 968     let no_nodes = Left "no nodes available"
 969         node_pairs = [(p,s) | p <- avail_nodes, s <- avail_nodes, p /= s]
 970     (nl', il', ops, _) <-
 971         annotateResult "Can't find any good nodes for relocation" .
 972         eitherToResult $
 973         foldl'
 974         (\accu nodes -> case evacDrbdAllInner nl il inst gdx nodes of
 975                           Bad msg ->
 976                               case accu of
 977                                 Right _ -> accu
 978                                 -- we don't need more details (which
 979                                 -- nodes, etc.) as we only selected
 980                                 -- this group if we can allocate on
 981                                 -- it, hence failures will not
 982                                 -- propagate out of this fold loop
 983                                 Left _ -> Left $ "Allocation failed: " ++ msg
 984                           Ok result@(_, _, _, new_cv) ->
 985                               let new_accu = Right result in
 986                               case accu of
 987                                 Left _ -> new_accu
 988                                 Right (_, _, _, old_cv) ->
 989                                     if old_cv < new_cv
 990                                     then accu
 991                                     else new_accu
 992         ) no_nodes node_pairs
 993
 994     return (nl', il', ops)
 995
 996 -- | Generic function for changing one node of an instance.
 997 --
 998 -- This is similar to 'nodeEvacInstance' but will be used in a few of
 999 -- its sub-patterns. It folds the inner function 'evacOneNodeInner'
1000 -- over the list of available nodes, which results in the best choice
1001 -- for relocation.
1002 evacOneNodeOnly :: Node.List         -- ^ The node list (cluster-wide)
1003                 -> Instance.List     -- ^ Instance list (cluster-wide)
1004                 -> Instance.Instance -- ^ The instance to be evacuated
1005                 -> Gdx               -- ^ The group we're targetting
1006                 -> [Ndx]             -- ^ The list of available nodes
1007                                       -- for allocation
1008                 -> Result (Node.List, Instance.List, [OpCodes.OpCode])
1009 evacOneNodeOnly nl il inst gdx avail_nodes = do
1010   op_fn <- case Instance.mirrorType inst of
1011              MirrorNone -> Bad "Can't relocate/evacuate non-mirrored instances"
1012              MirrorInternal -> Ok ReplaceSecondary
1013              MirrorExternal -> Ok FailoverToAny
1014   (nl', inst', _, ndx) <- annotateResult "Can't find any good node" .
1015                           eitherToResult $
1016                           foldl' (evacOneNodeInner nl inst gdx op_fn)
1017                           (Left "no nodes available") avail_nodes
1018   let idx = Instance.idx inst
1019       il' = Container.add idx inst' il
1020       ops = iMoveToJob nl' il' idx (op_fn ndx)
1021   return (nl', il', ops)
1022
1023 -- | Inner fold function for changing one node of an instance.
1024 --
1025 -- Depending on the instance disk template, this will either change
1026 -- the secondary (for DRBD) or the primary node (for shared
1027 -- storage). However, the operation is generic otherwise.
1028 --
1029 -- The running solution is either a @Left String@, which means we
1030 -- don't have yet a working solution, or a @Right (...)@, which
1031 -- represents a valid solution; it holds the modified node list, the
1032 -- modified instance (after evacuation), the score of that solution,
1033 -- and the new secondary node index.
1034 evacOneNodeInner :: Node.List         -- ^ Cluster node list
1035                  -> Instance.Instance -- ^ Instance being evacuated
1036                  -> Gdx               -- ^ The group index of the instance
1037                  -> (Ndx -> IMove)    -- ^ Operation constructor
1038                  -> EvacInnerState    -- ^ Current best solution
1039                  -> Ndx               -- ^ Node we're evaluating as target
1040                  -> EvacInnerState    -- ^ New best solution
1041 evacOneNodeInner nl inst gdx op_fn accu ndx =
1042   case applyMove nl inst (op_fn ndx) of
1043     Bad fm -> let fail_msg = "Node " ++ Container.nameOf nl ndx ++
1044                              " failed: " ++ show fm
1045               in either (const $ Left fail_msg) (const accu) accu
1046     Ok (nl', inst', _, _) ->
1047       let nodes = Container.elems nl'
1048           -- The fromJust below is ugly (it can fail nastily), but
1049           -- at this point we should have any internal mismatches,
1050           -- and adding a monad here would be quite involved
1051           grpnodes = fromJust (gdx `lookup` Node.computeGroups nodes)
1052           new_cv = compCVNodes grpnodes
1053           new_accu = Right (nl', inst', new_cv, ndx)
1054       in case accu of
1055            Left _ -> new_accu
1056            Right (_, _, old_cv, _) ->
1057              if old_cv < new_cv
1058                then accu
1059                else new_accu
1060
1061 -- | Compute result of changing all nodes of a DRBD instance.
1062 --
1063 -- Given the target primary and secondary node (which might be in a
1064 -- different group or not), this function will 'execute' all the
1065 -- required steps and assuming all operations succceed, will return
1066 -- the modified node and instance lists, the opcodes needed for this
1067 -- and the new group score.
1068 evacDrbdAllInner :: Node.List         -- ^ Cluster node list
1069                  -> Instance.List     -- ^ Cluster instance list
1070                  -> Instance.Instance -- ^ The instance to be moved
1071                  -> Gdx               -- ^ The target group index
1072                                       -- (which can differ from the
1073                                       -- current group of the
1074                                       -- instance)
1075                  -> (Ndx, Ndx)        -- ^ Tuple of new
1076                                       -- primary\/secondary nodes
1077                  -> Result (Node.List, Instance.List, [OpCodes.OpCode], Score)
1078 evacDrbdAllInner nl il inst gdx (t_pdx, t_sdx) = do
1079   let primary = Container.find (Instance.pNode inst) nl
1080       idx = Instance.idx inst
1081   -- if the primary is offline, then we first failover
1082   (nl1, inst1, ops1) <-
1083     if Node.offline primary
1084       then do
1085         (nl', inst', _, _) <-
1086           annotateResult "Failing over to the secondary" .
1087           opToResult $ applyMove nl inst Failover
1088         return (nl', inst', [Failover])
1089       else return (nl, inst, [])
1090   let (o1, o2, o3) = (ReplaceSecondary t_pdx,
1091                       Failover,
1092                       ReplaceSecondary t_sdx)
1093   -- we now need to execute a replace secondary to the future
1094   -- primary node
1095   (nl2, inst2, _, _) <-
1096     annotateResult "Changing secondary to new primary" .
1097     opToResult $
1098     applyMove nl1 inst1 o1
1099   let ops2 = o1:ops1
1100   -- we now execute another failover, the primary stays fixed now
1101   (nl3, inst3, _, _) <- annotateResult "Failing over to new primary" .
1102                         opToResult $ applyMove nl2 inst2 o2
1103   let ops3 = o2:ops2
1104   -- and finally another replace secondary, to the final secondary
1105   (nl4, inst4, _, _) <-
1106     annotateResult "Changing secondary to final secondary" .
1107     opToResult $
1108     applyMove nl3 inst3 o3
1109   let ops4 = o3:ops3
1110       il' = Container.add idx inst4 il
1111       ops = concatMap (iMoveToJob nl4 il' idx) $ reverse ops4
1112   let nodes = Container.elems nl4
1113       -- The fromJust below is ugly (it can fail nastily), but
1114       -- at this point we should have any internal mismatches,
1115       -- and adding a monad here would be quite involved
1116       grpnodes = fromJust (gdx `lookup` Node.computeGroups nodes)
1117       new_cv = compCVNodes grpnodes
1118   return (nl4, il', ops, new_cv)
1119
1120 -- | Computes the nodes in a given group which are available for
1121 -- allocation.
1122 availableGroupNodes :: [(Gdx, [Ndx])] -- ^ Group index/node index assoc list
1123                     -> IntSet.IntSet  -- ^ Nodes that are excluded
1124                     -> Gdx            -- ^ The group for which we
1125                                       -- query the nodes
1126                     -> Result [Ndx]   -- ^ List of available node indices
1127 availableGroupNodes group_nodes excl_ndx gdx = do
1128   local_nodes <- maybe (Bad $ "Can't find group with index " ++ show gdx)
1129                  Ok (lookup gdx group_nodes)
1130   let avail_nodes = filter (not . flip IntSet.member excl_ndx) local_nodes
1131   return avail_nodes
1132
1133 -- | Updates the evac solution with the results of an instance
1134 -- evacuation.
1135 updateEvacSolution :: (Node.List, Instance.List, EvacSolution)
1136                    -> Idx
1137                    -> Result (Node.List, Instance.List, [OpCodes.OpCode])
1138                    -> (Node.List, Instance.List, EvacSolution)
1139 updateEvacSolution (nl, il, es) idx (Bad msg) =
1140   (nl, il, es { esFailed = (idx, msg):esFailed es})
1141 updateEvacSolution (_, _, es) idx (Ok (nl, il, opcodes)) =
1142   (nl, il, es { esMoved = new_elem:esMoved es
1143               , esOpCodes = opcodes:esOpCodes es })
1144     where inst = Container.find idx il
1145           new_elem = (idx,
1146                       instancePriGroup nl inst,
1147                       Instance.allNodes inst)
1148
1149 -- | Node-evacuation IAllocator mode main function.
1150 tryNodeEvac :: Group.List    -- ^ The cluster groups
1151             -> Node.List     -- ^ The node list (cluster-wide, not per group)
1152             -> Instance.List -- ^ Instance list (cluster-wide)
1153             -> EvacMode      -- ^ The evacuation mode
1154             -> [Idx]         -- ^ List of instance (indices) to be evacuated
1155             -> Result (Node.List, Instance.List, EvacSolution)
1156 tryNodeEvac _ ini_nl ini_il mode idxs =
1157   let evac_ndx = nodesToEvacuate ini_il mode idxs
1158       offline = map Node.idx . filter Node.offline $ Container.elems ini_nl
1159       excl_ndx = foldl' (flip IntSet.insert) evac_ndx offline
1160       group_ndx = map (\(gdx, (nl, _)) -> (gdx, map Node.idx
1161                                            (Container.elems nl))) $
1162                   splitCluster ini_nl ini_il
1163       (fin_nl, fin_il, esol) =
1164         foldl' (\state@(nl, il, _) inst ->
1165                   let gdx = instancePriGroup nl inst
1166                       pdx = Instance.pNode inst in
1167                   updateEvacSolution state (Instance.idx inst) $
1168                   availableGroupNodes group_ndx
1169                     (IntSet.insert pdx excl_ndx) gdx >>=
1170                       nodeEvacInstance nl il mode inst gdx
1171                )
1172         (ini_nl, ini_il, emptyEvacSolution)
1173         (map (`Container.find` ini_il) idxs)
1174   in return (fin_nl, fin_il, reverseEvacSolution esol)
1175
1176 -- | Change-group IAllocator mode main function.
1177 --
1178 -- This is very similar to 'tryNodeEvac', the only difference is that
1179 -- we don't choose as target group the current instance group, but
1180 -- instead:
1181 --
1182 --   1. at the start of the function, we compute which are the target
1183 --   groups; either no groups were passed in, in which case we choose
1184 --   all groups out of which we don't evacuate instance, or there were
1185 --   some groups passed, in which case we use those
1186 --
1187 --   2. for each instance, we use 'findBestAllocGroup' to choose the
1188 --   best group to hold the instance, and then we do what
1189 --   'tryNodeEvac' does, except for this group instead of the current
1190 --   instance group.
1191 --
1192 -- Note that the correct behaviour of this function relies on the
1193 -- function 'nodeEvacInstance' to be able to do correctly both
1194 -- intra-group and inter-group moves when passed the 'ChangeAll' mode.
1195 tryChangeGroup :: Group.List    -- ^ The cluster groups
1196                -> Node.List     -- ^ The node list (cluster-wide)
1197                -> Instance.List -- ^ Instance list (cluster-wide)
1198                -> [Gdx]         -- ^ Target groups; if empty, any
1199                                 -- groups not being evacuated
1200                -> [Idx]         -- ^ List of instance (indices) to be evacuated
1201                -> Result (Node.List, Instance.List, EvacSolution)
1202 tryChangeGroup gl ini_nl ini_il gdxs idxs =
1203   let evac_gdxs = nub $ map (instancePriGroup ini_nl .
1204                              flip Container.find ini_il) idxs
1205       target_gdxs = (if null gdxs
1206                        then Container.keys gl
1207                        else gdxs) \\ evac_gdxs
1208       offline = map Node.idx . filter Node.offline $ Container.elems ini_nl
1209       excl_ndx = foldl' (flip IntSet.insert) IntSet.empty offline
1210       group_ndx = map (\(gdx, (nl, _)) -> (gdx, map Node.idx
1211                                            (Container.elems nl))) $
1212                   splitCluster ini_nl ini_il
1213       (fin_nl, fin_il, esol) =
1214         foldl' (\state@(nl, il, _) inst ->
1215                   let solution = do
1216                         let ncnt = Instance.requiredNodes $
1217                                    Instance.diskTemplate inst
1218                         (gdx, _, _) <- findBestAllocGroup gl nl il
1219                                        (Just target_gdxs) inst ncnt
1220                         av_nodes <- availableGroupNodes group_ndx
1221                                     excl_ndx gdx
1222                         nodeEvacInstance nl il ChangeAll inst gdx av_nodes
1223                   in updateEvacSolution state (Instance.idx inst) solution
1224                )
1225         (ini_nl, ini_il, emptyEvacSolution)
1226         (map (`Container.find` ini_il) idxs)
1227   in return (fin_nl, fin_il, reverseEvacSolution esol)
1228
1229 -- | Standard-sized allocation method.
1230 --
1231 -- This places instances of the same size on the cluster until we're
1232 -- out of space. The result will be a list of identically-sized
1233 -- instances.
1234 iterateAlloc :: AllocMethod
1235 iterateAlloc nl il limit newinst allocnodes ixes cstats =
1236   let depth = length ixes
1237       newname = printf "new-%d" depth::String
1238       newidx = Container.size il
1239       newi2 = Instance.setIdx (Instance.setName newinst newname) newidx
1240       newlimit = fmap (flip (-) 1) limit
1241   in case tryAlloc nl il newi2 allocnodes of
1242        Bad s -> Bad s
1243        Ok (AllocSolution { asFailures = errs, asSolution = sols3 }) ->
1244          let newsol = Ok (collapseFailures errs, nl, il, ixes, cstats) in
1245          case sols3 of
1246            Nothing -> newsol
1247            Just (xnl, xi, _, _) ->
1248              if limit == Just 0
1249                then newsol
1250                else iterateAlloc xnl (Container.add newidx xi il)
1251                       newlimit newinst allocnodes (xi:ixes)
1252                       (totalResources xnl:cstats)
1253
1254 -- | Tiered allocation method.
1255 --
1256 -- This places instances on the cluster, and decreases the spec until
1257 -- we can allocate again. The result will be a list of decreasing
1258 -- instance specs.
1259 tieredAlloc :: AllocMethod
1260 tieredAlloc nl il limit newinst allocnodes ixes cstats =
1261   case iterateAlloc nl il limit newinst allocnodes ixes cstats of
1262     Bad s -> Bad s
1263     Ok (errs, nl', il', ixes', cstats') ->
1264       let newsol = Ok (errs, nl', il', ixes', cstats')
1265           ixes_cnt = length ixes'
1266           (stop, newlimit) = case limit of
1267                                Nothing -> (False, Nothing)
1268                                Just n -> (n <= ixes_cnt,
1269                                             Just (n - ixes_cnt)) in
1270       if stop then newsol else
1271           case Instance.shrinkByType newinst . fst . last $
1272                sortBy (comparing snd) errs of
1273             Bad _ -> newsol
1274             Ok newinst' -> tieredAlloc nl' il' newlimit
1275                            newinst' allocnodes ixes' cstats'
1276
1277 -- * Formatting functions
1278
1279 -- | Given the original and final nodes, computes the relocation description.
1280 computeMoves :: Instance.Instance -- ^ The instance to be moved
1281              -> String -- ^ The instance name
1282              -> IMove  -- ^ The move being performed
1283              -> String -- ^ New primary
1284              -> String -- ^ New secondary
1285              -> (String, [String])
1286                 -- ^ Tuple of moves and commands list; moves is containing
1287                 -- either @/f/@ for failover or @/r:name/@ for replace
1288                 -- secondary, while the command list holds gnt-instance
1289                 -- commands (without that prefix), e.g \"@failover instance1@\"
1290 computeMoves i inam mv c d =
1291   case mv of
1292     Failover -> ("f", [mig])
1293     FailoverToAny _ -> (printf "fa:%s" c, [mig_any])
1294     FailoverAndReplace _ -> (printf "f r:%s" d, [mig, rep d])
1295     ReplaceSecondary _ -> (printf "r:%s" d, [rep d])
1296     ReplaceAndFailover _ -> (printf "r:%s f" c, [rep c, mig])
1297     ReplacePrimary _ -> (printf "f r:%s f" c, [mig, rep c, mig])
1298   where morf = if Instance.isRunning i then "migrate" else "failover"
1299         mig = printf "%s -f %s" morf inam::String
1300         mig_any = printf "%s -f -n %s %s" morf c inam::String
1301         rep n = printf "replace-disks -n %s %s" n inam::String
1302
1303 -- | Converts a placement to string format.
1304 printSolutionLine :: Node.List     -- ^ The node list
1305                   -> Instance.List -- ^ The instance list
1306                   -> Int           -- ^ Maximum node name length
1307                   -> Int           -- ^ Maximum instance name length
1308                   -> Placement     -- ^ The current placement
1309                   -> Int           -- ^ The index of the placement in
1310                                    -- the solution
1311                   -> (String, [String])
1312 printSolutionLine nl il nmlen imlen plc pos =
1313   let pmlen = (2*nmlen + 1)
1314       (i, p, s, mv, c) = plc
1315       old_sec = Instance.sNode inst
1316       inst = Container.find i il
1317       inam = Instance.alias inst
1318       npri = Node.alias $ Container.find p nl
1319       nsec = Node.alias $ Container.find s nl
1320       opri = Node.alias $ Container.find (Instance.pNode inst) nl
1321       osec = Node.alias $ Container.find old_sec nl
1322       (moves, cmds) =  computeMoves inst inam mv npri nsec
1323       -- FIXME: this should check instead/also the disk template
1324       ostr = if old_sec == Node.noSecondary
1325                then printf "%s" opri::String
1326                else printf "%s:%s" opri osec::String
1327       nstr = if s == Node.noSecondary
1328                then printf "%s" npri::String
1329                else printf "%s:%s" npri nsec::String
1330   in (printf "  %3d. %-*s %-*s => %-*s %12.8f a=%s"
1331       pos imlen inam pmlen ostr pmlen nstr c moves,
1332       cmds)
1333
1334 -- | Return the instance and involved nodes in an instance move.
1335 --
1336 -- Note that the output list length can vary, and is not required nor
1337 -- guaranteed to be of any specific length.
1338 involvedNodes :: Instance.List -- ^ Instance list, used for retrieving
1339                                -- the instance from its index; note
1340                                -- that this /must/ be the original
1341                                -- instance list, so that we can
1342                                -- retrieve the old nodes
1343               -> Placement     -- ^ The placement we're investigating,
1344                                -- containing the new nodes and
1345                                -- instance index
1346               -> [Ndx]         -- ^ Resulting list of node indices
1347 involvedNodes il plc =
1348   let (i, np, ns, _, _) = plc
1349       inst = Container.find i il
1350   in nub $ [np, ns] ++ Instance.allNodes inst
1351
1352 -- | Inner function for splitJobs, that either appends the next job to
1353 -- the current jobset, or starts a new jobset.
1354 mergeJobs :: ([JobSet], [Ndx]) -> MoveJob -> ([JobSet], [Ndx])
1355 mergeJobs ([], _) n@(ndx, _, _, _) = ([[n]], ndx)
1356 mergeJobs (cjs@(j:js), nbuf) n@(ndx, _, _, _)
1357   | null (ndx `intersect` nbuf) = ((n:j):js, ndx ++ nbuf)
1358   | otherwise = ([n]:cjs, ndx)
1359
1360 -- | Break a list of moves into independent groups. Note that this
1361 -- will reverse the order of jobs.
1362 splitJobs :: [MoveJob] -> [JobSet]
1363 splitJobs = fst . foldl mergeJobs ([], [])
1364
1365 -- | Given a list of commands, prefix them with @gnt-instance@ and
1366 -- also beautify the display a little.
1367 formatJob :: Int -> Int -> (Int, MoveJob) -> [String]
1368 formatJob jsn jsl (sn, (_, _, _, cmds)) =
1369   let out =
1370         printf "  echo job %d/%d" jsn sn:
1371         printf "  check":
1372         map ("  gnt-instance " ++) cmds
1373   in if sn == 1
1374        then ["", printf "echo jobset %d, %d jobs" jsn jsl] ++ out
1375        else out
1376
1377 -- | Given a list of commands, prefix them with @gnt-instance@ and
1378 -- also beautify the display a little.
1379 formatCmds :: [JobSet] -> String
1380 formatCmds =
1381   unlines .
1382   concatMap (\(jsn, js) -> concatMap (formatJob jsn (length js))
1383                            (zip [1..] js)) .
1384   zip [1..]
1385
1386 -- | Print the node list.
1387 printNodes :: Node.List -> [String] -> String
1388 printNodes nl fs =
1389   let fields = case fs of
1390                  [] -> Node.defaultFields
1391                  "+":rest -> Node.defaultFields ++ rest
1392                  _ -> fs
1393       snl = sortBy (comparing Node.idx) (Container.elems nl)
1394       (header, isnum) = unzip $ map Node.showHeader fields
1395   in printTable "" header (map (Node.list fields) snl) isnum
1396
1397 -- | Print the instance list.
1398 printInsts :: Node.List -> Instance.List -> String
1399 printInsts nl il =
1400   let sil = sortBy (comparing Instance.idx) (Container.elems il)
1401       helper inst = [ if Instance.isRunning inst then "R" else " "
1402                     , Instance.name inst
1403                     , Container.nameOf nl (Instance.pNode inst)
1404                     , let sdx = Instance.sNode inst
1405                       in if sdx == Node.noSecondary
1406                            then  ""
1407                            else Container.nameOf nl sdx
1408                     , if Instance.autoBalance inst then "Y" else "N"
1409                     , printf "%3d" $ Instance.vcpus inst
1410                     , printf "%5d" $ Instance.mem inst
1411                     , printf "%5d" $ Instance.dsk inst `div` 1024
1412                     , printf "%5.3f" lC
1413                     , printf "%5.3f" lM
1414                     , printf "%5.3f" lD
1415                     , printf "%5.3f" lN
1416                     ]
1417           where DynUtil lC lM lD lN = Instance.util inst
1418       header = [ "F", "Name", "Pri_node", "Sec_node", "Auto_bal"
1419                , "vcpu", "mem" , "dsk", "lCpu", "lMem", "lDsk", "lNet" ]
1420       isnum = False:False:False:False:False:repeat True
1421   in printTable "" header (map helper sil) isnum
1422
1423 -- | Shows statistics for a given node list.
1424 printStats :: String -> Node.List -> String
1425 printStats lp nl =
1426   let dcvs = compDetailedCV $ Container.elems nl
1427       (weights, names) = unzip detailedCVInfo
1428       hd = zip3 (weights ++ repeat 1) (names ++ repeat "unknown") dcvs
1429       header = [ "Field", "Value", "Weight" ]
1430       formatted = map (\(w, h, val) ->
1431                          [ h
1432                          , printf "%.8f" val
1433                          , printf "x%.2f" w
1434                          ]) hd
1435   in printTable lp header formatted $ False:repeat True
1436
1437 -- | Convert a placement into a list of OpCodes (basically a job).
1438 iMoveToJob :: Node.List        -- ^ The node list; only used for node
1439                                -- names, so any version is good
1440                                -- (before or after the operation)
1441            -> Instance.List    -- ^ The instance list; also used for
1442                                -- names only
1443            -> Idx              -- ^ The index of the instance being
1444                                -- moved
1445            -> IMove            -- ^ The actual move to be described
1446            -> [OpCodes.OpCode] -- ^ The list of opcodes equivalent to
1447                                -- the given move
1448 iMoveToJob nl il idx move =
1449   let inst = Container.find idx il
1450       iname = Instance.name inst
1451       lookNode  n = case mkNonEmpty (Container.nameOf nl n) of
1452                       -- FIXME: convert htools codebase to non-empty strings
1453                       Bad msg -> error $ "Empty node name for idx " ++
1454                                  show n ++ ": " ++ msg ++ "??"
1455                       Ok ne -> Just ne
1456       live = Just True
1457       opF = OpCodes.OpInstanceMigrate iname live False True Nothing
1458       opFA n = OpCodes.OpInstanceMigrate iname live False True (lookNode n)
1459       opR n = OpCodes.OpInstanceReplaceDisks iname (lookNode n)
1460               OpCodes.ReplaceNewSecondary [] Nothing
1461   in case move of
1462        Failover -> [ opF ]
1463        FailoverToAny np -> [ opFA np ]
1464        ReplacePrimary np -> [ opF, opR np, opF ]
1465        ReplaceSecondary ns -> [ opR ns ]
1466        ReplaceAndFailover np -> [ opR np, opF ]
1467        FailoverAndReplace ns -> [ opF, opR ns ]
1468
1469 -- * Node group functions
1470
1471 -- | Computes the group of an instance.
1472 instanceGroup :: Node.List -> Instance.Instance -> Result Gdx
1473 instanceGroup nl i =
1474   let sidx = Instance.sNode i
1475       pnode = Container.find (Instance.pNode i) nl
1476       snode = if sidx == Node.noSecondary
1477               then pnode
1478               else Container.find sidx nl
1479       pgroup = Node.group pnode
1480       sgroup = Node.group snode
1481   in if pgroup /= sgroup
1482        then fail ("Instance placed accross two node groups, primary " ++
1483                   show pgroup ++ ", secondary " ++ show sgroup)
1484        else return pgroup
1485
1486 -- | Computes the group of an instance per the primary node.
1487 instancePriGroup :: Node.List -> Instance.Instance -> Gdx
1488 instancePriGroup nl i =
1489   let pnode = Container.find (Instance.pNode i) nl
1490   in  Node.group pnode
1491
1492 -- | Compute the list of badly allocated instances (split across node
1493 -- groups).
1494 findSplitInstances :: Node.List -> Instance.List -> [Instance.Instance]
1495 findSplitInstances nl =
1496   filter (not . isOk . instanceGroup nl) . Container.elems
1497
1498 -- | Splits a cluster into the component node groups.
1499 splitCluster :: Node.List -> Instance.List ->
1500                 [(Gdx, (Node.List, Instance.List))]
1501 splitCluster nl il =
1502   let ngroups = Node.computeGroups (Container.elems nl)
1503   in map (\(guuid, nodes) ->
1504            let nidxs = map Node.idx nodes
1505                nodes' = zip nidxs nodes
1506                instances = Container.filter ((`elem` nidxs) . Instance.pNode) il
1507            in (guuid, (Container.fromList nodes', instances))) ngroups
1508
1509 -- | Compute the list of nodes that are to be evacuated, given a list
1510 -- of instances and an evacuation mode.
1511 nodesToEvacuate :: Instance.List -- ^ The cluster-wide instance list
1512                 -> EvacMode      -- ^ The evacuation mode we're using
1513                 -> [Idx]         -- ^ List of instance indices being evacuated
1514                 -> IntSet.IntSet -- ^ Set of node indices
1515 nodesToEvacuate il mode =
1516   IntSet.delete Node.noSecondary .
1517   foldl' (\ns idx ->
1518             let i = Container.find idx il
1519                 pdx = Instance.pNode i
1520                 sdx = Instance.sNode i
1521                 dt = Instance.diskTemplate i
1522                 withSecondary = case dt of
1523                                   DTDrbd8 -> IntSet.insert sdx ns
1524                                   _ -> ns
1525             in case mode of
1526                  ChangePrimary   -> IntSet.insert pdx ns
1527                  ChangeSecondary -> withSecondary
1528                  ChangeAll       -> IntSet.insert pdx withSecondary
1529          ) IntSet.empty