- 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)
+ if fin_cv < ini_cv
+ then Just fin_tbl -- this round made success, return the new table
+ else Nothing
+
+-- * Allocation functions
+
+-- | Build failure stats out of a list of failures
+collapseFailures :: [FailMode] -> FailStats
+collapseFailures flst =
+ map (\k -> (k, length $ filter ((==) k) flst)) [minBound..maxBound]
+
+-- | Update current Allocation solution and failure stats with new
+-- elements
+concatAllocs :: AllocSolution -> OpResult Node.AllocElement -> AllocSolution
+concatAllocs (flst, cntok, sols) (OpFail reason) = (reason:flst, cntok, sols)
+
+concatAllocs (flst, cntok, osols) (OpGood ns@(nl, _, _)) =
+ let nscore = compCV nl
+ -- Choose the old or new solution, based on the cluster score
+ nsols = case osols of
+ [] -> [(nscore, ns)]
+ (oscore, _):[] ->
+ if oscore < nscore
+ then osols
+ else [(nscore, ns)]
+ -- FIXME: here we simply concat to lists with more
+ -- than one element; we should instead abort, since
+ -- this is not a valid usage of this function
+ xs -> (nscore, ns):xs
+ nsuc = cntok + 1
+ -- Note: we force evaluation of nsols here in order to keep the
+ -- memory profile low - we know that we will need nsols for sure
+ -- in the next cycle, so we force evaluation of nsols, since the
+ -- foldl' in the caller will only evaluate the tuple, but not the
+ -- elements of the tuple
+ in nsols `seq` nsuc `seq` (flst, nsuc, nsols)
+
+-- | Try to allocate an instance on the cluster.
+tryAlloc :: (Monad m) =>
+ Node.List -- ^ The node list
+ -> Instance.List -- ^ The instance list
+ -> Instance.Instance -- ^ The instance to allocate
+ -> Int -- ^ Required number of nodes
+ -> m AllocSolution -- ^ Possible solution list
+tryAlloc nl _ inst 2 =
+ let all_nodes = getOnline nl
+ all_pairs = liftM2 (,) all_nodes all_nodes
+ ok_pairs = filter (\(x, y) -> Node.idx x /= Node.idx y) all_pairs
+ sols = foldl' (\cstate (p, s) ->
+ concatAllocs cstate $ allocateOnPair nl inst p s
+ ) ([], 0, []) ok_pairs
+ in return sols
+
+tryAlloc nl _ inst 1 =
+ let all_nodes = getOnline nl
+ sols = foldl' (\cstate ->
+ concatAllocs cstate . allocateOnSingle nl inst
+ ) ([], 0, []) all_nodes
+ in return sols
+
+tryAlloc _ _ _ reqn = fail $ "Unsupported number of allocation \
+ \destinations required (" ++ show reqn ++
+ "), only two supported"
+
+-- | Try to allocate an instance on the cluster.
+tryReloc :: (Monad m) =>
+ Node.List -- ^ The node list
+ -> Instance.List -- ^ The instance list
+ -> Idx -- ^ The index of the instance to move
+ -> Int -- ^ The number of nodes required
+ -> [Ndx] -- ^ Nodes which should not be used
+ -> m AllocSolution -- ^ Solution list
+tryReloc nl il xid 1 ex_idx =
+ let all_nodes = getOnline nl
+ inst = Container.find xid il
+ ex_idx' = Instance.pNode inst:ex_idx
+ valid_nodes = filter (not . flip elem ex_idx' . Node.idx) all_nodes
+ valid_idxes = map Node.idx valid_nodes
+ sols1 = foldl' (\cstate x ->
+ let em = do
+ (mnl, i, _, _) <-
+ applyMove nl inst (ReplaceSecondary x)
+ return (mnl, i, [Container.find x mnl])
+ in concatAllocs cstate em
+ ) ([], 0, []) valid_idxes
+ in return sols1
+
+tryReloc _ _ _ reqn _ = fail $ "Unsupported number of relocation \
+ \destinations required (" ++ show reqn ++
+ "), only one supported"
+
+-- | Try to allocate an instance on the cluster.
+tryEvac :: (Monad m) =>
+ Node.List -- ^ The node list
+ -> Instance.List -- ^ The instance list
+ -> [Ndx] -- ^ Nodes to be evacuated
+ -> m AllocSolution -- ^ Solution list
+tryEvac nl il ex_ndx =
+ let ex_nodes = map (flip Container.find nl) ex_ndx
+ all_insts = nub . concat . map Node.sList $ ex_nodes
+ in do
+ (_, sol) <- foldM (\(nl', (_, _, rsols)) idx -> do
+ -- FIXME: hardcoded one node here
+ (fm, cs, aes) <- tryReloc nl' il idx 1 ex_ndx
+ case aes of
+ csol@(_, (nl'', _, _)):_ ->
+ return (nl'', (fm, cs, csol:rsols))
+ _ -> fail $ "Can't evacuate instance " ++
+ show idx
+ ) (nl, ([], 0, [])) all_insts
+ return sol
+
+-- * Formatting functions
projects / ganeti-local / blobdiff