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