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