Parse node group networks
[ganeti-github.git] / src / Ganeti / HTools / Backend / IAlloc.hs
1 {-| Implementation of the iallocator interface.
2
3 -}
4
5 {-
6
7 Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
8
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.
13
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.
18
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
22 02110-1301, USA.
23
24 -}
25
26 module Ganeti.HTools.Backend.IAlloc
27 ( readRequest
28 , runIAllocator
29 , processRelocate
30 , loadData
31 ) where
32
33 import Data.Either ()
34 import Data.Maybe (fromMaybe, isJust, fromJust)
35 import Data.List
36 import Control.Monad
37 import System.Time
38 import Text.JSON (JSObject, JSValue(JSArray),
39 makeObj, encodeStrict, decodeStrict, fromJSObject, showJSON)
40
41 import Ganeti.BasicTypes
42 import qualified Ganeti.HTools.Cluster as Cluster
43 import qualified Ganeti.HTools.Container as Container
44 import qualified Ganeti.HTools.Group as Group
45 import qualified Ganeti.HTools.Node as Node
46 import qualified Ganeti.HTools.Instance as Instance
47 import qualified Ganeti.Constants as C
48 import Ganeti.HTools.CLI
49 import Ganeti.HTools.Loader
50 import Ganeti.HTools.Types
51 import Ganeti.JSON
52 import Ganeti.Utils
53
54 {-# ANN module "HLint: ignore Eta reduce" #-}
55
56 -- | Type alias for the result of an IAllocator call.
57 type IAllocResult = (String, JSValue, Node.List, Instance.List)
58
59 -- | Parse the basic specifications of an instance.
60 --
61 -- Instances in the cluster instance list and the instance in an
62 -- 'Allocate' request share some common properties, which are read by
63 -- this function.
64 parseBaseInstance :: String
65 -> JSRecord
66 -> Result (String, Instance.Instance)
67 parseBaseInstance n a = do
68 let errorMessage = "invalid data for instance '" ++ n ++ "'"
69 let extract x = tryFromObj errorMessage a x
70 disk <- extract "disk_space_total"
71 disks <- extract "disks" >>= toArray >>= asObjectList >>=
72 mapM (flip (tryFromObj errorMessage) "size" . fromJSObject)
73 mem <- extract "memory"
74 vcpus <- extract "vcpus"
75 tags <- extract "tags"
76 dt <- extract "disk_template"
77 su <- extract "spindle_use"
78 return (n, Instance.create n mem disk disks vcpus Running tags True 0 0 dt su)
79
80 -- | Parses an instance as found in the cluster instance list.
81 parseInstance :: NameAssoc -- ^ The node name-to-index association list
82 -> String -- ^ The name of the instance
83 -> JSRecord -- ^ The JSON object
84 -> Result (String, Instance.Instance)
85 parseInstance ktn n a = do
86 base <- parseBaseInstance n a
87 nodes <- fromObj a "nodes"
88 (pnode, snodes) <-
89 case nodes of
90 [] -> Bad $ "empty node list for instance " ++ n
91 x:xs -> readEitherString x >>= \x' -> return (x', xs)
92 pidx <- lookupNode ktn n pnode
93 sidx <- case snodes of
94 [] -> return Node.noSecondary
95 x:_ -> readEitherString x >>= lookupNode ktn n
96 return (n, Instance.setBoth (snd base) pidx sidx)
97
98 -- | Parses a node as found in the cluster node list.
99 parseNode :: NameAssoc -- ^ The group association
100 -> String -- ^ The node's name
101 -> JSRecord -- ^ The JSON object
102 -> Result (String, Node.Node)
103 parseNode ktg n a = do
104 let desc = "invalid data for node '" ++ n ++ "'"
105 extract x = tryFromObj desc a x
106 offline <- extract "offline"
107 drained <- extract "drained"
108 guuid <- extract "group"
109 vm_capable <- annotateResult desc $ maybeFromObj a "vm_capable"
110 let vm_capable' = fromMaybe True vm_capable
111 gidx <- lookupGroup ktg n guuid
112 node <- if offline || drained || not vm_capable'
113 then return $ Node.create n 0 0 0 0 0 0 True 0 gidx
114 else do
115 mtotal <- extract "total_memory"
116 mnode <- extract "reserved_memory"
117 mfree <- extract "free_memory"
118 dtotal <- extract "total_disk"
119 dfree <- extract "free_disk"
120 ctotal <- extract "total_cpus"
121 ndparams <- extract "ndparams" >>= asJSObject
122 spindles <- tryFromObj desc (fromJSObject ndparams)
123 "spindle_count"
124 return $ Node.create n mtotal mnode mfree
125 dtotal dfree ctotal False spindles gidx
126 return (n, node)
127
128 -- | Parses a group as found in the cluster group list.
129 parseGroup :: String -- ^ The group UUID
130 -> JSRecord -- ^ The JSON object
131 -> Result (String, Group.Group)
132 parseGroup u a = do
133 let extract x = tryFromObj ("invalid data for group '" ++ u ++ "'") a x
134 name <- extract "name"
135 apol <- extract "alloc_policy"
136 nets <- extract "networks"
137 ipol <- extract "ipolicy"
138 tags <- extract "tags"
139 return (u, Group.create name u apol nets ipol tags)
140
141 -- | Top-level parser.
142 --
143 -- The result is a tuple of eventual warning messages and the parsed
144 -- request; if parsing the input data fails, we'll return a 'Bad'
145 -- value.
146 parseData :: ClockTime -- ^ The current time
147 -> String -- ^ The JSON message as received from Ganeti
148 -> Result ([String], Request) -- ^ Result tuple
149 parseData now body = do
150 decoded <- fromJResult "Parsing input IAllocator message" (decodeStrict body)
151 let obj = fromJSObject decoded
152 extrObj x = tryFromObj "invalid iallocator message" obj x
153 -- request parser
154 request <- liftM fromJSObject (extrObj "request")
155 let extrFromReq r x = tryFromObj "invalid request dict" r x
156 let extrReq x = extrFromReq request x
157 -- existing group parsing
158 glist <- liftM fromJSObject (extrObj "nodegroups")
159 gobj <- mapM (\(x, y) -> asJSObject y >>= parseGroup x . fromJSObject) glist
160 let (ktg, gl) = assignIndices gobj
161 -- existing node parsing
162 nlist <- liftM fromJSObject (extrObj "nodes")
163 nobj <- mapM (\(x,y) ->
164 asJSObject y >>= parseNode ktg x . fromJSObject) nlist
165 let (ktn, nl) = assignIndices nobj
166 -- existing instance parsing
167 ilist <- extrObj "instances"
168 let idata = fromJSObject ilist
169 iobj <- mapM (\(x,y) ->
170 asJSObject y >>= parseInstance ktn x . fromJSObject) idata
171 let (kti, il) = assignIndices iobj
172 -- cluster tags
173 ctags <- extrObj "cluster_tags"
174 cdata1 <- mergeData [] [] [] [] now (ClusterData gl nl il ctags defIPolicy)
175 let (msgs, fix_nl) = checkData (cdNodes cdata1) (cdInstances cdata1)
176 cdata = cdata1 { cdNodes = fix_nl }
177 map_n = cdNodes cdata
178 map_i = cdInstances cdata
179 map_g = cdGroups cdata
180 optype <- extrReq "type"
181 rqtype <-
182 case () of
183 _ | optype == C.iallocatorModeAlloc ->
184 do
185 rname <- extrReq "name"
186 req_nodes <- extrReq "required_nodes"
187 inew <- parseBaseInstance rname request
188 let io = snd inew
189 return $ Allocate io req_nodes
190 | optype == C.iallocatorModeReloc ->
191 do
192 rname <- extrReq "name"
193 ridx <- lookupInstance kti rname
194 req_nodes <- extrReq "required_nodes"
195 ex_nodes <- extrReq "relocate_from"
196 ex_idex <- mapM (Container.findByName map_n) ex_nodes
197 return $ Relocate ridx req_nodes (map Node.idx ex_idex)
198 | optype == C.iallocatorModeChgGroup ->
199 do
200 rl_names <- extrReq "instances"
201 rl_insts <- mapM (liftM Instance.idx .
202 Container.findByName map_i) rl_names
203 gr_uuids <- extrReq "target_groups"
204 gr_idxes <- mapM (liftM Group.idx .
205 Container.findByName map_g) gr_uuids
206 return $ ChangeGroup rl_insts gr_idxes
207 | optype == C.iallocatorModeNodeEvac ->
208 do
209 rl_names <- extrReq "instances"
210 rl_insts <- mapM (Container.findByName map_i) rl_names
211 let rl_idx = map Instance.idx rl_insts
212 rl_mode <- extrReq "evac_mode"
213 return $ NodeEvacuate rl_idx rl_mode
214 | optype == C.iallocatorModeMultiAlloc ->
215 do
216 arry <- extrReq "instances" :: Result [JSObject JSValue]
217 let inst_reqs = map fromJSObject arry
218 prqs <- mapM (\r ->
219 do
220 rname <- extrFromReq r "name"
221 req_nodes <- extrFromReq r "required_nodes"
222 inew <- parseBaseInstance rname r
223 let io = snd inew
224 return (io, req_nodes)) inst_reqs
225 return $ MultiAllocate prqs
226 | otherwise -> fail ("Invalid request type '" ++ optype ++ "'")
227 return (msgs, Request rqtype cdata)
228
229 -- | Formats the result into a valid IAllocator response message.
230 formatResponse :: Bool -- ^ Whether the request was successful
231 -> String -- ^ Information text
232 -> JSValue -- ^ The JSON encoded result
233 -> String -- ^ The full JSON-formatted message
234 formatResponse success info result =
235 let e_success = ("success", showJSON success)
236 e_info = ("info", showJSON info)
237 e_result = ("result", result)
238 in encodeStrict $ makeObj [e_success, e_info, e_result]
239
240 -- | Flatten the log of a solution into a string.
241 describeSolution :: Cluster.AllocSolution -> String
242 describeSolution = intercalate ", " . Cluster.asLog
243
244 -- | Convert allocation/relocation results into the result format.
245 formatAllocate :: Instance.List -> Cluster.AllocSolution -> Result IAllocResult
246 formatAllocate il as = do
247 let info = describeSolution as
248 case Cluster.asSolution as of
249 Nothing -> fail info
250 Just (nl, inst, nodes, _) ->
251 do
252 let il' = Container.add (Instance.idx inst) inst il
253 return (info, showJSON $ map Node.name nodes, nl, il')
254
255 -- | Convert multi allocation results into the result format.
256 formatMultiAlloc :: (Node.List, Instance.List, Cluster.AllocSolutionList)
257 -> Result IAllocResult
258 formatMultiAlloc (fin_nl, fin_il, ars) =
259 let rars = reverse ars
260 (allocated, failed) = partition (isJust . Cluster.asSolution . snd) rars
261 aars = map (\(_, ar) ->
262 let (_, inst, nodes, _) = fromJust $ Cluster.asSolution ar
263 iname = Instance.name inst
264 nnames = map Node.name nodes
265 in (iname, nnames)) allocated
266 fars = map (\(inst, ar) ->
267 let iname = Instance.name inst
268 in (iname, describeSolution ar)) failed
269 info = show (length failed) ++ " instances failed to allocate and " ++
270 show (length allocated) ++ " were allocated successfully"
271 in return (info, showJSON (aars, fars), fin_nl, fin_il)
272
273 -- | Convert a node-evacuation/change group result.
274 formatNodeEvac :: Group.List
275 -> Node.List
276 -> Instance.List
277 -> (Node.List, Instance.List, Cluster.EvacSolution)
278 -> Result IAllocResult
279 formatNodeEvac gl nl il (fin_nl, fin_il, es) =
280 let iname = Instance.name . flip Container.find il
281 nname = Node.name . flip Container.find nl
282 gname = Group.name . flip Container.find gl
283 fes = map (\(idx, msg) -> (iname idx, msg)) $ Cluster.esFailed es
284 mes = map (\(idx, gdx, ndxs) -> (iname idx, gname gdx, map nname ndxs))
285 $ Cluster.esMoved es
286 failed = length fes
287 moved = length mes
288 info = show failed ++ " instances failed to move and " ++ show moved ++
289 " were moved successfully"
290 in Ok (info, showJSON (mes, fes, Cluster.esOpCodes es), fin_nl, fin_il)
291
292 -- | Runs relocate for a single instance.
293 --
294 -- This is wrapper over the 'Cluster.tryNodeEvac' function that is run
295 -- with a single instance (ours), and further it checks that the
296 -- result it got (in the nodes field) is actually consistent, as
297 -- tryNodeEvac is designed to output primarily an opcode list, not a
298 -- node list.
299 processRelocate :: Group.List -- ^ The group list
300 -> Node.List -- ^ The node list
301 -> Instance.List -- ^ The instance list
302 -> Idx -- ^ The index of the instance to move
303 -> Int -- ^ The number of nodes required
304 -> [Ndx] -- ^ Nodes which should not be used
305 -> Result (Node.List, Instance.List, [Ndx]) -- ^ Solution list
306 processRelocate gl nl il idx 1 exndx = do
307 let orig = Container.find idx il
308 sorig = Instance.sNode orig
309 porig = Instance.pNode orig
310 mir_type = Instance.mirrorType orig
311 (exp_node, node_type, reloc_type) <-
312 case mir_type of
313 MirrorNone -> fail "Can't relocate non-mirrored instances"
314 MirrorInternal -> return (sorig, "secondary", ChangeSecondary)
315 MirrorExternal -> return (porig, "primary", ChangePrimary)
316 when (exndx /= [exp_node]) .
317 -- FIXME: we can't use the excluded nodes here; the logic is
318 -- already _but only partially_ implemented in tryNodeEvac...
319 fail $ "Unsupported request: excluded nodes not equal to\
320 \ instance's " ++ node_type ++ "(" ++ show exp_node
321 ++ " versus " ++ show exndx ++ ")"
322 (nl', il', esol) <- Cluster.tryNodeEvac gl nl il reloc_type [idx]
323 nodes <- case lookup idx (Cluster.esFailed esol) of
324 Just msg -> fail msg
325 Nothing ->
326 case lookup idx (map (\(a, _, b) -> (a, b))
327 (Cluster.esMoved esol)) of
328 Nothing ->
329 fail "Internal error: lost instance idx during move"
330 Just n -> return n
331 let inst = Container.find idx il'
332 pnode = Instance.pNode inst
333 snode = Instance.sNode inst
334 nodes' <-
335 case mir_type of
336 MirrorNone -> fail "Internal error: mirror type none after relocation?!"
337 MirrorInternal ->
338 do
339 when (snode == sorig) $
340 fail "Internal error: instance didn't change secondary node?!"
341 when (snode == pnode) $
342 fail "Internal error: selected primary as new secondary?!"
343 if nodes == [pnode, snode]
344 then return [snode] -- only the new secondary is needed
345 else fail $ "Internal error: inconsistent node list (" ++
346 show nodes ++ ") versus instance nodes (" ++ show pnode ++
347 "," ++ show snode ++ ")"
348 MirrorExternal ->
349 do
350 when (pnode == porig) $
351 fail "Internal error: instance didn't change primary node?!"
352 if nodes == [pnode]
353 then return nodes
354 else fail $ "Internal error: inconsistent node list (" ++
355 show nodes ++ ") versus instance node (" ++ show pnode ++ ")"
356 return (nl', il', nodes')
357
358 processRelocate _ _ _ _ reqn _ =
359 fail $ "Exchange " ++ show reqn ++ " nodes mode is not implemented"
360
361 formatRelocate :: (Node.List, Instance.List, [Ndx])
362 -> Result IAllocResult
363 formatRelocate (nl, il, ndxs) =
364 let nodes = map (`Container.find` nl) ndxs
365 names = map Node.name nodes
366 in Ok ("success", showJSON names, nl, il)
367
368 -- | Process a request and return new node lists.
369 processRequest :: Request -> Result IAllocResult
370 processRequest request =
371 let Request rqtype (ClusterData gl nl il _ _) = request
372 in case rqtype of
373 Allocate xi reqn ->
374 Cluster.tryMGAlloc gl nl il xi reqn >>= formatAllocate il
375 Relocate idx reqn exnodes ->
376 processRelocate gl nl il idx reqn exnodes >>= formatRelocate
377 ChangeGroup gdxs idxs ->
378 Cluster.tryChangeGroup gl nl il idxs gdxs >>=
379 formatNodeEvac gl nl il
380 NodeEvacuate xi mode ->
381 Cluster.tryNodeEvac gl nl il mode xi >>=
382 formatNodeEvac gl nl il
383 MultiAllocate xies ->
384 Cluster.allocList gl nl il xies [] >>= formatMultiAlloc
385
386 -- | Reads the request from the data file(s).
387 readRequest :: FilePath -> IO Request
388 readRequest fp = do
389 now <- getClockTime
390 input_data <- case fp of
391 "-" -> getContents
392 _ -> readFile fp
393 case parseData now input_data of
394 Bad err -> exitErr err
395 Ok (fix_msgs, rq) -> maybeShowWarnings fix_msgs >> return rq
396
397 -- | Main iallocator pipeline.
398 runIAllocator :: Request -> (Maybe (Node.List, Instance.List), String)
399 runIAllocator request =
400 let (ok, info, result, cdata) =
401 case processRequest request of
402 Ok (msg, r, nl, il) -> (True, "Request successful: " ++ msg, r,
403 Just (nl, il))
404 Bad msg -> (False, "Request failed: " ++ msg, JSArray [], Nothing)
405 rstring = formatResponse ok info result
406 in (cdata, rstring)
407
408 -- | Load the data from an iallocation request file
409 loadData :: FilePath -- ^ The path to the file
410 -> IO (Result ClusterData)
411 loadData fp = do
412 Request _ cdata <- readRequest fp
413 return $ Ok cdata