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