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