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