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