50 |
50 |
import Ganeti.HTools.Types
|
51 |
51 |
|
52 |
52 |
-- | Type alias for the result of an IAllocator call.
|
53 |
|
type IAllocResult = (String, JSValue)
|
|
53 |
type IAllocResult = (String, JSValue, Node.List)
|
54 |
54 |
|
55 |
55 |
-- | Parse the basic specifications of an instance.
|
56 |
56 |
--
|
... | ... | |
229 |
229 |
when (null elems) $ fail info
|
230 |
230 |
let sols = map (\(_, inst, nl, _) -> Instance.name inst : map Node.name nl)
|
231 |
231 |
elems
|
232 |
|
return (info, showJSON sols)
|
|
232 |
-- FIXME: head elems is certainly not correct here, since we
|
|
233 |
-- don't always concat the elems and lists in the same order;
|
|
234 |
-- however, as the old evacuate mode is deprecated, we can leave
|
|
235 |
-- it like this for the moment
|
|
236 |
(head_nl, _, _, _) = head elems
|
|
237 |
return (info, showJSON sols, head_nl)
|
233 |
238 |
|
234 |
239 |
-- | Convert allocation/relocation results into the result format.
|
235 |
240 |
formatAllocate :: Cluster.AllocSolution -> Result IAllocResult
|
... | ... | |
237 |
242 |
let info = describeSolution as
|
238 |
243 |
case Cluster.asSolutions as of
|
239 |
244 |
[] -> fail info
|
240 |
|
(_, _, nodes, _):[] -> return (info, showJSON $ map (Node.name) nodes)
|
|
245 |
(nl, _, nodes, _):[] -> return (info, showJSON $ map (Node.name) nodes, nl)
|
241 |
246 |
_ -> fail "Internal error: multiple allocation solutions"
|
242 |
247 |
|
243 |
248 |
-- | Convert a node-evacuation/change group result.
|
... | ... | |
246 |
251 |
-> Instance.List
|
247 |
252 |
-> (Node.List, Instance.List, Cluster.EvacSolution)
|
248 |
253 |
-> Result IAllocResult
|
249 |
|
formatNodeEvac gl nl il (_, _, es) =
|
|
254 |
formatNodeEvac gl nl il (fin_nl, _, es) =
|
250 |
255 |
let iname = Instance.name . flip Container.find il
|
251 |
256 |
nname = Node.name . flip Container.find nl
|
252 |
257 |
gname = Group.name . flip Container.find gl
|
... | ... | |
257 |
262 |
moved = length mes
|
258 |
263 |
info = show failed ++ " instances failed to move and " ++ show moved ++
|
259 |
264 |
" were moved successfully"
|
260 |
|
in Ok (info, showJSON (mes, fes, Cluster.esOpCodes es))
|
|
265 |
in Ok (info, showJSON (mes, fes, Cluster.esOpCodes es), fin_nl)
|
261 |
266 |
|
262 |
267 |
-- | Process a request and return new node lists
|
263 |
268 |
processRequest :: Request -> Result IAllocResult
|
... | ... | |
298 |
303 |
else return r1)
|
299 |
304 |
|
300 |
305 |
-- | Main iallocator pipeline.
|
301 |
|
runIAllocator :: Request -> String
|
|
306 |
runIAllocator :: Request -> (Maybe Node.List, String)
|
302 |
307 |
runIAllocator request =
|
303 |
|
let (ok, info, result) =
|
|
308 |
let (ok, info, result, nl) =
|
304 |
309 |
case processRequest request of
|
305 |
|
Ok (msg, r) -> (True, "Request successful: " ++ msg, r)
|
306 |
|
Bad msg -> (False, "Request failed: " ++ msg, JSArray [])
|
307 |
|
in formatResponse ok info result
|
|
310 |
Ok (msg, r, nl) -> (True, "Request successful: " ++ msg, r,
|
|
311 |
Just nl)
|
|
312 |
Bad msg -> (False, "Request failed: " ++ msg, JSArray [], Nothing)
|
|
313 |
rstring = formatResponse ok info result
|
|
314 |
in (nl, rstring)
|