Revision 57f07ff2 htools/Ganeti/HTools/IAlloc.hs
b/htools/Ganeti/HTools/IAlloc.hs | ||
---|---|---|
124 | 124 |
apol <- extract "alloc_policy" |
125 | 125 |
return (u, Group.create name u apol) |
126 | 126 |
|
127 |
parseTargetGroups :: JSRecord -- ^ The JSON object (request dict) |
|
128 |
-> Group.List -- ^ The existing groups |
|
129 |
-> Result [Gdx] |
|
130 |
parseTargetGroups req map_g = do |
|
131 |
group_uuids <- fromObjWithDefault req "target_groups" [] |
|
132 |
mapM (liftM Group.idx . Container.findByName map_g) group_uuids |
|
133 |
|
|
134 | 127 |
-- | Top-level parser. |
135 | 128 |
parseData :: String -- ^ The JSON message as received from Ganeti |
136 | 129 |
-> Result Request -- ^ A (possible valid) request |
... | ... | |
186 | 179 |
ex_nodes <- mapM (Container.findByName map_n) ex_names |
187 | 180 |
let ex_ndx = map Node.idx ex_nodes |
188 | 181 |
return $ Evacuate ex_ndx |
189 |
| optype == C.iallocatorModeMreloc ->
|
|
182 |
| optype == C.iallocatorModeChgGroup ->
|
|
190 | 183 |
do |
191 | 184 |
rl_names <- extrReq "instances" |
192 |
rl_insts <- mapM (Container.findByName map_i) rl_names |
|
193 |
let rl_idx = map Instance.idx rl_insts |
|
194 |
rl_mode <- |
|
195 |
case extrReq "reloc_mode" of |
|
196 |
Ok s | s == C.iallocatorMrelocKeep -> return KeepGroup |
|
197 |
| s == C.iallocatorMrelocChange -> |
|
198 |
do |
|
199 |
tg_groups <- parseTargetGroups request map_g |
|
200 |
return $ ChangeGroup tg_groups |
|
201 |
| s == C.iallocatorMrelocAny -> return AnyGroup |
|
202 |
| otherwise -> Bad $ "Invalid relocate mode " ++ s |
|
203 |
Bad x -> Bad x |
|
204 |
return $ MultiReloc rl_idx rl_mode |
|
185 |
rl_insts <- mapM (liftM Instance.idx . |
|
186 |
Container.findByName map_i) rl_names |
|
187 |
gr_uuids <- extrReq "target_groups" |
|
188 |
gr_idxes <- mapM (liftM Group.idx . |
|
189 |
Container.findByName map_g) gr_uuids |
|
190 |
return $ ChangeGroup rl_insts gr_idxes |
|
205 | 191 |
| optype == C.iallocatorModeNodeEvac -> |
206 | 192 |
do |
207 | 193 |
rl_names <- extrReq "instances" |
... | ... | |
276 | 262 |
Cluster.tryMGReloc gl nl il idx reqn exnodes >>= formatAllocate |
277 | 263 |
Evacuate exnodes -> |
278 | 264 |
Cluster.tryMGEvac gl nl il exnodes >>= formatEvacuate |
279 |
MultiReloc _ _ -> fail "multi-reloc not handled"
|
|
265 |
ChangeGroup _ _ -> fail "Request 'change-group' not implemented"
|
|
280 | 266 |
NodeEvacuate xi mode -> |
281 | 267 |
Cluster.tryNodeEvac gl nl il mode xi >>= formatNodeEvac |
282 | 268 |
|
Also available in: Unified diff