add option to set logging function (#71)

* add option to set logging function

* Add documentation to ServerOptions

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 ()

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

tests/UnsafeTests.hs

@@ -13,19 +13,19 @@ import           GHC.Exts
 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.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
+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'