Revision 88df1fa9 htools/Ganeti/HTools/IAlloc.hs
b/htools/Ganeti/HTools/IAlloc.hs | ||
---|---|---|
152 | 152 |
let idata = fromJSObject ilist |
153 | 153 |
iobj <- mapM (\(x,y) -> |
154 | 154 |
asJSObject y >>= parseInstance ktn x . fromJSObject) idata |
155 |
let (_, il) = assignIndices iobj
|
|
155 |
let (kti, il) = assignIndices iobj
|
|
156 | 156 |
-- cluster tags |
157 | 157 |
ctags <- extrObj "cluster_tags" |
158 | 158 |
cdata1 <- mergeData [] [] [] [] (ClusterData gl nl il ctags) |
159 | 159 |
let (msgs, fix_nl) = checkData (cdNodes cdata1) (cdInstances cdata1) |
160 | 160 |
cdata = cdata1 { cdNodes = fix_nl } |
161 |
map_n = cdNodes cdata |
|
161 | 162 |
map_i = cdInstances cdata |
162 | 163 |
map_g = cdGroups cdata |
163 | 164 |
optype <- extrReq "type" |
... | ... | |
170 | 171 |
inew <- parseBaseInstance rname request |
171 | 172 |
let io = snd inew |
172 | 173 |
return $ Allocate io req_nodes |
174 |
| optype == C.iallocatorModeReloc -> |
|
175 |
do |
|
176 |
rname <- extrReq "name" |
|
177 |
ridx <- lookupInstance kti rname |
|
178 |
req_nodes <- extrReq "required_nodes" |
|
179 |
ex_nodes <- extrReq "relocate_from" |
|
180 |
ex_idex <- mapM (Container.findByName map_n) ex_nodes |
|
181 |
return $ Relocate ridx req_nodes (map Node.idx ex_idex) |
|
173 | 182 |
| optype == C.iallocatorModeChgGroup -> |
174 | 183 |
do |
175 | 184 |
rl_names <- extrReq "instances" |
... | ... | |
237 | 246 |
" were moved successfully" |
238 | 247 |
in Ok (info, showJSON (mes, fes, Cluster.esOpCodes es), fin_nl, fin_il) |
239 | 248 |
|
249 |
-- | Runs relocate for a single instance. |
|
250 |
-- |
|
251 |
-- This is wrapper over the 'Cluster.tryNodeEvac' function that is run |
|
252 |
-- with a single instance (ours), and further it checks that the |
|
253 |
-- result it got (in the nodes field) is actually consistent, as |
|
254 |
-- tryNodeEvac is designed to output primarily an opcode list, not a |
|
255 |
-- node list. |
|
256 |
processRelocate :: Group.List -- ^ The group list |
|
257 |
-> Node.List -- ^ The node list |
|
258 |
-> Instance.List -- ^ The instance list |
|
259 |
-> Idx -- ^ The index of the instance to move |
|
260 |
-> Int -- ^ The number of nodes required |
|
261 |
-> [Ndx] -- ^ Nodes which should not be used |
|
262 |
-> Result (Node.List, Instance.List, [Ndx]) -- ^ Solution list |
|
263 |
processRelocate gl nl il idx 1 exndx = do |
|
264 |
let orig = Container.find idx il |
|
265 |
sorig = Instance.sNode orig |
|
266 |
when (exndx /= [sorig]) $ |
|
267 |
-- FIXME: we can't use the excluded nodes here; the logic is |
|
268 |
-- already _but only partially_ implemented in tryNodeEvac... |
|
269 |
fail $ "Unsupported request: excluded nodes not equal to\ |
|
270 |
\ instance's secondary node (" ++ show sorig ++ " versus " ++ |
|
271 |
show exndx ++ ")" |
|
272 |
(nl', il', esol) <- Cluster.tryNodeEvac gl nl il ChangeSecondary [idx] |
|
273 |
nodes <- case lookup idx (Cluster.esFailed esol) of |
|
274 |
Just msg -> fail msg |
|
275 |
Nothing -> |
|
276 |
case lookup idx (map (\(a, _, b) -> (a, b)) |
|
277 |
(Cluster.esMoved esol)) of |
|
278 |
Nothing -> |
|
279 |
fail "Internal error: lost instance idx during move" |
|
280 |
Just n -> return n |
|
281 |
let inst = Container.find idx il' |
|
282 |
pnode = Instance.pNode inst |
|
283 |
snode = Instance.sNode inst |
|
284 |
when (snode == sorig) $ |
|
285 |
fail "Internal error: instance didn't change secondary node?!" |
|
286 |
|
|
287 |
nodes' <- if (nodes == [pnode, snode]) |
|
288 |
then return [snode] -- only the new secondary is needed |
|
289 |
else fail $ "Internal error: inconsistent node list (" ++ |
|
290 |
show nodes ++ ") versus instance nodes (" ++ show pnode ++ |
|
291 |
"," ++ show snode ++ ")" |
|
292 |
return (nl', il', nodes') |
|
293 |
|
|
294 |
processRelocate _ _ _ _ reqn _ = |
|
295 |
fail $ "Exchange " ++ show reqn ++ " nodes mode is not implemented" |
|
296 |
|
|
297 |
formatRelocate :: (Node.List, Instance.List, [Ndx]) |
|
298 |
-> Result IAllocResult |
|
299 |
formatRelocate (nl, il, ndxs) = |
|
300 |
let nodes = map (`Container.find` nl) ndxs |
|
301 |
names = map Node.name nodes |
|
302 |
in Ok ("success", showJSON names, nl, il) |
|
303 |
|
|
240 | 304 |
-- | Process a request and return new node lists. |
241 | 305 |
processRequest :: Request -> Result IAllocResult |
242 | 306 |
processRequest request = |
... | ... | |
244 | 308 |
in case rqtype of |
245 | 309 |
Allocate xi reqn -> |
246 | 310 |
Cluster.tryMGAlloc gl nl il xi reqn >>= formatAllocate il |
311 |
Relocate idx reqn exnodes -> |
|
312 |
processRelocate gl nl il idx reqn exnodes >>= formatRelocate |
|
247 | 313 |
ChangeGroup gdxs idxs -> |
248 | 314 |
Cluster.tryChangeGroup gl nl il idxs gdxs >>= |
249 | 315 |
formatNodeEvac gl nl il |
Also available in: Unified diff