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