diff --git a/grapesy/grapesy.cabal b/grapesy/grapesy.cabal index e0a78f4..f262dfc 100644 --- a/grapesy/grapesy.cabal +++ b/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: diff --git a/grapesy/src/Network/GRPC/Server/Call.hs b/grapesy/src/Network/GRPC/Server/Call.hs index 448eecc..caac56e 100644 --- a/grapesy/src/Network/GRPC/Server/Call.hs +++ b/grapesy/src/Network/GRPC/Server/Call.hs @@ -88,7 +88,7 @@ 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? -- @@ -96,6 +96,20 @@ data Call rpc = SupportsServerRpc rpc => Call { , 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,7 +230,7 @@ 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) @@ -224,36 +238,42 @@ 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 diff --git a/grapesy/src/Network/GRPC/Server/Handler.hs b/grapesy/src/Network/GRPC/Server/Handler.hs index ee0c533..3e25e49 100644 --- a/grapesy/src/Network/GRPC/Server/Handler.hs +++ b/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 diff --git a/grapesy/src/Network/GRPC/Server/RequestHandler.hs b/grapesy/src/Network/GRPC/Server/RequestHandler.hs index 39b9c65..80e8e7f 100644 --- a/grapesy/src/Network/GRPC/Server/RequestHandler.hs +++ b/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 { diff --git a/grapesy/src/Network/GRPC/Server/Session.hs b/grapesy/src/Network/GRPC/Server/Session.hs index 5433de8..e24f2b8 100644 --- a/grapesy/src/Network/GRPC/Server/Session.hs +++ b/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 diff --git a/grapesy/test-grapesy/Main.hs b/grapesy/test-grapesy/Main.hs index a88b40f..64510c3 100644 --- a/grapesy/test-grapesy/Main.hs +++ b/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 diff --git a/grapesy/test-grapesy/Test/Regression/Issue238.hs b/grapesy/test-grapesy/Test/Regression/Issue238.hs new file mode 100644 index 0000000..7f5eecc --- /dev/null +++ b/grapesy/test-grapesy/Test/Regression/Issue238.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Tests for +module Test.Regression.Issue238 (tests) where + +import Control.Exception +import Data.ByteString.Lazy (ByteString) +import Data.Text qualified as Text +import Test.Tasty +import Test.Tasty.HUnit + +import Network.GRPC.Client (rpc) +import Network.GRPC.Client qualified as Client +import Network.GRPC.Client.StreamType.IO qualified as Client +import Network.GRPC.Common +import Network.GRPC.Common.Protobuf +import Network.GRPC.Server qualified as Server +import Network.GRPC.Server.Protobuf qualified as Server +import Network.GRPC.Server.Run qualified as Server +import Network.GRPC.Server.StreamType qualified as Server + +import Proto.API.RouteGuide +import Proto.API.Trivial + +{------------------------------------------------------------------------------- + Top-level +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "Issue238" [ + testGroup "Trivial" [ + testCase "nonStreaming1" test_trivial_nonStreaming1 + , testCase "nonStreaming2" test_trivial_nonStreaming2 + ] + , testGroup "LowLevel" [ + testCase "nonStreaming1" test_lowLevel_nonStreaming1 + , testCase "nonStreaming2" test_lowLevel_nonStreaming2 + ] + , testGroup "RouteGuide" [ + testCase "nonStreaming1" test_routeGuide_nonStreaming1 + , testCase "nonStreaming2" test_routeGuide_nonStreaming2 + , testCase "nonStreaming3" test_routeGuide_nonStreaming3 + ] + ] + +{------------------------------------------------------------------------------- + Without Protobuf +-------------------------------------------------------------------------------} + +-- | Undefined handler body +test_trivial_nonStreaming1 :: Assertion +test_trivial_nonStreaming1 = + testWith handlers client + where + handlers :: [Server.SomeRpcHandler IO] + handlers = [Server.someRpcHandler $ Server.mkRpcHandler @Trivial undefined] + + client :: Client.Connection -> IO ByteString + client conn = Client.nonStreaming conn (rpc @Trivial) mempty + +-- | Like 'test_trivial_nonStreaming1', but without the call to @mkRpcHandler@ +-- +-- This matters, because 'mkRpcHandler' sets the initial metadata. +test_trivial_nonStreaming2 :: Assertion +test_trivial_nonStreaming2 = + testWith handlers client + where + handlers :: [Server.SomeRpcHandler IO] + handlers = [Server.someRpcHandler @Trivial undefined] + + client :: Client.Connection -> IO ByteString + client conn = Client.nonStreaming conn (rpc @Trivial) mempty + +{------------------------------------------------------------------------------- + Low-level API + + The ticket specifically says "when client uses high-level API". In this + section we therefore compare the behaviour of the @test_trivial@ tests (which + use the high-level API) to the corresponding behaviour with the low-level API. +-------------------------------------------------------------------------------} + +-- | Direct equivalent of 'test_trivial_nonStreaming2' +test_lowLevel_nonStreaming1 :: Assertion +test_lowLevel_nonStreaming1 = + testWith handlers client + where + handlers :: [Server.SomeRpcHandler IO] + handlers = [Server.someRpcHandler @Trivial undefined] + + client :: Client.Connection -> IO ByteString + client conn = + Client.withRPC conn def (Proxy @Trivial) $ \call -> do + Client.sendFinalInput call mempty + fst <$> Client.recvFinalOutput call + +-- | Like 'test_lowLevel_nonStreaming1, but without sending the input +test_lowLevel_nonStreaming2 :: Assertion +test_lowLevel_nonStreaming2 = + testWith handlers client + where + handlers :: [Server.SomeRpcHandler IO] + handlers = [Server.someRpcHandler @Trivial undefined] + + client :: Client.Connection -> IO ByteString + client conn = + Client.withRPC conn def (Proxy @Trivial) $ \call -> do + fst <$> Client.recvFinalOutput call + +{------------------------------------------------------------------------------- + With Protobuf + + Crucially, this uses 'fromMethods', which is not unlikely to have undefineds + in it during development. + + The @test_routeGuide_nonStreaming@ tests all use @undefined@ somewhere in + the declaration of the methods, but differ on how much is defined. +-------------------------------------------------------------------------------} + +-- | Completely @undefined@ 'Methods' +-- +-- This is different from 'test_routeGuide_nonStreaming2', where the /skeleton/ +-- is defined but the individual handlers are not: here we cannot even construct +-- the list without triggering an exception, forcing us to be very careful with +-- exception handling during lookup. +test_routeGuide_nonStreaming1 :: Assertion +test_routeGuide_nonStreaming1 = + testWith (Server.fromMethods methods) client + where + methods :: Server.Methods IO (Server.ProtobufMethodsOf RouteGuide) + methods = undefined + + client :: Client.Connection -> IO (Proto Feature) + client conn = Client.nonStreaming conn (rpc @GetFeature) defMessage + +test_routeGuide_nonStreaming2 :: Assertion +test_routeGuide_nonStreaming2 = + testWith (Server.fromMethods methods) client + where + methods :: Server.Methods IO (Server.ProtobufMethodsOf RouteGuide) + methods = + Server.Method undefined + $ Server.Method undefined + $ Server.Method undefined + $ Server.Method undefined + $ Server.NoMoreMethods + + client :: Client.Connection -> IO (Proto Feature) + client conn = Client.nonStreaming conn (rpc @GetFeature) defMessage + +test_routeGuide_nonStreaming3 :: Assertion +test_routeGuide_nonStreaming3 = + testWith (Server.fromMethods methods) client + where + methods :: Server.Methods IO (Server.ProtobufMethodsOf RouteGuide) + methods = + Server.Method (Server.mkNonStreaming undefined) + $ Server.Method undefined + $ Server.Method undefined + $ Server.Method undefined + $ Server.NoMoreMethods + + client :: Client.Connection -> IO (Proto Feature) + client conn = Client.nonStreaming conn (rpc @GetFeature) defMessage + +{------------------------------------------------------------------------------- + Auxiliary: test setup + + We don't use the test clients/server infrastructure here, since this issue + is about exception handling, and the test harnass does quite a bit of + exception processing. +-------------------------------------------------------------------------------} + +testWith :: + [Server.SomeRpcHandler IO] + -> (Client.Connection -> IO a) + -> Assertion +testWith handlers client = do + server <- Server.mkGrpcServer serverParams handlers + Server.forkServer def serverConfig server $ \runningServer -> do + serverPort <- Server.getServerPort runningServer + + let serverAddr = Client.ServerInsecure $ Client.Address { + addressHost = "127.0.0.1" + , addressPort = serverPort + , addressAuthority = Nothing + } + Client.withConnection def serverAddr $ \conn -> + checkClientReceivesUndefined $ client conn + where + serverConfig :: Server.ServerConfig + serverConfig = Server.ServerConfig { + serverInsecure = Just $ Server.InsecureConfig Nothing 0 + , serverSecure = Nothing + } + + serverParams :: Server.ServerParams + serverParams = def { + Server.serverTopLevel = \handler unmask req resp -> do + _result :: Either SomeException () <- try $ handler unmask req resp + -- Ignore any exceptions + return () + } + +-- | Verify that the client is notified of the undefined handler +checkClientReceivesUndefined :: + HasCallStack + => IO a -> Assertion +checkClientReceivesUndefined k = do + result <- try k + case result of + Right _ -> + assertFailure "Unexpected successful response" + Left err -> + case grpcErrorMessage err of + Just msg -> + assertBool (show (Text.unpack msg) ++ " contains \"undefined\"") $ + "undefined" `Text.isInfixOf` msg + Nothing -> + assertFailure "Missing error message" \ No newline at end of file