diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,15 @@ # Revision history for grapesy +## 1.2.2 -- 2026-10-30 + +* Support configurable HTTP/2 client idle timeout and keepalive ping, via + `http2ClientIdleTimeout` and `http2ClientKeepAlivePingInterval` in + `HTTP2Settings` [#228/#380, Adrian Huetter] +* Support for (non-standard) CBOR RPC [#383, Finley McIlwaine] + Requires `grpc-spec >= 1.1.1`. +* Use `http2-5.4.12`, relax bounds +* Silence harmless (and hard to prevent) uncaught exceptions in test suite + ## 1.2.1 -- 2026-09-29 * Bump `http2` to 5.4.6 diff --git a/grapesy.cabal b/grapesy.cabal --- a/grapesy.cabal +++ b/grapesy.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: grapesy -version: 1.2.1 +version: 1.2.2 synopsis: Native Haskell implementation of the gRPC framework description: This is a fully compliant and feature complete native Haskell implementation of gRPC, Google's RPC framework. @@ -103,6 +103,7 @@ Network.GRPC.Client.StreamType.IO.Binary Network.GRPC.Common Network.GRPC.Common.Binary + Network.GRPC.Common.CBOR Network.GRPC.Common.Compression Network.GRPC.Common.Exception Network.GRPC.Common.Headers @@ -168,12 +169,12 @@ , bytestring >= 0.10.12 && < 0.13 , conduit >= 1.3 && < 1.4 , containers >= 0.6 && < 0.9 - , crypton-x509 >= 1.7 && < 1.10 - , crypton-x509-store >= 1.6 && < 1.10 - , crypton-x509-system >= 1.6 && < 1.10 + , crypton-x509 >= 1.7 && < 1.11 + , crypton-x509-store >= 1.6 && < 1.11 + , crypton-x509-system >= 1.6 && < 1.11 , data-default >= 0.7 && < 0.9 , deepseq >= 1.4 && < 1.6 - , grpc-spec >= 1.1 && < 1.2 + , grpc-spec >= 1.1.1 && < 1.2 , http-types >= 0.12 && < 0.13 , lens >= 5.0 && < 5.4 , mtl >= 2.2 && < 2.4 @@ -181,9 +182,10 @@ , proto-lens >= 0.7 && < 0.8 , random >= 1.2 && < 1.4 , recv >= 0.1 && < 0.2 + , serialise >= 0.2 && < 0.3 , stm >= 2.5 && < 2.6 , text >= 1.2 && < 2.2 - , time-manager >= 0.3.2 && < 0.5 + , time-manager >= 0.3.2 && < 0.6 , tls >= 1.7 && < 2.5 , unbounded-delays >= 0.1.1 && < 0.2 , unordered-containers >= 0.2 && < 0.3 @@ -202,10 +204,10 @@ -- any new version should be tested against the full grapesy test suite -- (regular tests, stress tests and interop tests). build-depends: - , http2 == 5.4.6 + , http2 == 5.4.12 , http-semantics >= 0.4 && < 0.5 , http2-tls >= 0.5 && < 0.6 - , network-run >= 0.5 && < 0.7 + , network-run >= 0.5 && < 0.8 if(flag(patched-ghc-for-exception-debugging)) cpp-options: -DPATCHED_GHC_FOR_EXCEPTION_DEBUGGING @@ -262,6 +264,7 @@ Test.Sanity.Any Test.Sanity.BrokenDeployments Test.Sanity.Cancellation + Test.Sanity.CBOR Test.Sanity.Compression Test.Sanity.EndOfStream Test.Sanity.FramesAfterReset @@ -308,6 +311,7 @@ , network , proto-lens , proto-lens-protobuf-types + , serialise , stm , text , time-manager @@ -319,7 +323,6 @@ , filepath >= 1.4.2.1 && < 1.6 , proto-lens-runtime >= 0.7 && < 0.8 , QuickCheck >= 2.14 && < 2.20 - , serialise >= 0.2 && < 0.3 , tasty >= 1.4 && < 1.6 , tasty-hunit >= 0.10 && < 0.11 , tasty-quickcheck >= 0.10 && < 0.12 @@ -344,6 +347,7 @@ Test.Disconnect.Echo.Client Test.Disconnect.Echo.RPC Test.Disconnect.Echo.Server + Test.Disconnect.Keepalive Test.Disconnect.Util.Client Test.Disconnect.Util.Exception Test.Disconnect.Util.Process diff --git a/src/Network/GRPC/Client/Run.hs b/src/Network/GRPC/Client/Run.hs --- a/src/Network/GRPC/Client/Run.hs +++ b/src/Network/GRPC/Client/Run.hs @@ -31,9 +31,10 @@ import Network.GRPC.Util.Imports -import Control.Concurrent.MVar (MVar, newMVar, newEmptyMVar, putMVar, takeMVar) +import Control.Concurrent import Control.Concurrent.STM (TVar, TMVar) import Control.Concurrent.STM qualified as STM +import Control.Monad (forever) import Network.HPACK qualified as HPACK import Network.HTTP2.Client qualified as HTTP2.Client import Network.HTTP2.TLS.Client qualified as HTTP2.TLS.Client @@ -48,6 +49,7 @@ import Network.GRPC.Util.GHC import Network.GRPC.Util.Session.Client qualified as Session import Network.GRPC.Util.TLS qualified as Util.TLS +import Control.Exception (uninterruptibleMask_) {------------------------------------------------------------------------------- Open a new connection @@ -273,19 +275,27 @@ -- | Insecure connection over the given socket connectSocket :: ConnParams -> Attempt -> String -> Socket -> IO () -connectSocket connParams attempt connAuthority sock = do - bracket (HTTP2.Client.allocSimpleConfig sock writeBufferSize) - HTTP2.Client.freeSimpleConfig $ \conf -> - HTTP2.Client.run clientConfig conf $ \sendRequest _aux -> do - let conn = Session.ConnectionToServer sendRequest - atomically $ - STM.writeTVar (attemptState attempt) $ - ConnectionReady (attemptClosed attempt) conn - runOnConnection $ attemptOnConnection attempt - takeMVar $ attemptOutOfScope attempt +connectSocket connParams attempt connAuthority sock = + bracket allocConfig HTTP2.Client.freeSimpleConfig $ \conf -> + HTTP2.Client.run clientConfig conf $ \sendRequest aux -> + withKeepAlive aux connHTTP2Settings $ do + let conn = Session.ConnectionToServer sendRequest + atomically $ + STM.writeTVar (attemptState attempt) $ + ConnectionReady (attemptClosed attempt) conn + runOnConnection $ attemptOnConnection attempt + takeMVar $ attemptOutOfScope attempt where ConnParams{connHTTP2Settings} = connParams + allocConfig :: IO HTTP2.Client.Config + allocConfig = + case http2ClientIdleTimeout connHTTP2Settings of + Nothing -> + HTTP2.Client.allocSimpleConfig sock writeBufferSize + Just timeout -> + HTTP2.Client.allocSimpleConfig' sock writeBufferSize timeout + settings :: HTTP2.Client.Settings settings = HTTP2.Client.defaultSettings { HTTP2.Client.maxConcurrentStreams = @@ -299,8 +309,8 @@ clientConfig :: HTTP2.Client.ClientConfig clientConfig = overrideRateLimits connParams $ HTTP2.Client.defaultClientConfig { - HTTP2.Client.authority = connAuthority - , HTTP2.Client.settings = settings + HTTP2.Client.authority = connAuthority + , HTTP2.Client.settings = settings , HTTP2.Client.connectionWindowSize = fromIntegral $ http2ConnectionWindowSize connHTTP2Settings @@ -397,6 +407,32 @@ where settings :: HTTP2.Client.Settings settings = HTTP2.Client.settings clientConfig + +{------------------------------------------------------------------------------- + Keep-alive ping +-------------------------------------------------------------------------------} + +-- | Spawn keep-alive thread, if needed +-- +-- See 'http2ClientKeepAlivePingInterval'. +withKeepAlive :: HTTP2.Client.Aux -> HTTP2Settings -> IO r -> IO r +withKeepAlive aux settings k = + case http2ClientKeepAlivePingInterval settings of + Nothing -> k + Just i -> bracket (spawn i) kill $ \_ -> k + where + -- bracket's resource allocation happens with exceptions masked + spawn :: Int -> IO ThreadId + spawn interval = + forkIOWithUnmask $ \unmask -> unmask $ do + labelThisThread "grapesy:client:keepalive" + forever $ do + threadDelay interval + HTTP2.Client.auxSendPing aux + + -- killThread is itself interruptible + kill :: ThreadId -> IO () + kill = uninterruptibleMask_ . killThread {------------------------------------------------------------------------------- Auxiliary http2 diff --git a/src/Network/GRPC/Common/CBOR.hs b/src/Network/GRPC/Common/CBOR.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Common/CBOR.hs @@ -0,0 +1,14 @@ +-- | CBOR RPC +-- +-- Intended for unqualified import. +module Network.GRPC.Common.CBOR ( + CborRpc + + -- * Re-exports + -- ** Serialise + , Serialise(..) + ) where + +import Codec.Serialise + +import Network.GRPC.Spec diff --git a/src/Network/GRPC/Common/HTTP2Settings.hs b/src/Network/GRPC/Common/HTTP2Settings.hs --- a/src/Network/GRPC/Common/HTTP2Settings.hs +++ b/src/Network/GRPC/Common/HTTP2Settings.hs @@ -169,6 +169,22 @@ -- 'maxBound' (effectively turning off protection against RST frame -- flooding). , http2OverrideRstRateLimit :: Maybe Int + + -- | Idle timeout (microseconds) for the client connection + -- + -- @http2@ closes a connection once it goes this long without reading a + -- frame (default 30s). Prefer 'http2ClientKeepAlivePingInterval' for a + -- healthy-but-quiet connection; this is only a backstop for when no + -- ping is configured. 'Nothing' keeps @http2@'s default. Client only. + , http2ClientIdleTimeout :: Maybe Int + + -- | Interval (microseconds) for sending an HTTP\/2 keepalive @PING@ + -- + -- Mirrors @grpc-go@'s @keepalive.ClientParameters.Time@: keeps a quiet + -- connection from looking dead to a peer that vanished silently (e.g. + -- behind a NAT), and resets 'http2ClientIdleTimeout'. Uses @http2@'s + -- 'Network.HTTP2.Client.auxSendPing'. 'Nothing' disables it. + , http2ClientKeepAlivePingInterval :: Maybe Int } deriving (Show) @@ -201,6 +217,8 @@ , http2OverrideEmptyFrameRateLimit = Nothing , http2OverrideSettingsRateLimit = Nothing , http2OverrideRstRateLimit = Nothing + , http2ClientIdleTimeout = Nothing + , http2ClientKeepAlivePingInterval = Nothing } where defMaxConcurrentStreams = 128 diff --git a/src/Network/GRPC/Server.hs b/src/Network/GRPC/Server.hs --- a/src/Network/GRPC/Server.hs +++ b/src/Network/GRPC/Server.hs @@ -52,6 +52,7 @@ import Network.HTTP.Semantics.Server qualified as Server +import Network.GRPC.Common.Exception import Network.GRPC.Server.Call import Network.GRPC.Server.Context import Network.GRPC.Server.Handler @@ -60,7 +61,6 @@ import Network.GRPC.Server.RequestHandler import Network.GRPC.Server.Session (CallSetupFailure(..)) import Network.GRPC.Spec -import Network.GRPC.Util.Stream (ClientDisconnected(..)) {------------------------------------------------------------------------------- Server proper diff --git a/src/Network/GRPC/Server/RequestHandler.hs b/src/Network/GRPC/Server/RequestHandler.hs --- a/src/Network/GRPC/Server/RequestHandler.hs +++ b/src/Network/GRPC/Server/RequestHandler.hs @@ -33,7 +33,6 @@ import Network.GRPC.Server.HandlerMap qualified as HandlerMap import Network.GRPC.Server.RequestHandler.API import Network.GRPC.Server.Session (CallSetupFailure(..)) -import Network.GRPC.Util.GHC import Network.GRPC.Util.Session.Server {------------------------------------------------------------------------------- @@ -43,8 +42,6 @@ -- | Construct request handler requestHandler :: HandlerMap IO -> ServerContext -> RequestHandler () requestHandler handlers ctxt unmask request respond = do - labelThisThread "grapesy:requestHandler" - SomeRpcHandler (_ :: Proxy rpc) handler <- findHandler handlers request `catch` setupFailure params respond (call :: Call rpc, mTimeout :: Maybe Timeout) <- diff --git a/src/Network/GRPC/Server/RequestHandler/API.hs b/src/Network/GRPC/Server/RequestHandler/API.hs --- a/src/Network/GRPC/Server/RequestHandler/API.hs +++ b/src/Network/GRPC/Server/RequestHandler/API.hs @@ -11,6 +11,7 @@ import Control.Exception import Network.HTTP.Semantics.Server qualified as Server +import Network.GRPC.Util.GHC {------------------------------------------------------------------------------- Definition @@ -35,8 +36,19 @@ -- calling 'requestHandlerToServer') to catch any remaining exceptions. -> Server.Server requestHandlerToServer handler req _aux respond = - -- We start by masking asynchronous exceptions. It is possible that - -- http2 kills us /before/ this call to @mask@, but if it does, no harm - -- is done: nothing has happened yet, so nothing is interrupted. - mask $ \unmask -> + -- We start by masking asynchronous exceptions. Ideally http2 would start + -- the thread with exceptions /already/ masked; the fact that it doesn't + -- means that it is possible that + -- + -- 1. @http2@ kills the thread /before/ the handler begins + -- 2. @http2@ kills the thread /after/ the handler completes + -- + -- Either way no harm is done; to avoid confusion, however, we will label + -- the thread only /inside/ of the @mask@; in case (1) we'd get the label + -- as it appears in HTTP2 ("H2 response sender for stream"); in case (2) we'd + -- get the "done" label we set here. + mask $ \unmask -> do + labelThisThread "grapesy:requestHandler" handler unmask req (\resp -> respond resp []) + -- /Only/ label if the handler itself didn't throw any exceptions + labelThisThread "grapesy:requestHandler:done" diff --git a/src/Network/GRPC/Util/Session/Server.hs b/src/Network/GRPC/Util/Session/Server.hs --- a/src/Network/GRPC/Util/Session/Server.hs +++ b/src/Network/GRPC/Util/Session/Server.hs @@ -16,6 +16,7 @@ import Network.GRPC.Util.Session.Channel import Network.GRPC.Util.Stream import Network.GRPC.Util.Thread +import Network.GRPC.Util.GHC {------------------------------------------------------------------------------- Connection @@ -64,13 +65,15 @@ MVar (Either ExactException a) -> HTTP.OutBodyIface -> IO () - auxThreadBody resultVar iface = do - result <- try $ do + auxThreadBody resultVar iface = mask $ \unmask -> do + labelThisThread "grapesy:respondStreamingWithResult:auxThreadBody" + result <- try $ unmask $ do -- It is important we create the output stream inside the body of the -- exception handler, since that too can fail. ostrm <- serverOutputStream iface body ostrm putMVar resultVar result + labelThisThread "grapesy:respondStreamingWithResult:auxThreadBody:done" respondNoBody :: ConnectionToClient -> ResponseInfo -> IO () respondNoBody conn responseInfo = diff --git a/test-disconnect/Main.hs b/test-disconnect/Main.hs --- a/test-disconnect/Main.hs +++ b/test-disconnect/Main.hs @@ -18,6 +18,7 @@ import Test.Disconnect.Echo.Client import Test.Disconnect.Echo.RPC import Test.Disconnect.Echo.Server +import Test.Disconnect.Keepalive import Test.Disconnect.Util.Client import Test.Disconnect.Util.Process import Test.Disconnect.Util.Server @@ -55,6 +56,10 @@ runTest "clientDisconnect" test_clientDisconnect runTest "serverDisconnect" test_serverDisconnect + runTest "keepAlivePreventsIdleClose" + test_keepAlivePreventsIdleClose + runTest "idleTimeoutWithoutKeepAliveDisconnects" + test_idleTimeoutWithoutKeepAliveDisconnects where runTest :: String -> Assertion -> IO () runTest label testCase = do diff --git a/test-disconnect/Test/Disconnect/Keepalive.hs b/test-disconnect/Test/Disconnect/Keepalive.hs new file mode 100644 --- /dev/null +++ b/test-disconnect/Test/Disconnect/Keepalive.hs @@ -0,0 +1,132 @@ +module Test.Disconnect.Keepalive ( + test_keepAlivePreventsIdleClose + , test_idleTimeoutWithoutKeepAliveDisconnects + ) where + +import Control.Concurrent +import Control.Exception (SomeException, fromException, try) +import Data.Proxy +import Data.Word +import Network.HTTP2.Client (HTTP2Error(..)) +import Network.Socket (PortNumber) +import Test.HUnit + +import Network.GRPC.Common +import Network.GRPC.Client qualified as Client +import Network.GRPC.Client.Binary qualified as Client.Binary +import Network.GRPC.Server qualified as Server + +import Network.GRPC.Server.Run qualified as Grapesy + +import Test.Disconnect.Echo.RPC +import Test.Disconnect.Echo.Server + +{------------------------------------------------------------------------------- + Test client idle timeout / keepalive ping + + 'http2' closes a connection once idle for 'http2ClientIdleTimeout' (default + 30s); a keepalive ping ('http2ClientKeepAlivePingInterval') resets that + timer even when no RPCs are in flight. + + We use a short idle timeout so the tests run quickly, and check both + directions: a keepalive ping keeps an otherwise-silent connection alive + past the timeout, and without one the connection really is closed (with + @http2@'s own 'ConnectionIsTimeout') -- proving the first case isn't + trivially true just because nothing ever closes idle connections. +-------------------------------------------------------------------------------} + +-- | How long the client is configured to tolerate a silent connection +idleTimeout :: Int +idleTimeout = 500_000 -- 500ms + +-- | Keepalive ping interval, comfortably below 'idleTimeout' +keepAlivePingInterval :: Int +keepAlivePingInterval = 100_000 -- 100ms + +-- | How long the test stays silent before attempting another RPC +-- +-- Comfortably past 'idleTimeout', so an unkept-alive connection is +-- guaranteed to have been closed by @http2@ by the time we check. +silence :: Int +silence = 2_000_000 -- 2s + +test_keepAlivePreventsIdleClose :: Assertion +test_keepAlivePreventsIdleClose = + withServer $ \serverAddr -> + withKeepAlive (Just keepAlivePingInterval) serverAddr $ \conn -> do + threadDelay silence + result <- tryEcho conn + assertBool ("expected successful echo, got " ++ show result) $ + case result of + Right 42 -> True + _otherwise -> False + +test_idleTimeoutWithoutKeepAliveDisconnects :: Assertion +test_idleTimeoutWithoutKeepAliveDisconnects = + withServer $ \serverAddr -> + withKeepAlive Nothing serverAddr $ \conn -> do + threadDelay silence + result <- tryEcho conn + assertBool ("expected ConnectionIsTimeout, got " ++ show result) $ + case result of + Left e | Just ConnectionIsTimeout <- fromException e -> True + _otherwise -> False + +{------------------------------------------------------------------------------- + Util +-------------------------------------------------------------------------------} + +-- | Connect with 'idleTimeout' and the given keepalive ping interval +withKeepAlive :: + Maybe Int -- ^ 'http2ClientKeepAlivePingInterval' + -> Client.Server + -> (Client.Connection -> IO a) + -> IO a +withKeepAlive pingInterval = Client.withConnection connParams + where + connParams = def { + Client.connHTTP2Settings = def { + http2ClientIdleTimeout = Just idleTimeout + , http2ClientKeepAlivePingInterval = pingInterval + } + } + +-- | Run one echo round-trip, properly closing the stream +-- +-- Leaving 'withRPC''s scope with the request stream still open is itself +-- reported as a client-side 'GrpcCancelled' -- indistinguishable from the +-- failure we're testing for -- so we close it ('sendEndOfInput') and +-- consume the trailers ourselves. +tryEcho :: Client.Connection -> IO (Either SomeException Word64) +tryEcho conn = try $ + Client.withRPC conn def (Proxy @Echo1) $ \call -> do + Client.Binary.sendNextInput @Word64 call 42 + resp <- Client.Binary.recvNextOutput @Word64 call + Client.sendEndOfInput call + NoMetadata <- Client.recvTrailers call + return resp + +withServer :: (Client.Server -> IO a) -> IO a +withServer k = do + let handler = Server.someRpcHandler $ + Server.mkRpcHandler @Echo1 (handleEcho (Proxy @Echo1)) + server <- Server.mkGrpcServer def [handler] + Grapesy.forkServer def serverConfig server $ \runningServer -> do + serverPort <- Grapesy.getServerPort runningServer + k $ mkServerAddress serverPort + where + serverConfig :: Grapesy.ServerConfig + serverConfig = Grapesy.ServerConfig { + serverInsecure = Just $ Grapesy.InsecureConfig { + insecureHost = Just "127.0.0.1" + , insecurePort = 0 + } + , serverSecure = Nothing + } + + mkServerAddress :: PortNumber -> Client.Server + mkServerAddress port = Client.ServerInsecure Client.Address { + addressHost = "127.0.0.1" + , addressPort = port + , addressAuthority = Nothing + } diff --git a/test-grapesy/Main.hs b/test-grapesy/Main.hs --- a/test-grapesy/Main.hs +++ b/test-grapesy/Main.hs @@ -13,6 +13,7 @@ import Test.Sanity.Any qualified as Any import Test.Sanity.BrokenDeployments qualified as BrokenDeployments import Test.Sanity.Cancellation qualified as Cancellation +import Test.Sanity.CBOR qualified as CBOR import Test.Sanity.Compression qualified as Compression import Test.Sanity.EndOfStream qualified as EndOfStream import Test.Sanity.FramesAfterReset qualified as FramesAfterReset @@ -38,6 +39,7 @@ StreamingType.NonStreaming.tests , StreamingType.CustomFormat.tests ] + , CBOR.tests , Compression.tests , Any.tests , Interop.tests diff --git a/test-grapesy/Test/Sanity/CBOR.hs b/test-grapesy/Test/Sanity/CBOR.hs new file mode 100644 --- /dev/null +++ b/test-grapesy/Test/Sanity/CBOR.hs @@ -0,0 +1,55 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Sanity.CBOR (tests) where + +import Codec.Serialise (serialise) +import Data.Either (isLeft) +import Test.Tasty +import Test.Tasty.HUnit + +import Network.GRPC.Client (rpc) +import Network.GRPC.Client.StreamType.IO qualified as Client +import Network.GRPC.Common +import Network.GRPC.Common.CBOR +import Network.GRPC.Server.StreamType qualified as Server + +import Test.Driver.ClientServer + +type Sum = CborRpc "calculator" "sum" + +type instance Input Sum = [Int] +type instance Output Sum = Int + +type instance RequestMetadata Sum = NoMetadata +type instance ResponseInitialMetadata Sum = NoMetadata +type instance ResponseTrailingMetadata Sum = NoMetadata + +tests :: TestTree +tests = testGroup "Test.Sanity.CBOR" [ + testCase "sum" test_sum + , testCase "trailingBytes" test_trailingBytes + ] + +test_sum :: IO () +test_sum = testClientServer $ ClientServerTest { + config = def + , client = simpleTestClient $ \conn -> do + resp <- Client.nonStreaming conn (rpc @Sum) [1 .. 100] + assertEqual "" 5050 resp + , server = [ + Server.fromMethod @Sum $ Server.mkNonStreaming $ return . sum + ] + } + +test_trailingBytes :: IO () +test_trailingBytes = do + let input = serialise [1, 2 :: Int] + output = serialise (3 :: Int) + assertEqual "" (Right [1, 2]) $ + rpcDeserializeInput (Proxy @Sum) input + assertEqual "" (Right 3) $ + rpcDeserializeOutput (Proxy @Sum) output + assertBool "" $ isLeft $ + rpcDeserializeInput (Proxy @Sum) (input <> output) + assertBool "" $ isLeft $ + rpcDeserializeOutput (Proxy @Sum) (output <> input) diff --git a/test-grapesy/Test/Util/Exception.hs b/test-grapesy/Test/Util/Exception.hs --- a/test-grapesy/Test/Util/Exception.hs +++ b/test-grapesy/Test/Util/Exception.hs @@ -8,7 +8,9 @@ import Control.Concurrent import Control.Exception +import Control.Monad import Data.Function ((&)) +import Data.List qualified as List import Data.Maybe (fromMaybe) import Data.Proxy import System.IO @@ -54,11 +56,20 @@ #else return $ Just "unknown label" #endif - hPutStrLn stderr $ concat [ - "Uncaught exception in " - , show tid - , " (" - , fromMaybe "unlabelled" mLabel - , "): " - , renderAnyException testFormatCtx e - ] + -- See 'requestHandlerToServer' for details + let shouldIgnore = + case mLabel of + Nothing -> False + Just lbl -> or [ + "H2 response sender for stream" `List.isPrefixOf` lbl + , lbl == "grapesy:requestHandler:done" + ] + unless shouldIgnore $ + hPutStrLn stderr $ concat [ + "Uncaught exception in " + , show tid + , " (" + , fromMaybe "unlabelled" mLabel + , "): " + , renderAnyException testFormatCtx e + ]