code.grnet.gr Git - ganeti-local/blob - Ganeti/HTools/Cluster.hs

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