From 01fac2d5a6a944fdbabe87b7d86f1c147f2c0484 Mon Sep 17 00:00:00 2001 From: Connor Clark Date: Wed, 17 Aug 2016 14:12:22 -0700 Subject: [PATCH] add option to set logging function (#71) * add option to set logging function * Add documentation to ServerOptions --- src/Network/GRPC/HighLevel/Server.hs | 57 ++++++++++++------- .../GRPC/HighLevel/Server/Unregistered.hs | 8 ++- tests/UnsafeTests.hs | 28 ++++----- 3 files changed, 55 insertions(+), 38 deletions(-) diff --git a/src/Network/GRPC/HighLevel/Server.hs b/src/Network/GRPC/HighLevel/Server.hs index 475a36c..5aebd8f 100644 --- a/src/Network/GRPC/HighLevel/Server.hs +++ b/src/Network/GRPC/HighLevel/Server.hs @@ -98,60 +98,74 @@ handlerMethodName (ClientStreamHandler m _) = m handlerMethodName (ServerStreamHandler 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. -- 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 -- whether the error is our fault or user error. -handleCallError :: Either GRPCIOError a -> IO () -handleCallError (Right _) = return () -handleCallError (Left GRPCIOTimeout) = +handleCallError :: (String -> IO ()) + -- ^ logging function + -> Either GRPCIOError a + -> IO () +handleCallError _ (Right _) = return () +handleCallError _ (Left GRPCIOTimeout) = -- Probably a benign timeout (such as a client disappearing), noop for now. return () -handleCallError (Left GRPCIOShutdown) = +handleCallError _ (Left GRPCIOShutdown) = -- Server shutting down. Benign. return () -handleCallError (Left (GRPCIODecodeError e)) = +handleCallError logMsg (Left (GRPCIODecodeError e)) = logMsg $ "Decoding error: " ++ show e -handleCallError (Left (GRPCIOHandlerException e)) = +handleCallError logMsg (Left (GRPCIOHandlerException 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." loopWError :: Int + -> ServerOptions -> IO (Either GRPCIOError a) -> IO () -loopWError i f = do +loopWError i o@ServerOptions{..} f = do when (i `mod` 100 == 0) $ putStrLn $ "i = " ++ show i - f >>= handleCallError - loopWError (i + 1) f + f >>= handleCallError optLogger + loopWError (i + 1) o f -- TODO: options for setting initial/trailing metadata handleLoop :: Server + -> ServerOptions -> (Handler a, RegisteredMethod a) -> IO () -handleLoop s (UnaryHandler _ f, rm) = - loopWError 0 $ serverHandleNormalCall s rm mempty $ convertServerHandler f -handleLoop s (ClientStreamHandler _ f, rm) = - loopWError 0 $ serverReader s rm mempty $ convertServerReaderHandler f -handleLoop s (ServerStreamHandler _ f, rm) = - loopWError 0 $ serverWriter s rm mempty $ convertServerWriterHandler f -handleLoop s (BiDiStreamHandler _ f, rm) = - loopWError 0 $ serverRW s rm mempty $ convertServerRWHandler f +handleLoop s o (UnaryHandler _ f, rm) = + loopWError 0 o $ serverHandleNormalCall s rm mempty $ convertServerHandler f +handleLoop s o (ClientStreamHandler _ f, rm) = + loopWError 0 o $ serverReader s rm mempty $ convertServerReaderHandler f +handleLoop s o (ServerStreamHandler _ f, rm) = + loopWError 0 o $ serverWriter s rm mempty $ convertServerWriterHandler f +handleLoop s o (BiDiStreamHandler _ f, rm) = + loopWError 0 o $ serverRW s rm mempty $ convertServerRWHandler f data ServerOptions = ServerOptions { optNormalHandlers :: [Handler 'Normal] + -- ^ Handlers for unary (non-streaming) calls. , optClientStreamHandlers :: [Handler 'ClientStreaming] + -- ^ Handlers for client streaming calls. , optServerStreamHandlers :: [Handler 'ServerStreaming] + -- ^ Handlers for server streaming calls. , optBiDiStreamHandlers :: [Handler 'BiDiStreaming] + -- ^ Handlers for bidirectional streaming calls. , optServerPort :: Port + -- ^ Port on which to listen for requests. , optUseCompression :: Bool + -- ^ Whether to use compression when communicating with the client. , optUserAgentPrefix :: String + -- ^ Optional custom prefix to add to the user agent string. , optUserAgentSuffix :: String + -- ^ Optional custom suffix to add to the user agent string. , optInitialMetadata :: MetadataMap + -- ^ Metadata to send at the beginning of each call. , optSSLConfig :: Maybe ServerSSLConfig + -- ^ Security configuration. + , optLogger :: String -> IO () + -- ^ Logging function to use to log errors in handling calls. } defaultOptions :: ServerOptions @@ -166,6 +180,7 @@ defaultOptions = ServerOptions , optUserAgentSuffix = "" , optInitialMetadata = mempty , optSSLConfig = Nothing + , optLogger = hPutStrLn stderr } serverLoop :: ServerOptions -> IO () diff --git a/src/Network/GRPC/HighLevel/Server/Unregistered.hs b/src/Network/GRPC/HighLevel/Server/Unregistered.hs index 24d3956..5c06793 100644 --- a/src/Network/GRPC/HighLevel/Server/Unregistered.hs +++ b/src/Network/GRPC/HighLevel/Server/Unregistered.hs @@ -8,9 +8,9 @@ module Network.GRPC.HighLevel.Server.Unregistered where +import Control.Arrow import Control.Concurrent import Control.Concurrent.Async (async, wait) -import Control.Arrow import qualified Control.Exception as CE import Control.Monad 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 dispatchLoop :: Server + -> (String -> IO ()) -> MetadataMap -> [Handler 'Normal] -> [Handler 'ClientStreaming] -> [Handler 'ServerStreaming] -> [Handler 'BiDiStreaming] -> IO () -dispatchLoop s md hN hC hS hB = +dispatchLoop s logger md hN hC hS hB = forever $ U.withServerCallAsync s $ \sc -> case findHandler sc allHandlers 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") 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) serverLoop :: ServerOptions -> IO () @@ -72,6 +73,7 @@ serverLoop ServerOptions{..} = do tid <- async $ withGRPC $ \grpc -> withServer grpc config $ \server -> do dispatchLoop server + optLogger optInitialMetadata optNormalHandlers optClientStreamHandlers diff --git a/tests/UnsafeTests.hs b/tests/UnsafeTests.hs index 3e59bf4..eb743f2 100644 --- a/tests/UnsafeTests.hs +++ b/tests/UnsafeTests.hs @@ -3,29 +3,29 @@ module UnsafeTests (unsafeTests, unsafeProperties) where -import Control.Concurrent (threadDelay) -import Control.Exception (bracket_) +import Control.Concurrent (threadDelay) +import Control.Exception (bracket_) import Control.Monad -import qualified Data.ByteString as B +import qualified Data.ByteString as B import Foreign.Marshal.Alloc import Foreign.Storable import GHC.Exts -import Network.GRPC.LowLevel.GRPC (threadDelaySecs) +import Network.GRPC.LowLevel.GRPC (threadDelaySecs) import Network.GRPC.Unsafe import Network.GRPC.Unsafe.ByteBuffer +import Network.GRPC.Unsafe.ChannelArgs import Network.GRPC.Unsafe.Metadata +import Network.GRPC.Unsafe.Security import Network.GRPC.Unsafe.Slice import Network.GRPC.Unsafe.Time -import Network.GRPC.Unsafe.ChannelArgs -import Network.GRPC.Unsafe.Security import System.Clock +import Test.QuickCheck.Gen as QC +import Test.QuickCheck.Property as QC import Test.Tasty -import Test.Tasty.HUnit as HU (testCase, (@?=), - assertBool) -import Test.Tasty.QuickCheck as QC -import Test.Tasty.HUnit as HU (testCase, (@?=)) -import Test.QuickCheck.Gen as QC -import Test.QuickCheck.Property as QC +import Test.Tasty.HUnit as HU (assertBool, testCase, + (@?=)) +import Test.Tasty.HUnit as HU (testCase, (@?=)) +import Test.Tasty.QuickCheck as QC unsafeTests :: TestTree unsafeTests = testGroup "Unit tests for unsafe C bindings" @@ -64,8 +64,8 @@ instance Arbitrary MetadataMap where roundtripMetadataKeyVals :: MetadataMap -> IO MetadataMap roundtripMetadataKeyVals m = do - kvPtr <- createMetadata m - m' <- getAllMetadata kvPtr (length $ toList m) + (kvPtr, l) <- createMetadata m + m' <- getAllMetadata kvPtr l metadataFree kvPtr return m'