1 |
1 |
{-# LANGUAGE TemplateHaskell #-}
|
|
2 |
{-# LANGUAGE FlexibleContexts #-}
|
2 |
3 |
|
3 |
4 |
{-| Implementation of the Ganeti Unix Domain Socket JSON server interface.
|
4 |
5 |
|
... | ... | |
56 |
57 |
) where
|
57 |
58 |
|
58 |
59 |
import Control.Applicative
|
59 |
|
import Control.Concurrent (forkIO)
|
|
60 |
import Control.Concurrent.Lifted (fork)
|
|
61 |
import Control.Monad.Base
|
|
62 |
import Control.Monad.Trans.Control
|
60 |
63 |
import Control.Exception (catch)
|
61 |
64 |
import Control.Monad
|
62 |
65 |
import qualified Data.ByteString as B
|
... | ... | |
198 |
201 |
return Server { sSocket=s, sPath=path, serverConfig=conf }
|
199 |
202 |
|
200 |
203 |
-- | Closes a server endpoint.
|
201 |
|
closeServer :: Server -> IO ()
|
|
204 |
closeServer :: (MonadBase IO m) => Server -> m ()
|
202 |
205 |
closeServer server =
|
203 |
|
closeServerSocket (sSocket server) (sPath server)
|
|
206 |
liftBase $ closeServerSocket (sSocket server) (sPath server)
|
204 |
207 |
|
205 |
208 |
-- | Accepts a client
|
206 |
209 |
acceptClient :: Server -> IO Client
|
... | ... | |
285 |
288 |
-- | Logs an outgoing message.
|
286 |
289 |
logMsg
|
287 |
290 |
:: (Show e, J.JSON e, MonadLog m)
|
288 |
|
=> Handler i o
|
|
291 |
=> Handler i m o
|
289 |
292 |
-> i -- ^ the received request (used for logging)
|
290 |
293 |
-> GenericResult e J.JSValue -- ^ A message to be sent
|
291 |
294 |
-> m ()
|
... | ... | |
308 |
311 |
|
309 |
312 |
-- * Processing client requests
|
310 |
313 |
|
311 |
|
type HandlerResult o = IO (Bool, GenericResult GanetiException o)
|
|
314 |
type HandlerResult m o = m (Bool, GenericResult GanetiException o)
|
312 |
315 |
|
313 |
|
data Handler i o = Handler
|
|
316 |
data Handler i m o = Handler
|
314 |
317 |
{ hParse :: J.JSValue -> J.JSValue -> Result i
|
315 |
318 |
-- ^ parses method and its arguments into the input type
|
316 |
319 |
, hInputLogShort :: i -> String
|
317 |
320 |
-- ^ short description of an input, for the INFO logging level
|
318 |
321 |
, hInputLogLong :: i -> String
|
319 |
322 |
-- ^ long description of an input, for the DEBUG logging level
|
320 |
|
, hExec :: i -> HandlerResult o
|
|
323 |
, hExec :: i -> HandlerResult m o
|
321 |
324 |
-- ^ executes the handler on an input
|
322 |
325 |
}
|
323 |
326 |
|
324 |
327 |
|
325 |
328 |
handleJsonMessage
|
326 |
|
:: (J.JSON o)
|
327 |
|
=> Handler i o -- ^ handler
|
|
329 |
:: (J.JSON o, Monad m)
|
|
330 |
=> Handler i m o -- ^ handler
|
328 |
331 |
-> i -- ^ parsed input
|
329 |
|
-> HandlerResult J.JSValue
|
|
332 |
-> HandlerResult m J.JSValue
|
330 |
333 |
handleJsonMessage handler req = do
|
331 |
334 |
(close, call_result) <- hExec handler req
|
332 |
335 |
return (close, fmap J.showJSON call_result)
|
... | ... | |
334 |
337 |
-- | Takes a request as a 'String', parses it, passes it to a handler and
|
335 |
338 |
-- formats its response.
|
336 |
339 |
handleRawMessage
|
337 |
|
:: (J.JSON o)
|
338 |
|
=> Handler i o -- ^ handler
|
|
340 |
:: (J.JSON o, MonadLog m)
|
|
341 |
=> Handler i m o -- ^ handler
|
339 |
342 |
-> String -- ^ raw unparsed input
|
340 |
|
-> IO (Bool, String)
|
|
343 |
-> m (Bool, String)
|
341 |
344 |
handleRawMessage handler payload =
|
342 |
345 |
case parseCall payload >>= uncurry (hParse handler) of
|
343 |
346 |
Bad err -> do
|
... | ... | |
359 |
362 |
-- | Reads a request, passes it to a handler and sends a response back to the
|
360 |
363 |
-- client.
|
361 |
364 |
handleClient
|
362 |
|
:: (J.JSON o)
|
363 |
|
=> Handler i o
|
|
365 |
:: (J.JSON o, MonadBase IO m, MonadLog m)
|
|
366 |
=> Handler i m o
|
364 |
367 |
-> Client
|
365 |
|
-> IO Bool
|
|
368 |
-> m Bool
|
366 |
369 |
handleClient handler client = do
|
367 |
|
msg <- recvMsgExt client
|
|
370 |
msg <- liftBase $ recvMsgExt client
|
368 |
371 |
|
369 |
|
debugMode <- isDebugMode
|
|
372 |
debugMode <- liftBase isDebugMode
|
370 |
373 |
when (debugMode && isRisky msg) $
|
371 |
374 |
logAlert "POSSIBLE LEAKING OF CONFIDENTIAL PARAMETERS. \
|
372 |
375 |
\Daemon is running in debug mode. \
|
... | ... | |
380 |
383 |
return False
|
381 |
384 |
RecvOk payload -> do
|
382 |
385 |
(close, outMsg) <- handleRawMessage handler payload
|
383 |
|
sendMsg client outMsg
|
|
386 |
liftBase $ sendMsg client outMsg
|
384 |
387 |
return close
|
385 |
388 |
|
386 |
389 |
|
387 |
390 |
-- | Main client loop: runs one loop of 'handleClient', and if that
|
388 |
391 |
-- doesn't report a finished (closed) connection, restarts itself.
|
389 |
392 |
clientLoop
|
390 |
|
:: (J.JSON o)
|
391 |
|
=> Handler i o
|
|
393 |
:: (J.JSON o, MonadBase IO m, MonadLog m)
|
|
394 |
=> Handler i m o
|
392 |
395 |
-> Client
|
393 |
|
-> IO ()
|
|
396 |
-> m ()
|
394 |
397 |
clientLoop handler client = do
|
395 |
398 |
result <- handleClient handler client
|
396 |
399 |
if result
|
397 |
400 |
then clientLoop handler client
|
398 |
|
else closeClient client
|
|
401 |
else liftBase $ closeClient client
|
399 |
402 |
|
400 |
403 |
-- | Main listener loop: accepts clients, forks an I/O thread to handle
|
401 |
404 |
-- that client.
|
402 |
405 |
listener
|
403 |
|
:: (J.JSON o)
|
404 |
|
=> Handler i o
|
|
406 |
:: (J.JSON o, MonadBaseControl IO m, MonadLog m)
|
|
407 |
=> Handler i m o
|
405 |
408 |
-> Server
|
406 |
|
-> IO ()
|
|
409 |
-> m ()
|
407 |
410 |
listener handler server = do
|
408 |
|
client <- acceptClient server
|
409 |
|
_ <- forkIO $ clientLoop handler client
|
|
411 |
client <- liftBase $ acceptClient server
|
|
412 |
_ <- fork $ clientLoop handler client
|
410 |
413 |
return ()
|