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