| 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)
|