root / htools / Ganeti / HTools / IAlloc.hs @ 4036f63a
History | View | Annotate | Download (12 kB)
1 |
{-| Implementation of the iallocator interface. |
---|---|
2 |
|
3 |
-} |
4 |
|
5 |
{- |
6 |
|
7 |
Copyright (C) 2009, 2010, 2011 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.IAlloc |
27 |
( readRequest |
28 |
, runIAllocator |
29 |
) where |
30 |
|
31 |
import Data.Either () |
32 |
import Data.Maybe (fromMaybe, isJust) |
33 |
import Data.List |
34 |
import Control.Monad |
35 |
import Text.JSON (JSObject, JSValue(JSArray), |
36 |
makeObj, encodeStrict, decodeStrict, fromJSObject, showJSON) |
37 |
import System (exitWith, ExitCode(..)) |
38 |
import System.IO |
39 |
|
40 |
import qualified Ganeti.HTools.Cluster as Cluster |
41 |
import qualified Ganeti.HTools.Container as Container |
42 |
import qualified Ganeti.HTools.Group as Group |
43 |
import qualified Ganeti.HTools.Node as Node |
44 |
import qualified Ganeti.HTools.Instance as Instance |
45 |
import qualified Ganeti.Constants as C |
46 |
import Ganeti.HTools.CLI |
47 |
import Ganeti.HTools.Loader |
48 |
import Ganeti.HTools.ExtLoader (loadExternalData) |
49 |
import Ganeti.HTools.Utils |
50 |
import Ganeti.HTools.Types |
51 |
|
52 |
-- | Type alias for the result of an IAllocator call. |
53 |
type IAllocResult = (String, JSValue) |
54 |
|
55 |
-- | Parse the basic specifications of an instance. |
56 |
-- |
57 |
-- Instances in the cluster instance list and the instance in an |
58 |
-- 'Allocate' request share some common properties, which are read by |
59 |
-- this function. |
60 |
parseBaseInstance :: String |
61 |
-> JSRecord |
62 |
-> Result (String, Instance.Instance) |
63 |
parseBaseInstance n a = do |
64 |
let extract x = tryFromObj ("invalid data for instance '" ++ n ++ "'") a x |
65 |
disk <- extract "disk_space_total" |
66 |
mem <- extract "memory" |
67 |
vcpus <- extract "vcpus" |
68 |
tags <- extract "tags" |
69 |
dt <- extract "disk_template" |
70 |
let running = "running" |
71 |
return (n, Instance.create n mem disk vcpus running tags True 0 0 dt) |
72 |
|
73 |
-- | Parses an instance as found in the cluster instance list. |
74 |
parseInstance :: NameAssoc -- ^ The node name-to-index association list |
75 |
-> String -- ^ The name of the instance |
76 |
-> JSRecord -- ^ The JSON object |
77 |
-> Result (String, Instance.Instance) |
78 |
parseInstance ktn n a = do |
79 |
base <- parseBaseInstance n a |
80 |
nodes <- fromObj a "nodes" |
81 |
pnode <- if null nodes |
82 |
then Bad $ "empty node list for instance " ++ n |
83 |
else readEitherString $ head nodes |
84 |
pidx <- lookupNode ktn n pnode |
85 |
let snodes = tail nodes |
86 |
sidx <- (if null snodes then return Node.noSecondary |
87 |
else readEitherString (head snodes) >>= lookupNode ktn n) |
88 |
return (n, Instance.setBoth (snd base) pidx sidx) |
89 |
|
90 |
-- | Parses a node as found in the cluster node list. |
91 |
parseNode :: NameAssoc -- ^ The group association |
92 |
-> String -- ^ The node's name |
93 |
-> JSRecord -- ^ The JSON object |
94 |
-> Result (String, Node.Node) |
95 |
parseNode ktg n a = do |
96 |
let desc = "invalid data for node '" ++ n ++ "'" |
97 |
extract x = tryFromObj desc a x |
98 |
offline <- extract "offline" |
99 |
drained <- extract "drained" |
100 |
guuid <- extract "group" |
101 |
vm_capable <- annotateResult desc $ maybeFromObj a "vm_capable" |
102 |
let vm_capable' = fromMaybe True vm_capable |
103 |
gidx <- lookupGroup ktg n guuid |
104 |
node <- (if offline || drained || not vm_capable' |
105 |
then return $ Node.create n 0 0 0 0 0 0 True gidx |
106 |
else do |
107 |
mtotal <- extract "total_memory" |
108 |
mnode <- extract "reserved_memory" |
109 |
mfree <- extract "free_memory" |
110 |
dtotal <- extract "total_disk" |
111 |
dfree <- extract "free_disk" |
112 |
ctotal <- extract "total_cpus" |
113 |
return $ Node.create n mtotal mnode mfree |
114 |
dtotal dfree ctotal False gidx) |
115 |
return (n, node) |
116 |
|
117 |
-- | Parses a group as found in the cluster group list. |
118 |
parseGroup :: String -- ^ The group UUID |
119 |
-> JSRecord -- ^ The JSON object |
120 |
-> Result (String, Group.Group) |
121 |
parseGroup u a = do |
122 |
let extract x = tryFromObj ("invalid data for group '" ++ u ++ "'") a x |
123 |
name <- extract "name" |
124 |
apol <- extract "alloc_policy" |
125 |
return (u, Group.create name u apol) |
126 |
|
127 |
-- | Top-level parser. |
128 |
parseData :: String -- ^ The JSON message as received from Ganeti |
129 |
-> Result Request -- ^ A (possible valid) request |
130 |
parseData body = do |
131 |
decoded <- fromJResult "Parsing input IAllocator message" (decodeStrict body) |
132 |
let obj = fromJSObject decoded |
133 |
extrObj x = tryFromObj "invalid iallocator message" obj x |
134 |
-- request parser |
135 |
request <- liftM fromJSObject (extrObj "request") |
136 |
let extrReq x = tryFromObj "invalid request dict" request x |
137 |
-- existing group parsing |
138 |
glist <- liftM fromJSObject (extrObj "nodegroups") |
139 |
gobj <- mapM (\(x, y) -> asJSObject y >>= parseGroup x . fromJSObject) glist |
140 |
let (ktg, gl) = assignIndices gobj |
141 |
-- existing node parsing |
142 |
nlist <- liftM fromJSObject (extrObj "nodes") |
143 |
nobj <- mapM (\(x,y) -> |
144 |
asJSObject y >>= parseNode ktg x . fromJSObject) nlist |
145 |
let (ktn, nl) = assignIndices nobj |
146 |
-- existing instance parsing |
147 |
ilist <- extrObj "instances" |
148 |
let idata = fromJSObject ilist |
149 |
iobj <- mapM (\(x,y) -> |
150 |
asJSObject y >>= parseInstance ktn x . fromJSObject) idata |
151 |
let (kti, il) = assignIndices iobj |
152 |
-- cluster tags |
153 |
ctags <- extrObj "cluster_tags" |
154 |
cdata <- mergeData [] [] [] [] (ClusterData gl nl il ctags) |
155 |
let map_n = cdNodes cdata |
156 |
map_i = cdInstances cdata |
157 |
map_g = cdGroups cdata |
158 |
optype <- extrReq "type" |
159 |
rqtype <- |
160 |
case () of |
161 |
_ | optype == C.iallocatorModeAlloc -> |
162 |
do |
163 |
rname <- extrReq "name" |
164 |
req_nodes <- extrReq "required_nodes" |
165 |
inew <- parseBaseInstance rname request |
166 |
let io = snd inew |
167 |
return $ Allocate io req_nodes |
168 |
| optype == C.iallocatorModeReloc -> |
169 |
do |
170 |
rname <- extrReq "name" |
171 |
ridx <- lookupInstance kti rname |
172 |
req_nodes <- extrReq "required_nodes" |
173 |
ex_nodes <- extrReq "relocate_from" |
174 |
ex_idex <- mapM (Container.findByName map_n) ex_nodes |
175 |
return $ Relocate ridx req_nodes (map Node.idx ex_idex) |
176 |
| optype == C.iallocatorModeMevac -> |
177 |
do |
178 |
ex_names <- extrReq "evac_nodes" |
179 |
ex_nodes <- mapM (Container.findByName map_n) ex_names |
180 |
let ex_ndx = map Node.idx ex_nodes |
181 |
return $ Evacuate ex_ndx |
182 |
| optype == C.iallocatorModeChgGroup -> |
183 |
do |
184 |
rl_names <- extrReq "instances" |
185 |
rl_insts <- mapM (liftM Instance.idx . |
186 |
Container.findByName map_i) rl_names |
187 |
gr_uuids <- extrReq "target_groups" |
188 |
gr_idxes <- mapM (liftM Group.idx . |
189 |
Container.findByName map_g) gr_uuids |
190 |
return $ ChangeGroup rl_insts gr_idxes |
191 |
| optype == C.iallocatorModeNodeEvac -> |
192 |
do |
193 |
rl_names <- extrReq "instances" |
194 |
rl_insts <- mapM (Container.findByName map_i) rl_names |
195 |
let rl_idx = map Instance.idx rl_insts |
196 |
rl_mode <- |
197 |
case extrReq "evac_mode" of |
198 |
Ok s | s == C.iallocatorNevacAll -> return ChangeAll |
199 |
| s == C.iallocatorNevacPri -> return ChangePrimary |
200 |
| s == C.iallocatorNevacSec -> return ChangeSecondary |
201 |
| otherwise -> Bad $ "Invalid evacuate mode " ++ s |
202 |
Bad x -> Bad x |
203 |
return $ NodeEvacuate rl_idx rl_mode |
204 |
|
205 |
| otherwise -> fail ("Invalid request type '" ++ optype ++ "'") |
206 |
return $ Request rqtype cdata |
207 |
|
208 |
-- | Formats the result into a valid IAllocator response message. |
209 |
formatResponse :: Bool -- ^ Whether the request was successful |
210 |
-> String -- ^ Information text |
211 |
-> JSValue -- ^ The JSON encoded result |
212 |
-> String -- ^ The full JSON-formatted message |
213 |
formatResponse success info result = |
214 |
let |
215 |
e_success = ("success", showJSON success) |
216 |
e_info = ("info", showJSON info) |
217 |
e_result = ("result", result) |
218 |
in encodeStrict $ makeObj [e_success, e_info, e_result] |
219 |
|
220 |
-- | Flatten the log of a solution into a string. |
221 |
describeSolution :: Cluster.AllocSolution -> String |
222 |
describeSolution = intercalate ", " . Cluster.asLog |
223 |
|
224 |
-- | Convert evacuation results into the result format. |
225 |
formatEvacuate :: Cluster.AllocSolution -> Result IAllocResult |
226 |
formatEvacuate as = do |
227 |
let info = describeSolution as |
228 |
elems = Cluster.asSolutions as |
229 |
when (null elems) $ fail info |
230 |
let sols = map (\(_, inst, nl, _) -> Instance.name inst : map Node.name nl) |
231 |
elems |
232 |
return (info, showJSON sols) |
233 |
|
234 |
-- | Convert allocation/relocation results into the result format. |
235 |
formatAllocate :: Cluster.AllocSolution -> Result IAllocResult |
236 |
formatAllocate as = do |
237 |
let info = describeSolution as |
238 |
case Cluster.asSolutions as of |
239 |
[] -> fail info |
240 |
(_, _, nodes, _):[] -> return (info, showJSON $ map (Node.name) nodes) |
241 |
_ -> fail "Internal error: multiple allocation solutions" |
242 |
|
243 |
-- | Convert a node-evacuation/change group result. |
244 |
formatNodeEvac :: Group.List |
245 |
-> Node.List |
246 |
-> Instance.List |
247 |
-> (Node.List, Instance.List, Cluster.EvacSolution) |
248 |
-> Result IAllocResult |
249 |
formatNodeEvac gl nl il (_, _, es) = |
250 |
let iname = Instance.name . flip Container.find il |
251 |
nname = Node.name . flip Container.find nl |
252 |
gname = Group.name . flip Container.find gl |
253 |
fes = map (\(idx, msg) -> (iname idx, msg)) $ Cluster.esFailed es |
254 |
mes = map (\(idx, gdx, ndxs) -> (iname idx, gname gdx, map nname ndxs)) |
255 |
$ Cluster.esMoved es |
256 |
failed = length fes |
257 |
moved = length mes |
258 |
info = show failed ++ " instances failed to move and " ++ show moved ++ |
259 |
" were moved successfully" |
260 |
in Ok (info, showJSON (mes, fes, Cluster.esOpCodes es)) |
261 |
|
262 |
-- | Process a request and return new node lists |
263 |
processRequest :: Request -> Result IAllocResult |
264 |
processRequest request = |
265 |
let Request rqtype (ClusterData gl nl il _) = request |
266 |
in case rqtype of |
267 |
Allocate xi reqn -> |
268 |
Cluster.tryMGAlloc gl nl il xi reqn >>= formatAllocate |
269 |
Relocate idx reqn exnodes -> |
270 |
Cluster.tryMGReloc gl nl il idx reqn exnodes >>= formatAllocate |
271 |
Evacuate exnodes -> |
272 |
Cluster.tryMGEvac gl nl il exnodes >>= formatEvacuate |
273 |
ChangeGroup gdxs idxs -> |
274 |
Cluster.tryChangeGroup gl nl il idxs gdxs >>= |
275 |
formatNodeEvac gl nl il |
276 |
NodeEvacuate xi mode -> |
277 |
Cluster.tryNodeEvac gl nl il mode xi >>= |
278 |
formatNodeEvac gl nl il |
279 |
|
280 |
-- | Reads the request from the data file(s) |
281 |
readRequest :: Options -> [String] -> IO Request |
282 |
readRequest opts args = do |
283 |
when (null args) $ do |
284 |
hPutStrLn stderr "Error: this program needs an input file." |
285 |
exitWith $ ExitFailure 1 |
286 |
|
287 |
input_data <- readFile (head args) |
288 |
r1 <- case parseData input_data of |
289 |
Bad err -> do |
290 |
hPutStrLn stderr $ "Error: " ++ err |
291 |
exitWith $ ExitFailure 1 |
292 |
Ok rq -> return rq |
293 |
(if isJust (optDataFile opts) || (not . null . optNodeSim) opts |
294 |
then do |
295 |
cdata <- loadExternalData opts |
296 |
let Request rqt _ = r1 |
297 |
return $ Request rqt cdata |
298 |
else return r1) |
299 |
|
300 |
-- | Main iallocator pipeline. |
301 |
runIAllocator :: Request -> String |
302 |
runIAllocator request = |
303 |
let (ok, info, result) = |
304 |
case processRequest request of |
305 |
Ok (msg, r) -> (True, "Request successful: " ++ msg, r) |
306 |
Bad msg -> (False, "Request failed: " ++ msg, JSArray []) |
307 |
in formatResponse ok info result |