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