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