Revision 7c14b50a htools/Ganeti/HTools/IAlloc.hs
b/htools/Ganeti/HTools/IAlloc.hs | ||
---|---|---|
50 | 50 |
import Ganeti.HTools.Utils |
51 | 51 |
import Ganeti.HTools.Types |
52 | 52 |
|
53 |
-- | Type alias for the result of an IAllocator call. |
|
54 |
type IAllocResult = (String, JSValue) |
|
55 |
|
|
53 | 56 |
-- | Parse the basic specifications of an instance. |
54 | 57 |
-- |
55 | 58 |
-- Instances in the cluster instance list and the instance in an |
... | ... | |
216 | 219 |
| otherwise -> fail ("Invalid request type '" ++ optype ++ "'") |
217 | 220 |
return $ Request rqtype cdata |
218 | 221 |
|
219 |
-- | Format the result |
|
220 |
formatRVal :: RqType -> [Node.AllocElement] -> JSValue |
|
221 |
formatRVal _ [] = JSArray [] |
|
222 |
|
|
223 |
formatRVal (Evacuate _) elems = |
|
224 |
let sols = map (\(_, inst, nl, _) -> Instance.name inst : map Node.name nl) |
|
225 |
elems |
|
226 |
jsols = map (JSArray . map (JSString . toJSString)) sols |
|
227 |
in JSArray jsols |
|
228 |
|
|
229 |
formatRVal _ elems = |
|
230 |
let (_, _, nodes, _) = head elems |
|
231 |
nodes' = map Node.name nodes |
|
232 |
in JSArray $ map (JSString . toJSString) nodes' |
|
233 |
|
|
234 | 222 |
-- | Formats the result into a valid IAllocator response message. |
235 | 223 |
formatResponse :: Bool -- ^ Whether the request was successful |
236 | 224 |
-> String -- ^ Information text |
... | ... | |
243 | 231 |
e_result = ("result", result) |
244 | 232 |
in encodeStrict $ makeObj [e_success, e_info, e_result] |
245 | 233 |
|
246 |
processResults :: (Monad m) => |
|
247 |
RqType -> Cluster.AllocSolution |
|
248 |
-> m Cluster.AllocSolution |
|
249 |
processResults _ (Cluster.AllocSolution { Cluster.asSolutions = [], |
|
250 |
Cluster.asLog = msgs }) = |
|
251 |
fail $ intercalate ", " msgs |
|
234 |
-- | Flatten the log of a solution into a string. |
|
235 |
describeSolution :: Cluster.AllocSolution -> String |
|
236 |
describeSolution = intercalate ", " . Cluster.asLog |
|
252 | 237 |
|
253 |
processResults (Evacuate _) as = return as |
|
238 |
-- | Convert evacuation results into the result format. |
|
239 |
formatEvacuate :: Cluster.AllocSolution -> Result IAllocResult |
|
240 |
formatEvacuate as = do |
|
241 |
let info = describeSolution as |
|
242 |
elems = Cluster.asSolutions as |
|
243 |
when (null elems) $ fail info |
|
244 |
let sols = map (\(_, inst, nl, _) -> Instance.name inst : map Node.name nl) |
|
245 |
elems |
|
246 |
jsols = map (JSArray . map (JSString . toJSString)) sols |
|
247 |
return (info, JSArray jsols) |
|
254 | 248 |
|
255 |
processResults _ as = |
|
256 |
case Cluster.asSolutions as of |
|
257 |
_:[] -> return as |
|
258 |
_ -> fail "Internal error: multiple allocation solutions" |
|
249 |
-- | Convert allocation/relocation results into the result format. |
|
250 |
formatAllocate :: Cluster.AllocSolution -> Result IAllocResult |
|
251 |
formatAllocate as = do |
|
252 |
let info = describeSolution as |
|
253 |
case Cluster.asSolutions as of |
|
254 |
[] -> fail info |
|
255 |
(_, _, nodes, _):[] -> do |
|
256 |
let nodes' = map Node.name nodes |
|
257 |
return (info, JSArray $ map (JSString . toJSString) nodes') |
|
258 |
_ -> fail "Internal error: multiple allocation solutions" |
|
259 | 259 |
|
260 | 260 |
-- | Process a request and return new node lists |
261 |
processRequest :: Request |
|
262 |
-> Result Cluster.AllocSolution |
|
261 |
processRequest :: Request -> Result IAllocResult |
|
263 | 262 |
processRequest request = |
264 | 263 |
let Request rqtype (ClusterData gl nl il _) = request |
265 | 264 |
in case rqtype of |
266 |
Allocate xi reqn -> Cluster.tryMGAlloc gl nl il xi reqn |
|
267 |
Relocate idx reqn exnodes -> Cluster.tryMGReloc gl nl il |
|
268 |
idx reqn exnodes |
|
269 |
Evacuate exnodes -> Cluster.tryMGEvac gl nl il exnodes |
|
265 |
Allocate xi reqn -> |
|
266 |
Cluster.tryMGAlloc gl nl il xi reqn >>= formatAllocate |
|
267 |
Relocate idx reqn exnodes -> |
|
268 |
Cluster.tryMGReloc gl nl il idx reqn exnodes >>= formatAllocate |
|
269 |
Evacuate exnodes -> |
|
270 |
Cluster.tryMGEvac gl nl il exnodes >>= formatEvacuate |
|
270 | 271 |
MultiReloc _ _ -> fail "multi-reloc not handled" |
271 | 272 |
NodeEvacuate _ _ -> fail "node-evacuate not handled" |
272 | 273 |
|
... | ... | |
293 | 294 |
-- | Main iallocator pipeline. |
294 | 295 |
runIAllocator :: Request -> String |
295 | 296 |
runIAllocator request = |
296 |
let Request rq _ = request |
|
297 |
sols = processRequest request >>= processResults rq |
|
298 |
(ok, info, rn) = |
|
299 |
case sols of |
|
300 |
Ok as -> (True, "Request successful: " ++ |
|
301 |
intercalate ", " (Cluster.asLog as), |
|
302 |
Cluster.asSolutions as) |
|
303 |
Bad s -> (False, "Request failed: " ++ s, []) |
|
304 |
result = formatRVal rq rn |
|
305 |
resp = formatResponse ok info result |
|
306 |
in resp |
|
297 |
let (ok, info, result) = |
|
298 |
case processRequest request of |
|
299 |
Ok (msg, r) -> (True, "Request successful: " ++ msg, r) |
|
300 |
Bad msg -> (False, "Request failed: " ++ msg, JSArray []) |
|
301 |
in formatResponse ok info result |
Also available in: Unified diff