root / htools / Ganeti / Luxi.hs @ 5cefb2b2
History | View | Annotate | Download (8.8 kB)
1 | a0090487 | Agata Murawska | {-# LANGUAGE TemplateHaskell #-} |
---|---|---|---|
2 | a0090487 | Agata Murawska | |
3 | 6583e677 | Iustin Pop | {-| Implementation of the Ganeti LUXI interface. |
4 | 6583e677 | Iustin Pop | |
5 | 6583e677 | Iustin Pop | -} |
6 | 6583e677 | Iustin Pop | |
7 | 6583e677 | Iustin Pop | {- |
8 | 6583e677 | Iustin Pop | |
9 | fae980e5 | Iustin Pop | Copyright (C) 2009, 2010, 2011, 2012 Google Inc. |
10 | 6583e677 | Iustin Pop | |
11 | 6583e677 | Iustin Pop | This program is free software; you can redistribute it and/or modify |
12 | 6583e677 | Iustin Pop | it under the terms of the GNU General Public License as published by |
13 | 6583e677 | Iustin Pop | the Free Software Foundation; either version 2 of the License, or |
14 | 6583e677 | Iustin Pop | (at your option) any later version. |
15 | 6583e677 | Iustin Pop | |
16 | 6583e677 | Iustin Pop | This program is distributed in the hope that it will be useful, but |
17 | 6583e677 | Iustin Pop | WITHOUT ANY WARRANTY; without even the implied warranty of |
18 | 6583e677 | Iustin Pop | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
19 | 6583e677 | Iustin Pop | General Public License for more details. |
20 | 6583e677 | Iustin Pop | |
21 | 6583e677 | Iustin Pop | You should have received a copy of the GNU General Public License |
22 | 6583e677 | Iustin Pop | along with this program; if not, write to the Free Software |
23 | 6583e677 | Iustin Pop | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
24 | 6583e677 | Iustin Pop | 02110-1301, USA. |
25 | 6583e677 | Iustin Pop | |
26 | 6583e677 | Iustin Pop | -} |
27 | 6583e677 | Iustin Pop | |
28 | 6583e677 | Iustin Pop | module Ganeti.Luxi |
29 | ebf38064 | Iustin Pop | ( LuxiOp(..) |
30 | ebf38064 | Iustin Pop | , QrViaLuxi(..) |
31 | ebf38064 | Iustin Pop | , ResultStatus(..) |
32 | 95d0d502 | Iustin Pop | , LuxiReq(..) |
33 | ebf38064 | Iustin Pop | , Client |
34 | ebf38064 | Iustin Pop | , checkRS |
35 | ebf38064 | Iustin Pop | , getClient |
36 | ebf38064 | Iustin Pop | , closeClient |
37 | ebf38064 | Iustin Pop | , callMethod |
38 | ebf38064 | Iustin Pop | , submitManyJobs |
39 | ebf38064 | Iustin Pop | , queryJobsStatus |
40 | ebf38064 | Iustin Pop | ) where |
41 | 6583e677 | Iustin Pop | |
42 | 6583e677 | Iustin Pop | import Data.IORef |
43 | 6583e677 | Iustin Pop | import Control.Monad |
44 | 0903280b | Iustin Pop | import Text.JSON (encodeStrict, decodeStrict) |
45 | 6583e677 | Iustin Pop | import qualified Text.JSON as J |
46 | 6583e677 | Iustin Pop | import Text.JSON.Types |
47 | 6583e677 | Iustin Pop | import System.Timeout |
48 | 6583e677 | Iustin Pop | import qualified Network.Socket as S |
49 | 6583e677 | Iustin Pop | |
50 | b69be409 | Iustin Pop | import Ganeti.HTools.JSON |
51 | 6583e677 | Iustin Pop | import Ganeti.HTools.Types |
52 | 6583e677 | Iustin Pop | |
53 | 92678b3c | Iustin Pop | import Ganeti.Constants |
54 | 9a2ff880 | Iustin Pop | import Ganeti.Jobs (JobStatus) |
55 | 683b1ca7 | Iustin Pop | import Ganeti.OpCodes (OpCode) |
56 | a0090487 | Agata Murawska | import Ganeti.THH |
57 | 9a2ff880 | Iustin Pop | |
58 | 6583e677 | Iustin Pop | -- * Utility functions |
59 | 6583e677 | Iustin Pop | |
60 | 6583e677 | Iustin Pop | -- | Wrapper over System.Timeout.timeout that fails in the IO monad. |
61 | 6583e677 | Iustin Pop | withTimeout :: Int -> String -> IO a -> IO a |
62 | 6583e677 | Iustin Pop | withTimeout secs descr action = do |
63 | ebf38064 | Iustin Pop | result <- timeout (secs * 1000000) action |
64 | 3603605a | Iustin Pop | case result of |
65 | 3603605a | Iustin Pop | Nothing -> fail $ "Timeout in " ++ descr |
66 | 3603605a | Iustin Pop | Just v -> return v |
67 | 6583e677 | Iustin Pop | |
68 | 6583e677 | Iustin Pop | -- * Generic protocol functionality |
69 | 6583e677 | Iustin Pop | |
70 | 92678b3c | Iustin Pop | $(declareSADT "QrViaLuxi" |
71 | ebf38064 | Iustin Pop | [ ("QRLock", 'qrLock) |
72 | ebf38064 | Iustin Pop | , ("QRInstance", 'qrInstance) |
73 | ebf38064 | Iustin Pop | , ("QRNode", 'qrNode) |
74 | ebf38064 | Iustin Pop | , ("QRGroup", 'qrGroup) |
75 | ebf38064 | Iustin Pop | , ("QROs", 'qrOs) |
76 | ebf38064 | Iustin Pop | ]) |
77 | 92678b3c | Iustin Pop | $(makeJSONInstance ''QrViaLuxi) |
78 | 92678b3c | Iustin Pop | |
79 | a0090487 | Agata Murawska | -- | Currently supported Luxi operations and JSON serialization. |
80 | a0090487 | Agata Murawska | $(genLuxiOp "LuxiOp" |
81 | fae980e5 | Iustin Pop | [(luxiReqQuery, |
82 | ebf38064 | Iustin Pop | [ ("what", [t| QrViaLuxi |], [| id |]) |
83 | ebf38064 | Iustin Pop | , ("fields", [t| [String] |], [| id |]) |
84 | ebf38064 | Iustin Pop | , ("qfilter", [t| () |], [| const JSNull |]) |
85 | ebf38064 | Iustin Pop | ]) |
86 | fae980e5 | Iustin Pop | , (luxiReqQueryNodes, |
87 | ebf38064 | Iustin Pop | [ ("names", [t| [String] |], [| id |]) |
88 | ebf38064 | Iustin Pop | , ("fields", [t| [String] |], [| id |]) |
89 | ebf38064 | Iustin Pop | , ("lock", [t| Bool |], [| id |]) |
90 | ebf38064 | Iustin Pop | ]) |
91 | fae980e5 | Iustin Pop | , (luxiReqQueryGroups, |
92 | ebf38064 | Iustin Pop | [ ("names", [t| [String] |], [| id |]) |
93 | ebf38064 | Iustin Pop | , ("fields", [t| [String] |], [| id |]) |
94 | ebf38064 | Iustin Pop | , ("lock", [t| Bool |], [| id |]) |
95 | ebf38064 | Iustin Pop | ]) |
96 | fae980e5 | Iustin Pop | , (luxiReqQueryInstances, |
97 | ebf38064 | Iustin Pop | [ ("names", [t| [String] |], [| id |]) |
98 | ebf38064 | Iustin Pop | , ("fields", [t| [String] |], [| id |]) |
99 | ebf38064 | Iustin Pop | , ("lock", [t| Bool |], [| id |]) |
100 | ebf38064 | Iustin Pop | ]) |
101 | fae980e5 | Iustin Pop | , (luxiReqQueryJobs, |
102 | ebf38064 | Iustin Pop | [ ("ids", [t| [Int] |], [| map show |]) |
103 | ebf38064 | Iustin Pop | , ("fields", [t| [String] |], [| id |]) |
104 | ebf38064 | Iustin Pop | ]) |
105 | fae980e5 | Iustin Pop | , (luxiReqQueryExports, |
106 | ebf38064 | Iustin Pop | [ ("nodes", [t| [String] |], [| id |]) |
107 | ebf38064 | Iustin Pop | , ("lock", [t| Bool |], [| id |]) |
108 | ebf38064 | Iustin Pop | ]) |
109 | fae980e5 | Iustin Pop | , (luxiReqQueryConfigValues, |
110 | ebf38064 | Iustin Pop | [ ("fields", [t| [String] |], [| id |]) ] |
111 | ebf38064 | Iustin Pop | ) |
112 | fae980e5 | Iustin Pop | , (luxiReqQueryClusterInfo, []) |
113 | fae980e5 | Iustin Pop | , (luxiReqQueryTags, |
114 | ebf38064 | Iustin Pop | [ ("kind", [t| String |], [| id |]) |
115 | ebf38064 | Iustin Pop | , ("name", [t| String |], [| id |]) |
116 | ebf38064 | Iustin Pop | ]) |
117 | fae980e5 | Iustin Pop | , (luxiReqSubmitJob, |
118 | ebf38064 | Iustin Pop | [ ("job", [t| [OpCode] |], [| id |]) ] |
119 | ebf38064 | Iustin Pop | ) |
120 | fae980e5 | Iustin Pop | , (luxiReqSubmitManyJobs, |
121 | ebf38064 | Iustin Pop | [ ("ops", [t| [[OpCode]] |], [| id |]) ] |
122 | ebf38064 | Iustin Pop | ) |
123 | fae980e5 | Iustin Pop | , (luxiReqWaitForJobChange, |
124 | ebf38064 | Iustin Pop | [ ("job", [t| Int |], [| id |]) |
125 | ebf38064 | Iustin Pop | , ("fields", [t| [String]|], [| id |]) |
126 | ebf38064 | Iustin Pop | , ("prev_job", [t| JSValue |], [| id |]) |
127 | ebf38064 | Iustin Pop | , ("prev_log", [t| JSValue |], [| id |]) |
128 | ebf38064 | Iustin Pop | , ("tmout", [t| Int |], [| id |]) |
129 | ebf38064 | Iustin Pop | ]) |
130 | fae980e5 | Iustin Pop | , (luxiReqArchiveJob, |
131 | ebf38064 | Iustin Pop | [ ("job", [t| Int |], [| show |]) ] |
132 | ebf38064 | Iustin Pop | ) |
133 | fae980e5 | Iustin Pop | , (luxiReqAutoArchiveJobs, |
134 | ebf38064 | Iustin Pop | [ ("age", [t| Int |], [| id |]) |
135 | ebf38064 | Iustin Pop | , ("tmout", [t| Int |], [| id |]) |
136 | ebf38064 | Iustin Pop | ]) |
137 | fae980e5 | Iustin Pop | , (luxiReqCancelJob, |
138 | ebf38064 | Iustin Pop | [ ("job", [t| Int |], [| show |]) ] |
139 | ebf38064 | Iustin Pop | ) |
140 | fae980e5 | Iustin Pop | , (luxiReqSetDrainFlag, |
141 | ebf38064 | Iustin Pop | [ ("flag", [t| Bool |], [| id |]) ] |
142 | ebf38064 | Iustin Pop | ) |
143 | fae980e5 | Iustin Pop | , (luxiReqSetWatcherPause, |
144 | ebf38064 | Iustin Pop | [ ("duration", [t| Double |], [| id |]) ] |
145 | ebf38064 | Iustin Pop | ) |
146 | a0090487 | Agata Murawska | ]) |
147 | 6583e677 | Iustin Pop | |
148 | 95d0d502 | Iustin Pop | $(makeJSONInstance ''LuxiReq) |
149 | 95d0d502 | Iustin Pop | |
150 | 6583e677 | Iustin Pop | -- | The serialisation of LuxiOps into strings in messages. |
151 | a0090487 | Agata Murawska | $(genStrOfOp ''LuxiOp "strOfOp") |
152 | 6583e677 | Iustin Pop | |
153 | 260d0bda | Agata Murawska | $(declareIADT "ResultStatus" |
154 | ebf38064 | Iustin Pop | [ ("RSNormal", 'rsNormal) |
155 | ebf38064 | Iustin Pop | , ("RSUnknown", 'rsUnknown) |
156 | ebf38064 | Iustin Pop | , ("RSNoData", 'rsNodata) |
157 | ebf38064 | Iustin Pop | , ("RSUnavailable", 'rsUnavail) |
158 | ebf38064 | Iustin Pop | , ("RSOffline", 'rsOffline) |
159 | ebf38064 | Iustin Pop | ]) |
160 | 5f828ce4 | Agata Murawska | |
161 | 5f828ce4 | Agata Murawska | $(makeJSONInstance ''ResultStatus) |
162 | 260d0bda | Agata Murawska | |
163 | 260d0bda | Agata Murawska | -- | Check that ResultStatus is success or fail with descriptive message. |
164 | 260d0bda | Agata Murawska | checkRS :: (Monad m) => ResultStatus -> a -> m a |
165 | 260d0bda | Agata Murawska | checkRS RSNormal val = return val |
166 | 260d0bda | Agata Murawska | checkRS RSUnknown _ = fail "Unknown field" |
167 | 260d0bda | Agata Murawska | checkRS RSNoData _ = fail "No data for a field" |
168 | 260d0bda | Agata Murawska | checkRS RSUnavailable _ = fail "Ganeti reports unavailable data" |
169 | 260d0bda | Agata Murawska | checkRS RSOffline _ = fail "Ganeti reports resource as offline" |
170 | 260d0bda | Agata Murawska | |
171 | 6583e677 | Iustin Pop | -- | The end-of-message separator. |
172 | 6583e677 | Iustin Pop | eOM :: Char |
173 | 6583e677 | Iustin Pop | eOM = '\3' |
174 | 6583e677 | Iustin Pop | |
175 | 6583e677 | Iustin Pop | -- | Valid keys in the requests and responses. |
176 | 6583e677 | Iustin Pop | data MsgKeys = Method |
177 | 6583e677 | Iustin Pop | | Args |
178 | 6583e677 | Iustin Pop | | Success |
179 | 6583e677 | Iustin Pop | | Result |
180 | 6583e677 | Iustin Pop | |
181 | 6583e677 | Iustin Pop | -- | The serialisation of MsgKeys into strings in messages. |
182 | a0090487 | Agata Murawska | $(genStrOfKey ''MsgKeys "strOfKey") |
183 | 6583e677 | Iustin Pop | |
184 | 6583e677 | Iustin Pop | -- | Luxi client encapsulation. |
185 | 6583e677 | Iustin Pop | data Client = Client { socket :: S.Socket -- ^ The socket of the client |
186 | 6583e677 | Iustin Pop | , rbuf :: IORef String -- ^ Already received buffer |
187 | 6583e677 | Iustin Pop | } |
188 | 6583e677 | Iustin Pop | |
189 | 6583e677 | Iustin Pop | -- | Connects to the master daemon and returns a luxi Client. |
190 | 6583e677 | Iustin Pop | getClient :: String -> IO Client |
191 | 6583e677 | Iustin Pop | getClient path = do |
192 | ebf38064 | Iustin Pop | s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol |
193 | ebf38064 | Iustin Pop | withTimeout connTimeout "creating luxi connection" $ |
194 | ebf38064 | Iustin Pop | S.connect s (S.SockAddrUnix path) |
195 | ebf38064 | Iustin Pop | rf <- newIORef "" |
196 | ebf38064 | Iustin Pop | return Client { socket=s, rbuf=rf} |
197 | 6583e677 | Iustin Pop | |
198 | 6583e677 | Iustin Pop | -- | Closes the client socket. |
199 | 6583e677 | Iustin Pop | closeClient :: Client -> IO () |
200 | 6583e677 | Iustin Pop | closeClient = S.sClose . socket |
201 | 6583e677 | Iustin Pop | |
202 | 6583e677 | Iustin Pop | -- | Sends a message over a luxi transport. |
203 | 6583e677 | Iustin Pop | sendMsg :: Client -> String -> IO () |
204 | 6583e677 | Iustin Pop | sendMsg s buf = |
205 | ebf38064 | Iustin Pop | let _send obuf = do |
206 | ebf38064 | Iustin Pop | sbytes <- withTimeout queryTimeout |
207 | ebf38064 | Iustin Pop | "sending luxi message" $ |
208 | ebf38064 | Iustin Pop | S.send (socket s) obuf |
209 | ebf38064 | Iustin Pop | unless (sbytes == length obuf) $ _send (drop sbytes obuf) |
210 | ebf38064 | Iustin Pop | in _send (buf ++ [eOM]) |
211 | 6583e677 | Iustin Pop | |
212 | 6583e677 | Iustin Pop | -- | Waits for a message over a luxi transport. |
213 | 6583e677 | Iustin Pop | recvMsg :: Client -> IO String |
214 | 6583e677 | Iustin Pop | recvMsg s = do |
215 | 6583e677 | Iustin Pop | let _recv obuf = do |
216 | 6583e677 | Iustin Pop | nbuf <- withTimeout queryTimeout "reading luxi response" $ |
217 | 6583e677 | Iustin Pop | S.recv (socket s) 4096 |
218 | 95f490de | Iustin Pop | let (msg, remaining) = break (eOM ==) nbuf |
219 | 3603605a | Iustin Pop | if null remaining |
220 | 3603605a | Iustin Pop | then _recv (obuf ++ msg) |
221 | 3603605a | Iustin Pop | else return (obuf ++ msg, tail remaining) |
222 | 6583e677 | Iustin Pop | cbuf <- readIORef $ rbuf s |
223 | 95f490de | Iustin Pop | let (imsg, ibuf) = break (eOM ==) cbuf |
224 | 95f490de | Iustin Pop | (msg, nbuf) <- |
225 | 3603605a | Iustin Pop | if null ibuf -- if old buffer didn't contain a full message |
226 | 3603605a | Iustin Pop | then _recv cbuf -- then we read from network |
227 | 3603605a | Iustin Pop | else return (imsg, tail ibuf) -- else we return data from our buffer |
228 | 6583e677 | Iustin Pop | writeIORef (rbuf s) nbuf |
229 | 6583e677 | Iustin Pop | return msg |
230 | 6583e677 | Iustin Pop | |
231 | 6583e677 | Iustin Pop | -- | Serialize a request to String. |
232 | 6583e677 | Iustin Pop | buildCall :: LuxiOp -- ^ The method |
233 | 6583e677 | Iustin Pop | -> String -- ^ The serialized form |
234 | 683b1ca7 | Iustin Pop | buildCall lo = |
235 | ebf38064 | Iustin Pop | let ja = [ (strOfKey Method, JSString $ toJSString $ strOfOp lo::JSValue) |
236 | ebf38064 | Iustin Pop | , (strOfKey Args, opToArgs lo::JSValue) |
237 | ebf38064 | Iustin Pop | ] |
238 | ebf38064 | Iustin Pop | jo = toJSObject ja |
239 | ebf38064 | Iustin Pop | in encodeStrict jo |
240 | 6583e677 | Iustin Pop | |
241 | 6583e677 | Iustin Pop | -- | Check that luxi responses contain the required keys and that the |
242 | 6583e677 | Iustin Pop | -- call was successful. |
243 | 6583e677 | Iustin Pop | validateResult :: String -> Result JSValue |
244 | 6583e677 | Iustin Pop | validateResult s = do |
245 | c96d44df | Iustin Pop | oarr <- fromJResult "Parsing LUXI response" |
246 | c96d44df | Iustin Pop | (decodeStrict s)::Result (JSObject JSValue) |
247 | 262f3e6c | Iustin Pop | let arr = J.fromJSObject oarr |
248 | e8230242 | Iustin Pop | status <- fromObj arr (strOfKey Success)::Result Bool |
249 | 6583e677 | Iustin Pop | let rkey = strOfKey Result |
250 | 3603605a | Iustin Pop | if status |
251 | 3603605a | Iustin Pop | then fromObj arr rkey |
252 | 3603605a | Iustin Pop | else fromObj arr rkey >>= fail |
253 | 6583e677 | Iustin Pop | |
254 | 6583e677 | Iustin Pop | -- | Generic luxi method call. |
255 | 683b1ca7 | Iustin Pop | callMethod :: LuxiOp -> Client -> IO (Result JSValue) |
256 | 683b1ca7 | Iustin Pop | callMethod method s = do |
257 | 683b1ca7 | Iustin Pop | sendMsg s $ buildCall method |
258 | 6583e677 | Iustin Pop | result <- recvMsg s |
259 | 6583e677 | Iustin Pop | let rval = validateResult result |
260 | 6583e677 | Iustin Pop | return rval |
261 | 9a2ff880 | Iustin Pop | |
262 | 9a2ff880 | Iustin Pop | -- | Specialized submitManyJobs call. |
263 | 683b1ca7 | Iustin Pop | submitManyJobs :: Client -> [[OpCode]] -> IO (Result [String]) |
264 | 9a2ff880 | Iustin Pop | submitManyJobs s jobs = do |
265 | 683b1ca7 | Iustin Pop | rval <- callMethod (SubmitManyJobs jobs) s |
266 | 9a2ff880 | Iustin Pop | -- map each result (status, payload) pair into a nice Result ADT |
267 | 9a2ff880 | Iustin Pop | return $ case rval of |
268 | 9a2ff880 | Iustin Pop | Bad x -> Bad x |
269 | 9a2ff880 | Iustin Pop | Ok (JSArray r) -> |
270 | 9a2ff880 | Iustin Pop | mapM (\v -> case v of |
271 | 9a2ff880 | Iustin Pop | JSArray [JSBool True, JSString x] -> |
272 | 9a2ff880 | Iustin Pop | Ok (fromJSString x) |
273 | 9a2ff880 | Iustin Pop | JSArray [JSBool False, JSString x] -> |
274 | 9a2ff880 | Iustin Pop | Bad (fromJSString x) |
275 | 9a2ff880 | Iustin Pop | _ -> Bad "Unknown result from the master daemon" |
276 | 9a2ff880 | Iustin Pop | ) r |
277 | 9a2ff880 | Iustin Pop | x -> Bad ("Cannot parse response from Ganeti: " ++ show x) |
278 | 9a2ff880 | Iustin Pop | |
279 | 9a2ff880 | Iustin Pop | -- | Custom queryJobs call. |
280 | 9a2ff880 | Iustin Pop | queryJobsStatus :: Client -> [String] -> IO (Result [JobStatus]) |
281 | 9a2ff880 | Iustin Pop | queryJobsStatus s jids = do |
282 | 683b1ca7 | Iustin Pop | rval <- callMethod (QueryJobs (map read jids) ["status"]) s |
283 | 9a2ff880 | Iustin Pop | return $ case rval of |
284 | 9a2ff880 | Iustin Pop | Bad x -> Bad x |
285 | 9a2ff880 | Iustin Pop | Ok y -> case J.readJSON y::(J.Result [[JobStatus]]) of |
286 | 9a2ff880 | Iustin Pop | J.Ok vals -> if any null vals |
287 | 9a2ff880 | Iustin Pop | then Bad "Missing job status field" |
288 | 9a2ff880 | Iustin Pop | else Ok (map head vals) |
289 | 9a2ff880 | Iustin Pop | J.Error x -> Bad x |