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