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 module Ganeti.HTools.Cluster
   9     (
  10      -- * Types
  11      NodeList
  12     , InstanceList
  13     , NameList
  14     , Placement
  15     , Solution(..)
  16     , Table(..)
  17     , Removal
  18     , Score
  19     -- * Generic functions
  20     , totalResources
  21     -- * First phase functions
  22     , computeBadItems
  23     -- * Second phase functions
  24     , computeSolution
  25     , applySolution
  26     , printSolution
  27     , printSolutionLine
  28     , formatCmds
  29     , printNodes
  30     -- * Balacing functions
  31     , checkMove
  32     , compCV
  33     , printStats
  34     -- * Loading functions
  35     , checkData
  36     ) where
  37
  38 import Data.List
  39 import Data.Maybe (isNothing, fromJust)
  40 import Text.Printf (printf)
  41 import Data.Function
  42 import Control.Monad
  43
  44 import qualified Ganeti.HTools.Container as Container
  45 import qualified Ganeti.HTools.Instance as Instance
  46 import qualified Ganeti.HTools.Node as Node
  47 import Ganeti.HTools.Types
  48 import Ganeti.HTools.Utils
  49
  50 -- | A separate name for the cluster score type
  51 type Score = Double
  52
  53 -- | The description of an instance placement.
  54 type Placement = (Int, Int, Int, Score)
  55
  56 {- | A cluster solution described as the solution delta and the list
  57 of placements.
  58
  59 -}
  60 data Solution = Solution Int [Placement]
  61                 deriving (Eq, Ord, Show)
  62
  63 -- | Returns the delta of a solution or -1 for Nothing
  64 solutionDelta :: Maybe Solution -> Int
  65 solutionDelta sol = case sol of
  66                       Just (Solution d _) -> d
  67                       _ -> -1
  68
  69 -- | A removal set.
  70 data Removal = Removal NodeList [Instance.Instance]
  71
  72 -- | An instance move definition
  73 data IMove = Failover                -- ^ Failover the instance (f)
  74            | ReplacePrimary Int      -- ^ Replace primary (f, r:np, f)
  75            | ReplaceSecondary Int    -- ^ Replace secondary (r:ns)
  76            | ReplaceAndFailover Int  -- ^ Replace secondary, failover (r:np, f)
  77            | FailoverAndReplace Int  -- ^ Failover, replace secondary (f, r:ns)
  78              deriving (Show)
  79
  80 -- | The complete state for the balancing solution
  81 data Table = Table NodeList InstanceList Score [Placement]
  82              deriving (Show)
  83
  84 -- General functions
  85
  86 -- | Cap the removal list if needed.
  87 capRemovals :: [a] -> Int -> [a]
  88 capRemovals removals max_removals =
  89     if max_removals > 0 then
  90         take max_removals removals
  91     else
  92         removals
  93
  94 -- | Check if the given node list fails the N+1 check.
  95 verifyN1Check :: [Node.Node] -> Bool
  96 verifyN1Check nl = any Node.failN1 nl
  97
  98 -- | Verifies the N+1 status and return the affected nodes.
  99 verifyN1 :: [Node.Node] -> [Node.Node]
 100 verifyN1 nl = filter Node.failN1 nl
 101
 102 {-| Add an instance and return the new node and instance maps. -}
 103 addInstance :: NodeList -> Instance.Instance ->
 104                Node.Node -> Node.Node -> Maybe NodeList
 105 addInstance nl idata pri sec =
 106   let pdx = Node.idx pri
 107       sdx = Node.idx sec
 108   in do
 109       pnode <- Node.addPri pri idata
 110       snode <- Node.addSec sec idata pdx
 111       new_nl <- return $ Container.addTwo sdx snode
 112                          pdx pnode nl
 113       return new_nl
 114
 115 -- | Remove an instance and return the new node and instance maps.
 116 removeInstance :: NodeList -> Instance.Instance -> NodeList
 117 removeInstance nl idata =
 118   let pnode = Instance.pnode idata
 119       snode = Instance.snode idata
 120       pn = Container.find pnode nl
 121       sn = Container.find snode nl
 122       new_nl = Container.addTwo
 123                pnode (Node.removePri pn idata)
 124                snode (Node.removeSec sn idata) nl in
 125   new_nl
 126
 127 -- | Remove an instance and return the new node map.
 128 removeInstances :: NodeList -> [Instance.Instance] -> NodeList
 129 removeInstances = foldl' removeInstance
 130
 131 -- | Compute the total free disk and memory in the cluster.
 132 totalResources :: Container.Container Node.Node -> (Int, Int)
 133 totalResources nl =
 134     foldl'
 135     (\ (mem, dsk) node -> (mem + (Node.f_mem node),
 136                            dsk + (Node.f_dsk node)))
 137     (0, 0) (Container.elems nl)
 138
 139 {- | Compute a new version of a cluster given a solution.
 140
 141 This is not used for computing the solutions, but for applying a
 142 (known-good) solution to the original cluster for final display.
 143
 144 It first removes the relocated instances after which it places them on
 145 their new nodes.
 146
 147  -}
 148 applySolution :: NodeList -> InstanceList -> [Placement] -> NodeList
 149 applySolution nl il sol =
 150     let odxes = map (\ (a, b, c, _) -> (Container.find a il,
 151                                         Node.idx (Container.find b nl),
 152                                         Node.idx (Container.find c nl))
 153                     ) sol
 154         idxes = (\ (x, _, _) -> x) (unzip3 odxes)
 155         nc = removeInstances nl idxes
 156     in
 157       foldl' (\ nz (a, b, c) ->
 158                  let new_p = Container.find b nz
 159                      new_s = Container.find c nz in
 160                  fromJust (addInstance nz a new_p new_s)
 161            ) nc odxes
 162
 163
 164 -- First phase functions
 165
 166 {- | Given a list 1,2,3..n build a list of pairs [(1, [2..n]), (2,
 167     [3..n]), ...]
 168
 169 -}
 170 genParts :: [a] -> Int -> [(a, [a])]
 171 genParts l count =
 172     case l of
 173       [] -> []
 174       x:xs ->
 175           if length l < count then
 176               []
 177           else
 178               (x, xs) : (genParts xs count)
 179
 180 -- | Generates combinations of count items from the names list.
 181 genNames :: Int -> [b] -> [[b]]
 182 genNames count1 names1 =
 183   let aux_fn count names current =
 184           case count of
 185             0 -> [current]
 186             _ ->
 187                 concatMap
 188                 (\ (x, xs) -> aux_fn (count - 1) xs (x:current))
 189                 (genParts names count)
 190   in
 191     aux_fn count1 names1 []
 192
 193 {- | Computes the pair of bad nodes and instances.
 194
 195 The bad node list is computed via a simple 'verifyN1' check, and the
 196 bad instance list is the list of primary and secondary instances of
 197 those nodes.
 198
 199 -}
 200 computeBadItems :: NodeList -> InstanceList ->
 201                    ([Node.Node], [Instance.Instance])
 202 computeBadItems nl il =
 203   let bad_nodes = verifyN1 $ filter (not . Node.offline) $ Container.elems nl
 204       bad_instances = map (\idx -> Container.find idx il) $
 205                       sort $ nub $ concat $
 206                       map (\ n -> (Node.slist n) ++ (Node.plist n)) bad_nodes
 207   in
 208     (bad_nodes, bad_instances)
 209
 210
 211 {- | Checks if removal of instances results in N+1 pass.
 212
 213 Note: the check removal cannot optimize by scanning only the affected
 214 nodes, since the cluster is known to be not healthy; only the check
 215 placement can make this shortcut.
 216
 217 -}
 218 checkRemoval :: NodeList -> [Instance.Instance] -> Maybe Removal
 219 checkRemoval nl victims =
 220   let nx = removeInstances nl victims
 221       failN1 = verifyN1Check (Container.elems nx)
 222   in
 223     if failN1 then
 224       Nothing
 225     else
 226       Just $ Removal nx victims
 227
 228
 229 -- | Computes the removals list for a given depth
 230 computeRemovals :: NodeList
 231                  -> [Instance.Instance]
 232                  -> Int
 233                  -> [Maybe Removal]
 234 computeRemovals nl bad_instances depth =
 235     map (checkRemoval nl) $ genNames depth bad_instances
 236
 237 -- Second phase functions
 238
 239 -- | Single-node relocation cost
 240 nodeDelta :: Int -> Int -> Int -> Int
 241 nodeDelta i p s =
 242     if i == p || i == s then
 243         0
 244     else
 245         1
 246
 247 {-| Compute best solution.
 248
 249     This function compares two solutions, choosing the minimum valid
 250     solution.
 251 -}
 252 compareSolutions :: Maybe Solution -> Maybe Solution -> Maybe Solution
 253 compareSolutions a b = case (a, b) of
 254   (Nothing, x) -> x
 255   (x, Nothing) -> x
 256   (x, y) -> min x y
 257
 258 -- | Compute best table. Note that the ordering of the arguments is important.
 259 compareTables :: Table -> Table -> Table
 260 compareTables a@(Table _ _ a_cv _) b@(Table _ _ b_cv _ ) =
 261     if a_cv > b_cv then b else a
 262
 263 -- | Check if a given delta is worse then an existing solution.
 264 tooHighDelta :: Maybe Solution -> Int -> Int -> Bool
 265 tooHighDelta sol new_delta max_delta =
 266     if new_delta > max_delta && max_delta >=0 then
 267         True
 268     else
 269         case sol of
 270           Nothing -> False
 271           Just (Solution old_delta _) -> old_delta <= new_delta
 272
 273 {-| Check if placement of instances still keeps the cluster N+1 compliant.
 274
 275     This is the workhorse of the allocation algorithm: given the
 276     current node and instance maps, the list of instances to be
 277     placed, and the current solution, this will return all possible
 278     solution by recursing until all target instances are placed.
 279
 280 -}
 281 checkPlacement :: NodeList            -- ^ The current node list
 282                -> [Instance.Instance] -- ^ List of instances still to place
 283                -> [Placement]         -- ^ Partial solution until now
 284                -> Int                 -- ^ The delta of the partial solution
 285                -> Maybe Solution      -- ^ The previous solution
 286                -> Int                 -- ^ Abort if the we go above this delta
 287                -> Maybe Solution      -- ^ The new solution
 288 checkPlacement nl victims current current_delta prev_sol max_delta =
 289   let target = head victims
 290       opdx = Instance.pnode target
 291       osdx = Instance.snode target
 292       vtail = tail victims
 293       have_tail = (length vtail) > 0
 294       nodes = Container.elems nl
 295       iidx = Instance.idx target
 296   in
 297     foldl'
 298     (\ accu_p pri ->
 299          let
 300              pri_idx = Node.idx pri
 301              upri_delta = current_delta + nodeDelta pri_idx opdx osdx
 302              new_pri = Node.addPri pri target
 303              fail_delta1 = tooHighDelta accu_p upri_delta max_delta
 304          in
 305            if fail_delta1 || isNothing(new_pri) then accu_p
 306            else let pri_nl = Container.add pri_idx (fromJust new_pri) nl in
 307                 foldl'
 308                 (\ accu sec ->
 309                      let
 310                          sec_idx = Node.idx sec
 311                          upd_delta = upri_delta +
 312                                      nodeDelta sec_idx opdx osdx
 313                          fail_delta2 = tooHighDelta accu upd_delta max_delta
 314                          new_sec = Node.addSec sec target pri_idx
 315                      in
 316                        if sec_idx == pri_idx || fail_delta2 ||
 317                           isNothing new_sec then accu
 318                        else let
 319                            nx = Container.add sec_idx (fromJust new_sec) pri_nl
 320                            upd_cv = compCV nx
 321                            plc = (iidx, pri_idx, sec_idx, upd_cv)
 322                            c2 = plc:current
 323                            result =
 324                                if have_tail then
 325                                    checkPlacement nx vtail c2 upd_delta
 326                                                   accu max_delta
 327                                else
 328                                    Just (Solution upd_delta c2)
 329                       in compareSolutions accu result
 330                 ) accu_p nodes
 331     ) prev_sol nodes
 332
 333 -- | Apply a move
 334 applyMove :: NodeList -> Instance.Instance
 335           -> IMove -> (Maybe NodeList, Instance.Instance, Int, Int)
 336 -- Failover (f)
 337 applyMove nl inst Failover =
 338     let old_pdx = Instance.pnode inst
 339         old_sdx = Instance.snode inst
 340         old_p = Container.find old_pdx nl
 341         old_s = Container.find old_sdx nl
 342         int_p = Node.removePri old_p inst
 343         int_s = Node.removeSec old_s inst
 344         new_nl = do -- Maybe monad
 345           new_p <- Node.addPri int_s inst
 346           new_s <- Node.addSec int_p inst old_sdx
 347           return $ Container.addTwo old_pdx new_s old_sdx new_p nl
 348     in (new_nl, Instance.setBoth inst old_sdx old_pdx, old_sdx, old_pdx)
 349
 350 -- Replace the primary (f:, r:np, f)
 351 applyMove nl inst (ReplacePrimary new_pdx) =
 352     let old_pdx = Instance.pnode inst
 353         old_sdx = Instance.snode inst
 354         old_p = Container.find old_pdx nl
 355         old_s = Container.find old_sdx nl
 356         tgt_n = Container.find new_pdx nl
 357         int_p = Node.removePri old_p inst
 358         int_s = Node.removeSec old_s inst
 359         new_nl = do -- Maybe monad
 360           new_p <- Node.addPri tgt_n inst
 361           new_s <- Node.addSec int_s inst new_pdx
 362           return $ Container.add new_pdx new_p $
 363                  Container.addTwo old_pdx int_p old_sdx new_s nl
 364     in (new_nl, Instance.setPri inst new_pdx, new_pdx, old_sdx)
 365
 366 -- Replace the secondary (r:ns)
 367 applyMove nl inst (ReplaceSecondary new_sdx) =
 368     let old_pdx = Instance.pnode inst
 369         old_sdx = Instance.snode inst
 370         old_s = Container.find old_sdx nl
 371         tgt_n = Container.find new_sdx nl
 372         int_s = Node.removeSec old_s inst
 373         new_nl = Node.addSec tgt_n inst old_pdx >>=
 374                  \new_s -> return $ Container.addTwo new_sdx
 375                            new_s old_sdx int_s nl
 376     in (new_nl, Instance.setSec inst new_sdx, old_pdx, new_sdx)
 377
 378 -- Replace the secondary and failover (r:np, f)
 379 applyMove nl inst (ReplaceAndFailover new_pdx) =
 380     let old_pdx = Instance.pnode inst
 381         old_sdx = Instance.snode inst
 382         old_p = Container.find old_pdx nl
 383         old_s = Container.find old_sdx nl
 384         tgt_n = Container.find new_pdx nl
 385         int_p = Node.removePri old_p inst
 386         int_s = Node.removeSec old_s inst
 387         new_nl = do -- Maybe monad
 388           new_p <- Node.addPri tgt_n inst
 389           new_s <- Node.addSec int_p inst new_pdx
 390           return $ Container.add new_pdx new_p $
 391                  Container.addTwo old_pdx new_s old_sdx int_s nl
 392     in (new_nl, Instance.setBoth inst new_pdx old_pdx, new_pdx, old_pdx)
 393
 394 -- Failver and replace the secondary (f, r:ns)
 395 applyMove nl inst (FailoverAndReplace new_sdx) =
 396     let old_pdx = Instance.pnode inst
 397         old_sdx = Instance.snode inst
 398         old_p = Container.find old_pdx nl
 399         old_s = Container.find old_sdx nl
 400         tgt_n = Container.find new_sdx nl
 401         int_p = Node.removePri old_p inst
 402         int_s = Node.removeSec old_s inst
 403         new_nl = do -- Maybe monad
 404           new_p <- Node.addPri int_s inst
 405           new_s <- Node.addSec tgt_n inst old_sdx
 406           return $ Container.add new_sdx new_s $
 407                  Container.addTwo old_sdx new_p old_pdx int_p nl
 408     in (new_nl, Instance.setBoth inst old_sdx new_sdx, old_sdx, new_sdx)
 409
 410 checkSingleStep :: Table -- ^ The original table
 411                 -> Instance.Instance -- ^ The instance to move
 412                 -> Table -- ^ The current best table
 413                 -> IMove -- ^ The move to apply
 414                 -> Table -- ^ The final best table
 415 checkSingleStep ini_tbl target cur_tbl move =
 416     let
 417         Table ini_nl ini_il _ ini_plc = ini_tbl
 418         (tmp_nl, new_inst, pri_idx, sec_idx) = applyMove ini_nl target move
 419     in
 420       if isNothing tmp_nl then cur_tbl
 421       else
 422           let tgt_idx = Instance.idx target
 423               upd_nl = fromJust tmp_nl
 424               upd_cvar = compCV upd_nl
 425               upd_il = Container.add tgt_idx new_inst ini_il
 426               upd_plc = (tgt_idx, pri_idx, sec_idx, upd_cvar):ini_plc
 427               upd_tbl = Table upd_nl upd_il upd_cvar upd_plc
 428           in
 429             compareTables cur_tbl upd_tbl
 430
 431 -- | Given the status of the current secondary as a valid new node
 432 -- and the current candidate target node,
 433 -- generate the possible moves for a instance.
 434 possibleMoves :: Bool -> Int -> [IMove]
 435 possibleMoves True tdx =
 436     [ReplaceSecondary tdx,
 437      ReplaceAndFailover tdx,
 438      ReplacePrimary tdx,
 439      FailoverAndReplace tdx]
 440
 441 possibleMoves False tdx =
 442     [ReplaceSecondary tdx,
 443      ReplaceAndFailover tdx]
 444
 445 -- | Compute the best move for a given instance.
 446 checkInstanceMove :: [Int]             -- Allowed target node indices
 447                   -> Table             -- Original table
 448                   -> Instance.Instance -- Instance to move
 449                   -> Table             -- Best new table for this instance
 450 checkInstanceMove nodes_idx ini_tbl target =
 451     let
 452         opdx = Instance.pnode target
 453         osdx = Instance.snode target
 454         nodes = filter (\idx -> idx /= opdx && idx /= osdx) nodes_idx
 455         use_secondary = elem osdx nodes_idx
 456         aft_failover = if use_secondary -- if allowed to failover
 457                        then checkSingleStep ini_tbl target ini_tbl Failover
 458                        else ini_tbl
 459         all_moves = concatMap (possibleMoves use_secondary) nodes
 460     in
 461       -- iterate over the possible nodes for this instance
 462       foldl' (checkSingleStep ini_tbl target) aft_failover all_moves
 463
 464 -- | Compute the best next move.
 465 checkMove :: [Int]               -- ^ Allowed target node indices
 466           -> Table               -- ^ The current solution
 467           -> [Instance.Instance] -- ^ List of instances still to move
 468           -> Table               -- ^ The new solution
 469 checkMove nodes_idx ini_tbl victims =
 470     let Table _ _ _ ini_plc = ini_tbl
 471         -- iterate over all instances, computing the best move
 472         best_tbl =
 473             foldl'
 474             (\ step_tbl elem ->
 475                  if Instance.snode elem == Node.noSecondary then step_tbl
 476                     else compareTables step_tbl $
 477                          checkInstanceMove nodes_idx ini_tbl elem)
 478             ini_tbl victims
 479         Table _ _ _ best_plc = best_tbl
 480     in
 481       if length best_plc == length ini_plc then -- no advancement
 482           ini_tbl
 483       else
 484           best_tbl
 485
 486 {- | Auxiliary function for solution computation.
 487
 488 We write this in an explicit recursive fashion in order to control
 489 early-abort in case we have met the min delta. We can't use foldr
 490 instead of explicit recursion since we need the accumulator for the
 491 abort decision.
 492
 493 -}
 494 advanceSolution :: [Maybe Removal] -- ^ The removal to process
 495                 -> Int             -- ^ Minimum delta parameter
 496                 -> Int             -- ^ Maximum delta parameter
 497                 -> Maybe Solution  -- ^ Current best solution
 498                 -> Maybe Solution  -- ^ New best solution
 499 advanceSolution [] _ _ sol = sol
 500 advanceSolution (Nothing:xs) m n sol = advanceSolution xs m n sol
 501 advanceSolution ((Just (Removal nx removed)):xs) min_d max_d prev_sol =
 502     let new_sol = checkPlacement nx removed [] 0 prev_sol max_d
 503         new_delta = solutionDelta $! new_sol
 504     in
 505       if new_delta >= 0 && new_delta <= min_d then
 506           new_sol
 507       else
 508           advanceSolution xs min_d max_d new_sol
 509
 510 -- | Computes the placement solution.
 511 solutionFromRemovals :: [Maybe Removal] -- ^ The list of (possible) removals
 512                      -> Int             -- ^ Minimum delta parameter
 513                      -> Int             -- ^ Maximum delta parameter
 514                      -> Maybe Solution  -- ^ The best solution found
 515 solutionFromRemovals removals min_delta max_delta =
 516     advanceSolution removals min_delta max_delta Nothing
 517
 518 {- | Computes the solution at the given depth.
 519
 520 This is a wrapper over both computeRemovals and
 521 solutionFromRemovals. In case we have no solution, we return Nothing.
 522
 523 -}
 524 computeSolution :: NodeList        -- ^ The original node data
 525                 -> [Instance.Instance] -- ^ The list of /bad/ instances
 526                 -> Int             -- ^ The /depth/ of removals
 527                 -> Int             -- ^ Maximum number of removals to process
 528                 -> Int             -- ^ Minimum delta parameter
 529                 -> Int             -- ^ Maximum delta parameter
 530                 -> Maybe Solution  -- ^ The best solution found (or Nothing)
 531 computeSolution nl bad_instances depth max_removals min_delta max_delta =
 532   let
 533       removals = computeRemovals nl bad_instances depth
 534       removals' = capRemovals removals max_removals
 535   in
 536     solutionFromRemovals removals' min_delta max_delta
 537
 538 -- Solution display functions (pure)
 539
 540 -- | Given the original and final nodes, computes the relocation description.
 541 computeMoves :: String -- ^ The instance name
 542              -> String -- ^ Original primary
 543              -> String -- ^ Original secondary
 544              -> String -- ^ New primary
 545              -> String -- ^ New secondary
 546              -> (String, [String])
 547                 -- ^ Tuple of moves and commands list; moves is containing
 548                 -- either @/f/@ for failover or @/r:name/@ for replace
 549                 -- secondary, while the command list holds gnt-instance
 550                 -- commands (without that prefix), e.g \"@failover instance1@\"
 551 computeMoves i a b c d =
 552     if c == a then {- Same primary -}
 553         if d == b then {- Same sec??! -}
 554             ("-", [])
 555         else {- Change of secondary -}
 556             (printf "r:%s" d,
 557              [printf "replace-disks -n %s %s" d i])
 558     else
 559         if c == b then {- Failover and ... -}
 560             if d == a then {- that's all -}
 561                 ("f", [printf "migrate -f %s" i])
 562             else
 563                 (printf "f r:%s" d,
 564                  [printf "migrate -f %s" i,
 565                   printf "replace-disks -n %s %s" d i])
 566         else
 567             if d == a then {- ... and keep primary as secondary -}
 568                 (printf "r:%s f" c,
 569                  [printf "replace-disks -n %s %s" c i,
 570                   printf "migrate -f %s" i])
 571             else
 572                 if d == b then {- ... keep same secondary -}
 573                     (printf "f r:%s f" c,
 574                      [printf "migrate -f %s" i,
 575                       printf "replace-disks -n %s %s" c i,
 576                       printf "migrate -f %s" i])
 577
 578                 else {- Nothing in common -}
 579                     (printf "r:%s f r:%s" c d,
 580                      [printf "replace-disks -n %s %s" c i,
 581                       printf "migrate -f %s" i,
 582                       printf "replace-disks -n %s %s" d i])
 583
 584 {-| Converts a placement to string format -}
 585 printSolutionLine :: InstanceList
 586               -> NameList
 587               -> NameList
 588               -> Int
 589               -> Int
 590               -> Placement
 591               -> Int
 592               -> (String, [String])
 593 printSolutionLine il ktn kti nmlen imlen plc pos =
 594     let
 595         pmlen = (2*nmlen + 1)
 596         (i, p, s, c) = plc
 597         inst = Container.find i il
 598         inam = fromJust $ lookup (Instance.idx inst) kti
 599         npri = fromJust $ lookup p ktn
 600         nsec = fromJust $ lookup s ktn
 601         opri = fromJust $ lookup (Instance.pnode inst) ktn
 602         osec = fromJust $ lookup (Instance.snode inst) ktn
 603         (moves, cmds) =  computeMoves inam opri osec npri nsec
 604         ostr = (printf "%s:%s" opri osec)::String
 605         nstr = (printf "%s:%s" npri nsec)::String
 606     in
 607       (printf "  %3d. %-*s %-*s => %-*s %.8f a=%s"
 608        pos imlen inam pmlen ostr
 609        pmlen nstr c moves,
 610        cmds)
 611
 612 formatCmds :: [[String]] -> String
 613 formatCmds cmd_strs =
 614     unlines $
 615     concat $ map (\(a, b) ->
 616         (printf "echo step %d" (a::Int)):
 617         (printf "check"):
 618         (map ("gnt-instance " ++) b)) $
 619         zip [1..] cmd_strs
 620
 621 {-| Converts a solution to string format -}
 622 printSolution :: InstanceList
 623               -> NameList
 624               -> NameList
 625               -> [Placement]
 626               -> ([String], [[String]])
 627 printSolution il ktn kti sol =
 628     let
 629         mlen_fn = maximum . (map length) . snd . unzip
 630         imlen = mlen_fn kti
 631         nmlen = mlen_fn ktn
 632     in
 633       unzip $ map (uncurry $ printSolutionLine il ktn kti nmlen imlen) $
 634             zip sol [1..]
 635
 636 -- | Print the node list.
 637 printNodes :: NameList -> NodeList -> String
 638 printNodes ktn nl =
 639     let snl = sortBy (compare `on` Node.idx) (Container.elems nl)
 640         snl' = map (\ n -> ((fromJust $ lookup (Node.idx n) ktn), n)) snl
 641         m_name = maximum . (map length) . fst . unzip $ snl'
 642         helper = Node.list m_name
 643         header = printf
 644                  "%2s %-*s %5s %5s %5s %5s %5s %5s %5s %5s %3s %3s %7s %7s"
 645                  " F" m_name "Name"
 646                  "t_mem" "n_mem" "i_mem" "x_mem" "f_mem" "r_mem"
 647                  "t_dsk" "f_dsk"
 648                  "pri" "sec" "p_fmem" "p_fdsk"
 649     in unlines $ (header:map (uncurry helper) snl')
 650
 651 -- | Compute the mem and disk covariance.
 652 compDetailedCV :: NodeList -> (Double, Double, Double, Double, Double)
 653 compDetailedCV nl =
 654     let
 655         all_nodes = Container.elems nl
 656         (offline, nodes) = partition Node.offline all_nodes
 657         mem_l = map Node.p_mem nodes
 658         dsk_l = map Node.p_dsk nodes
 659         mem_cv = varianceCoeff mem_l
 660         dsk_cv = varianceCoeff dsk_l
 661         n1_l = length $ filter Node.failN1 nodes
 662         n1_score = (fromIntegral n1_l) / (fromIntegral $ length nodes)
 663         res_l = map Node.p_rem nodes
 664         res_cv = varianceCoeff res_l
 665         offline_inst = sum . map (\n -> (length . Node.plist $ n) +
 666                                         (length . Node.slist $ n)) $ offline
 667         online_inst = sum . map (\n -> (length . Node.plist $ n) +
 668                                        (length . Node.slist $ n)) $ nodes
 669         off_score = (fromIntegral offline_inst) /
 670                     (fromIntegral $ online_inst + offline_inst)
 671     in (mem_cv, dsk_cv, n1_score, res_cv, off_score)
 672
 673 -- | Compute the 'total' variance.
 674 compCV :: NodeList -> Double
 675 compCV nl =
 676     let (mem_cv, dsk_cv, n1_score, res_cv, off_score) = compDetailedCV nl
 677     in mem_cv + dsk_cv + n1_score + res_cv + off_score
 678
 679 printStats :: NodeList -> String
 680 printStats nl =
 681     let (mem_cv, dsk_cv, n1_score, res_cv, off_score) = compDetailedCV nl
 682     in printf "f_mem=%.8f, r_mem=%.8f, f_dsk=%.8f, n1=%.3f, uf=%.3f"
 683        mem_cv res_cv dsk_cv n1_score off_score
 684
 685 -- Balancing functions
 686
 687 -- Loading functions
 688
 689 -- | Compute the amount of memory used by primary instances on a node.
 690 nodeImem :: Node.Node -> InstanceList -> Int
 691 nodeImem node il =
 692     let rfind = flip Container.find $ il
 693     in sum . map Instance.mem .
 694        map rfind $ Node.plist node
 695
 696 -- | Compute the amount of disk used by instances on a node (either primary
 697 -- or secondary).
 698 nodeIdsk :: Node.Node -> InstanceList -> Int
 699 nodeIdsk node il =
 700     let rfind = flip Container.find $ il
 701     in sum . map Instance.dsk .
 702        map rfind $ (Node.plist node) ++ (Node.slist node)
 703
 704 -- | Check cluster data for consistency
 705 checkData :: NodeList -> InstanceList -> NameList -> NameList
 706           -> ([String], NodeList)
 707 checkData nl il ktn _ =
 708     Container.mapAccum
 709         (\ msgs node ->
 710              let nname = fromJust $ lookup (Node.idx node) ktn
 711                  nilst = map (flip Container.find $ il) (Node.plist node)
 712                  dilst = filter (not . Instance.running) nilst
 713                  adj_mem = sum . map Instance.mem $ dilst
 714                  delta_mem = (truncate $ Node.t_mem node)
 715                              - (Node.n_mem node)
 716                              - (Node.f_mem node)
 717                              - (nodeImem node il)
 718                              + adj_mem
 719                  delta_dsk = (truncate $ Node.t_dsk node)
 720                              - (Node.f_dsk node)
 721                              - (nodeIdsk node il)
 722                  newn = Node.setFmem (Node.setXmem node delta_mem)
 723                         (Node.f_mem node - adj_mem)
 724                  umsg1 = if delta_mem > 512 || delta_dsk > 1024
 725                          then [printf "node %s is missing %d MB ram \
 726                                      \and %d GB disk"
 727                                      nname delta_mem (delta_dsk `div` 1024)]
 728                          else []
 729              in (msgs ++ umsg1, newn)
 730         ) [] nl