Revision d79a6502 src/Ganeti/Query/Server.hs
b/src/Ganeti/Query/Server.hs | ||
---|---|---|
1 |
{-# LANGUAGE BangPatterns #-} |
|
2 |
|
|
3 | 1 |
{-| Implementation of the Ganeti Query2 server. |
4 | 2 |
|
5 | 3 |
-} |
... | ... | |
61 | 59 |
import Ganeti.Query.Query |
62 | 60 |
import Ganeti.Query.Filter (makeSimpleFilter) |
63 | 61 |
import Ganeti.Types |
62 |
import qualified Ganeti.UDSServer as U |
|
64 | 63 |
import Ganeti.Utils (lockFile, exitIfBad, watchFile) |
65 | 64 |
import qualified Ganeti.Version as Version |
66 | 65 |
|
... | ... | |
297 | 296 |
logDebug $ "Updates for job " ++ sjid ++ " are " ++ encode (rfields, rlogs) |
298 | 297 |
return (JSArray rfields, rlogs) |
299 | 298 |
|
300 |
-- | Given a decoded luxi request, executes it and sends the luxi |
|
301 |
-- response back to the client. |
|
302 |
handleClientMsg :: MVar () -> JQStatus -> Client -> ConfigReader |
|
303 |
-> LuxiOp -> IO Bool |
|
304 |
handleClientMsg qlock qstat client creader args = do |
|
299 |
|
|
300 |
type LuxiConfig = (MVar (), JQStatus, ConfigReader) |
|
301 |
|
|
302 |
luxiExec |
|
303 |
:: LuxiConfig |
|
304 |
-> LuxiOp |
|
305 |
-> IO (Bool, GenericResult GanetiException JSValue) |
|
306 |
luxiExec (qlock, qstat, creader) args = do |
|
305 | 307 |
cfg <- creader |
306 |
logDebug $ "Request: " ++ show args |
|
307 |
call_result <- handleCallWrapper qlock qstat cfg args |
|
308 |
(!status, !rval) <- |
|
309 |
case call_result of |
|
310 |
Bad err -> do |
|
311 |
logWarning $ "Failed to execute request " ++ show args ++ ": " |
|
312 |
++ show err |
|
313 |
return (False, showJSON err) |
|
314 |
Ok result -> do |
|
315 |
-- only log the first 2,000 chars of the result |
|
316 |
logDebug $ "Result (truncated): " ++ take 2000 (J.encode result) |
|
317 |
logInfo $ "Successfully handled " ++ strOfOp args |
|
318 |
return (True, result) |
|
319 |
sendMsg client $ buildResponse status rval |
|
320 |
return True |
|
321 |
|
|
322 |
-- | Handles one iteration of the client protocol: receives message, |
|
323 |
-- checks it for validity and decodes it, returns response. |
|
324 |
handleClient :: MVar () -> JQStatus -> Client -> ConfigReader -> IO Bool |
|
325 |
handleClient qlock qstat client creader = do |
|
326 |
!msg <- recvMsgExt client |
|
308 |
result <- handleCallWrapper qlock qstat cfg args |
|
309 |
return (True, result) |
|
310 |
|
|
311 |
luxiHandler :: LuxiConfig -> U.Handler LuxiOp JSValue |
|
312 |
luxiHandler cfg = U.Handler { U.hParse = decodeLuxiCall |
|
313 |
, U.hInputLogShort = strOfOp |
|
314 |
, U.hInputLogLong = show |
|
315 |
, U.hExec = luxiExec cfg |
|
316 |
} |
|
317 |
|
|
318 |
|
|
319 |
-- | Logs an outgoing message. |
|
320 |
logMsg |
|
321 |
:: (Show e, J.JSON e, MonadLog m) |
|
322 |
=> U.Handler i o |
|
323 |
-> i -- ^ the received request (used for logging) |
|
324 |
-> GenericResult e J.JSValue -- ^ A message to be sent |
|
325 |
-> m () |
|
326 |
logMsg handler req (Bad err) = |
|
327 |
logWarning $ "Failed to execute request " |
|
328 |
++ U.hInputLogLong handler req ++ ": " |
|
329 |
++ show err |
|
330 |
logMsg handler req (Ok result) = do |
|
331 |
-- only log the first 2,000 chars of the result |
|
332 |
logDebug $ "Result (truncated): " ++ take 2000 (J.encode result) |
|
333 |
logInfo $ "Successfully handled " ++ U.hInputLogShort handler req |
|
334 |
|
|
335 |
-- | Prepares an outgoing message. |
|
336 |
prepareMsg |
|
337 |
:: (J.JSON e) |
|
338 |
=> GenericResult e J.JSValue -- ^ A message to be sent |
|
339 |
-> (Bool, J.JSValue) |
|
340 |
prepareMsg (Bad err) = (False, J.showJSON err) |
|
341 |
prepareMsg (Ok result) = (True, result) |
|
342 |
|
|
343 |
handleJsonMessage |
|
344 |
:: (J.JSON o) |
|
345 |
=> U.Handler i o -- ^ handler |
|
346 |
-> i -- ^ parsed input |
|
347 |
-> U.HandlerResult J.JSValue |
|
348 |
handleJsonMessage handler req = do |
|
349 |
(close, call_result) <- U.hExec handler req |
|
350 |
return (close, fmap J.showJSON call_result) |
|
351 |
|
|
352 |
-- | Takes a request as a 'String', parses it, passes it to a handler and |
|
353 |
-- formats its response. |
|
354 |
handleRawMessage |
|
355 |
:: (J.JSON o) |
|
356 |
=> U.Handler i o -- ^ handler |
|
357 |
-> String -- ^ raw unparsed input |
|
358 |
-> IO (Bool, String) |
|
359 |
handleRawMessage handler payload = |
|
360 |
case U.parseCall payload >>= uncurry (U.hParse handler) of |
|
361 |
Bad err -> do |
|
362 |
let errmsg = "Failed to parse request: " ++ err |
|
363 |
logWarning errmsg |
|
364 |
return (False, buildResponse False (J.showJSON errmsg)) |
|
365 |
Ok req -> do |
|
366 |
logDebug $ "Request: " ++ U.hInputLogLong handler req |
|
367 |
(close, call_result_json) <- handleJsonMessage handler req |
|
368 |
logMsg handler req call_result_json |
|
369 |
let (status, response) = prepareMsg call_result_json |
|
370 |
return (close, buildResponse status response) |
|
371 |
|
|
372 |
-- | Reads a request, passes it to a handler and sends a response back to the |
|
373 |
-- client. |
|
374 |
handleClient |
|
375 |
:: (J.JSON o) |
|
376 |
=> U.Handler i o |
|
377 |
-> Client |
|
378 |
-> IO Bool |
|
379 |
handleClient handler client = do |
|
380 |
msg <- recvMsgExt client |
|
327 | 381 |
logDebug $ "Received message: " ++ show msg |
328 | 382 |
case msg of |
329 |
RecvConnClosed -> logDebug "Connection closed" >> return False |
|
383 |
RecvConnClosed -> logDebug "Connection closed" >> |
|
384 |
return False |
|
330 | 385 |
RecvError err -> logWarning ("Error during message receiving: " ++ err) >> |
331 | 386 |
return False |
332 |
RecvOk payload -> |
|
333 |
case validateCall payload >>= decodeCall of |
|
334 |
Bad err -> do |
|
335 |
let errmsg = "Failed to parse request: " ++ err |
|
336 |
logWarning errmsg |
|
337 |
sendMsg client $ buildResponse False (showJSON errmsg) |
|
338 |
return False |
|
339 |
Ok args -> handleClientMsg qlock qstat client creader args |
|
387 |
RecvOk payload -> do |
|
388 |
(close, outMsg) <- handleRawMessage handler payload |
|
389 |
sendMsg client outMsg |
|
390 |
return close |
|
340 | 391 |
|
341 | 392 |
-- | Main client loop: runs one loop of 'handleClient', and if that |
342 | 393 |
-- doesn't report a finished (closed) connection, restarts itself. |
343 |
clientLoop :: MVar () -> JQStatus -> Client -> ConfigReader -> IO () |
|
344 |
clientLoop qlock qstat client creader = do |
|
345 |
result <- handleClient qlock qstat client creader |
|
394 |
clientLoop |
|
395 |
:: (J.JSON o) |
|
396 |
=> U.Handler i o |
|
397 |
-> Client |
|
398 |
-> IO () |
|
399 |
clientLoop handler client = do |
|
400 |
result <- handleClient handler client |
|
346 | 401 |
if result |
347 |
then clientLoop qlock qstat client creader
|
|
402 |
then clientLoop handler client
|
|
348 | 403 |
else closeClient client |
349 | 404 |
|
350 | 405 |
-- | Main listener loop: accepts clients, forks an I/O thread to handle |
351 | 406 |
-- that client. |
352 |
listener :: MVar () -> JQStatus -> ConfigReader -> Server -> IO () |
|
353 |
listener qlock qstat creader socket = do |
|
354 |
client <- acceptClient socket |
|
355 |
_ <- forkIO $ clientLoop qlock qstat client creader |
|
407 |
listener |
|
408 |
:: (J.JSON o) |
|
409 |
=> U.Handler i o |
|
410 |
-> Server |
|
411 |
-> IO () |
|
412 |
listener handler server = do |
|
413 |
client <- acceptClient server |
|
414 |
_ <- forkIO $ clientLoop handler client |
|
356 | 415 |
return () |
357 | 416 |
|
417 |
|
|
358 | 418 |
-- | Type alias for prepMain results |
359 | 419 |
type PrepResult = (Server, IORef (Result ConfigData), JQStatus) |
360 | 420 |
|
... | ... | |
385 | 445 |
qlock <- newMVar () |
386 | 446 |
|
387 | 447 |
finally |
388 |
(forever $ listener qlock jq creader server)
|
|
448 |
(forever $ listener (luxiHandler (qlock, jq, creader)) server)
|
|
389 | 449 |
(closeServer server) |
Also available in: Unified diff