Synnefo » snf-ganeti » ganeti-local

    , Solution(..)

    , Removal

    , computeSolution

    , applySolution

-- | A cluster solution described as the solution delta and the list

-- of placements.

data Solution = Solution Int [Placement]

                deriving (Eq, Ord, Show)

-- | A removal set.

data Removal = Removal Node.List [Instance.Instance]

-- | Returns the delta of a solution or -1 for Nothing.

solutionDelta :: Maybe Solution -> Int

solutionDelta sol = case sol of

                      Just (Solution d _) -> d

                      _ -> -1

-- | 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

-- * hn1 functions

-- | Add an instance and return the new node and instance maps.

addInstance :: Node.List -> Instance.Instance ->

               Node.Node -> Node.Node -> Maybe Node.List

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 :: Node.List -> Instance.Instance -> Node.List

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 :: Node.List -> [Instance.Instance] -> Node.List

removeInstances = foldl' removeInstance

{-| 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 :: Node.List -> Instance.List -> [Placement] -> Node.List

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 []

{-| 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 :: Node.List -> [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 :: Node.List

                 -> [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 :: Ndx -> Ndx -> Ndx -> 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

-- | 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 :: Node.List            -- ^ 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

{-| 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 :: Node.List        -- ^ 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