Cluster.hs

{-| Implementation of cluster-wide logic.

This module holds all pure cluster-logic; I\/O related functionality
goes into the "Main" module for the individual binaries.

-}

module Ganeti.HTools.Cluster
    (
     -- * Types
     NodeList
    , InstanceList
    , NameList
    , Placement
    , Solution(..)
    , Table(..)
    , Removal
    , Score
    -- * Generic functions
    , totalResources
    -- * First phase functions
    , computeBadItems
    -- * Second phase functions
    , computeSolution
    , applySolution
    , printSolution
    , printSolutionLine
    , formatCmds
    , printNodes
    -- * Balacing functions
    , checkMove
    , compCV
    , printStats
    -- * Loading functions
    , loadData
    , checkData
    ) where

import Data.List
import Data.Maybe (isNothing, fromJust)
import Text.Printf (printf)
import Data.Function
import Control.Monad

import qualified Ganeti.HTools.Container as Container
import qualified Ganeti.HTools.Instance as Instance
import qualified Ganeti.HTools.Node as Node
import Ganeti.HTools.Utils

type NodeList = Container.Container Node.Node
type InstanceList = Container.Container Instance.Instance
-- | The type used to hold idx-to-name mappings
type NameList = [(Int, String)]
-- | A separate name for the cluster score type
type Score = Double

-- | The description of an instance placement.
type Placement = (Int, Int, Int, Score)

{- | A cluster solution described as the solution delta and the list
of placements.

-}
data Solution = Solution Int [Placement]
                deriving (Eq, Ord, Show)

-- | Returns the delta of a solution or -1 for Nothing
solutionDelta :: Maybe Solution -> Int
solutionDelta sol = case sol of
                      Just (Solution d _) -> d
                      _ -> -1

-- | A removal set.
data Removal = Removal NodeList [Instance.Instance]

-- | An instance move definition
data IMove = Failover                -- ^ Failover the instance (f)
           | ReplacePrimary Int      -- ^ Replace primary (f, r:np, f)
           | ReplaceSecondary Int    -- ^ Replace secondary (r:ns)
           | ReplaceAndFailover Int  -- ^ Replace secondary, failover (r:np, f)
           | FailoverAndReplace Int  -- ^ Failover, replace secondary (f, r:ns)
             deriving (Show)

-- | The complete state for the balancing solution
data Table = Table NodeList InstanceList Score [Placement]
             deriving (Show)

-- General functions

-- | Cap the removal list if needed.
capRemovals :: [a] -> Int -> [a]
capRemovals removals max_removals =
    if max_removals > 0 then
        take max_removals removals
    else
        removals

-- | Check if the given node list fails the N+1 check.
verifyN1Check :: [Node.Node] -> Bool
verifyN1Check nl = any Node.failN1 nl

-- | Verifies the N+1 status and return the affected nodes.
verifyN1 :: [Node.Node] -> [Node.Node]
verifyN1 nl = filter Node.failN1 nl

{-| Add an instance and return the new node and instance maps. -}
addInstance :: NodeList -> Instance.Instance ->
               Node.Node -> Node.Node -> Maybe NodeList
addInstance nl idata pri sec =
  let pdx = Node.idx pri
      sdx = Node.idx sec
  in do
      pnode <- Node.addPri pri idata
      snode <- Node.addSec sec idata pdx
      new_nl <- return $ Container.addTwo sdx snode
                         pdx pnode nl
      return new_nl

-- | Remove an instance and return the new node and instance maps.
removeInstance :: NodeList -> Instance.Instance -> NodeList
removeInstance nl idata =
  let pnode = Instance.pnode idata
      snode = Instance.snode idata
      pn = Container.find pnode nl
      sn = Container.find snode nl
      new_nl = Container.addTwo
               pnode (Node.removePri pn idata)
               snode (Node.removeSec sn idata) nl in
  new_nl

-- | Remove an instance and return the new node map.
removeInstances :: NodeList -> [Instance.Instance] -> NodeList
removeInstances = foldl' removeInstance

-- | Compute the total free disk and memory in the cluster.
totalResources :: Container.Container Node.Node -> (Int, Int)
totalResources nl =
    foldl'
    (\ (mem, dsk) node -> (mem + (Node.f_mem node),
                           dsk + (Node.f_dsk node)))
    (0, 0) (Container.elems nl)

{- | Compute a new version of a cluster given a solution.

This is not used for computing the solutions, but for applying a
(known-good) solution to the original cluster for final display.

It first removes the relocated instances after which it places them on
their new nodes.

 -}
applySolution :: NodeList -> InstanceList -> [Placement] -> NodeList
applySolution nl il sol =
    let odxes = map (\ (a, b, c, _) -> (Container.find a il,
                                        Node.idx (Container.find b nl),
                                        Node.idx (Container.find c nl))
                    ) sol
        idxes = (\ (x, _, _) -> x) (unzip3 odxes)
        nc = removeInstances nl idxes
    in
      foldl' (\ nz (a, b, c) ->
                 let new_p = Container.find b nz
                     new_s = Container.find c nz in
                 fromJust (addInstance nz a new_p new_s)
           ) nc odxes


-- First phase functions

{- | Given a list 1,2,3..n build a list of pairs [(1, [2..n]), (2,
    [3..n]), ...]

-}
genParts :: [a] -> Int -> [(a, [a])]
genParts l count =
    case l of
      [] -> []
      x:xs ->
          if length l < count then
              []
          else
              (x, xs) : (genParts xs count)

-- | Generates combinations of count items from the names list.
genNames :: Int -> [b] -> [[b]]
genNames count1 names1 =
  let aux_fn count names current =
          case count of
            0 -> [current]
            _ ->
                concatMap
                (\ (x, xs) -> aux_fn (count - 1) xs (x:current))
                (genParts names count)
  in
    aux_fn count1 names1 []

{- | Computes the pair of bad nodes and instances.

The bad node list is computed via a simple 'verifyN1' check, and the
bad instance list is the list of primary and secondary instances of
those nodes.

-}
computeBadItems :: NodeList -> InstanceList ->
                   ([Node.Node], [Instance.Instance])
computeBadItems nl il =
  let bad_nodes = verifyN1 $ filter (not . Node.offline) $ Container.elems nl
      bad_instances = map (\idx -> Container.find idx il) $
                      sort $ nub $ concat $
                      map (\ n -> (Node.slist n) ++ (Node.plist n)) bad_nodes
  in
    (bad_nodes, bad_instances)


{- | Checks if removal of instances results in N+1 pass.

Note: the check removal cannot optimize by scanning only the affected
nodes, since the cluster is known to be not healthy; only the check
placement can make this shortcut.

-}
checkRemoval :: NodeList -> [Instance.Instance] -> Maybe Removal
checkRemoval nl victims =
  let nx = removeInstances nl victims
      failN1 = verifyN1Check (Container.elems nx)
  in
    if failN1 then
      Nothing
    else
      Just $ Removal nx victims


-- | Computes the removals list for a given depth
computeRemovals :: NodeList
                 -> [Instance.Instance]
                 -> Int
                 -> [Maybe Removal]
computeRemovals nl bad_instances depth =
    map (checkRemoval nl) $ genNames depth bad_instances

-- Second phase functions

-- | Single-node relocation cost
nodeDelta :: Int -> Int -> Int -> Int
nodeDelta i p s =
    if i == p || i == s then
        0
    else
        1

{-| Compute best solution.

    This function compares two solutions, choosing the minimum valid
    solution.
-}
compareSolutions :: Maybe Solution -> Maybe Solution -> Maybe Solution
compareSolutions a b = case (a, b) of
  (Nothing, x) -> x
  (x, Nothing) -> x
  (x, y) -> min x y

-- | Compute best table. Note that the ordering of the arguments is important.
compareTables :: Table -> Table -> Table
compareTables a@(Table _ _ a_cv _) b@(Table _ _ b_cv _ ) =
    if a_cv > b_cv then b else a

-- | Check if a given delta is worse then an existing solution.
tooHighDelta :: Maybe Solution -> Int -> Int -> Bool
tooHighDelta sol new_delta max_delta =
    if new_delta > max_delta && max_delta >=0 then
        True
    else
        case sol of
          Nothing -> False
          Just (Solution old_delta _) -> old_delta <= new_delta

{-| Check if placement of instances still keeps the cluster N+1 compliant.

    This is the workhorse of the allocation algorithm: given the
    current node and instance maps, the list of instances to be
    placed, and the current solution, this will return all possible
    solution by recursing until all target instances are placed.

-}
checkPlacement :: NodeList            -- ^ The current node list
               -> [Instance.Instance] -- ^ List of instances still to place
               -> [Placement]         -- ^ Partial solution until now
               -> Int                 -- ^ The delta of the partial solution
               -> Maybe Solution      -- ^ The previous solution
               -> Int                 -- ^ Abort if the we go above this delta
               -> Maybe Solution      -- ^ The new solution
checkPlacement nl victims current current_delta prev_sol max_delta =
  let target = head victims
      opdx = Instance.pnode target
      osdx = Instance.snode target
      vtail = tail victims
      have_tail = (length vtail) > 0
      nodes = Container.elems nl
      iidx = Instance.idx target
  in
    foldl'
    (\ accu_p pri ->
         let
             pri_idx = Node.idx pri
             upri_delta = current_delta + nodeDelta pri_idx opdx osdx
             new_pri = Node.addPri pri target
             fail_delta1 = tooHighDelta accu_p upri_delta max_delta
         in
           if fail_delta1 || isNothing(new_pri) then accu_p
           else let pri_nl = Container.add pri_idx (fromJust new_pri) nl in
                foldl'
                (\ accu sec ->
                     let
                         sec_idx = Node.idx sec
                         upd_delta = upri_delta +
                                     nodeDelta sec_idx opdx osdx
                         fail_delta2 = tooHighDelta accu upd_delta max_delta
                         new_sec = Node.addSec sec target pri_idx
                     in
                       if sec_idx == pri_idx || fail_delta2 ||
                          isNothing new_sec then accu
                       else let
                           nx = Container.add sec_idx (fromJust new_sec) pri_nl
                           upd_cv = compCV nx
                           plc = (iidx, pri_idx, sec_idx, upd_cv)
                           c2 = plc:current
                           result =
                               if have_tail then
                                   checkPlacement nx vtail c2 upd_delta
                                                  accu max_delta
                               else
                                   Just (Solution upd_delta c2)
                      in compareSolutions accu result
                ) accu_p nodes
    ) prev_sol nodes

-- | Apply a move
applyMove :: NodeList -> Instance.Instance
          -> IMove -> (Maybe NodeList, Instance.Instance, Int, Int)
-- Failover (f)
applyMove nl inst Failover =
    let old_pdx = Instance.pnode inst
        old_sdx = Instance.snode inst
        old_p = Container.find old_pdx nl
        old_s = Container.find old_sdx nl
        int_p = Node.removePri old_p inst
        int_s = Node.removeSec old_s inst
        new_nl = do -- Maybe monad
          new_p <- Node.addPri int_s inst
          new_s <- Node.addSec int_p inst old_sdx
          return $ Container.addTwo old_pdx new_s old_sdx new_p nl
    in (new_nl, Instance.setBoth inst old_sdx old_pdx, old_sdx, old_pdx)

-- Replace the primary (f:, r:np, f)
applyMove nl inst (ReplacePrimary new_pdx) =
    let old_pdx = Instance.pnode inst
        old_sdx = Instance.snode inst
        old_p = Container.find old_pdx nl
        old_s = Container.find old_sdx nl
        tgt_n = Container.find new_pdx nl
        int_p = Node.removePri old_p inst
        int_s = Node.removeSec old_s inst
        new_nl = do -- Maybe monad
          new_p <- Node.addPri tgt_n inst
          new_s <- Node.addSec int_s inst new_pdx
          return $ Container.add new_pdx new_p $
                 Container.addTwo old_pdx int_p old_sdx new_s nl
    in (new_nl, Instance.setPri inst new_pdx, new_pdx, old_sdx)

-- Replace the secondary (r:ns)
applyMove nl inst (ReplaceSecondary new_sdx) =
    let old_pdx = Instance.pnode inst
        old_sdx = Instance.snode inst
        old_s = Container.find old_sdx nl
        tgt_n = Container.find new_sdx nl
        int_s = Node.removeSec old_s inst
        new_nl = Node.addSec tgt_n inst old_pdx >>=
                 \new_s -> return $ Container.addTwo new_sdx
                           new_s old_sdx int_s nl
    in (new_nl, Instance.setSec inst new_sdx, old_pdx, new_sdx)

-- Replace the secondary and failover (r:np, f)
applyMove nl inst (ReplaceAndFailover new_pdx) =
    let old_pdx = Instance.pnode inst
        old_sdx = Instance.snode inst
        old_p = Container.find old_pdx nl
        old_s = Container.find old_sdx nl
        tgt_n = Container.find new_pdx nl
        int_p = Node.removePri old_p inst
        int_s = Node.removeSec old_s inst
        new_nl = do -- Maybe monad
          new_p <- Node.addPri tgt_n inst
          new_s <- Node.addSec int_p inst new_pdx
          return $ Container.add new_pdx new_p $
                 Container.addTwo old_pdx new_s old_sdx int_s nl
    in (new_nl, Instance.setBoth inst new_pdx old_pdx, new_pdx, old_pdx)

-- Failver and replace the secondary (f, r:ns)
applyMove nl inst (FailoverAndReplace new_sdx) =
    let old_pdx = Instance.pnode inst
        old_sdx = Instance.snode inst
        old_p = Container.find old_pdx nl
        old_s = Container.find old_sdx nl
        tgt_n = Container.find new_sdx nl
        int_p = Node.removePri old_p inst
        int_s = Node.removeSec old_s inst
        new_nl = do -- Maybe monad
          new_p <- Node.addPri int_s inst
          new_s <- Node.addSec tgt_n inst old_sdx
          return $ Container.add new_sdx new_s $
                 Container.addTwo old_sdx new_p old_pdx int_p nl
    in (new_nl, Instance.setBoth inst old_sdx new_sdx, old_sdx, new_sdx)

checkSingleStep :: Table -- ^ The original table
                -> Instance.Instance -- ^ The instance to move
                -> Table -- ^ The current best table
                -> IMove -- ^ The move to apply
                -> Table -- ^ The final best table
checkSingleStep ini_tbl target cur_tbl move =
    let
        Table ini_nl ini_il _ ini_plc = ini_tbl
        (tmp_nl, new_inst, pri_idx, sec_idx) = applyMove ini_nl target move
    in
      if isNothing tmp_nl then cur_tbl
      else
          let tgt_idx = Instance.idx target
              upd_nl = fromJust tmp_nl
              upd_cvar = compCV upd_nl
              upd_il = Container.add tgt_idx new_inst ini_il
              upd_plc = (tgt_idx, pri_idx, sec_idx, upd_cvar):ini_plc
              upd_tbl = Table upd_nl upd_il upd_cvar upd_plc
          in
            compareTables cur_tbl upd_tbl

-- | Given the status of the current secondary as a valid new node
-- and the current candidate target node,
-- generate the possible moves for a instance.
possibleMoves :: Bool -> Int -> [IMove]
possibleMoves True tdx =
    [ReplaceSecondary tdx,
     ReplaceAndFailover tdx,
     ReplacePrimary tdx,
     FailoverAndReplace tdx]

possibleMoves False tdx =
    [ReplaceSecondary tdx,
     ReplaceAndFailover tdx]

-- | Compute the best move for a given instance.
checkInstanceMove :: [Int]             -- Allowed target node indices
                  -> Table             -- Original table
                  -> Instance.Instance -- Instance to move
                  -> Table             -- Best new table for this instance
checkInstanceMove nodes_idx ini_tbl target =
    let
        opdx = Instance.pnode target
        osdx = Instance.snode target
        nodes = filter (\idx -> idx /= opdx && idx /= osdx) nodes_idx
        use_secondary = elem osdx nodes_idx
        aft_failover = if use_secondary -- if allowed to failover
                       then checkSingleStep ini_tbl target ini_tbl Failover
                       else ini_tbl
        all_moves = concatMap (possibleMoves use_secondary) nodes
    in
      -- iterate over the possible nodes for this instance
      foldl' (checkSingleStep ini_tbl target) aft_failover all_moves

-- | Compute the best next move.
checkMove :: [Int]               -- ^ Allowed target node indices
          -> Table               -- ^ The current solution
          -> [Instance.Instance] -- ^ List of instances still to move
          -> Table               -- ^ The new solution
checkMove nodes_idx ini_tbl victims =
    let Table _ _ _ ini_plc = ini_tbl
        -- iterate over all instances, computing the best move
        best_tbl =
            foldl'
            (\ step_tbl elem -> compareTables step_tbl $
                                checkInstanceMove nodes_idx ini_tbl elem)
            ini_tbl victims
        Table _ _ _ best_plc = best_tbl
    in
      if length best_plc == length ini_plc then -- no advancement
          ini_tbl
      else
          best_tbl

{- | Auxiliary function for solution computation.

We write this in an explicit recursive fashion in order to control
early-abort in case we have met the min delta. We can't use foldr
instead of explicit recursion since we need the accumulator for the
abort decision.

-}
advanceSolution :: [Maybe Removal] -- ^ The removal to process
                -> Int             -- ^ Minimum delta parameter
                -> Int             -- ^ Maximum delta parameter
                -> Maybe Solution  -- ^ Current best solution
                -> Maybe Solution  -- ^ New best solution
advanceSolution [] _ _ sol = sol
advanceSolution (Nothing:xs) m n sol = advanceSolution xs m n sol
advanceSolution ((Just (Removal nx removed)):xs) min_d max_d prev_sol =
    let new_sol = checkPlacement nx removed [] 0 prev_sol max_d
        new_delta = solutionDelta $! new_sol
    in
      if new_delta >= 0 && new_delta <= min_d then
          new_sol
      else
          advanceSolution xs min_d max_d new_sol

-- | Computes the placement solution.
solutionFromRemovals :: [Maybe Removal] -- ^ The list of (possible) removals
                     -> Int             -- ^ Minimum delta parameter
                     -> Int             -- ^ Maximum delta parameter
                     -> Maybe Solution  -- ^ The best solution found
solutionFromRemovals removals min_delta max_delta =
    advanceSolution removals min_delta max_delta Nothing

{- | Computes the solution at the given depth.

This is a wrapper over both computeRemovals and
solutionFromRemovals. In case we have no solution, we return Nothing.

-}
computeSolution :: NodeList        -- ^ The original node data
                -> [Instance.Instance] -- ^ The list of /bad/ instances
                -> Int             -- ^ The /depth/ of removals
                -> Int             -- ^ Maximum number of removals to process
                -> Int             -- ^ Minimum delta parameter
                -> Int             -- ^ Maximum delta parameter
                -> Maybe Solution  -- ^ The best solution found (or Nothing)
computeSolution nl bad_instances depth max_removals min_delta max_delta =
  let
      removals = computeRemovals nl bad_instances depth
      removals' = capRemovals removals max_removals
  in
    solutionFromRemovals removals' min_delta max_delta

-- Solution display functions (pure)

-- | Given the original and final nodes, computes the relocation description.
computeMoves :: String -- ^ The instance name
             -> String -- ^ Original primary
             -> String -- ^ Original secondary
             -> String -- ^ New primary
             -> String -- ^ New secondary
             -> (String, [String])
                -- ^ Tuple of moves and commands list; moves is containing
                -- either @/f/@ for failover or @/r:name/@ for replace
                -- secondary, while the command list holds gnt-instance
                -- commands (without that prefix), e.g \"@failover instance1@\"
computeMoves i a b c d =
    if c == a then {- Same primary -}
        if d == b then {- Same sec??! -}
            ("-", [])
        else {- Change of secondary -}
            (printf "r:%s" d,
             [printf "replace-disks -n %s %s" d i])
    else
        if c == b then {- Failover and ... -}
            if d == a then {- that's all -}
                ("f", [printf "migrate -f %s" i])
            else
                (printf "f r:%s" d,
                 [printf "migrate -f %s" i,
                  printf "replace-disks -n %s %s" d i])
        else
            if d == a then {- ... and keep primary as secondary -}
                (printf "r:%s f" c,
                 [printf "replace-disks -n %s %s" c i,
                  printf "migrate -f %s" i])
            else
                if d == b then {- ... keep same secondary -}
                    (printf "f r:%s f" c,
                     [printf "migrate -f %s" i,
                      printf "replace-disks -n %s %s" c i,
                      printf "migrate -f %s" i])

                else {- Nothing in common -}
                    (printf "r:%s f r:%s" c d,
                     [printf "replace-disks -n %s %s" c i,
                      printf "migrate -f %s" i,
                      printf "replace-disks -n %s %s" d i])

{-| Converts a placement to string format -}
printSolutionLine :: InstanceList
              -> NameList
              -> NameList
              -> Int
              -> Int
              -> Placement
              -> Int
              -> (String, [String])
printSolutionLine il ktn kti nmlen imlen plc pos =
    let
        pmlen = (2*nmlen + 1)
        (i, p, s, c) = plc
        inst = Container.find i il
        inam = fromJust $ lookup (Instance.idx inst) kti
        npri = fromJust $ lookup p ktn
        nsec = fromJust $ lookup s ktn
        opri = fromJust $ lookup (Instance.pnode inst) ktn
        osec = fromJust $ lookup (Instance.snode inst) ktn
        (moves, cmds) =  computeMoves inam opri osec npri nsec
        ostr = (printf "%s:%s" opri osec)::String
        nstr = (printf "%s:%s" npri nsec)::String
    in
      (printf "  %3d. %-*s %-*s => %-*s %.8f a=%s"
       pos imlen inam pmlen ostr
       pmlen nstr c moves,
       cmds)

formatCmds :: [[String]] -> String
formatCmds cmd_strs =
    unlines $
    concat $ map (\(a, b) ->
        (printf "echo step %d" (a::Int)):
        (printf "check"):
        (map ("gnt-instance " ++) b)) $
        zip [1..] cmd_strs

{-| Converts a solution to string format -}
printSolution :: InstanceList
              -> NameList
              -> NameList
              -> [Placement]
              -> ([String], [[String]])
printSolution il ktn kti sol =
    let
        mlen_fn = maximum . (map length) . snd . unzip
        imlen = mlen_fn kti
        nmlen = mlen_fn ktn
    in
      unzip $ map (uncurry $ printSolutionLine il ktn kti nmlen imlen) $
            zip sol [1..]

-- | Print the node list.
printNodes :: NameList -> NodeList -> String
printNodes ktn nl =
    let snl = sortBy (compare `on` Node.idx) (Container.elems nl)
        snl' = map (\ n -> ((fromJust $ lookup (Node.idx n) ktn), n)) snl
        m_name = maximum . (map length) . fst . unzip $ snl'
        helper = Node.list m_name
        header = printf
                 "%2s %-*s %5s %5s %5s %5s %5s %5s %5s %5s %3s %3s %7s %7s"
                 " F" m_name "Name"
                 "t_mem" "n_mem" "i_mem" "x_mem" "f_mem" "r_mem"
                 "t_dsk" "f_dsk"
                 "pri" "sec" "p_fmem" "p_fdsk"
    in unlines $ (header:map (uncurry helper) snl')

-- | Compute the mem and disk covariance.
compDetailedCV :: NodeList -> (Double, Double, Double, Double, Double)
compDetailedCV nl =
    let
        all_nodes = Container.elems nl
        (offline, nodes) = partition Node.offline all_nodes
        mem_l = map Node.p_mem nodes
        dsk_l = map Node.p_dsk nodes
        mem_cv = varianceCoeff mem_l
        dsk_cv = varianceCoeff dsk_l
        n1_l = length $ filter Node.failN1 nodes
        n1_score = (fromIntegral n1_l) / (fromIntegral $ length nodes)
        res_l = map Node.p_rem nodes
        res_cv = varianceCoeff res_l
        offline_inst = sum . map (\n -> (length . Node.plist $ n) +
                                        (length . Node.slist $ n)) $ offline
        online_inst = sum . map (\n -> (length . Node.plist $ n) +
                                       (length . Node.slist $ n)) $ nodes
        off_score = (fromIntegral offline_inst) /
                    (fromIntegral $ online_inst + offline_inst)
    in (mem_cv, dsk_cv, n1_score, res_cv, off_score)

-- | Compute the 'total' variance.
compCV :: NodeList -> Double
compCV nl =
    let (mem_cv, dsk_cv, n1_score, res_cv, off_score) = compDetailedCV nl
    in mem_cv + dsk_cv + n1_score + res_cv + off_score

printStats :: NodeList -> String
printStats nl =
    let (mem_cv, dsk_cv, n1_score, res_cv, off_score) = compDetailedCV nl
    in printf "f_mem=%.8f, r_mem=%.8f, f_dsk=%.8f, n1=%.3f, uf=%.3f"
       mem_cv res_cv dsk_cv n1_score off_score

-- Balancing functions

-- Loading functions

{- | Convert newline and delimiter-separated text.

This function converts a text in tabular format as generated by
@gnt-instance list@ and @gnt-node list@ to a list of objects using a
supplied conversion function.

-}
loadTabular :: (Monad m) => String -> ([String] -> m (String, a))
            -> (a -> Int -> a) -> m ([(String, Int)], [(Int, a)])
loadTabular text_data convert_fn set_fn = do
  let lines_data = lines text_data
      rows = map (sepSplit '|') lines_data
  kerows <- mapM convert_fn rows
  let idxrows = map (\ (idx, (k, v)) -> ((k, idx), (idx, set_fn v idx)))
                (zip [0..] kerows)
  return $ unzip idxrows

-- | For each instance, add its index to its primary and secondary nodes
fixNodes :: [(Int, Node.Node)]
         -> [(Int, Instance.Instance)]
         -> [(Int, Node.Node)]
fixNodes nl il =
    foldl' (\accu (idx, inst) ->
                let
                    assocEqual = (\ (i, _) (j, _) -> i == j)
                    pdx = Instance.pnode inst
                    sdx = Instance.snode inst
                    pold = fromJust $ lookup pdx accu
                    sold = fromJust $ lookup sdx accu
                    pnew = Node.setPri pold idx
                    snew = Node.setSec sold idx
                    ac1 = deleteBy assocEqual (pdx, pold) accu
                    ac2 = deleteBy assocEqual (sdx, sold) ac1
                    ac3 = (pdx, pnew):(sdx, snew):ac2
                in ac3) nl il

-- | Compute the longest common suffix of a NameList list that
-- | starts with a dot
longestDomain :: NameList -> String
longestDomain [] = ""
longestDomain ((_,x):xs) =
    let
        onlyStrings = snd $ unzip xs
    in
      foldr (\ suffix accu -> if all (isSuffixOf suffix) onlyStrings
                              then suffix
                              else accu)
      "" $ filter (isPrefixOf ".") (tails x)

-- | Remove tails from the (Int, String) lists
stripSuffix :: String -> NameList -> NameList
stripSuffix suffix lst =
    let sflen = length suffix in
    map (\ (key, name) -> (key, take ((length name) - sflen) name)) lst

-- | Safe 'read' function returning data encapsulated in a Result
tryRead :: (Monad m, Read a) => String -> String -> m a
tryRead name s =
    let sols = readsPrec 0 s
    in case sols of
         (v, ""):[] -> return v
         (_, e):[] -> fail $ name ++ ": leftover characters when parsing '"
                      ++ s ++ "': '" ++ e ++ "'"
         _ -> fail $ name ++ ": cannot parse string '" ++ s ++ "'"

-- | Lookups a node into an assoc list
lookupNode :: (Monad m) => String -> String -> [(String, Int)] -> m Int
lookupNode node inst ktn =
    case lookup node ktn of
      Nothing -> fail $ "Unknown node '" ++ node ++ "' for instance " ++ inst
      Just idx -> return idx

-- | Load a node from a field list
loadNode :: (Monad m) => [String] -> m (String, Node.Node)
loadNode (name:tm:nm:fm:td:fd:fo:[]) = do
  new_node <-
      if any (== "?") [tm,nm,fm,td,fd] || fo == "Y" then
          return $ Node.create 0 0 0 0 0 True
      else do
        vtm <- tryRead name tm
        vnm <- tryRead name nm
        vfm <- tryRead name fm
        vtd <- tryRead name td
        vfd <- tryRead name fd
        return $ Node.create vtm vnm vfm vtd vfd False
  return (name, new_node)
loadNode s = fail $ "Invalid/incomplete node data: '" ++ (show s) ++ "'"

-- | Load an instance from a field list
loadInst :: (Monad m) =>
            [(String, Int)] -> [String] -> m (String, Instance.Instance)
loadInst ktn (name:mem:dsk:status:pnode:snode:[]) = do
  pidx <- lookupNode pnode name ktn
  sidx <- lookupNode snode name ktn
  vmem <- tryRead name mem
  vdsk <- tryRead name dsk
  when (sidx == pidx) $ fail $ "Instance " ++ name ++
           " has same primary and secondary node - " ++ pnode
  let newinst = Instance.create vmem vdsk status pidx sidx
  return (name, newinst)
loadInst _ s = fail $ "Invalid/incomplete instance data: '" ++ (show s) ++ "'"

{-| Initializer function that loads the data from a node and list file
    and massages it into the correct format. -}
loadData :: String -- ^ Node data in text format
         -> String -- ^ Instance data in text format
         -> Result (Container.Container Node.Node,
                    Container.Container Instance.Instance,
                    String, NameList, NameList)
loadData ndata idata = do
  {- node file: name t_mem n_mem f_mem t_disk f_disk -}
  (ktn, nl) <- loadTabular ndata loadNode Node.setIdx
      {- instance file: name mem disk status pnode snode -}
  (kti, il) <- loadTabular idata (loadInst ktn) Instance.setIdx
  let
      nl2 = fixNodes nl il
      il3 = Container.fromAssocList il
      nl3 = Container.fromAssocList
            (map (\ (k, v) -> (k, Node.buildPeers v il3 (length nl2))) nl2)
      xtn = swapPairs ktn
      xti = swapPairs kti
      common_suffix = longestDomain (xti ++ xtn)
      stn = stripSuffix common_suffix xtn
      sti = stripSuffix common_suffix xti
  return (nl3, il3, common_suffix, stn, sti)

-- | Compute the amount of memory used by primary instances on a node.
nodeImem :: Node.Node -> InstanceList -> Int
nodeImem node il =
    let rfind = flip Container.find $ il
    in sum . map Instance.mem .
       map rfind $ Node.plist node

-- | Compute the amount of disk used by instances on a node (either primary
-- or secondary).
nodeIdsk :: Node.Node -> InstanceList -> Int
nodeIdsk node il =
    let rfind = flip Container.find $ il
    in sum . map Instance.dsk .
       map rfind $ (Node.plist node) ++ (Node.slist node)

-- | Check cluster data for consistency
checkData :: NodeList -> InstanceList -> NameList -> NameList
          -> ([String], NodeList)
checkData nl il ktn _ =
    Container.mapAccum
        (\ msgs node ->
             let nname = fromJust $ lookup (Node.idx node) ktn
                 nilst = map (flip Container.find $ il) (Node.plist node)
                 dilst = filter (not . Instance.running) nilst
                 adj_mem = sum . map Instance.mem $ dilst
                 delta_mem = (truncate $ Node.t_mem node)
                             - (Node.n_mem node)
                             - (Node.f_mem node)
                             - (nodeImem node il)
                             + adj_mem
                 delta_dsk = (truncate $ Node.t_dsk node)
                             - (Node.f_dsk node)
                             - (nodeIdsk node il)
                 newn = Node.setFmem (Node.setXmem node delta_mem)
                        (Node.f_mem node - adj_mem)
                 umsg1 = if delta_mem > 512 || delta_dsk > 1024
                         then [printf "node %s is missing %d MB ram \
                                     \and %d GB disk"
                                     nname delta_mem (delta_dsk `div` 1024)]
                         else []
             in (msgs ++ umsg1, newn)
        ) [] nl