Revision 695c1bab htools/Ganeti/HTools/IAlloc.hs
| b/htools/Ganeti/HTools/IAlloc.hs | ||
|---|---|---|
| 114 | 114 |
apol <- extract "alloc_policy" |
| 115 | 115 |
return (u, Group.create name u apol) |
| 116 | 116 |
|
| 117 |
parseTargetGroups :: [(String, JSValue)] -- ^ The JSON object (request dict) |
|
| 118 |
-> Group.List -- ^ The existing groups |
|
| 119 |
-> Result [Gdx] |
|
| 120 |
parseTargetGroups req map_g = do |
|
| 121 |
group_uuids <- fromObjWithDefault req "target_groups" [] |
|
| 122 |
mapM (liftM Group.idx . Container.findByName map_g) group_uuids |
|
| 123 |
|
|
| 117 | 124 |
-- | Top-level parser. |
| 118 | 125 |
parseData :: String -- ^ The JSON message as received from Ganeti |
| 119 | 126 |
-> Result Request -- ^ A (possible valid) request |
| ... | ... | |
| 143 | 150 |
ctags <- extrObj "cluster_tags" |
| 144 | 151 |
cdata <- mergeData [] [] [] (ClusterData gl nl il ctags) |
| 145 | 152 |
let map_n = cdNodes cdata |
| 153 |
map_i = cdInstances cdata |
|
| 154 |
map_g = cdGroups cdata |
|
| 146 | 155 |
optype <- extrReq "type" |
| 147 | 156 |
rqtype <- |
| 148 | 157 |
case () of |
| ... | ... | |
| 167 | 176 |
ex_nodes <- mapM (Container.findByName map_n) ex_names |
| 168 | 177 |
let ex_ndx = map Node.idx ex_nodes |
| 169 | 178 |
return $ Evacuate ex_ndx |
| 179 |
| optype == C.iallocatorModeMreloc -> |
|
| 180 |
do |
|
| 181 |
rl_names <- extrReq "instances" |
|
| 182 |
rl_insts <- mapM (Container.findByName map_i) rl_names |
|
| 183 |
let rl_idx = map Instance.idx rl_insts |
|
| 184 |
rl_mode <- do |
|
| 185 |
case extrReq "reloc_mode" of |
|
| 186 |
Ok s | s == C.iallocatorMrelocKeep -> return KeepGroup |
|
| 187 |
| s == C.iallocatorMrelocChange -> |
|
| 188 |
do |
|
| 189 |
tg_groups <- parseTargetGroups request map_g |
|
| 190 |
return $ ChangeGroup tg_groups |
|
| 191 |
| s == C.iallocatorMrelocAny -> return AnyGroup |
|
| 192 |
| otherwise -> Bad $ "Invalid relocate mode " ++ s |
|
| 193 |
Bad x -> Bad x |
|
| 194 |
return $ MultiReloc rl_idx rl_mode |
|
| 195 |
|
|
| 170 | 196 |
| otherwise -> fail ("Invalid request type '" ++ optype ++ "'")
|
| 171 | 197 |
return $ Request rqtype cdata |
| 172 | 198 |
|
Also available in: Unified diff