add option to set logging function (#71)

* add option to set logging function

* Add documentation to ServerOptions
This commit is contained in:
Connor Clark 2016-08-17 14:12:22 -07:00 committed by GitHub Enterprise
parent 3366dde7ab
commit 01fac2d5a6
3 changed files with 55 additions and 38 deletions

View file

@ -98,60 +98,74 @@ handlerMethodName (ClientStreamHandler m _) = m
handlerMethodName (ServerStreamHandler m _) = m handlerMethodName (ServerStreamHandler m _) = m
handlerMethodName (BiDiStreamHandler m _) = m handlerMethodName (BiDiStreamHandler m _) = m
logMsg :: String -> IO ()
logMsg = hPutStrLn stderr
-- | Handles errors that result from trying to handle a call on the server. -- | Handles errors that result from trying to handle a call on the server.
-- For each error, takes a different action depending on the severity in the -- For each error, takes a different action depending on the severity in the
-- context of handling a server call. This also tries to give an indication of -- context of handling a server call. This also tries to give an indication of
-- whether the error is our fault or user error. -- whether the error is our fault or user error.
handleCallError :: Either GRPCIOError a -> IO () handleCallError :: (String -> IO ())
handleCallError (Right _) = return () -- ^ logging function
handleCallError (Left GRPCIOTimeout) = -> Either GRPCIOError a
-> IO ()
handleCallError _ (Right _) = return ()
handleCallError _ (Left GRPCIOTimeout) =
-- Probably a benign timeout (such as a client disappearing), noop for now. -- Probably a benign timeout (such as a client disappearing), noop for now.
return () return ()
handleCallError (Left GRPCIOShutdown) = handleCallError _ (Left GRPCIOShutdown) =
-- Server shutting down. Benign. -- Server shutting down. Benign.
return () return ()
handleCallError (Left (GRPCIODecodeError e)) = handleCallError logMsg (Left (GRPCIODecodeError e)) =
logMsg $ "Decoding error: " ++ show e logMsg $ "Decoding error: " ++ show e
handleCallError (Left (GRPCIOHandlerException e)) = handleCallError logMsg (Left (GRPCIOHandlerException e)) =
logMsg $ "Handler exception caught: " ++ show e logMsg $ "Handler exception caught: " ++ show e
handleCallError (Left x) = handleCallError logMsg (Left x) =
logMsg $ show x ++ ": This probably indicates a bug in gRPC-haskell. Please report this error." logMsg $ show x ++ ": This probably indicates a bug in gRPC-haskell. Please report this error."
loopWError :: Int loopWError :: Int
-> ServerOptions
-> IO (Either GRPCIOError a) -> IO (Either GRPCIOError a)
-> IO () -> IO ()
loopWError i f = do loopWError i o@ServerOptions{..} f = do
when (i `mod` 100 == 0) $ putStrLn $ "i = " ++ show i when (i `mod` 100 == 0) $ putStrLn $ "i = " ++ show i
f >>= handleCallError f >>= handleCallError optLogger
loopWError (i + 1) f loopWError (i + 1) o f
-- TODO: options for setting initial/trailing metadata -- TODO: options for setting initial/trailing metadata
handleLoop :: Server handleLoop :: Server
-> ServerOptions
-> (Handler a, RegisteredMethod a) -> (Handler a, RegisteredMethod a)
-> IO () -> IO ()
handleLoop s (UnaryHandler _ f, rm) = handleLoop s o (UnaryHandler _ f, rm) =
loopWError 0 $ serverHandleNormalCall s rm mempty $ convertServerHandler f loopWError 0 o $ serverHandleNormalCall s rm mempty $ convertServerHandler f
handleLoop s (ClientStreamHandler _ f, rm) = handleLoop s o (ClientStreamHandler _ f, rm) =
loopWError 0 $ serverReader s rm mempty $ convertServerReaderHandler f loopWError 0 o $ serverReader s rm mempty $ convertServerReaderHandler f
handleLoop s (ServerStreamHandler _ f, rm) = handleLoop s o (ServerStreamHandler _ f, rm) =
loopWError 0 $ serverWriter s rm mempty $ convertServerWriterHandler f loopWError 0 o $ serverWriter s rm mempty $ convertServerWriterHandler f
handleLoop s (BiDiStreamHandler _ f, rm) = handleLoop s o (BiDiStreamHandler _ f, rm) =
loopWError 0 $ serverRW s rm mempty $ convertServerRWHandler f loopWError 0 o $ serverRW s rm mempty $ convertServerRWHandler f
data ServerOptions = ServerOptions data ServerOptions = ServerOptions
{ optNormalHandlers :: [Handler 'Normal] { optNormalHandlers :: [Handler 'Normal]
-- ^ Handlers for unary (non-streaming) calls.
, optClientStreamHandlers :: [Handler 'ClientStreaming] , optClientStreamHandlers :: [Handler 'ClientStreaming]
-- ^ Handlers for client streaming calls.
, optServerStreamHandlers :: [Handler 'ServerStreaming] , optServerStreamHandlers :: [Handler 'ServerStreaming]
-- ^ Handlers for server streaming calls.
, optBiDiStreamHandlers :: [Handler 'BiDiStreaming] , optBiDiStreamHandlers :: [Handler 'BiDiStreaming]
-- ^ Handlers for bidirectional streaming calls.
, optServerPort :: Port , optServerPort :: Port
-- ^ Port on which to listen for requests.
, optUseCompression :: Bool , optUseCompression :: Bool
-- ^ Whether to use compression when communicating with the client.
, optUserAgentPrefix :: String , optUserAgentPrefix :: String
-- ^ Optional custom prefix to add to the user agent string.
, optUserAgentSuffix :: String , optUserAgentSuffix :: String
-- ^ Optional custom suffix to add to the user agent string.
, optInitialMetadata :: MetadataMap , optInitialMetadata :: MetadataMap
-- ^ Metadata to send at the beginning of each call.
, optSSLConfig :: Maybe ServerSSLConfig , optSSLConfig :: Maybe ServerSSLConfig
-- ^ Security configuration.
, optLogger :: String -> IO ()
-- ^ Logging function to use to log errors in handling calls.
} }
defaultOptions :: ServerOptions defaultOptions :: ServerOptions
@ -166,6 +180,7 @@ defaultOptions = ServerOptions
, optUserAgentSuffix = "" , optUserAgentSuffix = ""
, optInitialMetadata = mempty , optInitialMetadata = mempty
, optSSLConfig = Nothing , optSSLConfig = Nothing
, optLogger = hPutStrLn stderr
} }
serverLoop :: ServerOptions -> IO () serverLoop :: ServerOptions -> IO ()

View file

@ -8,9 +8,9 @@
module Network.GRPC.HighLevel.Server.Unregistered where module Network.GRPC.HighLevel.Server.Unregistered where
import Control.Arrow
import Control.Concurrent import Control.Concurrent
import Control.Concurrent.Async (async, wait) import Control.Concurrent.Async (async, wait)
import Control.Arrow
import qualified Control.Exception as CE import qualified Control.Exception as CE
import Control.Monad import Control.Monad
import Data.Foldable (find) import Data.Foldable (find)
@ -21,13 +21,14 @@ import qualified Network.GRPC.LowLevel.Call.Unregistered as U
import qualified Network.GRPC.LowLevel.Server.Unregistered as U import qualified Network.GRPC.LowLevel.Server.Unregistered as U
dispatchLoop :: Server dispatchLoop :: Server
-> (String -> IO ())
-> MetadataMap -> MetadataMap
-> [Handler 'Normal] -> [Handler 'Normal]
-> [Handler 'ClientStreaming] -> [Handler 'ClientStreaming]
-> [Handler 'ServerStreaming] -> [Handler 'ServerStreaming]
-> [Handler 'BiDiStreaming] -> [Handler 'BiDiStreaming]
-> IO () -> IO ()
dispatchLoop s md hN hC hS hB = dispatchLoop s logger md hN hC hS hB =
forever $ U.withServerCallAsync s $ \sc -> forever $ U.withServerCallAsync s $ \sc ->
case findHandler sc allHandlers of case findHandler sc allHandlers of
Just (AnyHandler ah) -> case ah of Just (AnyHandler ah) -> case ah of
@ -62,7 +63,7 @@ dispatchLoop s md hN hC hS hB =
return (mempty, mempty, StatusNotFound, StatusDetails "unknown method") return (mempty, mempty, StatusNotFound, StatusDetails "unknown method")
handleError :: IO a -> IO () handleError :: IO a -> IO ()
handleError = (handleCallError . left herr =<<) . CE.try handleError = (handleCallError logger . left herr =<<) . CE.try
where herr (e :: CE.SomeException) = GRPCIOHandlerException (show e) where herr (e :: CE.SomeException) = GRPCIOHandlerException (show e)
serverLoop :: ServerOptions -> IO () serverLoop :: ServerOptions -> IO ()
@ -72,6 +73,7 @@ serverLoop ServerOptions{..} = do
tid <- async $ withGRPC $ \grpc -> tid <- async $ withGRPC $ \grpc ->
withServer grpc config $ \server -> do withServer grpc config $ \server -> do
dispatchLoop server dispatchLoop server
optLogger
optInitialMetadata optInitialMetadata
optNormalHandlers optNormalHandlers
optClientStreamHandlers optClientStreamHandlers

View file

@ -3,29 +3,29 @@
module UnsafeTests (unsafeTests, unsafeProperties) where module UnsafeTests (unsafeTests, unsafeProperties) where
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import Control.Exception (bracket_) import Control.Exception (bracket_)
import Control.Monad import Control.Monad
import qualified Data.ByteString as B import qualified Data.ByteString as B
import Foreign.Marshal.Alloc import Foreign.Marshal.Alloc
import Foreign.Storable import Foreign.Storable
import GHC.Exts import GHC.Exts
import Network.GRPC.LowLevel.GRPC (threadDelaySecs) import Network.GRPC.LowLevel.GRPC (threadDelaySecs)
import Network.GRPC.Unsafe import Network.GRPC.Unsafe
import Network.GRPC.Unsafe.ByteBuffer import Network.GRPC.Unsafe.ByteBuffer
import Network.GRPC.Unsafe.ChannelArgs
import Network.GRPC.Unsafe.Metadata import Network.GRPC.Unsafe.Metadata
import Network.GRPC.Unsafe.Security
import Network.GRPC.Unsafe.Slice import Network.GRPC.Unsafe.Slice
import Network.GRPC.Unsafe.Time import Network.GRPC.Unsafe.Time
import Network.GRPC.Unsafe.ChannelArgs
import Network.GRPC.Unsafe.Security
import System.Clock import System.Clock
import Test.QuickCheck.Gen as QC
import Test.QuickCheck.Property as QC
import Test.Tasty import Test.Tasty
import Test.Tasty.HUnit as HU (testCase, (@?=), import Test.Tasty.HUnit as HU (assertBool, testCase,
assertBool) (@?=))
import Test.Tasty.QuickCheck as QC import Test.Tasty.HUnit as HU (testCase, (@?=))
import Test.Tasty.HUnit as HU (testCase, (@?=)) import Test.Tasty.QuickCheck as QC
import Test.QuickCheck.Gen as QC
import Test.QuickCheck.Property as QC
unsafeTests :: TestTree unsafeTests :: TestTree
unsafeTests = testGroup "Unit tests for unsafe C bindings" unsafeTests = testGroup "Unit tests for unsafe C bindings"
@ -64,8 +64,8 @@ instance Arbitrary MetadataMap where
roundtripMetadataKeyVals :: MetadataMap -> IO MetadataMap roundtripMetadataKeyVals :: MetadataMap -> IO MetadataMap
roundtripMetadataKeyVals m = do roundtripMetadataKeyVals m = do
kvPtr <- createMetadata m (kvPtr, l) <- createMetadata m
m' <- getAllMetadata kvPtr (length $ toList m) m' <- getAllMetadata kvPtr l
metadataFree kvPtr metadataFree kvPtr
return m' return m'