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