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