Commit b172b0ab authored by Petr Pudlak's avatar Petr Pudlak

Allow clients of UDSServer to use different monads

.. as long as they're instances of "MonadBaseControl IO" and "MonadLog".
This allows the UDSServer to call functions like "fork" within monads
such as "ResultT e IO" or "ReaderT IO".
Signed-off-by: default avatarPetr Pudlak <pudlak@google.com>
Reviewed-by: default avatarKlaus Aehlig <aehlig@google.com>
parent e1b9b5c6
...@@ -430,7 +430,7 @@ luxiExec (qlock, qstat, creader) args = do ...@@ -430,7 +430,7 @@ luxiExec (qlock, qstat, creader) args = do
result <- handleCallWrapper qlock qstat cfg args result <- handleCallWrapper qlock qstat cfg args
return (True, result) return (True, result)
luxiHandler :: LuxiConfig -> U.Handler LuxiOp JSValue luxiHandler :: LuxiConfig -> U.Handler LuxiOp IO JSValue
luxiHandler cfg = U.Handler { U.hParse = decodeLuxiCall luxiHandler cfg = U.Handler { U.hParse = decodeLuxiCall
, U.hInputLogShort = strOfOp , U.hInputLogShort = strOfOp
, U.hInputLogLong = show , U.hInputLogLong = show
......
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-| Implementation of the Ganeti Unix Domain Socket JSON server interface. {-| Implementation of the Ganeti Unix Domain Socket JSON server interface.
...@@ -56,7 +57,9 @@ module Ganeti.UDSServer ...@@ -56,7 +57,9 @@ module Ganeti.UDSServer
) where ) where
import Control.Applicative import Control.Applicative
import Control.Concurrent (forkIO) import Control.Concurrent.Lifted (fork)
import Control.Monad.Base
import Control.Monad.Trans.Control
import Control.Exception (catch) import Control.Exception (catch)
import Control.Monad import Control.Monad
import qualified Data.ByteString as B import qualified Data.ByteString as B
...@@ -198,9 +201,9 @@ connectServer conf setOwner path = do ...@@ -198,9 +201,9 @@ connectServer conf setOwner path = do
return Server { sSocket=s, sPath=path, serverConfig=conf } return Server { sSocket=s, sPath=path, serverConfig=conf }
-- | Closes a server endpoint. -- | Closes a server endpoint.
closeServer :: Server -> IO () closeServer :: (MonadBase IO m) => Server -> m ()
closeServer server = closeServer server =
closeServerSocket (sSocket server) (sPath server) liftBase $ closeServerSocket (sSocket server) (sPath server)
-- | Accepts a client -- | Accepts a client
acceptClient :: Server -> IO Client acceptClient :: Server -> IO Client
...@@ -285,7 +288,7 @@ buildResponse success args = ...@@ -285,7 +288,7 @@ buildResponse success args =
-- | Logs an outgoing message. -- | Logs an outgoing message.
logMsg logMsg
:: (Show e, J.JSON e, MonadLog m) :: (Show e, J.JSON e, MonadLog m)
=> Handler i o => Handler i m o
-> i -- ^ the received request (used for logging) -> i -- ^ the received request (used for logging)
-> GenericResult e J.JSValue -- ^ A message to be sent -> GenericResult e J.JSValue -- ^ A message to be sent
-> m () -> m ()
...@@ -308,25 +311,25 @@ prepareMsg (Ok result) = (True, result) ...@@ -308,25 +311,25 @@ prepareMsg (Ok result) = (True, result)
-- * Processing client requests -- * Processing client requests
type HandlerResult o = IO (Bool, GenericResult GanetiException o) type HandlerResult m o = m (Bool, GenericResult GanetiException o)
data Handler i o = Handler data Handler i m o = Handler
{ hParse :: J.JSValue -> J.JSValue -> Result i { hParse :: J.JSValue -> J.JSValue -> Result i
-- ^ parses method and its arguments into the input type -- ^ parses method and its arguments into the input type
, hInputLogShort :: i -> String , hInputLogShort :: i -> String
-- ^ short description of an input, for the INFO logging level -- ^ short description of an input, for the INFO logging level
, hInputLogLong :: i -> String , hInputLogLong :: i -> String
-- ^ long description of an input, for the DEBUG logging level -- ^ long description of an input, for the DEBUG logging level
, hExec :: i -> HandlerResult o , hExec :: i -> HandlerResult m o
-- ^ executes the handler on an input -- ^ executes the handler on an input
} }
handleJsonMessage handleJsonMessage
:: (J.JSON o) :: (J.JSON o, Monad m)
=> Handler i o -- ^ handler => Handler i m o -- ^ handler
-> i -- ^ parsed input -> i -- ^ parsed input
-> HandlerResult J.JSValue -> HandlerResult m J.JSValue
handleJsonMessage handler req = do handleJsonMessage handler req = do
(close, call_result) <- hExec handler req (close, call_result) <- hExec handler req
return (close, fmap J.showJSON call_result) return (close, fmap J.showJSON call_result)
...@@ -334,10 +337,10 @@ handleJsonMessage handler req = do ...@@ -334,10 +337,10 @@ handleJsonMessage handler req = do
-- | Takes a request as a 'String', parses it, passes it to a handler and -- | Takes a request as a 'String', parses it, passes it to a handler and
-- formats its response. -- formats its response.
handleRawMessage handleRawMessage
:: (J.JSON o) :: (J.JSON o, MonadLog m)
=> Handler i o -- ^ handler => Handler i m o -- ^ handler
-> String -- ^ raw unparsed input -> String -- ^ raw unparsed input
-> IO (Bool, String) -> m (Bool, String)
handleRawMessage handler payload = handleRawMessage handler payload =
case parseCall payload >>= uncurry (hParse handler) of case parseCall payload >>= uncurry (hParse handler) of
Bad err -> do Bad err -> do
...@@ -359,14 +362,14 @@ isRisky msg = case msg of ...@@ -359,14 +362,14 @@ isRisky msg = case msg of
-- | Reads a request, passes it to a handler and sends a response back to the -- | Reads a request, passes it to a handler and sends a response back to the
-- client. -- client.
handleClient handleClient
:: (J.JSON o) :: (J.JSON o, MonadBase IO m, MonadLog m)
=> Handler i o => Handler i m o
-> Client -> Client
-> IO Bool -> m Bool
handleClient handler client = do handleClient handler client = do
msg <- recvMsgExt client msg <- liftBase $ recvMsgExt client
debugMode <- isDebugMode debugMode <- liftBase isDebugMode
when (debugMode && isRisky msg) $ when (debugMode && isRisky msg) $
logAlert "POSSIBLE LEAKING OF CONFIDENTIAL PARAMETERS. \ logAlert "POSSIBLE LEAKING OF CONFIDENTIAL PARAMETERS. \
\Daemon is running in debug mode. \ \Daemon is running in debug mode. \
...@@ -380,31 +383,31 @@ handleClient handler client = do ...@@ -380,31 +383,31 @@ handleClient handler client = do
return False return False
RecvOk payload -> do RecvOk payload -> do
(close, outMsg) <- handleRawMessage handler payload (close, outMsg) <- handleRawMessage handler payload
sendMsg client outMsg liftBase $ sendMsg client outMsg
return close return close
-- | Main client loop: runs one loop of 'handleClient', and if that -- | Main client loop: runs one loop of 'handleClient', and if that
-- doesn't report a finished (closed) connection, restarts itself. -- doesn't report a finished (closed) connection, restarts itself.
clientLoop clientLoop
:: (J.JSON o) :: (J.JSON o, MonadBase IO m, MonadLog m)
=> Handler i o => Handler i m o
-> Client -> Client
-> IO () -> m ()
clientLoop handler client = do clientLoop handler client = do
result <- handleClient handler client result <- handleClient handler client
if result if result
then clientLoop handler client then clientLoop handler client
else closeClient client else liftBase $ closeClient client
-- | Main listener loop: accepts clients, forks an I/O thread to handle -- | Main listener loop: accepts clients, forks an I/O thread to handle
-- that client. -- that client.
listener listener
:: (J.JSON o) :: (J.JSON o, MonadBaseControl IO m, MonadLog m)
=> Handler i o => Handler i m o
-> Server -> Server
-> IO () -> m ()
listener handler server = do listener handler server = do
client <- acceptClient server client <- liftBase $ acceptClient server
_ <- forkIO $ clientLoop handler client _ <- fork $ clientLoop handler client
return () return ()
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment