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 -> compareTables step_tbl $
 479                                 checkInstanceMove nodes_idx ini_tbl elem)
 480             ini_tbl victims
 481         Table _ _ _ best_plc = best_tbl
 482     in
 483       if length best_plc == length ini_plc then -- no advancement
 484           ini_tbl
 485       else
 486           best_tbl
 487
 488 {- | Auxiliary function for solution computation.
 489
 490 We write this in an explicit recursive fashion in order to control
 491 early-abort in case we have met the min delta. We can't use foldr
 492 instead of explicit recursion since we need the accumulator for the
 493 abort decision.
 494
 495 -}
 496 advanceSolution :: [Maybe Removal] -- ^ The removal to process
 497                 -> Int             -- ^ Minimum delta parameter
 498                 -> Int             -- ^ Maximum delta parameter
 499                 -> Maybe Solution  -- ^ Current best solution
 500                 -> Maybe Solution  -- ^ New best solution
 501 advanceSolution [] _ _ sol = sol
 502 advanceSolution (Nothing:xs) m n sol = advanceSolution xs m n sol
 503 advanceSolution ((Just (Removal nx removed)):xs) min_d max_d prev_sol =
 504     let new_sol = checkPlacement nx removed [] 0 prev_sol max_d
 505         new_delta = solutionDelta $! new_sol
 506     in
 507       if new_delta >= 0 && new_delta <= min_d then
 508           new_sol
 509       else
 510           advanceSolution xs min_d max_d new_sol
 511
 512 -- | Computes the placement solution.
 513 solutionFromRemovals :: [Maybe Removal] -- ^ The list of (possible) removals
 514                      -> Int             -- ^ Minimum delta parameter
 515                      -> Int             -- ^ Maximum delta parameter
 516                      -> Maybe Solution  -- ^ The best solution found
 517 solutionFromRemovals removals min_delta max_delta =
 518     advanceSolution removals min_delta max_delta Nothing
 519
 520 {- | Computes the solution at the given depth.
 521
 522 This is a wrapper over both computeRemovals and
 523 solutionFromRemovals. In case we have no solution, we return Nothing.
 524
 525 -}
 526 computeSolution :: NodeList        -- ^ The original node data
 527                 -> [Instance.Instance] -- ^ The list of /bad/ instances
 528                 -> Int             -- ^ The /depth/ of removals
 529                 -> Int             -- ^ Maximum number of removals to process
 530                 -> Int             -- ^ Minimum delta parameter
 531                 -> Int             -- ^ Maximum delta parameter
 532                 -> Maybe Solution  -- ^ The best solution found (or Nothing)
 533 computeSolution nl bad_instances depth max_removals min_delta max_delta =
 534   let
 535       removals = computeRemovals nl bad_instances depth
 536       removals' = capRemovals removals max_removals
 537   in
 538     solutionFromRemovals removals' min_delta max_delta
 539
 540 -- Solution display functions (pure)
 541
 542 -- | Given the original and final nodes, computes the relocation description.
 543 computeMoves :: String -- ^ The instance name
 544              -> String -- ^ Original primary
 545              -> String -- ^ Original secondary
 546              -> String -- ^ New primary
 547              -> String -- ^ New secondary
 548              -> (String, [String])
 549                 -- ^ Tuple of moves and commands list; moves is containing
 550                 -- either @/f/@ for failover or @/r:name/@ for replace
 551                 -- secondary, while the command list holds gnt-instance
 552                 -- commands (without that prefix), e.g \"@failover instance1@\"
 553 computeMoves i a b c d =
 554     if c == a then {- Same primary -}
 555         if d == b then {- Same sec??! -}
 556             ("-", [])
 557         else {- Change of secondary -}
 558             (printf "r:%s" d,
 559              [printf "replace-disks -n %s %s" d i])
 560     else
 561         if c == b then {- Failover and ... -}
 562             if d == a then {- that's all -}
 563                 ("f", [printf "migrate -f %s" i])
 564             else
 565                 (printf "f r:%s" d,
 566                  [printf "migrate -f %s" i,
 567                   printf "replace-disks -n %s %s" d i])
 568         else
 569             if d == a then {- ... and keep primary as secondary -}
 570                 (printf "r:%s f" c,
 571                  [printf "replace-disks -n %s %s" c i,
 572                   printf "migrate -f %s" i])
 573             else
 574                 if d == b then {- ... keep same secondary -}
 575                     (printf "f r:%s f" c,
 576                      [printf "migrate -f %s" i,
 577                       printf "replace-disks -n %s %s" c i,
 578                       printf "migrate -f %s" i])
 579
 580                 else {- Nothing in common -}
 581                     (printf "r:%s f r:%s" c d,
 582                      [printf "replace-disks -n %s %s" c i,
 583                       printf "migrate -f %s" i,
 584                       printf "replace-disks -n %s %s" d i])
 585
 586 {-| Converts a placement to string format -}
 587 printSolutionLine :: InstanceList
 588               -> NameList
 589               -> NameList
 590               -> Int
 591               -> Int
 592               -> Placement
 593               -> Int
 594               -> (String, [String])
 595 printSolutionLine il ktn kti nmlen imlen plc pos =
 596     let
 597         pmlen = (2*nmlen + 1)
 598         (i, p, s, c) = plc
 599         inst = Container.find i il
 600         inam = fromJust $ lookup (Instance.idx inst) kti
 601         npri = fromJust $ lookup p ktn
 602         nsec = fromJust $ lookup s ktn
 603         opri = fromJust $ lookup (Instance.pnode inst) ktn
 604         osec = fromJust $ lookup (Instance.snode inst) ktn
 605         (moves, cmds) =  computeMoves inam opri osec npri nsec
 606         ostr = (printf "%s:%s" opri osec)::String
 607         nstr = (printf "%s:%s" npri nsec)::String
 608     in
 609       (printf "  %3d. %-*s %-*s => %-*s %.8f a=%s"
 610        pos imlen inam pmlen ostr
 611        pmlen nstr c moves,
 612        cmds)
 613
 614 formatCmds :: [[String]] -> String
 615 formatCmds cmd_strs =
 616     unlines $
 617     concat $ map (\(a, b) ->
 618         (printf "echo step %d" (a::Int)):
 619         (printf "check"):
 620         (map ("gnt-instance " ++) b)) $
 621         zip [1..] cmd_strs
 622
 623 {-| Converts a solution to string format -}
 624 printSolution :: InstanceList
 625               -> NameList
 626               -> NameList
 627               -> [Placement]
 628               -> ([String], [[String]])
 629 printSolution il ktn kti sol =
 630     let
 631         mlen_fn = maximum . (map length) . snd . unzip
 632         imlen = mlen_fn kti
 633         nmlen = mlen_fn ktn
 634     in
 635       unzip $ map (uncurry $ printSolutionLine il ktn kti nmlen imlen) $
 636             zip sol [1..]
 637
 638 -- | Print the node list.
 639 printNodes :: NameList -> NodeList -> String
 640 printNodes ktn nl =
 641     let snl = sortBy (compare `on` Node.idx) (Container.elems nl)
 642         snl' = map (\ n -> ((fromJust $ lookup (Node.idx n) ktn), n)) snl
 643         m_name = maximum . (map length) . fst . unzip $ snl'
 644         helper = Node.list m_name
 645         header = printf
 646                  "%2s %-*s %5s %5s %5s %5s %5s %5s %5s %5s %3s %3s %7s %7s"
 647                  " F" m_name "Name"
 648                  "t_mem" "n_mem" "i_mem" "x_mem" "f_mem" "r_mem"
 649                  "t_dsk" "f_dsk"
 650                  "pri" "sec" "p_fmem" "p_fdsk"
 651     in unlines $ (header:map (uncurry helper) snl')
 652
 653 -- | Compute the mem and disk covariance.
 654 compDetailedCV :: NodeList -> (Double, Double, Double, Double, Double)
 655 compDetailedCV nl =
 656     let
 657         all_nodes = Container.elems nl
 658         (offline, nodes) = partition Node.offline all_nodes
 659         mem_l = map Node.p_mem nodes
 660         dsk_l = map Node.p_dsk nodes
 661         mem_cv = varianceCoeff mem_l
 662         dsk_cv = varianceCoeff dsk_l
 663         n1_l = length $ filter Node.failN1 nodes
 664         n1_score = (fromIntegral n1_l) / (fromIntegral $ length nodes)
 665         res_l = map Node.p_rem nodes
 666         res_cv = varianceCoeff res_l
 667         offline_inst = sum . map (\n -> (length . Node.plist $ n) +
 668                                         (length . Node.slist $ n)) $ offline
 669         online_inst = sum . map (\n -> (length . Node.plist $ n) +
 670                                        (length . Node.slist $ n)) $ nodes
 671         off_score = (fromIntegral offline_inst) /
 672                     (fromIntegral $ online_inst + offline_inst)
 673     in (mem_cv, dsk_cv, n1_score, res_cv, off_score)
 674
 675 -- | Compute the 'total' variance.
 676 compCV :: NodeList -> Double
 677 compCV nl =
 678     let (mem_cv, dsk_cv, n1_score, res_cv, off_score) = compDetailedCV nl
 679     in mem_cv + dsk_cv + n1_score + res_cv + off_score
 680
 681 printStats :: NodeList -> String
 682 printStats nl =
 683     let (mem_cv, dsk_cv, n1_score, res_cv, off_score) = compDetailedCV nl
 684     in printf "f_mem=%.8f, r_mem=%.8f, f_dsk=%.8f, n1=%.3f, uf=%.3f"
 685        mem_cv res_cv dsk_cv n1_score off_score
 686
 687 -- Balancing functions
 688
 689 -- Loading functions
 690
 691 {- | Convert newline and delimiter-separated text.
 692
 693 This function converts a text in tabular format as generated by
 694 @gnt-instance list@ and @gnt-node list@ to a list of objects using a
 695 supplied conversion function.
 696
 697 -}
 698 loadTabular :: (Monad m) => String -> ([String] -> m (String, a))
 699             -> (a -> Int -> a) -> m ([(String, Int)], [(Int, a)])
 700 loadTabular text_data convert_fn set_fn = do
 701   let lines_data = lines text_data
 702       rows = map (sepSplit '|') lines_data
 703   kerows <- mapM convert_fn rows
 704   let idxrows = map (\ (idx, (k, v)) -> ((k, idx), (idx, set_fn v idx)))
 705                 (zip [0..] kerows)
 706   return $ unzip idxrows
 707
 708 -- | For each instance, add its index to its primary and secondary nodes
 709 fixNodes :: [(Int, Node.Node)]
 710          -> [(Int, Instance.Instance)]
 711          -> [(Int, Node.Node)]
 712 fixNodes nl il =
 713     foldl' (\accu (idx, inst) ->
 714                 let
 715                     assocEqual = (\ (i, _) (j, _) -> i == j)
 716                     pdx = Instance.pnode inst
 717                     sdx = Instance.snode inst
 718                     pold = fromJust $ lookup pdx accu
 719                     sold = fromJust $ lookup sdx accu
 720                     pnew = Node.setPri pold idx
 721                     snew = Node.setSec sold idx
 722                     ac1 = deleteBy assocEqual (pdx, pold) accu
 723                     ac2 = deleteBy assocEqual (sdx, sold) ac1
 724                     ac3 = (pdx, pnew):(sdx, snew):ac2
 725                 in ac3) nl il
 726
 727 -- | Compute the longest common suffix of a NameList list that
 728 -- | starts with a dot
 729 longestDomain :: NameList -> String
 730 longestDomain [] = ""
 731 longestDomain ((_,x):xs) =
 732     let
 733         onlyStrings = snd $ unzip xs
 734     in
 735       foldr (\ suffix accu -> if all (isSuffixOf suffix) onlyStrings
 736                               then suffix
 737                               else accu)
 738       "" $ filter (isPrefixOf ".") (tails x)
 739
 740 -- | Remove tails from the (Int, String) lists
 741 stripSuffix :: String -> NameList -> NameList
 742 stripSuffix suffix lst =
 743     let sflen = length suffix in
 744     map (\ (key, name) -> (key, take ((length name) - sflen) name)) lst
 745
 746 -- | Lookups a node into an assoc list
 747 lookupNode :: (Monad m) => String -> String -> [(String, Int)] -> m Int
 748 lookupNode node inst ktn =
 749     case lookup node ktn of
 750       Nothing -> fail $ "Unknown node " ++ node ++ " for instance " ++ inst
 751       Just idx -> return idx
 752
 753 {-| Initializer function that loads the data from a node and list file
 754     and massages it into the correct format. -}
 755 loadData :: String -- ^ Node data in text format
 756          -> String -- ^ Instance data in text format
 757          -> Result (Container.Container Node.Node,
 758                     Container.Container Instance.Instance,
 759                     String, NameList, NameList)
 760 loadData ndata idata = do
 761   {- node file: name t_mem n_mem f_mem t_disk f_disk -}
 762   (ktn, nl) <- loadTabular ndata
 763                (\ (name:tm:nm:fm:td:fd:fo:[]) ->
 764                     return (name,
 765                             if any (== "?") [tm,nm,fm,td,fd] || fo == "Y" then
 766                                 Node.create 0 0 0 0 0 True
 767                             else
 768                                 Node.create (read tm) (read nm) (read fm)
 769                                         (read td) (read fd) False
 770                            ))
 771                Node.setIdx
 772       {- instance file: name mem disk status pnode snode -}
 773   (kti, il) <- loadTabular idata
 774                   (\ (name:mem:dsk:status:pnode:snode:[]) -> do
 775                      pidx <- lookupNode pnode name ktn
 776                      sidx <- lookupNode snode name ktn
 777                      let newinst = Instance.create (read mem) (read dsk)
 778                                    status pidx sidx
 779                      return (name, newinst)
 780                   )
 781                   Instance.setIdx
 782   let
 783       nl2 = fixNodes nl il
 784       il3 = Container.fromAssocList il
 785       nl3 = Container.fromAssocList
 786             (map (\ (k, v) -> (k, Node.buildPeers v il3 (length nl2))) nl2)
 787       xtn = swapPairs ktn
 788       xti = swapPairs kti
 789       common_suffix = longestDomain (xti ++ xtn)
 790       stn = stripSuffix common_suffix xtn
 791       sti = stripSuffix common_suffix xti
 792   return (nl3, il3, common_suffix, stn, sti)
 793
 794 -- | Compute the amount of memory used by primary instances on a node.
 795 nodeImem :: Node.Node -> InstanceList -> Int
 796 nodeImem node il =
 797     let rfind = flip Container.find $ il
 798     in sum . map Instance.mem .
 799        map rfind $ Node.plist node
 800
 801 -- | Compute the amount of disk used by instances on a node (either primary
 802 -- or secondary).
 803 nodeIdsk :: Node.Node -> InstanceList -> Int
 804 nodeIdsk node il =
 805     let rfind = flip Container.find $ il
 806     in sum . map Instance.dsk .
 807        map rfind $ (Node.plist node) ++ (Node.slist node)
 808
 809
 810 -- | Check cluster data for consistency
 811 checkData :: NodeList -> InstanceList -> NameList -> NameList
 812           -> ([String], NodeList)
 813 checkData nl il ktn _ =
 814     Container.mapAccum
 815         (\ msgs node ->
 816              let nname = fromJust $ lookup (Node.idx node) ktn
 817                  nilst = map (flip Container.find $ il) (Node.plist node)
 818                  dilst = filter (not . Instance.running) nilst
 819                  adj_mem = sum . map Instance.mem $ dilst
 820                  delta_mem = (truncate $ Node.t_mem node)
 821                              - (Node.n_mem node)
 822                              - (Node.f_mem node)
 823                              - (nodeImem node il)
 824                              + adj_mem
 825                  delta_dsk = (truncate $ Node.t_dsk node)
 826                              - (Node.f_dsk node)
 827                              - (nodeIdsk node il)
 828                  newn = Node.setFmem (Node.setXmem node delta_mem)
 829                         (Node.f_mem node - adj_mem)
 830                  umsg1 = if delta_mem > 512 || delta_dsk > 1024
 831                          then [printf "node %s is missing %d MB ram \
 832                                      \and %d GB disk"
 833                                      nname delta_mem (delta_dsk `div` 1024)]
 834                          else []
 835              in (msgs ++ umsg1, newn)
 836         ) [] nl