+ if fin_cv < ini_cv && (ini_cv > mg_limit || ini_cv - fin_cv >= min_gain)
+ 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@(_, _, _, nscore)) =
+ let -- 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],
+ compCV 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 evacuate a list of nodes.
+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 (`Container.find` nl) ex_ndx
+ all_insts = nub . concatMap 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 " ++
+ Instance.name (Container.find idx il)
+ ) (nl, ([], 0, [])) all_insts
+ return sol
+
+-- | Recursively place instances on the cluster until we're out of space
+iterateAlloc :: Node.List
+ -> Instance.List
+ -> Instance.Instance
+ -> Int
+ -> [Instance.Instance]
+ -> Result (FailStats, Node.List, Instance.List,
+ [Instance.Instance])
+iterateAlloc nl il newinst nreq ixes =
+ let depth = length ixes
+ newname = printf "new-%d" depth::String
+ newidx = length (Container.elems il) + depth
+ newi2 = Instance.setIdx (Instance.setName newinst newname) newidx
+ in case tryAlloc nl il newi2 nreq of
+ Bad s -> Bad s
+ Ok (errs, _, sols3) ->
+ case sols3 of
+ [] -> Ok (collapseFailures errs, nl, il, ixes)
+ (_, (xnl, xi, _, _)):[] ->
+ iterateAlloc xnl (Container.add newidx xi il)
+ newinst nreq $! (xi:ixes)
+ _ -> Bad "Internal error: multiple solutions for single\
+ \ allocation"
+
+tieredAlloc :: Node.List
+ -> Instance.List
+ -> Instance.Instance
+ -> Int
+ -> [Instance.Instance]
+ -> Result (FailStats, Node.List, Instance.List,
+ [Instance.Instance])
+tieredAlloc nl il newinst nreq ixes =
+ case iterateAlloc nl il newinst nreq ixes of
+ Bad s -> Bad s
+ Ok (errs, nl', il', ixes') ->
+ case Instance.shrinkByType newinst . fst . last $
+ sortBy (comparing snd) errs of
+ Bad _ -> Ok (errs, nl', il', ixes')
+ Ok newinst' ->
+ tieredAlloc nl' il' newinst' nreq ixes'