1 {-| Implementation of the iallocator interface.
7 Copyright (C) 2009, 2010, 2011 Google Inc.
9 This program is free software; you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation; either version 2 of the License, or
12 (at your option) any later version.
14 This program is distributed in the hope that it will be useful, but
15 WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17 General Public License for more details.
19 You should have received a copy of the GNU General Public License
20 along with this program; if not, write to the Free Software
21 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
26 module Ganeti.HTools.IAlloc
32 import Data.Maybe (fromMaybe, isJust)
35 import Text.JSON (JSObject, JSValue(JSArray),
36 makeObj, encodeStrict, decodeStrict, fromJSObject, showJSON)
37 import System (exitWith, ExitCode(..))
40 import qualified Ganeti.HTools.Cluster as Cluster
41 import qualified Ganeti.HTools.Container as Container
42 import qualified Ganeti.HTools.Group as Group
43 import qualified Ganeti.HTools.Node as Node
44 import qualified Ganeti.HTools.Instance as Instance
45 import qualified Ganeti.Constants as C
46 import Ganeti.HTools.CLI
47 import Ganeti.HTools.Loader
48 import Ganeti.HTools.ExtLoader (loadExternalData)
49 import Ganeti.HTools.Utils
50 import Ganeti.HTools.Types
52 -- | Type alias for the result of an IAllocator call.
53 type IAllocResult = (String, JSValue)
55 -- | Parse the basic specifications of an instance.
57 -- Instances in the cluster instance list and the instance in an
58 -- 'Allocate' request share some common properties, which are read by
60 parseBaseInstance :: String
62 -> Result (String, Instance.Instance)
63 parseBaseInstance n a = do
64 let extract x = tryFromObj ("invalid data for instance '" ++ n ++ "'") a x
65 disk <- extract "disk_space_total"
66 mem <- extract "memory"
67 vcpus <- extract "vcpus"
68 tags <- extract "tags"
69 let running = "running"
70 return (n, Instance.create n mem disk vcpus running tags True 0 0 DTDrbd8)
72 -- | Parses an instance as found in the cluster instance list.
73 parseInstance :: NameAssoc -- ^ The node name-to-index association list
74 -> String -- ^ The name of the instance
75 -> JSRecord -- ^ The JSON object
76 -> Result (String, Instance.Instance)
77 parseInstance ktn n a = do
78 base <- parseBaseInstance n a
79 nodes <- fromObj a "nodes"
80 pnode <- if null nodes
81 then Bad $ "empty node list for instance " ++ n
82 else readEitherString $ head nodes
83 pidx <- lookupNode ktn n pnode
84 let snodes = tail nodes
85 sidx <- (if null snodes then return Node.noSecondary
86 else readEitherString (head snodes) >>= lookupNode ktn n)
87 return (n, Instance.setBoth (snd base) pidx sidx)
89 -- | Parses a node as found in the cluster node list.
90 parseNode :: NameAssoc -- ^ The group association
91 -> String -- ^ The node's name
92 -> JSRecord -- ^ The JSON object
93 -> Result (String, Node.Node)
94 parseNode ktg n a = do
95 let desc = "invalid data for node '" ++ n ++ "'"
96 extract x = tryFromObj desc a x
97 offline <- extract "offline"
98 drained <- extract "drained"
99 guuid <- extract "group"
100 vm_capable <- annotateResult desc $ maybeFromObj a "vm_capable"
101 let vm_capable' = fromMaybe True vm_capable
102 gidx <- lookupGroup ktg n guuid
103 node <- (if offline || drained || not vm_capable'
104 then return $ Node.create n 0 0 0 0 0 0 True gidx
106 mtotal <- extract "total_memory"
107 mnode <- extract "reserved_memory"
108 mfree <- extract "free_memory"
109 dtotal <- extract "total_disk"
110 dfree <- extract "free_disk"
111 ctotal <- extract "total_cpus"
112 return $ Node.create n mtotal mnode mfree
113 dtotal dfree ctotal False gidx)
116 -- | Parses a group as found in the cluster group list.
117 parseGroup :: String -- ^ The group UUID
118 -> JSRecord -- ^ The JSON object
119 -> Result (String, Group.Group)
121 let extract x = tryFromObj ("invalid data for group '" ++ u ++ "'") a x
122 name <- extract "name"
123 apol <- extract "alloc_policy"
124 return (u, Group.create name u apol)
126 parseTargetGroups :: JSRecord -- ^ The JSON object (request dict)
127 -> Group.List -- ^ The existing groups
129 parseTargetGroups req map_g = do
130 group_uuids <- fromObjWithDefault req "target_groups" []
131 mapM (liftM Group.idx . Container.findByName map_g) group_uuids
133 -- | Top-level parser.
134 parseData :: String -- ^ The JSON message as received from Ganeti
135 -> Result Request -- ^ A (possible valid) request
137 decoded <- fromJResult "Parsing input IAllocator message" (decodeStrict body)
138 let obj = fromJSObject decoded
139 extrObj x = tryFromObj "invalid iallocator message" obj x
141 request <- liftM fromJSObject (extrObj "request")
142 let extrReq x = tryFromObj "invalid request dict" request x
143 -- existing group parsing
144 glist <- liftM fromJSObject (extrObj "nodegroups")
145 gobj <- mapM (\(x, y) -> asJSObject y >>= parseGroup x . fromJSObject) glist
146 let (ktg, gl) = assignIndices gobj
147 -- existing node parsing
148 nlist <- liftM fromJSObject (extrObj "nodes")
149 nobj <- mapM (\(x,y) ->
150 asJSObject y >>= parseNode ktg x . fromJSObject) nlist
151 let (ktn, nl) = assignIndices nobj
152 -- existing instance parsing
153 ilist <- extrObj "instances"
154 let idata = fromJSObject ilist
155 iobj <- mapM (\(x,y) ->
156 asJSObject y >>= parseInstance ktn x . fromJSObject) idata
157 let (kti, il) = assignIndices iobj
159 ctags <- extrObj "cluster_tags"
160 cdata <- mergeData [] [] [] [] (ClusterData gl nl il ctags)
161 let map_n = cdNodes cdata
162 map_i = cdInstances cdata
163 map_g = cdGroups cdata
164 optype <- extrReq "type"
167 _ | optype == C.iallocatorModeAlloc ->
169 rname <- extrReq "name"
170 req_nodes <- extrReq "required_nodes"
171 inew <- parseBaseInstance rname request
173 return $ Allocate io req_nodes
174 | optype == C.iallocatorModeReloc ->
176 rname <- extrReq "name"
177 ridx <- lookupInstance kti rname
178 req_nodes <- extrReq "required_nodes"
179 ex_nodes <- extrReq "relocate_from"
180 ex_idex <- mapM (Container.findByName map_n) ex_nodes
181 return $ Relocate ridx req_nodes (map Node.idx ex_idex)
182 | optype == C.iallocatorModeMevac ->
184 ex_names <- extrReq "evac_nodes"
185 ex_nodes <- mapM (Container.findByName map_n) ex_names
186 let ex_ndx = map Node.idx ex_nodes
187 return $ Evacuate ex_ndx
188 | optype == C.iallocatorModeMreloc ->
190 rl_names <- extrReq "instances"
191 rl_insts <- mapM (Container.findByName map_i) rl_names
192 let rl_idx = map Instance.idx rl_insts
194 case extrReq "reloc_mode" of
195 Ok s | s == C.iallocatorMrelocKeep -> return KeepGroup
196 | s == C.iallocatorMrelocChange ->
198 tg_groups <- parseTargetGroups request map_g
199 return $ ChangeGroup tg_groups
200 | s == C.iallocatorMrelocAny -> return AnyGroup
201 | otherwise -> Bad $ "Invalid relocate mode " ++ s
203 return $ MultiReloc rl_idx rl_mode
204 | optype == C.iallocatorModeNodeEvac ->
206 rl_names <- extrReq "instances"
207 rl_insts <- mapM (Container.findByName map_i) rl_names
208 let rl_idx = map Instance.idx rl_insts
210 case extrReq "evac_mode" of
211 Ok s | s == C.iallocatorNevacAll -> return ChangeAll
212 | s == C.iallocatorNevacPri -> return ChangePrimary
213 | s == C.iallocatorNevacSec -> return ChangeSecondary
214 | otherwise -> Bad $ "Invalid evacuate mode " ++ s
216 return $ NodeEvacuate rl_idx rl_mode
218 | otherwise -> fail ("Invalid request type '" ++ optype ++ "'")
219 return $ Request rqtype cdata
221 -- | Formats the result into a valid IAllocator response message.
222 formatResponse :: Bool -- ^ Whether the request was successful
223 -> String -- ^ Information text
224 -> JSValue -- ^ The JSON encoded result
225 -> String -- ^ The full JSON-formatted message
226 formatResponse success info result =
228 e_success = ("success", showJSON success)
229 e_info = ("info", showJSON info)
230 e_result = ("result", result)
231 in encodeStrict $ makeObj [e_success, e_info, e_result]
233 -- | Flatten the log of a solution into a string.
234 describeSolution :: Cluster.AllocSolution -> String
235 describeSolution = intercalate ", " . Cluster.asLog
237 -- | Convert evacuation results into the result format.
238 formatEvacuate :: Cluster.AllocSolution -> Result IAllocResult
239 formatEvacuate as = do
240 let info = describeSolution as
241 elems = Cluster.asSolutions as
242 when (null elems) $ fail info
243 let sols = map (\(_, inst, nl, _) -> Instance.name inst : map Node.name nl)
245 return (info, showJSON sols)
247 -- | Convert allocation/relocation results into the result format.
248 formatAllocate :: Cluster.AllocSolution -> Result IAllocResult
249 formatAllocate as = do
250 let info = describeSolution as
251 case Cluster.asSolutions as of
253 (_, _, nodes, _):[] -> return (info, showJSON $ map (Node.name) nodes)
254 _ -> fail "Internal error: multiple allocation solutions"
256 -- | Process a request and return new node lists
257 processRequest :: Request -> Result IAllocResult
258 processRequest request =
259 let Request rqtype (ClusterData gl nl il _) = request
262 Cluster.tryMGAlloc gl nl il xi reqn >>= formatAllocate
263 Relocate idx reqn exnodes ->
264 Cluster.tryMGReloc gl nl il idx reqn exnodes >>= formatAllocate
266 Cluster.tryMGEvac gl nl il exnodes >>= formatEvacuate
267 MultiReloc _ _ -> fail "multi-reloc not handled"
268 NodeEvacuate _ _ -> fail "node-evacuate not handled"
270 -- | Reads the request from the data file(s)
271 readRequest :: Options -> [String] -> IO Request
272 readRequest opts args = do
273 when (null args) $ do
274 hPutStrLn stderr "Error: this program needs an input file."
275 exitWith $ ExitFailure 1
277 input_data <- readFile (head args)
278 r1 <- case parseData input_data of
280 hPutStrLn stderr $ "Error: " ++ err
281 exitWith $ ExitFailure 1
283 (if isJust (optDataFile opts) || (not . null . optNodeSim) opts
285 cdata <- loadExternalData opts
286 let Request rqt _ = r1
287 return $ Request rqt cdata
290 -- | Main iallocator pipeline.
291 runIAllocator :: Request -> String
292 runIAllocator request =
293 let (ok, info, result) =
294 case processRequest request of
295 Ok (msg, r) -> (True, "Request successful: " ++ msg, r)
296 Bad msg -> (False, "Request failed: " ++ msg, JSArray [])
297 in formatResponse ok info result