grapesy 1.2.1 → 1.2.2

raw patch · 14 files changed

+339/−40 lines, 14 filesdep ~crypton-x509dep ~crypton-x509-storedep ~crypton-x509-systemPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: crypton-x509, crypton-x509-store, crypton-x509-system, grpc-spec, http2, network-run, serialise, time-manager

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• grapesy.cabal +13/−9
• src/Network/GRPC/Client/Run.hs +49/−13
• src/Network/GRPC/Common/CBOR.hs +14/−0
• src/Network/GRPC/Common/HTTP2Settings.hs +18/−0
• src/Network/GRPC/Server.hs +1/−1
• src/Network/GRPC/Server/RequestHandler.hs +0/−3
• src/Network/GRPC/Server/RequestHandler/API.hs +16/−4
• src/Network/GRPC/Util/Session/Server.hs +5/−2
• test-disconnect/Main.hs +5/−0
• test-disconnect/Test/Disconnect/Keepalive.hs +132/−0
• test-grapesy/Main.hs +2/−0
• test-grapesy/Test/Sanity/CBOR.hs +55/−0
• test-grapesy/Test/Util/Exception.hs +19/−8

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

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

@@ -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"

@@ -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 =

@@ -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

@@ -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+        }

@@ -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

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

@@ -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+        ]