Revision 695c1bab

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