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