+-- | 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', old_as) idx -> do
+ -- FIXME: hardcoded one node here
+ -- (fm, cs, aes)
+ new_as <- tryReloc nl' il idx 1 ex_ndx
+ case asSolutions new_as of
+ csol@(nl'', _, _, _):_ ->
+ -- an individual relocation succeeded,
+ -- we kind of compose the data from
+ -- the two solutions
+ return (nl'',
+ new_as { asSolutions =
+ csol:asSolutions old_as })
+ -- this relocation failed, so we fail
+ -- the entire evac
+ _ -> fail $ "Can't evacuate instance " ++
+ Instance.name (Container.find idx il)
+ ) (nl, emptySolution) 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 (AllocSolution { asFailures = errs, asSolutions = 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'
+