root / htools / Ganeti / HTools / IAlloc.hs @ 2e5eb96a
History | View | Annotate | Download (7.7 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 | e8230242 | Iustin Pop | Copyright (C) 2009, 2010, 2011 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 | 43643696 | Iustin Pop | module Ganeti.HTools.IAlloc |
27 | 19f38ee8 | Iustin Pop | ( parseData |
28 | 43643696 | Iustin Pop | , formatResponse |
29 | 43643696 | Iustin Pop | ) where |
30 | 43643696 | Iustin Pop | |
31 | 43643696 | Iustin Pop | import Data.Either () |
32 | 3eeea90f | Iustin Pop | import Data.Maybe (fromMaybe) |
33 | 43643696 | Iustin Pop | import Control.Monad |
34 | 942403e6 | Iustin Pop | import Text.JSON (JSObject, JSValue(JSBool, JSString, JSArray), |
35 | 942403e6 | Iustin Pop | makeObj, encodeStrict, decodeStrict, |
36 | 942403e6 | Iustin Pop | fromJSObject, toJSString) |
37 | 262a08a2 | Iustin Pop | import qualified Ganeti.HTools.Container as Container |
38 | a679e9dc | Iustin Pop | import qualified Ganeti.HTools.Group as Group |
39 | 942403e6 | Iustin Pop | import qualified Ganeti.HTools.Node as Node |
40 | 942403e6 | Iustin Pop | import qualified Ganeti.HTools.Instance as Instance |
41 | df5227dc | Iustin Pop | import qualified Ganeti.Constants as C |
42 | e4c5beaf | Iustin Pop | import Ganeti.HTools.Loader |
43 | e4c5beaf | Iustin Pop | import Ganeti.HTools.Utils |
44 | e4c5beaf | Iustin Pop | import Ganeti.HTools.Types |
45 | 43643696 | Iustin Pop | |
46 | 9188aeef | Iustin Pop | -- | Parse the basic specifications of an instance. |
47 | 9188aeef | Iustin Pop | -- |
48 | 9188aeef | Iustin Pop | -- Instances in the cluster instance list and the instance in an |
49 | 9188aeef | Iustin Pop | -- 'Allocate' request share some common properties, which are read by |
50 | 9188aeef | Iustin Pop | -- this function. |
51 | e4c5beaf | Iustin Pop | parseBaseInstance :: String |
52 | 262f3e6c | Iustin Pop | -> [(String, JSValue)] |
53 | e4c5beaf | Iustin Pop | -> Result (String, Instance.Instance) |
54 | e4c5beaf | Iustin Pop | parseBaseInstance n a = do |
55 | e8230242 | Iustin Pop | let extract x = tryFromObj ("invalid data for instance '" ++ n ++ "'") a x |
56 | e8230242 | Iustin Pop | disk <- extract "disk_space_total" |
57 | e8230242 | Iustin Pop | mem <- extract "memory" |
58 | e8230242 | Iustin Pop | vcpus <- extract "vcpus" |
59 | e8230242 | Iustin Pop | tags <- extract "tags" |
60 | e4c5beaf | Iustin Pop | let running = "running" |
61 | c352b0a9 | Iustin Pop | return (n, Instance.create n mem disk vcpus running tags True 0 0) |
62 | 585d4420 | Iustin Pop | |
63 | 262f3e6c | Iustin Pop | -- | Parses an instance as found in the cluster instance listg. |
64 | 9188aeef | Iustin Pop | parseInstance :: NameAssoc -- ^ The node name-to-index association list |
65 | 9188aeef | Iustin Pop | -> String -- ^ The name of the instance |
66 | 262f3e6c | Iustin Pop | -> [(String, JSValue)] -- ^ The JSON object |
67 | e4c5beaf | Iustin Pop | -> Result (String, Instance.Instance) |
68 | e4c5beaf | Iustin Pop | parseInstance ktn n a = do |
69 | 262f3e6c | Iustin Pop | base <- parseBaseInstance n a |
70 | e8230242 | Iustin Pop | nodes <- fromObj a "nodes" |
71 | e41f4ba0 | Iustin Pop | pnode <- if null nodes |
72 | e41f4ba0 | Iustin Pop | then Bad $ "empty node list for instance " ++ n |
73 | e41f4ba0 | Iustin Pop | else readEitherString $ head nodes |
74 | 262f3e6c | Iustin Pop | pidx <- lookupNode ktn n pnode |
75 | 262f3e6c | Iustin Pop | let snodes = tail nodes |
76 | 262f3e6c | Iustin Pop | sidx <- (if null snodes then return Node.noSecondary |
77 | 262f3e6c | Iustin Pop | else readEitherString (head snodes) >>= lookupNode ktn n) |
78 | 262f3e6c | Iustin Pop | return (n, Instance.setBoth (snd base) pidx sidx) |
79 | 585d4420 | Iustin Pop | |
80 | 9188aeef | Iustin Pop | -- | Parses a node as found in the cluster node list. |
81 | 10ef6b4e | Iustin Pop | parseNode :: NameAssoc -- ^ The group association |
82 | 10ef6b4e | Iustin Pop | -> String -- ^ The node's name |
83 | 262f3e6c | Iustin Pop | -> [(String, JSValue)] -- ^ The JSON object |
84 | 9188aeef | Iustin Pop | -> Result (String, Node.Node) |
85 | 10ef6b4e | Iustin Pop | parseNode ktg n a = do |
86 | 3eeea90f | Iustin Pop | let desc = "invalid data for node '" ++ n ++ "'" |
87 | 3eeea90f | Iustin Pop | extract x = tryFromObj desc a x |
88 | e8230242 | Iustin Pop | offline <- extract "offline" |
89 | e8230242 | Iustin Pop | drained <- extract "drained" |
90 | e8230242 | Iustin Pop | guuid <- extract "group" |
91 | 3eeea90f | Iustin Pop | vm_capable <- annotateResult desc $ maybeFromObj a "vm_capable" |
92 | 3eeea90f | Iustin Pop | let vm_capable' = fromMaybe True vm_capable |
93 | 10ef6b4e | Iustin Pop | gidx <- lookupGroup ktg n guuid |
94 | 3eeea90f | Iustin Pop | node <- (if offline || drained || not vm_capable' |
95 | 10ef6b4e | Iustin Pop | then return $ Node.create n 0 0 0 0 0 0 True gidx |
96 | 262f3e6c | Iustin Pop | else do |
97 | e8230242 | Iustin Pop | mtotal <- extract "total_memory" |
98 | e8230242 | Iustin Pop | mnode <- extract "reserved_memory" |
99 | e8230242 | Iustin Pop | mfree <- extract "free_memory" |
100 | e8230242 | Iustin Pop | dtotal <- extract "total_disk" |
101 | e8230242 | Iustin Pop | dfree <- extract "free_disk" |
102 | e8230242 | Iustin Pop | ctotal <- extract "total_cpus" |
103 | 262f3e6c | Iustin Pop | return $ Node.create n mtotal mnode mfree |
104 | 10ef6b4e | Iustin Pop | dtotal dfree ctotal False gidx) |
105 | 262f3e6c | Iustin Pop | return (n, node) |
106 | 144f190b | Iustin Pop | |
107 | a679e9dc | Iustin Pop | -- | Parses a group as found in the cluster group list. |
108 | a679e9dc | Iustin Pop | parseGroup :: String -- ^ The group UUID |
109 | a679e9dc | Iustin Pop | -> [(String, JSValue)] -- ^ The JSON object |
110 | a679e9dc | Iustin Pop | -> Result (String, Group.Group) |
111 | a679e9dc | Iustin Pop | parseGroup u a = do |
112 | 1b2cb110 | Iustin Pop | let extract x = tryFromObj ("invalid data for group '" ++ u ++ "'") a x |
113 | 1b2cb110 | Iustin Pop | name <- extract "name" |
114 | 1b2cb110 | Iustin Pop | apol <- extract "alloc_policy" |
115 | 1b2cb110 | Iustin Pop | return (u, Group.create name u apol) |
116 | a679e9dc | Iustin Pop | |
117 | 9188aeef | Iustin Pop | -- | Top-level parser. |
118 | 9188aeef | Iustin Pop | parseData :: String -- ^ The JSON message as received from Ganeti |
119 | 9188aeef | Iustin Pop | -> Result Request -- ^ A (possible valid) request |
120 | e4c5beaf | Iustin Pop | parseData body = do |
121 | c96d44df | Iustin Pop | decoded <- fromJResult "Parsing input IAllocator message" (decodeStrict body) |
122 | 262f3e6c | Iustin Pop | let obj = fromJSObject decoded |
123 | e8230242 | Iustin Pop | extrObj x = tryFromObj "invalid iallocator message" obj x |
124 | e4c5beaf | Iustin Pop | -- request parser |
125 | e8230242 | Iustin Pop | request <- liftM fromJSObject (extrObj "request") |
126 | e8230242 | Iustin Pop | let extrReq x = tryFromObj "invalid request dict" request x |
127 | a679e9dc | Iustin Pop | -- existing group parsing |
128 | e8230242 | Iustin Pop | glist <- liftM fromJSObject (extrObj "nodegroups") |
129 | a679e9dc | Iustin Pop | gobj <- mapM (\(x, y) -> asJSObject y >>= parseGroup x . fromJSObject) glist |
130 | 10ef6b4e | Iustin Pop | let (ktg, gl) = assignIndices gobj |
131 | e4c5beaf | Iustin Pop | -- existing node parsing |
132 | e8230242 | Iustin Pop | nlist <- liftM fromJSObject (extrObj "nodes") |
133 | 10ef6b4e | Iustin Pop | nobj <- mapM (\(x,y) -> |
134 | 10ef6b4e | Iustin Pop | asJSObject y >>= parseNode ktg x . fromJSObject) nlist |
135 | 497e30a1 | Iustin Pop | let (ktn, nl) = assignIndices nobj |
136 | e4c5beaf | Iustin Pop | -- existing instance parsing |
137 | e8230242 | Iustin Pop | ilist <- extrObj "instances" |
138 | e4c5beaf | Iustin Pop | let idata = fromJSObject ilist |
139 | 262f3e6c | Iustin Pop | iobj <- mapM (\(x,y) -> |
140 | 262f3e6c | Iustin Pop | asJSObject y >>= parseInstance ktn x . fromJSObject) idata |
141 | 497e30a1 | Iustin Pop | let (kti, il) = assignIndices iobj |
142 | 669ea132 | Iustin Pop | -- cluster tags |
143 | e8230242 | Iustin Pop | ctags <- extrObj "cluster_tags" |
144 | f4f6eb0b | Iustin Pop | cdata <- mergeData [] [] [] (ClusterData gl nl il ctags) |
145 | 017a0c3d | Iustin Pop | let map_n = cdNodes cdata |
146 | e8230242 | Iustin Pop | optype <- extrReq "type" |
147 | e4c5beaf | Iustin Pop | rqtype <- |
148 | df5227dc | Iustin Pop | case () of |
149 | df5227dc | Iustin Pop | _ | optype == C.iallocatorModeAlloc -> |
150 | df5227dc | Iustin Pop | do |
151 | df5227dc | Iustin Pop | rname <- extrReq "name" |
152 | df5227dc | Iustin Pop | req_nodes <- extrReq "required_nodes" |
153 | df5227dc | Iustin Pop | inew <- parseBaseInstance rname request |
154 | df5227dc | Iustin Pop | let io = snd inew |
155 | df5227dc | Iustin Pop | return $ Allocate io req_nodes |
156 | df5227dc | Iustin Pop | | optype == C.iallocatorModeReloc -> |
157 | df5227dc | Iustin Pop | do |
158 | df5227dc | Iustin Pop | rname <- extrReq "name" |
159 | df5227dc | Iustin Pop | ridx <- lookupInstance kti rname |
160 | df5227dc | Iustin Pop | req_nodes <- extrReq "required_nodes" |
161 | df5227dc | Iustin Pop | ex_nodes <- extrReq "relocate_from" |
162 | df5227dc | Iustin Pop | ex_idex <- mapM (Container.findByName map_n) ex_nodes |
163 | df5227dc | Iustin Pop | return $ Relocate ridx req_nodes (map Node.idx ex_idex) |
164 | df5227dc | Iustin Pop | | optype == C.iallocatorModeMevac -> |
165 | df5227dc | Iustin Pop | do |
166 | df5227dc | Iustin Pop | ex_names <- extrReq "evac_nodes" |
167 | df5227dc | Iustin Pop | ex_nodes <- mapM (Container.findByName map_n) ex_names |
168 | df5227dc | Iustin Pop | let ex_ndx = map Node.idx ex_nodes |
169 | df5227dc | Iustin Pop | return $ Evacuate ex_ndx |
170 | df5227dc | Iustin Pop | | otherwise -> fail ("Invalid request type '" ++ optype ++ "'") |
171 | 017a0c3d | Iustin Pop | return $ Request rqtype cdata |
172 | 942403e6 | Iustin Pop | |
173 | e41f4ba0 | Iustin Pop | -- | Format the result |
174 | 3e4480e0 | Iustin Pop | formatRVal :: RqType -> [Node.AllocElement] -> JSValue |
175 | 3e4480e0 | Iustin Pop | formatRVal _ [] = JSArray [] |
176 | e41f4ba0 | Iustin Pop | |
177 | 3e4480e0 | Iustin Pop | formatRVal (Evacuate _) elems = |
178 | 7d3f4253 | Iustin Pop | let sols = map (\(_, inst, nl, _) -> Instance.name inst : map Node.name nl) |
179 | 3e4480e0 | Iustin Pop | elems |
180 | 54365762 | Iustin Pop | jsols = map (JSArray . map (JSString . toJSString)) sols |
181 | 54365762 | Iustin Pop | in JSArray jsols |
182 | 54365762 | Iustin Pop | |
183 | 3e4480e0 | Iustin Pop | formatRVal _ elems = |
184 | 7d3f4253 | Iustin Pop | let (_, _, nodes, _) = head elems |
185 | 3e4480e0 | Iustin Pop | nodes' = map Node.name nodes |
186 | 54365762 | Iustin Pop | in JSArray $ map (JSString . toJSString) nodes' |
187 | 54365762 | Iustin Pop | |
188 | 9188aeef | Iustin Pop | -- | Formats the response into a valid IAllocator response message. |
189 | 9188aeef | Iustin Pop | formatResponse :: Bool -- ^ Whether the request was successful |
190 | 9188aeef | Iustin Pop | -> String -- ^ Information text |
191 | 54365762 | Iustin Pop | -> RqType -- ^ Request type |
192 | 54365762 | Iustin Pop | -> [Node.AllocElement] -- ^ The resulting allocations |
193 | 9188aeef | Iustin Pop | -> String -- ^ The JSON-formatted message |
194 | 3e4480e0 | Iustin Pop | formatResponse success info rq elems = |
195 | 43643696 | Iustin Pop | let |
196 | 43643696 | Iustin Pop | e_success = ("success", JSBool success) |
197 | 43643696 | Iustin Pop | e_info = ("info", JSString . toJSString $ info) |
198 | 3e4480e0 | Iustin Pop | e_nodes = ("nodes", formatRVal rq elems) |
199 | 43643696 | Iustin Pop | in encodeStrict $ makeObj [e_success, e_info, e_nodes] |