root / htools / Ganeti / Luxi.hs @ ccc817a2
History | View | Annotate | Download (12.6 kB)
1 |
{-# LANGUAGE TemplateHaskell #-} |
---|---|
2 |
|
3 |
{-| Implementation of the Ganeti LUXI interface. |
4 |
|
5 |
-} |
6 |
|
7 |
{- |
8 |
|
9 |
Copyright (C) 2009, 2010, 2011, 2012 Google Inc. |
10 |
|
11 |
This program is free software; you can redistribute it and/or modify |
12 |
it under the terms of the GNU General Public License as published by |
13 |
the Free Software Foundation; either version 2 of the License, or |
14 |
(at your option) any later version. |
15 |
|
16 |
This program is distributed in the hope that it will be useful, but |
17 |
WITHOUT ANY WARRANTY; without even the implied warranty of |
18 |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
19 |
General Public License for more details. |
20 |
|
21 |
You should have received a copy of the GNU General Public License |
22 |
along with this program; if not, write to the Free Software |
23 |
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
24 |
02110-1301, USA. |
25 |
|
26 |
-} |
27 |
|
28 |
module Ganeti.Luxi |
29 |
( LuxiOp(..) |
30 |
, QrViaLuxi(..) |
31 |
, ResultStatus(..) |
32 |
, LuxiReq(..) |
33 |
, Client |
34 |
, JobId |
35 |
, checkRS |
36 |
, getClient |
37 |
, closeClient |
38 |
, callMethod |
39 |
, submitManyJobs |
40 |
, queryJobsStatus |
41 |
, buildCall |
42 |
, validateCall |
43 |
, decodeCall |
44 |
) where |
45 |
|
46 |
import Data.IORef |
47 |
import Control.Monad |
48 |
import Text.JSON (encodeStrict, decodeStrict) |
49 |
import qualified Text.JSON as J |
50 |
import Text.JSON.Types |
51 |
import System.Timeout |
52 |
import qualified Network.Socket as S |
53 |
|
54 |
import Ganeti.HTools.JSON |
55 |
import Ganeti.HTools.Types |
56 |
import Ganeti.HTools.Utils |
57 |
|
58 |
import Ganeti.Constants |
59 |
import Ganeti.Jobs (JobStatus) |
60 |
import Ganeti.OpCodes (OpCode) |
61 |
import Ganeti.THH |
62 |
|
63 |
-- * Utility functions |
64 |
|
65 |
-- | Wrapper over System.Timeout.timeout that fails in the IO monad. |
66 |
withTimeout :: Int -> String -> IO a -> IO a |
67 |
withTimeout secs descr action = do |
68 |
result <- timeout (secs * 1000000) action |
69 |
case result of |
70 |
Nothing -> fail $ "Timeout in " ++ descr |
71 |
Just v -> return v |
72 |
|
73 |
-- * Generic protocol functionality |
74 |
|
75 |
-- | The Ganeti job type. |
76 |
type JobId = String |
77 |
|
78 |
$(declareSADT "QrViaLuxi" |
79 |
[ ("QRLock", 'qrLock) |
80 |
, ("QRInstance", 'qrInstance) |
81 |
, ("QRNode", 'qrNode) |
82 |
, ("QRGroup", 'qrGroup) |
83 |
, ("QROs", 'qrOs) |
84 |
]) |
85 |
$(makeJSONInstance ''QrViaLuxi) |
86 |
|
87 |
-- | Currently supported Luxi operations and JSON serialization. |
88 |
$(genLuxiOp "LuxiOp" |
89 |
[(luxiReqQuery, |
90 |
[ ("what", [t| QrViaLuxi |], [| id |]) |
91 |
, ("fields", [t| [String] |], [| id |]) |
92 |
, ("qfilter", [t| () |], [| const JSNull |]) |
93 |
]) |
94 |
, (luxiReqQueryNodes, |
95 |
[ ("names", [t| [String] |], [| id |]) |
96 |
, ("fields", [t| [String] |], [| id |]) |
97 |
, ("lock", [t| Bool |], [| id |]) |
98 |
]) |
99 |
, (luxiReqQueryGroups, |
100 |
[ ("names", [t| [String] |], [| id |]) |
101 |
, ("fields", [t| [String] |], [| id |]) |
102 |
, ("lock", [t| Bool |], [| id |]) |
103 |
]) |
104 |
, (luxiReqQueryInstances, |
105 |
[ ("names", [t| [String] |], [| id |]) |
106 |
, ("fields", [t| [String] |], [| id |]) |
107 |
, ("lock", [t| Bool |], [| id |]) |
108 |
]) |
109 |
, (luxiReqQueryJobs, |
110 |
[ ("ids", [t| [Int] |], [| map show |]) |
111 |
, ("fields", [t| [String] |], [| id |]) |
112 |
]) |
113 |
, (luxiReqQueryExports, |
114 |
[ ("nodes", [t| [String] |], [| id |]) |
115 |
, ("lock", [t| Bool |], [| id |]) |
116 |
]) |
117 |
, (luxiReqQueryConfigValues, |
118 |
[ ("fields", [t| [String] |], [| id |]) ] |
119 |
) |
120 |
, (luxiReqQueryClusterInfo, []) |
121 |
, (luxiReqQueryTags, |
122 |
[ ("kind", [t| String |], [| id |]) |
123 |
, ("name", [t| String |], [| id |]) |
124 |
]) |
125 |
, (luxiReqSubmitJob, |
126 |
[ ("job", [t| [OpCode] |], [| id |]) ] |
127 |
) |
128 |
, (luxiReqSubmitManyJobs, |
129 |
[ ("ops", [t| [[OpCode]] |], [| id |]) ] |
130 |
) |
131 |
, (luxiReqWaitForJobChange, |
132 |
[ ("job", [t| Int |], [| show |]) |
133 |
, ("fields", [t| [String]|], [| id |]) |
134 |
, ("prev_job", [t| JSValue |], [| id |]) |
135 |
, ("prev_log", [t| JSValue |], [| id |]) |
136 |
, ("tmout", [t| Int |], [| id |]) |
137 |
]) |
138 |
, (luxiReqArchiveJob, |
139 |
[ ("job", [t| Int |], [| show |]) ] |
140 |
) |
141 |
, (luxiReqAutoArchiveJobs, |
142 |
[ ("age", [t| Int |], [| id |]) |
143 |
, ("tmout", [t| Int |], [| id |]) |
144 |
]) |
145 |
, (luxiReqCancelJob, |
146 |
[ ("job", [t| Int |], [| show |]) ] |
147 |
) |
148 |
, (luxiReqSetDrainFlag, |
149 |
[ ("flag", [t| Bool |], [| id |]) ] |
150 |
) |
151 |
, (luxiReqSetWatcherPause, |
152 |
[ ("duration", [t| Double |], [| id |]) ] |
153 |
) |
154 |
]) |
155 |
|
156 |
$(makeJSONInstance ''LuxiReq) |
157 |
|
158 |
-- | The serialisation of LuxiOps into strings in messages. |
159 |
$(genStrOfOp ''LuxiOp "strOfOp") |
160 |
|
161 |
$(declareIADT "ResultStatus" |
162 |
[ ("RSNormal", 'rsNormal) |
163 |
, ("RSUnknown", 'rsUnknown) |
164 |
, ("RSNoData", 'rsNodata) |
165 |
, ("RSUnavailable", 'rsUnavail) |
166 |
, ("RSOffline", 'rsOffline) |
167 |
]) |
168 |
|
169 |
$(makeJSONInstance ''ResultStatus) |
170 |
|
171 |
-- | Type holding the initial (unparsed) Luxi call. |
172 |
data LuxiCall = LuxiCall LuxiReq JSValue |
173 |
|
174 |
-- | Check that ResultStatus is success or fail with descriptive message. |
175 |
checkRS :: (Monad m) => ResultStatus -> a -> m a |
176 |
checkRS RSNormal val = return val |
177 |
checkRS RSUnknown _ = fail "Unknown field" |
178 |
checkRS RSNoData _ = fail "No data for a field" |
179 |
checkRS RSUnavailable _ = fail "Ganeti reports unavailable data" |
180 |
checkRS RSOffline _ = fail "Ganeti reports resource as offline" |
181 |
|
182 |
-- | The end-of-message separator. |
183 |
eOM :: Char |
184 |
eOM = '\3' |
185 |
|
186 |
-- | Valid keys in the requests and responses. |
187 |
data MsgKeys = Method |
188 |
| Args |
189 |
| Success |
190 |
| Result |
191 |
|
192 |
-- | The serialisation of MsgKeys into strings in messages. |
193 |
$(genStrOfKey ''MsgKeys "strOfKey") |
194 |
|
195 |
-- | Luxi client encapsulation. |
196 |
data Client = Client { socket :: S.Socket -- ^ The socket of the client |
197 |
, rbuf :: IORef String -- ^ Already received buffer |
198 |
} |
199 |
|
200 |
-- | Connects to the master daemon and returns a luxi Client. |
201 |
getClient :: String -> IO Client |
202 |
getClient path = do |
203 |
s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol |
204 |
withTimeout connTimeout "creating luxi connection" $ |
205 |
S.connect s (S.SockAddrUnix path) |
206 |
rf <- newIORef "" |
207 |
return Client { socket=s, rbuf=rf} |
208 |
|
209 |
-- | Closes the client socket. |
210 |
closeClient :: Client -> IO () |
211 |
closeClient = S.sClose . socket |
212 |
|
213 |
-- | Sends a message over a luxi transport. |
214 |
sendMsg :: Client -> String -> IO () |
215 |
sendMsg s buf = |
216 |
let _send obuf = do |
217 |
sbytes <- withTimeout queryTimeout |
218 |
"sending luxi message" $ |
219 |
S.send (socket s) obuf |
220 |
unless (sbytes == length obuf) $ _send (drop sbytes obuf) |
221 |
in _send (buf ++ [eOM]) |
222 |
|
223 |
-- | Waits for a message over a luxi transport. |
224 |
recvMsg :: Client -> IO String |
225 |
recvMsg s = do |
226 |
let _recv obuf = do |
227 |
nbuf <- withTimeout queryTimeout "reading luxi response" $ |
228 |
S.recv (socket s) 4096 |
229 |
let (msg, remaining) = break (eOM ==) nbuf |
230 |
if null remaining |
231 |
then _recv (obuf ++ msg) |
232 |
else return (obuf ++ msg, tail remaining) |
233 |
cbuf <- readIORef $ rbuf s |
234 |
let (imsg, ibuf) = break (eOM ==) cbuf |
235 |
(msg, nbuf) <- |
236 |
if null ibuf -- if old buffer didn't contain a full message |
237 |
then _recv cbuf -- then we read from network |
238 |
else return (imsg, tail ibuf) -- else we return data from our buffer |
239 |
writeIORef (rbuf s) nbuf |
240 |
return msg |
241 |
|
242 |
-- | Serialize a request to String. |
243 |
buildCall :: LuxiOp -- ^ The method |
244 |
-> String -- ^ The serialized form |
245 |
buildCall lo = |
246 |
let ja = [ (strOfKey Method, JSString $ toJSString $ strOfOp lo::JSValue) |
247 |
, (strOfKey Args, opToArgs lo::JSValue) |
248 |
] |
249 |
jo = toJSObject ja |
250 |
in encodeStrict jo |
251 |
|
252 |
-- | Check that luxi request contains the required keys and parse it. |
253 |
validateCall :: String -> Result LuxiCall |
254 |
validateCall s = do |
255 |
arr <- fromJResult "luxi call" $ decodeStrict s::Result (JSObject JSValue) |
256 |
let aobj = fromJSObject arr |
257 |
call <- fromObj aobj (strOfKey Method)::Result LuxiReq |
258 |
args <- fromObj aobj (strOfKey Args) |
259 |
return (LuxiCall call args) |
260 |
|
261 |
-- | Converts Luxi call arguments into a 'LuxiOp' data structure. |
262 |
-- |
263 |
-- This is currently hand-coded until we make it more uniform so that |
264 |
-- it can be generated using TH. |
265 |
decodeCall :: LuxiCall -> Result LuxiOp |
266 |
decodeCall (LuxiCall call args) = |
267 |
case call of |
268 |
ReqQueryJobs -> do |
269 |
(jid, jargs) <- fromJVal args |
270 |
rid <- mapM (tryRead "parsing job ID" . fromJSString) jid |
271 |
let rargs = map fromJSString jargs |
272 |
return $ QueryJobs rid rargs |
273 |
ReqQueryInstances -> do |
274 |
(names, fields, locking) <- fromJVal args |
275 |
return $ QueryInstances names fields locking |
276 |
ReqQueryNodes -> do |
277 |
(names, fields, locking) <- fromJVal args |
278 |
return $ QueryNodes names fields locking |
279 |
ReqQueryGroups -> do |
280 |
(names, fields, locking) <- fromJVal args |
281 |
return $ QueryGroups names fields locking |
282 |
ReqQueryClusterInfo -> do |
283 |
return QueryClusterInfo |
284 |
ReqQuery -> do |
285 |
(what, fields, _) <- |
286 |
fromJVal args::Result (QrViaLuxi, [String], JSValue) |
287 |
return $ Query what fields () |
288 |
ReqSubmitJob -> do |
289 |
[ops1] <- fromJVal args |
290 |
ops2 <- mapM (fromJResult (luxiReqToRaw call) . J.readJSON) ops1 |
291 |
return $ SubmitJob ops2 |
292 |
ReqSubmitManyJobs -> do |
293 |
[ops1] <- fromJVal args |
294 |
ops2 <- mapM (fromJResult (luxiReqToRaw call) . J.readJSON) ops1 |
295 |
return $ SubmitManyJobs ops2 |
296 |
ReqWaitForJobChange -> do |
297 |
(jid, fields, pinfo, pidx, wtmout) <- |
298 |
-- No instance for 5-tuple, code copied from the |
299 |
-- json sources and adapted |
300 |
fromJResult "Parsing WaitForJobChange message" $ |
301 |
case args of |
302 |
JSArray [a, b, c, d, e] -> |
303 |
(,,,,) `fmap` |
304 |
J.readJSON a `ap` |
305 |
J.readJSON b `ap` |
306 |
J.readJSON c `ap` |
307 |
J.readJSON d `ap` |
308 |
J.readJSON e |
309 |
_ -> J.Error "Not enough values" |
310 |
rid <- tryRead "parsing job ID" jid |
311 |
return $ WaitForJobChange rid fields pinfo pidx wtmout |
312 |
ReqArchiveJob -> do |
313 |
[jid] <- fromJVal args |
314 |
rid <- tryRead "parsing job ID" jid |
315 |
return $ ArchiveJob rid |
316 |
ReqAutoArchiveJobs -> do |
317 |
(age, tmout) <- fromJVal args |
318 |
return $ AutoArchiveJobs age tmout |
319 |
ReqQueryExports -> do |
320 |
(nodes, lock) <- fromJVal args |
321 |
return $ QueryExports nodes lock |
322 |
ReqQueryConfigValues -> do |
323 |
[fields] <- fromJVal args |
324 |
return $ QueryConfigValues fields |
325 |
ReqQueryTags -> do |
326 |
(kind, name) <- fromJVal args |
327 |
return $ QueryTags kind name |
328 |
ReqCancelJob -> do |
329 |
[job] <- fromJVal args |
330 |
rid <- tryRead "parsing job ID" job |
331 |
return $ CancelJob rid |
332 |
ReqSetDrainFlag -> do |
333 |
[flag] <- fromJVal args |
334 |
return $ SetDrainFlag flag |
335 |
ReqSetWatcherPause -> do |
336 |
[duration] <- fromJVal args |
337 |
return $ SetWatcherPause duration |
338 |
|
339 |
-- | Check that luxi responses contain the required keys and that the |
340 |
-- call was successful. |
341 |
validateResult :: String -> Result JSValue |
342 |
validateResult s = do |
343 |
oarr <- fromJResult "Parsing LUXI response" |
344 |
(decodeStrict s)::Result (JSObject JSValue) |
345 |
let arr = J.fromJSObject oarr |
346 |
status <- fromObj arr (strOfKey Success)::Result Bool |
347 |
let rkey = strOfKey Result |
348 |
if status |
349 |
then fromObj arr rkey |
350 |
else fromObj arr rkey >>= fail |
351 |
|
352 |
-- | Generic luxi method call. |
353 |
callMethod :: LuxiOp -> Client -> IO (Result JSValue) |
354 |
callMethod method s = do |
355 |
sendMsg s $ buildCall method |
356 |
result <- recvMsg s |
357 |
let rval = validateResult result |
358 |
return rval |
359 |
|
360 |
-- | Specialized submitManyJobs call. |
361 |
submitManyJobs :: Client -> [[OpCode]] -> IO (Result [JobId]) |
362 |
submitManyJobs s jobs = do |
363 |
rval <- callMethod (SubmitManyJobs jobs) s |
364 |
-- map each result (status, payload) pair into a nice Result ADT |
365 |
return $ case rval of |
366 |
Bad x -> Bad x |
367 |
Ok (JSArray r) -> |
368 |
mapM (\v -> case v of |
369 |
JSArray [JSBool True, JSString x] -> |
370 |
Ok (fromJSString x) |
371 |
JSArray [JSBool False, JSString x] -> |
372 |
Bad (fromJSString x) |
373 |
_ -> Bad "Unknown result from the master daemon" |
374 |
) r |
375 |
x -> Bad ("Cannot parse response from Ganeti: " ++ show x) |
376 |
|
377 |
-- | Custom queryJobs call. |
378 |
queryJobsStatus :: Client -> [JobId] -> IO (Result [JobStatus]) |
379 |
queryJobsStatus s jids = do |
380 |
rval <- callMethod (QueryJobs (map read jids) ["status"]) s |
381 |
return $ case rval of |
382 |
Bad x -> Bad x |
383 |
Ok y -> case J.readJSON y::(J.Result [[JobStatus]]) of |
384 |
J.Ok vals -> if any null vals |
385 |
then Bad "Missing job status field" |
386 |
else Ok (map head vals) |
387 |
J.Error x -> Bad x |