Revision f9283686 htools/Ganeti/HTools/IAlloc.hs
b/htools/Ganeti/HTools/IAlloc.hs | ||
---|---|---|
50 | 50 |
import Ganeti.HTools.Types |
51 | 51 |
|
52 | 52 |
-- | Type alias for the result of an IAllocator call. |
53 |
type IAllocResult = (String, JSValue, Node.List) |
|
53 |
type IAllocResult = (String, JSValue, Node.List, Instance.List)
|
|
54 | 54 |
|
55 | 55 |
-- | Parse the basic specifications of an instance. |
56 | 56 |
-- |
... | ... | |
222 | 222 |
describeSolution = intercalate ", " . Cluster.asLog |
223 | 223 |
|
224 | 224 |
-- | Convert evacuation results into the result format. |
225 |
formatEvacuate :: Cluster.AllocSolution -> Result IAllocResult |
|
226 |
formatEvacuate as = do |
|
225 |
formatEvacuate :: Instance.List -> Cluster.AllocSolution -> Result IAllocResult
|
|
226 |
formatEvacuate il as = do
|
|
227 | 227 |
let info = describeSolution as |
228 | 228 |
elems = Cluster.asSolutions as |
229 | 229 |
when (null elems) $ fail info |
... | ... | |
234 | 234 |
-- however, as the old evacuate mode is deprecated, we can leave |
235 | 235 |
-- it like this for the moment |
236 | 236 |
(head_nl, _, _, _) = head elems |
237 |
return (info, showJSON sols, head_nl) |
|
237 |
il' = foldl' (\ilist (_, inst, _, _) -> |
|
238 |
Container.add (Instance.idx inst) inst ilist) |
|
239 |
il elems |
|
240 |
return (info, showJSON sols, head_nl, il') |
|
238 | 241 |
|
239 | 242 |
-- | Convert allocation/relocation results into the result format. |
240 |
formatAllocate :: Cluster.AllocSolution -> Result IAllocResult |
|
241 |
formatAllocate as = do |
|
243 |
formatAllocate :: Instance.List -> Cluster.AllocSolution -> Result IAllocResult
|
|
244 |
formatAllocate il as = do
|
|
242 | 245 |
let info = describeSolution as |
243 | 246 |
case Cluster.asSolutions as of |
244 | 247 |
[] -> fail info |
245 |
(nl, _, nodes, _):[] -> return (info, showJSON $ map (Node.name) nodes, nl) |
|
248 |
(nl, inst, nodes, _):[] -> |
|
249 |
do |
|
250 |
let il' = Container.add (Instance.idx inst) inst il |
|
251 |
return (info, showJSON $ map (Node.name) nodes, nl, il') |
|
246 | 252 |
_ -> fail "Internal error: multiple allocation solutions" |
247 | 253 |
|
248 | 254 |
-- | Convert a node-evacuation/change group result. |
... | ... | |
251 | 257 |
-> Instance.List |
252 | 258 |
-> (Node.List, Instance.List, Cluster.EvacSolution) |
253 | 259 |
-> Result IAllocResult |
254 |
formatNodeEvac gl nl il (fin_nl, _, es) =
|
|
260 |
formatNodeEvac gl nl il (fin_nl, fin_il, es) =
|
|
255 | 261 |
let iname = Instance.name . flip Container.find il |
256 | 262 |
nname = Node.name . flip Container.find nl |
257 | 263 |
gname = Group.name . flip Container.find gl |
... | ... | |
262 | 268 |
moved = length mes |
263 | 269 |
info = show failed ++ " instances failed to move and " ++ show moved ++ |
264 | 270 |
" were moved successfully" |
265 |
in Ok (info, showJSON (mes, fes, Cluster.esOpCodes es), fin_nl) |
|
271 |
in Ok (info, showJSON (mes, fes, Cluster.esOpCodes es), fin_nl, fin_il)
|
|
266 | 272 |
|
267 | 273 |
-- | Process a request and return new node lists |
268 | 274 |
processRequest :: Request -> Result IAllocResult |
... | ... | |
270 | 276 |
let Request rqtype (ClusterData gl nl il _) = request |
271 | 277 |
in case rqtype of |
272 | 278 |
Allocate xi reqn -> |
273 |
Cluster.tryMGAlloc gl nl il xi reqn >>= formatAllocate |
|
279 |
Cluster.tryMGAlloc gl nl il xi reqn >>= formatAllocate il
|
|
274 | 280 |
Relocate idx reqn exnodes -> |
275 |
Cluster.tryMGReloc gl nl il idx reqn exnodes >>= formatAllocate |
|
281 |
Cluster.tryMGReloc gl nl il idx reqn exnodes >>= formatAllocate il
|
|
276 | 282 |
Evacuate exnodes -> |
277 |
Cluster.tryMGEvac gl nl il exnodes >>= formatEvacuate |
|
283 |
Cluster.tryMGEvac gl nl il exnodes >>= formatEvacuate il
|
|
278 | 284 |
ChangeGroup gdxs idxs -> |
279 | 285 |
Cluster.tryChangeGroup gl nl il idxs gdxs >>= |
280 | 286 |
formatNodeEvac gl nl il |
... | ... | |
303 | 309 |
else return r1) |
304 | 310 |
|
305 | 311 |
-- | Main iallocator pipeline. |
306 |
runIAllocator :: Request -> (Maybe Node.List, String)
|
|
312 |
runIAllocator :: Request -> (Maybe (Node.List, Instance.List), String)
|
|
307 | 313 |
runIAllocator request = |
308 |
let (ok, info, result, nl) =
|
|
314 |
let (ok, info, result, cdata) =
|
|
309 | 315 |
case processRequest request of |
310 |
Ok (msg, r, nl) -> (True, "Request successful: " ++ msg, r, |
|
311 |
Just nl)
|
|
316 |
Ok (msg, r, nl, il) -> (True, "Request successful: " ++ msg, r,
|
|
317 |
Just (nl, il))
|
|
312 | 318 |
Bad msg -> (False, "Request failed: " ++ msg, JSArray [], Nothing) |
313 | 319 |
rstring = formatResponse ok info result |
314 |
in (nl, rstring) |
|
320 |
in (cdata, rstring) |
Also available in: Unified diff