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