Merge pull request #263 from well-typed/edsko/issue-238

Fix #238

grapesy/grapesy.cabal

@@ -171,7 +171,7 @@ library
     , unordered-containers >= 0.2     && < 0.3
     , utf8-string          >= 1.0     && < 1.1
 
-      -- We pin a very specific vrsion of http2.
+      -- We pin very specific versions of http2.
       --
       -- Other versions should be tested against the full grapesy test suite
       -- (regular tests and stress tests).
@@ -223,6 +223,7 @@ test-suite test-grapesy
       Test.Driver.Dialogue.TestClock
       Test.Prop.Dialogue
       Test.Regression.Issue102
+      Test.Regression.Issue238
       Test.Sanity.BrokenDeployments
       Test.Sanity.Compression
       Test.Sanity.Disconnect
@@ -239,11 +240,13 @@ test-suite test-grapesy
       Proto.API.Helloworld
       Proto.API.Interop
       Proto.API.Ping
+      Proto.API.RouteGuide
       Proto.API.Trivial
       Proto.Empty
       Proto.Helloworld
       Proto.Messages
       Proto.Ping
+      Proto.RouteGuide
       Proto.Test
 
   build-depends:

grapesy/src/Network/GRPC/Server/Call.hs

@@ -88,14 +88,28 @@ data Call rpc = SupportsServerRpc rpc => Call {
       --
       -- Can be updated until the first message (see 'callFirstMessage'), at
       -- which point it /must/ have been set (if not, an exception is thrown).
-    , callResponseMetadata :: TVar (Maybe (ResponseInitialMetadata rpc))
+    , callResponseMetadata :: TVar (CallInitialMetadata rpc)
 
       -- | What kicked off the response?
       --
       -- This is empty until the response /has/ in fact been kicked off.
     , callResponseKickoff :: TMVar Kickoff
     }
 
+-- | Initial metadata
+--
+-- See 'callResponseMetadata' for discussion.
+data CallInitialMetadata rpc =
+    -- | Initial metadata not yet set
+    CallInitialMetadataNotSet
+
+    -- | Initial metadata has been set
+    --
+    -- We record the 'CallStack' of where the metadata was set.
+  | CallInitialMetadataSet (ResponseInitialMetadata rpc) CallStack
+
+deriving stock instance IsRPC rpc => Show (CallInitialMetadata rpc)
+
 -- | What kicked off the response?
 --
 -- When the server handler starts, we do not immediately initiate the response
@@ -136,7 +150,7 @@ setupCall :: forall rpc.
   -> ServerContext
   -> IO (Call rpc, Maybe Timeout)
 setupCall conn callContext@ServerContext{serverParams} = do
-    callResponseMetadata <- newTVarIO Nothing
+    callResponseMetadata <- newTVarIO CallInitialMetadataNotSet
     callResponseKickoff  <- newEmptyTMVarIO
 
     (inboundHeaders, timeout) <- determineInbound callSession req
@@ -216,44 +230,50 @@ determineInbound session req = do
 startOutbound :: forall rpc.
      SupportsServerRpc rpc
   => ServerParams
-  -> TVar (Maybe (ResponseInitialMetadata rpc))
+  -> TVar (CallInitialMetadata rpc)
   -> TMVar Kickoff
   -> Compression
   -> IO (Session.FlowStart (ServerOutbound rpc), Session.ResponseInfo)
 startOutbound serverParams metadataVar kickoffVar cOut = do
     -- Wait for kickoff (see 'Kickoff' for discussion)
     kickoff <- atomically $ readTMVar kickoffVar
 
-    -- Get response metadata (see 'setResponseMetadata')
-    -- It is important we read this only /after/ the kickoff.
-    responseMetadata <- do
-      mMetadata <- atomically $ readTVar metadataVar
-      case mMetadata of
-        Just md -> buildMetadataIO md
-        Nothing -> throwIO $ ResponseInitialMetadataNotSet
-
     -- Session start
-    let flowStart :: Session.FlowStart (ServerOutbound rpc)
-        flowStart =
-          case kickoff of
-            KickoffRegular _cs ->
-              Session.FlowStartRegular $ OutboundHeaders {
-                  outHeaders = ResponseHeaders {
-                      responseCompression =
-                        Just $ Compr.compressionId cOut
-                    , responseAcceptCompression =
-                        Just $ Compr.offer compr
-                    , responseContentType =
-                        serverContentType serverParams
-                    , responseMetadata =
-                        customMetadataMapFromList responseMetadata
-                    , responseUnrecognized =
-                        ()
-                    }
-                , outCompression = cOut
+    flowStart :: Session.FlowStart (ServerOutbound rpc) <-
+      case kickoff of
+        KickoffRegular _cs -> do
+          -- Get response metadata (see 'setResponseMetadata')
+          --
+          -- It is important we do this only for 'KickoffRegular', because the
+          -- initial metadata is not used in the Trailers-Only case, and we
+          -- should not unecessarily throw the 'ResponseInitialMetadataNotSet'
+          -- exception. This is especially important when that Trailers-Only
+          -- case was triggered by an exception in the handler, because the
+          -- handler might not yet have had the opportunity to set the initial
+          -- metdata prior to the error.
+          responseMetadata <- do
+            mMetadata <- atomically $ readTVar metadataVar
+            case mMetadata of
+              CallInitialMetadataSet md _cs -> buildMetadataIO md
+              CallInitialMetadataNotSet     -> throwIO $ ResponseInitialMetadataNotSet
+
+          return $ Session.FlowStartRegular $ OutboundHeaders {
+              outHeaders = ResponseHeaders {
+                  responseCompression =
+                    Just $ Compr.compressionId cOut
+                , responseAcceptCompression =
+                    Just $ Compr.offer compr
+                , responseContentType =
+                    serverContentType serverParams
+                , responseMetadata =
+                    customMetadataMapFromList responseMetadata
+                , responseUnrecognized =
+                    ()
                 }
-            KickoffTrailersOnly _cs trailers ->
-              Session.FlowStartNoMessages trailers
+            , outCompression = cOut
+            }
+        KickoffTrailersOnly _cs trailers ->
+          return $ Session.FlowStartNoMessages trailers
 
     return (flowStart, buildResponseInfo flowStart)
   where
@@ -503,8 +523,10 @@ setResponseInitialMetadata Call{ callResponseMetadata
                            md = atomically $ do
     mKickoff <- fmap kickoffCallStack <$> tryReadTMVar callResponseKickoff
     case mKickoff of
-      Nothing -> writeTVar callResponseMetadata (Just md)
-      Just cs -> throwSTM $ ResponseAlreadyInitiated cs callStack
+      Nothing ->
+        writeTVar callResponseMetadata (CallInitialMetadataSet md callStack)
+      Just cs ->
+        throwSTM $ ResponseAlreadyInitiated cs callStack
 
 {-------------------------------------------------------------------------------
   Low-level API

grapesy/src/Network/GRPC/Server/Handler.hs

@@ -159,17 +159,17 @@ runHandler :: forall rpc.
   -> Call rpc
   -> RpcHandler IO rpc
   -> IO ()
-runHandler unmask call (RpcHandler k) = do
+runHandler unmask call handler = do
     -- http2 will kill the handler when the client disappears, but we want the
     -- handler to be able to terminate cleanly. We therefore run the handler in
     -- a separate thread, and wait for that thread to terminate.
-    handlerThread <- asyncLabelled "grapesy:handler" handler
+    handlerThread <- asyncLabelled "grapesy:handler" handler'
     waitForHandler unmask call handlerThread
   where
     -- The handler itself will run in a separate thread
-    handler :: IO ()
-    handler = do
-        result <- try $ k call
+    handler' :: IO ()
+    handler' = do
+        result <- try $ runRpcHandler handler call
         handlerTeardown result
 
     -- Deal with any exceptions thrown in the handler
@@ -184,7 +184,7 @@ runHandler unmask call (RpcHandler k) = do
           throwM HandlerTerminated
     handlerTeardown (Left err) = do
         -- The handler threw an exception. Attempt to tell the client.
-        void $ forwardException call err
+        _forwarded <- forwardException call err
         ignoreUncleanClose call $ ExitCaseException err
         throwM err
 
@@ -284,4 +284,4 @@ forwardException call@Call{callContext} err = do
     (True <$ sendProperTrailers call trailers) `catch` handler
  where
    handler :: SomeException -> IO Bool
-   handler _ = return False
+   handler _e = return False

grapesy/src/Network/GRPC/Server/RequestHandler.hs

@@ -15,6 +15,7 @@ module Network.GRPC.Server.RequestHandler (
 
 import Control.Concurrent
 import Control.Concurrent.Thread.Delay qualified as UnboundedDelays
+import Control.Exception (evaluate)
 import Control.Monad.Catch
 import Data.Bifunctor
 import Data.ByteString.Builder qualified as Builder
@@ -27,7 +28,7 @@ import Network.HTTP.Types qualified as HTTP
 import Network.HTTP2.Server qualified as HTTP2
 
 import Network.GRPC.Server.Call
-import Network.GRPC.Server.Context (ServerContext (..))
+import Network.GRPC.Server.Context (ServerContext (..), ServerParams(..))
 import Network.GRPC.Server.Handler
 import Network.GRPC.Server.HandlerMap (HandlerMap)
 import Network.GRPC.Server.HandlerMap qualified as HandlerMap
@@ -48,13 +49,15 @@ requestHandler handlers ctxt unmask request respond = do
     labelThisThread "grapesy:requestHandler"
 
     SomeRpcHandler (_ :: Proxy rpc) handler <-
-      findHandler handlers request      `catch` setupFailure respond
+      findHandler handlers request      `catch` setupFailure params respond
     (call :: Call rpc, mTimeout :: Maybe Timeout) <-
-      setupCall connectionToClient ctxt `catch` setupFailure respond
+      setupCall connectionToClient ctxt `catch` setupFailure params respond
 
     imposeTimeout mTimeout $
       runHandler unmask call handler
   where
+    ServerContext{serverParams = params} = ctxt
+
     connectionToClient :: ConnectionToClient
     connectionToClient = ConnectionToClient{request, respond}
 
@@ -84,12 +87,14 @@ findHandler handlers req = do
       either throwM return . first CallSetupInvalidResourceHeaders $
         parseResourceHeaders rawHeaders
     let path = resourcePath resourceHeaders
-    handler <- do
-      case HandlerMap.lookup path handlers of
-        Just h  -> return h
-        Nothing -> throwM $ CallSetupUnimplementedMethod path
 
-    return handler
+    -- We have to be careful looking up the handler; there might be pure
+    -- exceptions in the list of handlers (most commonly @undefined@).
+    mHandler <- try $ evaluate $ HandlerMap.lookup path handlers
+    case mHandler of
+      Right (Just h) -> return h
+      Right Nothing  -> throwM $ CallSetupUnimplementedMethod path
+      Left err       -> throwM $ CallSetupHandlerLookupException err
   where
     rawHeaders :: RawResourceHeaders
     rawHeaders = RawResourceHeaders {
@@ -103,11 +108,13 @@ findHandler handlers req = do
 -- client at all yet. We try to tell the client what happened, but ignore any
 -- exceptions that might arise from doing so.
 setupFailure ::
-     (HTTP2.Response -> IO ())
+     ServerParams
+  -> (HTTP2.Response -> IO ())
   -> CallSetupFailure
   -> IO a
-setupFailure respond failure = do
-    _ :: Either SomeException () <- try $ respond $ failureResponse failure
+setupFailure params sendResponse failure = do
+    response <- mkFailureResponse params failure
+    _ :: Either SomeException () <- try $ sendResponse response
     throwM failure
 
 {-------------------------------------------------------------------------------
@@ -132,36 +139,62 @@ setupFailure respond failure = do
 -- Testing out-of-spec errors can be bit awkward. One option is @curl@:
 --
 -- > curl --verbose --http2 --http2-prior-knowledge http://127.0.0.1:50051/
-failureResponse :: CallSetupFailure -> HTTP2.Response
-failureResponse (CallSetupInvalidResourceHeaders (InvalidMethod method)) =
-    HTTP2.responseBuilder
-      HTTP.methodNotAllowed405
-      [("Allow", "POST")]
-      (Builder.byteString . mconcat $ [
-          "Unexpected :method " <> method <> ".\n"
-        , "The only method supported by gRPC is POST.\n"
-        ])
-failureResponse (CallSetupInvalidResourceHeaders (InvalidPath path)) =
-    HTTP2.responseBuilder HTTP.badRequest400 [] . Builder.byteString $
-      "Invalid path " <> path
-failureResponse (CallSetupInvalidRequestHeaders invalid) =
-    HTTP2.responseBuilder (statusInvalidHeaders invalid) [] $
-      prettyInvalidHeaders invalid
-failureResponse (CallSetupUnsupportedCompression cid) =
-    HTTP2.responseBuilder HTTP.badRequest400 [] . Builder.byteString $
-      "Unsupported compression: " <> BS.UTF8.fromString (show cid)
-failureResponse (CallSetupUnimplementedMethod path) =
-    HTTP2.responseNoBody HTTP.ok200 . buildTrailersOnly chooseContentType' $
-      properTrailersToTrailersOnly (
-          grpcExceptionToTrailers $ grpcUnimplemented path
-        , Just ContentTypeDefault
-        )
+mkFailureResponse :: ServerParams -> CallSetupFailure -> IO HTTP2.Response
+mkFailureResponse params = \case
+    CallSetupInvalidResourceHeaders (InvalidMethod method) ->
+      return $
+        HTTP2.responseBuilder
+          HTTP.methodNotAllowed405
+          [("Allow", "POST")]
+          (Builder.byteString . mconcat $ [
+              "Unexpected :method " <> method <> ".\n"
+            , "The only method supported by gRPC is POST.\n"
+            ])
+    CallSetupInvalidResourceHeaders (InvalidPath path) ->
+      return $
+        HTTP2.responseBuilder HTTP.badRequest400 [] . Builder.byteString $
+          "Invalid path " <> path
+    CallSetupInvalidRequestHeaders invalid ->
+      return $
+        HTTP2.responseBuilder (statusInvalidHeaders invalid) [] $
+          prettyInvalidHeaders invalid
+    CallSetupUnsupportedCompression cid ->
+      return $
+        HTTP2.responseBuilder HTTP.badRequest400 [] . Builder.byteString $
+          "Unsupported compression: " <> BS.UTF8.fromString (show cid)
+    CallSetupUnimplementedMethod path -> do
+      let trailersOnly :: TrailersOnly
+          trailersOnly = properTrailersToTrailersOnly (
+              grpcExceptionToTrailers $ grpcUnimplemented path
+            , serverContentType
+            )
+      return $
+        HTTP2.responseNoBody HTTP.ok200 $
+          buildTrailersOnly contentTypeForUnknown trailersOnly
+    CallSetupHandlerLookupException err -> do
+      msg <- serverExceptionToClient err
+      let trailersOnly :: TrailersOnly
+          trailersOnly = properTrailersToTrailersOnly (
+              grpcExceptionToTrailers $ GrpcException {
+                  grpcError         = GrpcUnknown
+                , grpcErrorMessage  = msg
+                , grpcErrorMetadata = []
+                }
+            , serverContentType
+            )
+      return $
+        HTTP2.responseNoBody HTTP.ok200 $
+          buildTrailersOnly contentTypeForUnknown trailersOnly
   where
-    -- We cannot use the regular 'chooseContentType' here because we don't know
-    -- which @rpc@ this is (given that it's an unimplemented method).
-    chooseContentType' :: ContentType -> Maybe BS.UTF8.ByteString
-    chooseContentType' ContentTypeDefault       = Nothing
-    chooseContentType' (ContentTypeOverride ct) = Just ct
+    ServerParams{
+        serverExceptionToClient
+      , serverContentType
+      } = params
+
+-- | Variation on 'chooseContentType' that can be used when the RPC is unknown
+contentTypeForUnknown :: ContentType -> Maybe BS.UTF8.ByteString
+contentTypeForUnknown ContentTypeDefault       = Nothing
+contentTypeForUnknown (ContentTypeOverride ct) = Just ct
 
 grpcUnimplemented :: Path -> GrpcException
 grpcUnimplemented path = GrpcException {

grapesy/src/Network/GRPC/Server/Session.hs

@@ -99,6 +99,11 @@ data CallSetupFailure =
     -- 'CallSetupUnimplementedMethod' is referring to.
   | CallSetupUnimplementedMethod Path
 
+    -- | An exception arose while we tried to look up the handler
+    --
+    -- This can arise when the list of handlers /itself/ is @undefined@.
+  | CallSetupHandlerLookupException SomeException
+
 deriving stock    instance Show      CallSetupFailure
 deriving anyclass instance Exception CallSetupFailure
 

grapesy/test-grapesy/Main.hs

@@ -15,6 +15,7 @@ import GHC.Conc.Sync (threadLabel)
 
 import Test.Prop.Dialogue                     qualified as Dialogue
 import Test.Regression.Issue102               qualified as Issue102
+import Test.Regression.Issue238               qualified as Issue238
 import Test.Sanity.BrokenDeployments          qualified as BrokenDeployments
 import Test.Sanity.Compression                qualified as Compression
 import Test.Sanity.Disconnect                 qualified as Disconnect
@@ -41,6 +42,7 @@ main = do
           ]
       , testGroup "Regression" [
             Issue102.tests
+          , Issue238.tests
           ]
       , testGroup "Prop" [
             Dialogue.tests