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, Node.List, Instance.List)
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 dt <- extract "disk_template"
70 let running = "running"
71 return (n, Instance.create n mem disk vcpus running tags True 0 0 dt)
73 -- | Parses an instance as found in the cluster instance list.
74 parseInstance :: NameAssoc -- ^ The node name-to-index association list
75 -> String -- ^ The name of the instance
76 -> JSRecord -- ^ The JSON object
77 -> Result (String, Instance.Instance)
78 parseInstance ktn n a = do
79 base <- parseBaseInstance n a
80 nodes <- fromObj a "nodes"
81 pnode <- if null nodes
82 then Bad $ "empty node list for instance " ++ n
83 else readEitherString $ head nodes
84 pidx <- lookupNode ktn n pnode
85 let snodes = tail nodes
86 sidx <- (if null snodes then return Node.noSecondary
87 else readEitherString (head snodes) >>= lookupNode ktn n)
88 return (n, Instance.setBoth (snd base) pidx sidx)
90 -- | Parses a node as found in the cluster node list.
91 parseNode :: NameAssoc -- ^ The group association
92 -> String -- ^ The node's name
93 -> JSRecord -- ^ The JSON object
94 -> Result (String, Node.Node)
95 parseNode ktg n a = do
96 let desc = "invalid data for node '" ++ n ++ "'"
97 extract x = tryFromObj desc a x
98 offline <- extract "offline"
99 drained <- extract "drained"
100 guuid <- extract "group"
101 vm_capable <- annotateResult desc $ maybeFromObj a "vm_capable"
102 let vm_capable' = fromMaybe True vm_capable
103 gidx <- lookupGroup ktg n guuid
104 node <- (if offline || drained || not vm_capable'
105 then return $ Node.create n 0 0 0 0 0 0 True gidx
107 mtotal <- extract "total_memory"
108 mnode <- extract "reserved_memory"
109 mfree <- extract "free_memory"
110 dtotal <- extract "total_disk"
111 dfree <- extract "free_disk"
112 ctotal <- extract "total_cpus"
113 return $ Node.create n mtotal mnode mfree
114 dtotal dfree ctotal False gidx)
117 -- | Parses a group as found in the cluster group list.
118 parseGroup :: String -- ^ The group UUID
119 -> JSRecord -- ^ The JSON object
120 -> Result (String, Group.Group)
122 let extract x = tryFromObj ("invalid data for group '" ++ u ++ "'") a x
123 name <- extract "name"
124 apol <- extract "alloc_policy"
125 return (u, Group.create name u apol)
127 -- | Top-level parser.
129 -- The result is a tuple of eventual warning messages and the parsed
130 -- request; if parsing the input data fails, we'll return a 'Bad'
132 parseData :: String -- ^ The JSON message as received from Ganeti
133 -> Result ([String], Request) -- ^ Result tuple
135 decoded <- fromJResult "Parsing input IAllocator message" (decodeStrict body)
136 let obj = fromJSObject decoded
137 extrObj x = tryFromObj "invalid iallocator message" obj x
139 request <- liftM fromJSObject (extrObj "request")
140 let extrReq x = tryFromObj "invalid request dict" request x
141 -- existing group parsing
142 glist <- liftM fromJSObject (extrObj "nodegroups")
143 gobj <- mapM (\(x, y) -> asJSObject y >>= parseGroup x . fromJSObject) glist
144 let (ktg, gl) = assignIndices gobj
145 -- existing node parsing
146 nlist <- liftM fromJSObject (extrObj "nodes")
147 nobj <- mapM (\(x,y) ->
148 asJSObject y >>= parseNode ktg x . fromJSObject) nlist
149 let (ktn, nl) = assignIndices nobj
150 -- existing instance parsing
151 ilist <- extrObj "instances"
152 let idata = fromJSObject ilist
153 iobj <- mapM (\(x,y) ->
154 asJSObject y >>= parseInstance ktn x . fromJSObject) idata
155 let (kti, il) = assignIndices iobj
157 ctags <- extrObj "cluster_tags"
158 cdata1 <- mergeData [] [] [] [] (ClusterData gl nl il ctags)
159 let (msgs, fix_nl) = checkData (cdNodes cdata1) (cdInstances cdata1)
160 cdata = cdata1 { cdNodes = fix_nl }
161 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.iallocatorModeChgGroup ->
184 rl_names <- extrReq "instances"
185 rl_insts <- mapM (liftM Instance.idx .
186 Container.findByName map_i) rl_names
187 gr_uuids <- extrReq "target_groups"
188 gr_idxes <- mapM (liftM Group.idx .
189 Container.findByName map_g) gr_uuids
190 return $ ChangeGroup rl_insts gr_idxes
191 | optype == C.iallocatorModeNodeEvac ->
193 rl_names <- extrReq "instances"
194 rl_insts <- mapM (Container.findByName map_i) rl_names
195 let rl_idx = map Instance.idx rl_insts
196 rl_mode <- extrReq "evac_mode"
197 return $ NodeEvacuate rl_idx rl_mode
199 | otherwise -> fail ("Invalid request type '" ++ optype ++ "'")
200 return (msgs, Request rqtype cdata)
202 -- | Formats the result into a valid IAllocator response message.
203 formatResponse :: Bool -- ^ Whether the request was successful
204 -> String -- ^ Information text
205 -> JSValue -- ^ The JSON encoded result
206 -> String -- ^ The full JSON-formatted message
207 formatResponse success info result =
209 e_success = ("success", showJSON success)
210 e_info = ("info", showJSON info)
211 e_result = ("result", result)
212 in encodeStrict $ makeObj [e_success, e_info, e_result]
214 -- | Flatten the log of a solution into a string.
215 describeSolution :: Cluster.AllocSolution -> String
216 describeSolution = intercalate ", " . Cluster.asLog
218 -- | Convert allocation/relocation results into the result format.
219 formatAllocate :: Instance.List -> Cluster.AllocSolution -> Result IAllocResult
220 formatAllocate il as = do
221 let info = describeSolution as
222 case Cluster.asSolutions as of
224 (nl, inst, nodes, _):[] ->
226 let il' = Container.add (Instance.idx inst) inst il
227 return (info, showJSON $ map Node.name nodes, nl, il')
228 _ -> fail "Internal error: multiple allocation solutions"
230 -- | Convert a node-evacuation/change group result.
231 formatNodeEvac :: Group.List
234 -> (Node.List, Instance.List, Cluster.EvacSolution)
235 -> Result IAllocResult
236 formatNodeEvac gl nl il (fin_nl, fin_il, es) =
237 let iname = Instance.name . flip Container.find il
238 nname = Node.name . flip Container.find nl
239 gname = Group.name . flip Container.find gl
240 fes = map (\(idx, msg) -> (iname idx, msg)) $ Cluster.esFailed es
241 mes = map (\(idx, gdx, ndxs) -> (iname idx, gname gdx, map nname ndxs))
245 info = show failed ++ " instances failed to move and " ++ show moved ++
246 " were moved successfully"
247 in Ok (info, showJSON (mes, fes, Cluster.esOpCodes es), fin_nl, fin_il)
249 -- | Runs relocate for a single instance.
251 -- This is wrapper over the 'Cluster.tryNodeEvac' function that is run
252 -- with a single instance (ours), and further it checks that the
253 -- result it got (in the nodes field) is actually consistent, as
254 -- tryNodeEvac is designed to output primarily an opcode list, not a
256 processRelocate :: Group.List -- ^ The group list
257 -> Node.List -- ^ The node list
258 -> Instance.List -- ^ The instance list
259 -> Idx -- ^ The index of the instance to move
260 -> Int -- ^ The number of nodes required
261 -> [Ndx] -- ^ Nodes which should not be used
262 -> Result (Node.List, Instance.List, [Ndx]) -- ^ Solution list
263 processRelocate gl nl il idx 1 exndx = do
264 let orig = Container.find idx il
265 sorig = Instance.sNode orig
266 when (exndx /= [sorig]) $
267 -- FIXME: we can't use the excluded nodes here; the logic is
268 -- already _but only partially_ implemented in tryNodeEvac...
269 fail $ "Unsupported request: excluded nodes not equal to\
270 \ instance's secondary node (" ++ show sorig ++ " versus " ++
272 (nl', il', esol) <- Cluster.tryNodeEvac gl nl il ChangeSecondary [idx]
273 nodes <- case lookup idx (Cluster.esFailed esol) of
276 case lookup idx (map (\(a, _, b) -> (a, b))
277 (Cluster.esMoved esol)) of
279 fail "Internal error: lost instance idx during move"
281 let inst = Container.find idx il'
282 pnode = Instance.pNode inst
283 snode = Instance.sNode inst
284 when (snode == sorig) $
285 fail "Internal error: instance didn't change secondary node?!"
286 when (snode == pnode) $
287 fail "Internal error: selected primary as new secondary?!"
289 nodes' <- if (nodes == [pnode, snode])
290 then return [snode] -- only the new secondary is needed
291 else fail $ "Internal error: inconsistent node list (" ++
292 show nodes ++ ") versus instance nodes (" ++ show pnode ++
293 "," ++ show snode ++ ")"
294 return (nl', il', nodes')
296 processRelocate _ _ _ _ reqn _ =
297 fail $ "Exchange " ++ show reqn ++ " nodes mode is not implemented"
299 formatRelocate :: (Node.List, Instance.List, [Ndx])
300 -> Result IAllocResult
301 formatRelocate (nl, il, ndxs) =
302 let nodes = map (`Container.find` nl) ndxs
303 names = map Node.name nodes
304 in Ok ("success", showJSON names, nl, il)
306 -- | Process a request and return new node lists.
307 processRequest :: Request -> Result IAllocResult
308 processRequest request =
309 let Request rqtype (ClusterData gl nl il _) = request
312 Cluster.tryMGAlloc gl nl il xi reqn >>= formatAllocate il
313 Relocate idx reqn exnodes ->
314 processRelocate gl nl il idx reqn exnodes >>= formatRelocate
315 ChangeGroup gdxs idxs ->
316 Cluster.tryChangeGroup gl nl il idxs gdxs >>=
317 formatNodeEvac gl nl il
318 NodeEvacuate xi mode ->
319 Cluster.tryNodeEvac gl nl il mode xi >>=
320 formatNodeEvac gl nl il
322 -- | Reads the request from the data file(s).
323 readRequest :: Options -> [String] -> IO Request
324 readRequest opts args = do
325 when (null args) $ do
326 hPutStrLn stderr "Error: this program needs an input file."
327 exitWith $ ExitFailure 1
329 input_data <- readFile (head args)
330 r1 <- case parseData input_data of
332 hPutStrLn stderr $ "Error: " ++ err
333 exitWith $ ExitFailure 1
334 Ok (fix_msgs, rq) -> maybeShowWarnings fix_msgs >> return rq
335 (if isJust (optDataFile opts) || (not . null . optNodeSim) opts
337 cdata <- loadExternalData opts
338 let Request rqt _ = r1
339 return $ Request rqt cdata
342 -- | Main iallocator pipeline.
343 runIAllocator :: Request -> (Maybe (Node.List, Instance.List), String)
344 runIAllocator request =
345 let (ok, info, result, cdata) =
346 case processRequest request of
347 Ok (msg, r, nl, il) -> (True, "Request successful: " ++ msg, r,
349 Bad msg -> (False, "Request failed: " ++ msg, JSArray [], Nothing)
350 rstring = formatResponse ok info result