Revision 3e4480e0 Ganeti/HTools/IAlloc.hs
| b/Ganeti/HTools/IAlloc.hs | ||
|---|---|---|
| 113 | 113 |
let (kti, il) = assignIndices iobj |
| 114 | 114 |
-- cluster tags |
| 115 | 115 |
ctags <- fromObj "cluster_tags" obj |
| 116 |
(map_n, map_i, ptags, csf) <- mergeData [] [] [] (nl, il, ctags)
|
|
| 116 |
(map_n, map_i, ptags) <- mergeData [] [] [] (nl, il, ctags) |
|
| 117 | 117 |
optype <- fromObj "type" request |
| 118 | 118 |
rqtype <- |
| 119 | 119 |
case optype of |
| ... | ... | |
| 130 | 130 |
ridx <- lookupInstance kti rname |
| 131 | 131 |
req_nodes <- fromObj "required_nodes" request |
| 132 | 132 |
ex_nodes <- fromObj "relocate_from" request |
| 133 |
let ex_nodes' = map (stripSuffix $ length csf) ex_nodes |
|
| 134 |
ex_idex <- mapM (Container.findByName map_n) ex_nodes' |
|
| 133 |
ex_idex <- mapM (Container.findByName map_n) ex_nodes |
|
| 135 | 134 |
return $ Relocate ridx req_nodes (map Node.idx ex_idex) |
| 136 | 135 |
"multi-evacuate" -> |
| 137 | 136 |
do |
| 138 | 137 |
ex_names <- fromObj "evac_nodes" request |
| 139 |
let ex_names' = map (stripSuffix $ length csf) ex_names |
|
| 140 |
ex_nodes <- mapM (Container.findByName map_n) ex_names' |
|
| 138 |
ex_nodes <- mapM (Container.findByName map_n) ex_names |
|
| 141 | 139 |
let ex_ndx = map Node.idx ex_nodes |
| 142 | 140 |
return $ Evacuate ex_ndx |
| 143 | 141 |
other -> fail ("Invalid request type '" ++ other ++ "'")
|
| 144 |
return $ Request rqtype map_n map_i ptags csf
|
|
| 142 |
return $ Request rqtype map_n map_i ptags |
|
| 145 | 143 |
|
| 146 | 144 |
-- | Format the result |
| 147 |
formatRVal :: String -> RqType -> [Node.AllocElement] -> JSValue
|
|
| 148 |
formatRVal _ _ [] = JSArray []
|
|
| 145 |
formatRVal :: RqType -> [Node.AllocElement] -> JSValue |
|
| 146 |
formatRVal _ [] = JSArray [] |
|
| 149 | 147 |
|
| 150 |
formatRVal csf (Evacuate _) elems = |
|
| 151 |
let sols = map (\(_, inst, nl) -> |
|
| 152 |
let names = Instance.name inst : map Node.name nl |
|
| 153 |
in map (++ csf) names) elems |
|
| 148 |
formatRVal (Evacuate _) elems = |
|
| 149 |
let sols = map (\(_, inst, nl) -> Instance.name inst : map Node.name nl) |
|
| 150 |
elems |
|
| 154 | 151 |
jsols = map (JSArray . map (JSString . toJSString)) sols |
| 155 | 152 |
in JSArray jsols |
| 156 | 153 |
|
| 157 |
formatRVal csf _ elems =
|
|
| 154 |
formatRVal _ elems = |
|
| 158 | 155 |
let (_, _, nodes) = head elems |
| 159 |
nodes' = map ((++ csf) . Node.name) nodes
|
|
| 156 |
nodes' = map Node.name nodes
|
|
| 160 | 157 |
in JSArray $ map (JSString . toJSString) nodes' |
| 161 | 158 |
|
| 162 | 159 |
-- | Formats the response into a valid IAllocator response message. |
| 163 | 160 |
formatResponse :: Bool -- ^ Whether the request was successful |
| 164 | 161 |
-> String -- ^ Information text |
| 165 |
-> String -- ^ Suffix for nodes and instances |
|
| 166 | 162 |
-> RqType -- ^ Request type |
| 167 | 163 |
-> [Node.AllocElement] -- ^ The resulting allocations |
| 168 | 164 |
-> String -- ^ The JSON-formatted message |
| 169 |
formatResponse success info csf rq elems =
|
|
| 165 |
formatResponse success info rq elems = |
|
| 170 | 166 |
let |
| 171 | 167 |
e_success = ("success", JSBool success)
|
| 172 | 168 |
e_info = ("info", JSString . toJSString $ info)
|
| 173 |
e_nodes = ("nodes", formatRVal csf rq elems)
|
|
| 169 |
e_nodes = ("nodes", formatRVal rq elems)
|
|
| 174 | 170 |
in encodeStrict $ makeObj [e_success, e_info, e_nodes] |
Also available in: Unified diff