root / src / Ganeti / HTools / Backend / IAlloc.hs @ 241cea1e
History | View | Annotate | Download (16.9 kB)
1 | 43643696 | Iustin Pop | {-| Implementation of the iallocator interface. |
---|---|---|---|
2 | 43643696 | Iustin Pop | |
3 | 43643696 | Iustin Pop | -} |
4 | 43643696 | Iustin Pop | |
5 | e2fa2baf | Iustin Pop | {- |
6 | e2fa2baf | Iustin Pop | |
7 | 72747d91 | Iustin Pop | Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc. |
8 | e2fa2baf | Iustin Pop | |
9 | e2fa2baf | Iustin Pop | This program is free software; you can redistribute it and/or modify |
10 | e2fa2baf | Iustin Pop | it under the terms of the GNU General Public License as published by |
11 | e2fa2baf | Iustin Pop | the Free Software Foundation; either version 2 of the License, or |
12 | e2fa2baf | Iustin Pop | (at your option) any later version. |
13 | e2fa2baf | Iustin Pop | |
14 | e2fa2baf | Iustin Pop | This program is distributed in the hope that it will be useful, but |
15 | e2fa2baf | Iustin Pop | WITHOUT ANY WARRANTY; without even the implied warranty of |
16 | e2fa2baf | Iustin Pop | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
17 | e2fa2baf | Iustin Pop | General Public License for more details. |
18 | e2fa2baf | Iustin Pop | |
19 | e2fa2baf | Iustin Pop | You should have received a copy of the GNU General Public License |
20 | e2fa2baf | Iustin Pop | along with this program; if not, write to the Free Software |
21 | e2fa2baf | Iustin Pop | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
22 | e2fa2baf | Iustin Pop | 02110-1301, USA. |
23 | e2fa2baf | Iustin Pop | |
24 | e2fa2baf | Iustin Pop | -} |
25 | e2fa2baf | Iustin Pop | |
26 | 879d9290 | Iustin Pop | module Ganeti.HTools.Backend.IAlloc |
27 | 00dd69a2 | Iustin Pop | ( readRequest |
28 | 00dd69a2 | Iustin Pop | , runIAllocator |
29 | 00dd69a2 | Iustin Pop | , processRelocate |
30 | 786c514c | René Nussbaumer | , loadData |
31 | 00dd69a2 | Iustin Pop | ) where |
32 | 43643696 | Iustin Pop | |
33 | 43643696 | Iustin Pop | import Data.Either () |
34 | 2a9aff11 | René Nussbaumer | import Data.Maybe (fromMaybe, isJust, fromJust) |
35 | cabce2f4 | Iustin Pop | import Data.List |
36 | 43643696 | Iustin Pop | import Control.Monad |
37 | ef947a42 | Dato Simó | import System.Time |
38 | 34c5a24a | Iustin Pop | import Text.JSON (JSObject, JSValue(JSArray), |
39 | 34c5a24a | Iustin Pop | makeObj, encodeStrict, decodeStrict, fromJSObject, showJSON) |
40 | cabce2f4 | Iustin Pop | |
41 | 01e52493 | Iustin Pop | import Ganeti.BasicTypes |
42 | cabce2f4 | Iustin Pop | import qualified Ganeti.HTools.Cluster as Cluster |
43 | 262a08a2 | Iustin Pop | import qualified Ganeti.HTools.Container as Container |
44 | a679e9dc | Iustin Pop | import qualified Ganeti.HTools.Group as Group |
45 | 942403e6 | Iustin Pop | import qualified Ganeti.HTools.Node as Node |
46 | 942403e6 | Iustin Pop | import qualified Ganeti.HTools.Instance as Instance |
47 | df5227dc | Iustin Pop | import qualified Ganeti.Constants as C |
48 | cabce2f4 | Iustin Pop | import Ganeti.HTools.CLI |
49 | e4c5beaf | Iustin Pop | import Ganeti.HTools.Loader |
50 | e4c5beaf | Iustin Pop | import Ganeti.HTools.Types |
51 | f3baf5ef | Iustin Pop | import Ganeti.JSON |
52 | 707cd3d7 | Helga Velroyen | import Ganeti.Utils |
53 | 43643696 | Iustin Pop | |
54 | 3603605a | Iustin Pop | {-# ANN module "HLint: ignore Eta reduce" #-} |
55 | 3603605a | Iustin Pop | |
56 | 7c14b50a | Iustin Pop | -- | Type alias for the result of an IAllocator call. |
57 | f9283686 | Iustin Pop | type IAllocResult = (String, JSValue, Node.List, Instance.List) |
58 | 7c14b50a | Iustin Pop | |
59 | 9188aeef | Iustin Pop | -- | Parse the basic specifications of an instance. |
60 | 9188aeef | Iustin Pop | -- |
61 | 9188aeef | Iustin Pop | -- Instances in the cluster instance list and the instance in an |
62 | 9188aeef | Iustin Pop | -- 'Allocate' request share some common properties, which are read by |
63 | 9188aeef | Iustin Pop | -- this function. |
64 | e4c5beaf | Iustin Pop | parseBaseInstance :: String |
65 | 28f19313 | Iustin Pop | -> JSRecord |
66 | e4c5beaf | Iustin Pop | -> Result (String, Instance.Instance) |
67 | e4c5beaf | Iustin Pop | parseBaseInstance n a = do |
68 | 241cea1e | Klaus Aehlig | let errorMessage = "invalid data for instance '" ++ n ++ "'" |
69 | 241cea1e | Klaus Aehlig | let extract x = tryFromObj errorMessage a x |
70 | e8230242 | Iustin Pop | disk <- extract "disk_space_total" |
71 | 241cea1e | Klaus Aehlig | disks <- extract "disks" >>= toArray >>= asObjectList >>= |
72 | 241cea1e | Klaus Aehlig | mapM (flip (tryFromObj errorMessage) "size" . fromJSObject) |
73 | e8230242 | Iustin Pop | mem <- extract "memory" |
74 | e8230242 | Iustin Pop | vcpus <- extract "vcpus" |
75 | e8230242 | Iustin Pop | tags <- extract "tags" |
76 | 5a4a3b7f | Iustin Pop | dt <- extract "disk_template" |
77 | ec629280 | René Nussbaumer | su <- extract "spindle_use" |
78 | 241cea1e | Klaus Aehlig | return (n, Instance.create n mem disk disks vcpus Running tags True 0 0 dt su) |
79 | 585d4420 | Iustin Pop | |
80 | 525bfb36 | Iustin Pop | -- | Parses an instance as found in the cluster instance list. |
81 | 28f19313 | Iustin Pop | parseInstance :: NameAssoc -- ^ The node name-to-index association list |
82 | 28f19313 | Iustin Pop | -> String -- ^ The name of the instance |
83 | 28f19313 | Iustin Pop | -> JSRecord -- ^ The JSON object |
84 | e4c5beaf | Iustin Pop | -> Result (String, Instance.Instance) |
85 | e4c5beaf | Iustin Pop | parseInstance ktn n a = do |
86 | 262f3e6c | Iustin Pop | base <- parseBaseInstance n a |
87 | e8230242 | Iustin Pop | nodes <- fromObj a "nodes" |
88 | 72747d91 | Iustin Pop | (pnode, snodes) <- |
89 | 72747d91 | Iustin Pop | case nodes of |
90 | 72747d91 | Iustin Pop | [] -> Bad $ "empty node list for instance " ++ n |
91 | 72747d91 | Iustin Pop | x:xs -> readEitherString x >>= \x' -> return (x', xs) |
92 | 262f3e6c | Iustin Pop | pidx <- lookupNode ktn n pnode |
93 | 72747d91 | Iustin Pop | sidx <- case snodes of |
94 | 72747d91 | Iustin Pop | [] -> return Node.noSecondary |
95 | 72747d91 | Iustin Pop | x:_ -> readEitherString x >>= lookupNode ktn n |
96 | 262f3e6c | Iustin Pop | return (n, Instance.setBoth (snd base) pidx sidx) |
97 | 585d4420 | Iustin Pop | |
98 | 9188aeef | Iustin Pop | -- | Parses a node as found in the cluster node list. |
99 | 28f19313 | Iustin Pop | parseNode :: NameAssoc -- ^ The group association |
100 | 28f19313 | Iustin Pop | -> String -- ^ The node's name |
101 | 28f19313 | Iustin Pop | -> JSRecord -- ^ The JSON object |
102 | 9188aeef | Iustin Pop | -> Result (String, Node.Node) |
103 | 10ef6b4e | Iustin Pop | parseNode ktg n a = do |
104 | 3eeea90f | Iustin Pop | let desc = "invalid data for node '" ++ n ++ "'" |
105 | 3eeea90f | Iustin Pop | extract x = tryFromObj desc a x |
106 | e8230242 | Iustin Pop | offline <- extract "offline" |
107 | e8230242 | Iustin Pop | drained <- extract "drained" |
108 | e8230242 | Iustin Pop | guuid <- extract "group" |
109 | 3eeea90f | Iustin Pop | vm_capable <- annotateResult desc $ maybeFromObj a "vm_capable" |
110 | 3eeea90f | Iustin Pop | let vm_capable' = fromMaybe True vm_capable |
111 | 10ef6b4e | Iustin Pop | gidx <- lookupGroup ktg n guuid |
112 | 3603605a | Iustin Pop | node <- if offline || drained || not vm_capable' |
113 | 8bc34c7b | Iustin Pop | then return $ Node.create n 0 0 0 0 0 0 True 0 gidx |
114 | 3603605a | Iustin Pop | else do |
115 | 3603605a | Iustin Pop | mtotal <- extract "total_memory" |
116 | 3603605a | Iustin Pop | mnode <- extract "reserved_memory" |
117 | 3603605a | Iustin Pop | mfree <- extract "free_memory" |
118 | 3603605a | Iustin Pop | dtotal <- extract "total_disk" |
119 | 3603605a | Iustin Pop | dfree <- extract "free_disk" |
120 | 3603605a | Iustin Pop | ctotal <- extract "total_cpus" |
121 | 8bc34c7b | Iustin Pop | ndparams <- extract "ndparams" >>= asJSObject |
122 | 8bc34c7b | Iustin Pop | spindles <- tryFromObj desc (fromJSObject ndparams) |
123 | 8bc34c7b | Iustin Pop | "spindle_count" |
124 | 3603605a | Iustin Pop | return $ Node.create n mtotal mnode mfree |
125 | 8bc34c7b | Iustin Pop | dtotal dfree ctotal False spindles gidx |
126 | 262f3e6c | Iustin Pop | return (n, node) |
127 | 144f190b | Iustin Pop | |
128 | a679e9dc | Iustin Pop | -- | Parses a group as found in the cluster group list. |
129 | 28f19313 | Iustin Pop | parseGroup :: String -- ^ The group UUID |
130 | 28f19313 | Iustin Pop | -> JSRecord -- ^ The JSON object |
131 | a679e9dc | Iustin Pop | -> Result (String, Group.Group) |
132 | a679e9dc | Iustin Pop | parseGroup u a = do |
133 | 1b2cb110 | Iustin Pop | let extract x = tryFromObj ("invalid data for group '" ++ u ++ "'") a x |
134 | 1b2cb110 | Iustin Pop | name <- extract "name" |
135 | 1b2cb110 | Iustin Pop | apol <- extract "alloc_policy" |
136 | 6cff91f5 | Iustin Pop | ipol <- extract "ipolicy" |
137 | 6b6e335b | Dato Simó | tags <- extract "tags" |
138 | 6b6e335b | Dato Simó | return (u, Group.create name u apol ipol tags) |
139 | a679e9dc | Iustin Pop | |
140 | 9188aeef | Iustin Pop | -- | Top-level parser. |
141 | 96a12113 | Iustin Pop | -- |
142 | 96a12113 | Iustin Pop | -- The result is a tuple of eventual warning messages and the parsed |
143 | 96a12113 | Iustin Pop | -- request; if parsing the input data fails, we'll return a 'Bad' |
144 | 96a12113 | Iustin Pop | -- value. |
145 | ef947a42 | Dato Simó | parseData :: ClockTime -- ^ The current time |
146 | ef947a42 | Dato Simó | -> String -- ^ The JSON message as received from Ganeti |
147 | 96a12113 | Iustin Pop | -> Result ([String], Request) -- ^ Result tuple |
148 | ef947a42 | Dato Simó | parseData now body = do |
149 | c96d44df | Iustin Pop | decoded <- fromJResult "Parsing input IAllocator message" (decodeStrict body) |
150 | 262f3e6c | Iustin Pop | let obj = fromJSObject decoded |
151 | e8230242 | Iustin Pop | extrObj x = tryFromObj "invalid iallocator message" obj x |
152 | e4c5beaf | Iustin Pop | -- request parser |
153 | e8230242 | Iustin Pop | request <- liftM fromJSObject (extrObj "request") |
154 | 2a9aff11 | René Nussbaumer | let extrFromReq r x = tryFromObj "invalid request dict" r x |
155 | 2a9aff11 | René Nussbaumer | let extrReq x = extrFromReq request x |
156 | a679e9dc | Iustin Pop | -- existing group parsing |
157 | e8230242 | Iustin Pop | glist <- liftM fromJSObject (extrObj "nodegroups") |
158 | a679e9dc | Iustin Pop | gobj <- mapM (\(x, y) -> asJSObject y >>= parseGroup x . fromJSObject) glist |
159 | 10ef6b4e | Iustin Pop | let (ktg, gl) = assignIndices gobj |
160 | e4c5beaf | Iustin Pop | -- existing node parsing |
161 | e8230242 | Iustin Pop | nlist <- liftM fromJSObject (extrObj "nodes") |
162 | 10ef6b4e | Iustin Pop | nobj <- mapM (\(x,y) -> |
163 | 10ef6b4e | Iustin Pop | asJSObject y >>= parseNode ktg x . fromJSObject) nlist |
164 | 497e30a1 | Iustin Pop | let (ktn, nl) = assignIndices nobj |
165 | e4c5beaf | Iustin Pop | -- existing instance parsing |
166 | e8230242 | Iustin Pop | ilist <- extrObj "instances" |
167 | e4c5beaf | Iustin Pop | let idata = fromJSObject ilist |
168 | 262f3e6c | Iustin Pop | iobj <- mapM (\(x,y) -> |
169 | 262f3e6c | Iustin Pop | asJSObject y >>= parseInstance ktn x . fromJSObject) idata |
170 | 88df1fa9 | Iustin Pop | let (kti, il) = assignIndices iobj |
171 | 669ea132 | Iustin Pop | -- cluster tags |
172 | e8230242 | Iustin Pop | ctags <- extrObj "cluster_tags" |
173 | ef947a42 | Dato Simó | cdata1 <- mergeData [] [] [] [] now (ClusterData gl nl il ctags defIPolicy) |
174 | 96a12113 | Iustin Pop | let (msgs, fix_nl) = checkData (cdNodes cdata1) (cdInstances cdata1) |
175 | 96a12113 | Iustin Pop | cdata = cdata1 { cdNodes = fix_nl } |
176 | 88df1fa9 | Iustin Pop | map_n = cdNodes cdata |
177 | 695c1bab | Iustin Pop | map_i = cdInstances cdata |
178 | 695c1bab | Iustin Pop | map_g = cdGroups cdata |
179 | e8230242 | Iustin Pop | optype <- extrReq "type" |
180 | e4c5beaf | Iustin Pop | rqtype <- |
181 | 00dd69a2 | Iustin Pop | case () of |
182 | 00dd69a2 | Iustin Pop | _ | optype == C.iallocatorModeAlloc -> |
183 | 00dd69a2 | Iustin Pop | do |
184 | 00dd69a2 | Iustin Pop | rname <- extrReq "name" |
185 | 00dd69a2 | Iustin Pop | req_nodes <- extrReq "required_nodes" |
186 | 00dd69a2 | Iustin Pop | inew <- parseBaseInstance rname request |
187 | 00dd69a2 | Iustin Pop | let io = snd inew |
188 | 00dd69a2 | Iustin Pop | return $ Allocate io req_nodes |
189 | 00dd69a2 | Iustin Pop | | optype == C.iallocatorModeReloc -> |
190 | 00dd69a2 | Iustin Pop | do |
191 | 00dd69a2 | Iustin Pop | rname <- extrReq "name" |
192 | 00dd69a2 | Iustin Pop | ridx <- lookupInstance kti rname |
193 | 00dd69a2 | Iustin Pop | req_nodes <- extrReq "required_nodes" |
194 | 00dd69a2 | Iustin Pop | ex_nodes <- extrReq "relocate_from" |
195 | 00dd69a2 | Iustin Pop | ex_idex <- mapM (Container.findByName map_n) ex_nodes |
196 | 00dd69a2 | Iustin Pop | return $ Relocate ridx req_nodes (map Node.idx ex_idex) |
197 | 00dd69a2 | Iustin Pop | | optype == C.iallocatorModeChgGroup -> |
198 | 00dd69a2 | Iustin Pop | do |
199 | 00dd69a2 | Iustin Pop | rl_names <- extrReq "instances" |
200 | 00dd69a2 | Iustin Pop | rl_insts <- mapM (liftM Instance.idx . |
201 | 00dd69a2 | Iustin Pop | Container.findByName map_i) rl_names |
202 | 00dd69a2 | Iustin Pop | gr_uuids <- extrReq "target_groups" |
203 | 00dd69a2 | Iustin Pop | gr_idxes <- mapM (liftM Group.idx . |
204 | 00dd69a2 | Iustin Pop | Container.findByName map_g) gr_uuids |
205 | 00dd69a2 | Iustin Pop | return $ ChangeGroup rl_insts gr_idxes |
206 | 00dd69a2 | Iustin Pop | | optype == C.iallocatorModeNodeEvac -> |
207 | 00dd69a2 | Iustin Pop | do |
208 | 00dd69a2 | Iustin Pop | rl_names <- extrReq "instances" |
209 | 00dd69a2 | Iustin Pop | rl_insts <- mapM (Container.findByName map_i) rl_names |
210 | 00dd69a2 | Iustin Pop | let rl_idx = map Instance.idx rl_insts |
211 | 00dd69a2 | Iustin Pop | rl_mode <- extrReq "evac_mode" |
212 | 00dd69a2 | Iustin Pop | return $ NodeEvacuate rl_idx rl_mode |
213 | 2a9aff11 | René Nussbaumer | | optype == C.iallocatorModeMultiAlloc -> |
214 | 2a9aff11 | René Nussbaumer | do |
215 | 2a9aff11 | René Nussbaumer | arry <- extrReq "instances" :: Result [JSObject JSValue] |
216 | 2a9aff11 | René Nussbaumer | let inst_reqs = map fromJSObject arry |
217 | 2a9aff11 | René Nussbaumer | prqs <- mapM (\r -> |
218 | 2a9aff11 | René Nussbaumer | do |
219 | 2a9aff11 | René Nussbaumer | rname <- extrFromReq r "name" |
220 | 2a9aff11 | René Nussbaumer | req_nodes <- extrFromReq r "required_nodes" |
221 | 2a9aff11 | René Nussbaumer | inew <- parseBaseInstance rname r |
222 | 2a9aff11 | René Nussbaumer | let io = snd inew |
223 | 2a9aff11 | René Nussbaumer | return (io, req_nodes)) inst_reqs |
224 | 2a9aff11 | René Nussbaumer | return $ MultiAllocate prqs |
225 | 00dd69a2 | Iustin Pop | | otherwise -> fail ("Invalid request type '" ++ optype ++ "'") |
226 | 1b0a6356 | Iustin Pop | return (msgs, Request rqtype cdata) |
227 | 942403e6 | Iustin Pop | |
228 | d6cf394e | Iustin Pop | -- | Formats the result into a valid IAllocator response message. |
229 | 9188aeef | Iustin Pop | formatResponse :: Bool -- ^ Whether the request was successful |
230 | 9188aeef | Iustin Pop | -> String -- ^ Information text |
231 | d6cf394e | Iustin Pop | -> JSValue -- ^ The JSON encoded result |
232 | d6cf394e | Iustin Pop | -> String -- ^ The full JSON-formatted message |
233 | d6cf394e | Iustin Pop | formatResponse success info result = |
234 | 00dd69a2 | Iustin Pop | let e_success = ("success", showJSON success) |
235 | 00dd69a2 | Iustin Pop | e_info = ("info", showJSON info) |
236 | 00dd69a2 | Iustin Pop | e_result = ("result", result) |
237 | 00dd69a2 | Iustin Pop | in encodeStrict $ makeObj [e_success, e_info, e_result] |
238 | cabce2f4 | Iustin Pop | |
239 | 7c14b50a | Iustin Pop | -- | Flatten the log of a solution into a string. |
240 | 7c14b50a | Iustin Pop | describeSolution :: Cluster.AllocSolution -> String |
241 | 7c14b50a | Iustin Pop | describeSolution = intercalate ", " . Cluster.asLog |
242 | cabce2f4 | Iustin Pop | |
243 | 7c14b50a | Iustin Pop | -- | Convert allocation/relocation results into the result format. |
244 | f9283686 | Iustin Pop | formatAllocate :: Instance.List -> Cluster.AllocSolution -> Result IAllocResult |
245 | f9283686 | Iustin Pop | formatAllocate il as = do |
246 | 7c14b50a | Iustin Pop | let info = describeSolution as |
247 | 129734d3 | Iustin Pop | case Cluster.asSolution as of |
248 | 129734d3 | Iustin Pop | Nothing -> fail info |
249 | 129734d3 | Iustin Pop | Just (nl, inst, nodes, _) -> |
250 | 00dd69a2 | Iustin Pop | do |
251 | 00dd69a2 | Iustin Pop | let il' = Container.add (Instance.idx inst) inst il |
252 | 00dd69a2 | Iustin Pop | return (info, showJSON $ map Node.name nodes, nl, il') |
253 | cabce2f4 | Iustin Pop | |
254 | 2a9aff11 | René Nussbaumer | -- | Convert multi allocation results into the result format. |
255 | 2a9aff11 | René Nussbaumer | formatMultiAlloc :: (Node.List, Instance.List, Cluster.AllocSolutionList) |
256 | 2a9aff11 | René Nussbaumer | -> Result IAllocResult |
257 | 2a9aff11 | René Nussbaumer | formatMultiAlloc (fin_nl, fin_il, ars) = |
258 | 2a9aff11 | René Nussbaumer | let rars = reverse ars |
259 | 2a9aff11 | René Nussbaumer | (allocated, failed) = partition (isJust . Cluster.asSolution . snd) rars |
260 | 2a9aff11 | René Nussbaumer | aars = map (\(_, ar) -> |
261 | 2a9aff11 | René Nussbaumer | let (_, inst, nodes, _) = fromJust $ Cluster.asSolution ar |
262 | 2a9aff11 | René Nussbaumer | iname = Instance.name inst |
263 | 2a9aff11 | René Nussbaumer | nnames = map Node.name nodes |
264 | 2a9aff11 | René Nussbaumer | in (iname, nnames)) allocated |
265 | 2a9aff11 | René Nussbaumer | fars = map (\(inst, ar) -> |
266 | 2a9aff11 | René Nussbaumer | let iname = Instance.name inst |
267 | 2a9aff11 | René Nussbaumer | in (iname, describeSolution ar)) failed |
268 | 2a9aff11 | René Nussbaumer | info = show (length failed) ++ " instances failed to allocate and " ++ |
269 | 2a9aff11 | René Nussbaumer | show (length allocated) ++ " were allocated successfully" |
270 | 2a9aff11 | René Nussbaumer | in return (info, showJSON (aars, fars), fin_nl, fin_il) |
271 | 2a9aff11 | René Nussbaumer | |
272 | 47eed3f4 | Iustin Pop | -- | Convert a node-evacuation/change group result. |
273 | 5440c877 | Iustin Pop | formatNodeEvac :: Group.List |
274 | 5440c877 | Iustin Pop | -> Node.List |
275 | 5440c877 | Iustin Pop | -> Instance.List |
276 | 4036f63a | Iustin Pop | -> (Node.List, Instance.List, Cluster.EvacSolution) |
277 | 5440c877 | Iustin Pop | -> Result IAllocResult |
278 | f9283686 | Iustin Pop | formatNodeEvac gl nl il (fin_nl, fin_il, es) = |
279 | 00dd69a2 | Iustin Pop | let iname = Instance.name . flip Container.find il |
280 | 00dd69a2 | Iustin Pop | nname = Node.name . flip Container.find nl |
281 | 00dd69a2 | Iustin Pop | gname = Group.name . flip Container.find gl |
282 | 00dd69a2 | Iustin Pop | fes = map (\(idx, msg) -> (iname idx, msg)) $ Cluster.esFailed es |
283 | 00dd69a2 | Iustin Pop | mes = map (\(idx, gdx, ndxs) -> (iname idx, gname gdx, map nname ndxs)) |
284 | 00dd69a2 | Iustin Pop | $ Cluster.esMoved es |
285 | 00dd69a2 | Iustin Pop | failed = length fes |
286 | 00dd69a2 | Iustin Pop | moved = length mes |
287 | 00dd69a2 | Iustin Pop | info = show failed ++ " instances failed to move and " ++ show moved ++ |
288 | 00dd69a2 | Iustin Pop | " were moved successfully" |
289 | 00dd69a2 | Iustin Pop | in Ok (info, showJSON (mes, fes, Cluster.esOpCodes es), fin_nl, fin_il) |
290 | 47eed3f4 | Iustin Pop | |
291 | 88df1fa9 | Iustin Pop | -- | Runs relocate for a single instance. |
292 | 88df1fa9 | Iustin Pop | -- |
293 | 88df1fa9 | Iustin Pop | -- This is wrapper over the 'Cluster.tryNodeEvac' function that is run |
294 | 88df1fa9 | Iustin Pop | -- with a single instance (ours), and further it checks that the |
295 | 88df1fa9 | Iustin Pop | -- result it got (in the nodes field) is actually consistent, as |
296 | 88df1fa9 | Iustin Pop | -- tryNodeEvac is designed to output primarily an opcode list, not a |
297 | 88df1fa9 | Iustin Pop | -- node list. |
298 | 88df1fa9 | Iustin Pop | processRelocate :: Group.List -- ^ The group list |
299 | 88df1fa9 | Iustin Pop | -> Node.List -- ^ The node list |
300 | 88df1fa9 | Iustin Pop | -> Instance.List -- ^ The instance list |
301 | 88df1fa9 | Iustin Pop | -> Idx -- ^ The index of the instance to move |
302 | 88df1fa9 | Iustin Pop | -> Int -- ^ The number of nodes required |
303 | 88df1fa9 | Iustin Pop | -> [Ndx] -- ^ Nodes which should not be used |
304 | 88df1fa9 | Iustin Pop | -> Result (Node.List, Instance.List, [Ndx]) -- ^ Solution list |
305 | 88df1fa9 | Iustin Pop | processRelocate gl nl il idx 1 exndx = do |
306 | 88df1fa9 | Iustin Pop | let orig = Container.find idx il |
307 | 88df1fa9 | Iustin Pop | sorig = Instance.sNode orig |
308 | 3d7d3a1f | Iustin Pop | porig = Instance.pNode orig |
309 | fafd0773 | Iustin Pop | mir_type = Instance.mirrorType orig |
310 | 3d7d3a1f | Iustin Pop | (exp_node, node_type, reloc_type) <- |
311 | 3d7d3a1f | Iustin Pop | case mir_type of |
312 | 3d7d3a1f | Iustin Pop | MirrorNone -> fail "Can't relocate non-mirrored instances" |
313 | 3d7d3a1f | Iustin Pop | MirrorInternal -> return (sorig, "secondary", ChangeSecondary) |
314 | 3d7d3a1f | Iustin Pop | MirrorExternal -> return (porig, "primary", ChangePrimary) |
315 | 2cdaf225 | Iustin Pop | when (exndx /= [exp_node]) . |
316 | 88df1fa9 | Iustin Pop | -- FIXME: we can't use the excluded nodes here; the logic is |
317 | 88df1fa9 | Iustin Pop | -- already _but only partially_ implemented in tryNodeEvac... |
318 | 88df1fa9 | Iustin Pop | fail $ "Unsupported request: excluded nodes not equal to\ |
319 | 3d7d3a1f | Iustin Pop | \ instance's " ++ node_type ++ "(" ++ show exp_node |
320 | 3d7d3a1f | Iustin Pop | ++ " versus " ++ show exndx ++ ")" |
321 | 3d7d3a1f | Iustin Pop | (nl', il', esol) <- Cluster.tryNodeEvac gl nl il reloc_type [idx] |
322 | 88df1fa9 | Iustin Pop | nodes <- case lookup idx (Cluster.esFailed esol) of |
323 | 88df1fa9 | Iustin Pop | Just msg -> fail msg |
324 | 88df1fa9 | Iustin Pop | Nothing -> |
325 | 88df1fa9 | Iustin Pop | case lookup idx (map (\(a, _, b) -> (a, b)) |
326 | 88df1fa9 | Iustin Pop | (Cluster.esMoved esol)) of |
327 | 88df1fa9 | Iustin Pop | Nothing -> |
328 | 88df1fa9 | Iustin Pop | fail "Internal error: lost instance idx during move" |
329 | 88df1fa9 | Iustin Pop | Just n -> return n |
330 | 88df1fa9 | Iustin Pop | let inst = Container.find idx il' |
331 | 88df1fa9 | Iustin Pop | pnode = Instance.pNode inst |
332 | 88df1fa9 | Iustin Pop | snode = Instance.sNode inst |
333 | 3d7d3a1f | Iustin Pop | nodes' <- |
334 | 3d7d3a1f | Iustin Pop | case mir_type of |
335 | 3d7d3a1f | Iustin Pop | MirrorNone -> fail "Internal error: mirror type none after relocation?!" |
336 | 3d7d3a1f | Iustin Pop | MirrorInternal -> |
337 | 3d7d3a1f | Iustin Pop | do |
338 | 3d7d3a1f | Iustin Pop | when (snode == sorig) $ |
339 | 3d7d3a1f | Iustin Pop | fail "Internal error: instance didn't change secondary node?!" |
340 | 3d7d3a1f | Iustin Pop | when (snode == pnode) $ |
341 | 3d7d3a1f | Iustin Pop | fail "Internal error: selected primary as new secondary?!" |
342 | 3d7d3a1f | Iustin Pop | if nodes == [pnode, snode] |
343 | 88df1fa9 | Iustin Pop | then return [snode] -- only the new secondary is needed |
344 | 88df1fa9 | Iustin Pop | else fail $ "Internal error: inconsistent node list (" ++ |
345 | 88df1fa9 | Iustin Pop | show nodes ++ ") versus instance nodes (" ++ show pnode ++ |
346 | 88df1fa9 | Iustin Pop | "," ++ show snode ++ ")" |
347 | 3d7d3a1f | Iustin Pop | MirrorExternal -> |
348 | 3d7d3a1f | Iustin Pop | do |
349 | 3d7d3a1f | Iustin Pop | when (pnode == porig) $ |
350 | 3d7d3a1f | Iustin Pop | fail "Internal error: instance didn't change primary node?!" |
351 | 3d7d3a1f | Iustin Pop | if nodes == [pnode] |
352 | 3d7d3a1f | Iustin Pop | then return nodes |
353 | 3d7d3a1f | Iustin Pop | else fail $ "Internal error: inconsistent node list (" ++ |
354 | 3d7d3a1f | Iustin Pop | show nodes ++ ") versus instance node (" ++ show pnode ++ ")" |
355 | 88df1fa9 | Iustin Pop | return (nl', il', nodes') |
356 | 88df1fa9 | Iustin Pop | |
357 | 88df1fa9 | Iustin Pop | processRelocate _ _ _ _ reqn _ = |
358 | 88df1fa9 | Iustin Pop | fail $ "Exchange " ++ show reqn ++ " nodes mode is not implemented" |
359 | 88df1fa9 | Iustin Pop | |
360 | 88df1fa9 | Iustin Pop | formatRelocate :: (Node.List, Instance.List, [Ndx]) |
361 | 88df1fa9 | Iustin Pop | -> Result IAllocResult |
362 | 88df1fa9 | Iustin Pop | formatRelocate (nl, il, ndxs) = |
363 | 00dd69a2 | Iustin Pop | let nodes = map (`Container.find` nl) ndxs |
364 | 00dd69a2 | Iustin Pop | names = map Node.name nodes |
365 | 00dd69a2 | Iustin Pop | in Ok ("success", showJSON names, nl, il) |
366 | 88df1fa9 | Iustin Pop | |
367 | 179c0828 | Iustin Pop | -- | Process a request and return new node lists. |
368 | 7c14b50a | Iustin Pop | processRequest :: Request -> Result IAllocResult |
369 | cabce2f4 | Iustin Pop | processRequest request = |
370 | 71375ef7 | Iustin Pop | let Request rqtype (ClusterData gl nl il _ _) = request |
371 | cabce2f4 | Iustin Pop | in case rqtype of |
372 | 7c14b50a | Iustin Pop | Allocate xi reqn -> |
373 | 00dd69a2 | Iustin Pop | Cluster.tryMGAlloc gl nl il xi reqn >>= formatAllocate il |
374 | 88df1fa9 | Iustin Pop | Relocate idx reqn exnodes -> |
375 | 00dd69a2 | Iustin Pop | processRelocate gl nl il idx reqn exnodes >>= formatRelocate |
376 | 20b376ff | Iustin Pop | ChangeGroup gdxs idxs -> |
377 | 00dd69a2 | Iustin Pop | Cluster.tryChangeGroup gl nl il idxs gdxs >>= |
378 | 00dd69a2 | Iustin Pop | formatNodeEvac gl nl il |
379 | 47eed3f4 | Iustin Pop | NodeEvacuate xi mode -> |
380 | 00dd69a2 | Iustin Pop | Cluster.tryNodeEvac gl nl il mode xi >>= |
381 | 00dd69a2 | Iustin Pop | formatNodeEvac gl nl il |
382 | 2a9aff11 | René Nussbaumer | MultiAllocate xies -> |
383 | 2a9aff11 | René Nussbaumer | Cluster.allocList gl nl il xies [] >>= formatMultiAlloc |
384 | cabce2f4 | Iustin Pop | |
385 | 179c0828 | Iustin Pop | -- | Reads the request from the data file(s). |
386 | c3f8cb12 | René Nussbaumer | readRequest :: FilePath -> IO Request |
387 | c3f8cb12 | René Nussbaumer | readRequest fp = do |
388 | ef947a42 | Dato Simó | now <- getClockTime |
389 | f183de56 | Iustin Pop | input_data <- case fp of |
390 | f183de56 | Iustin Pop | "-" -> getContents |
391 | f183de56 | Iustin Pop | _ -> readFile fp |
392 | ef947a42 | Dato Simó | case parseData now input_data of |
393 | 707cd3d7 | Helga Velroyen | Bad err -> exitErr err |
394 | c3f8cb12 | René Nussbaumer | Ok (fix_msgs, rq) -> maybeShowWarnings fix_msgs >> return rq |
395 | 00152519 | Iustin Pop | |
396 | 00152519 | Iustin Pop | -- | Main iallocator pipeline. |
397 | f9283686 | Iustin Pop | runIAllocator :: Request -> (Maybe (Node.List, Instance.List), String) |
398 | 00152519 | Iustin Pop | runIAllocator request = |
399 | f9283686 | Iustin Pop | let (ok, info, result, cdata) = |
400 | 00dd69a2 | Iustin Pop | case processRequest request of |
401 | 00dd69a2 | Iustin Pop | Ok (msg, r, nl, il) -> (True, "Request successful: " ++ msg, r, |
402 | 00dd69a2 | Iustin Pop | Just (nl, il)) |
403 | 00dd69a2 | Iustin Pop | Bad msg -> (False, "Request failed: " ++ msg, JSArray [], Nothing) |
404 | ce6a0b53 | Iustin Pop | rstring = formatResponse ok info result |
405 | f9283686 | Iustin Pop | in (cdata, rstring) |
406 | 786c514c | René Nussbaumer | |
407 | 786c514c | René Nussbaumer | -- | Load the data from an iallocation request file |
408 | 786c514c | René Nussbaumer | loadData :: FilePath -- ^ The path to the file |
409 | 786c514c | René Nussbaumer | -> IO (Result ClusterData) |
410 | 786c514c | René Nussbaumer | loadData fp = do |
411 | 786c514c | René Nussbaumer | Request _ cdata <- readRequest fp |
412 | 786c514c | René Nussbaumer | return $ Ok cdata |