grapesy 1.2.0 → 1.2.1
raw patch · 10 files changed
+1163/−14 lines, 10 filesdep ~QuickCheckdep ~http2dep ~network-run
Dependency ranges changed: QuickCheck, http2, network-run, time-manager
Files
- CHANGELOG.md +6/−0
- grapesy.cabal +10/−6
- interop/Interop/Server.hs +2/−2
- src/Network/GRPC/Common/HTTP2Settings.hs +10/−0
- src/Network/GRPC/Server/Run.hs +14/−5
- test-grapesy/Main.hs +9/−1
- test-grapesy/Test/Meta/FrameLevelServer.hs +134/−0
- test-grapesy/Test/Sanity/FramesAfterReset.hs +262/−0
- test-grapesy/Test/Sanity/Trailers.hs +210/−0
- test-grapesy/Test/Util/FrameLevelServer.hs +506/−0
CHANGELOG.md view
@@ -1,5 +1,11 @@ # Revision history for grapesy +## 1.2.1 -- 2026-09-29++* Bump `http2` to 5.4.6+* Extend test suite with some HPACK/trailers tests+* Add `http2IPv6Only` [#378, with Noah Harvey]+ ## 1.2.0 -- 2026-09-02 * Use `http2-5.4.4` (which brings in `crypton-1.1.*`).
grapesy.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: grapesy-version: 1.2.0+version: 1.2.1 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.@@ -13,7 +13,7 @@ extra-doc-files: CHANGELOG.md data-dir: data extra-source-files: data/route_guide_db.json- data/grpc-demo.pem+ data/grpc-demo.pem data/grpc-demo.key data/interop.pem data/interop.key@@ -183,7 +183,7 @@ , recv >= 0.1 && < 0.2 , stm >= 2.5 && < 2.6 , text >= 1.2 && < 2.2- , time-manager >= 0.3.2 && < 0.4+ , time-manager >= 0.3.2 && < 0.5 , tls >= 1.7 && < 2.5 , unbounded-delays >= 0.1.1 && < 0.2 , unordered-containers >= 0.2 && < 0.3@@ -202,10 +202,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.4+ , http2 == 5.4.6 , http-semantics >= 0.4 && < 0.5 , http2-tls >= 0.5 && < 0.6- , network-run >= 0.5 && < 0.6+ , network-run >= 0.5 && < 0.7 if(flag(patched-ghc-for-exception-debugging)) cpp-options: -DPATCHED_GHC_FOR_EXCEPTION_DEBUGGING@@ -255,6 +255,7 @@ Test.Driver.Dialogue.Execution Test.Driver.Dialogue.Generation Test.Driver.Dialogue.TestClock+ Test.Meta.FrameLevelServer Test.Prop.Dialogue Test.Regression.Issue102 Test.Regression.Issue238@@ -263,14 +264,17 @@ Test.Sanity.Cancellation Test.Sanity.Compression Test.Sanity.EndOfStream+ Test.Sanity.FramesAfterReset Test.Sanity.Interop Test.Sanity.Metadata Test.Sanity.NoIsLabel Test.Sanity.Reclamation Test.Sanity.StreamingType.CustomFormat Test.Sanity.StreamingType.NonStreaming+ Test.Sanity.Trailers Test.Util Test.Util.Exception+ Test.Util.FrameLevelServer Test.Util.RawTestServer Paths_@@ -314,7 +318,7 @@ -- Additional dependencies , filepath >= 1.4.2.1 && < 1.6 , proto-lens-runtime >= 0.7 && < 0.8- , QuickCheck >= 2.14 && < 2.19+ , QuickCheck >= 2.14 && < 2.20 , serialise >= 0.2 && < 0.3 , tasty >= 1.4 && < 1.6 , tasty-hunit >= 0.10 && < 0.11
interop/Interop/Server.hs view
@@ -76,7 +76,7 @@ = ServerConfig { serverInsecure = Nothing , serverSecure = Just SecureConfig {- secureHost = "0.0.0.0"+ secureHost = cmdHost cmdline , securePort = cmdPort cmdline , securePubCert = cmdPubCert cmdline , secureChainCerts = []@@ -89,7 +89,7 @@ = ServerConfig { serverSecure = Nothing , serverInsecure = Just InsecureConfig {- insecureHost = Just "127.0.0.1"+ insecureHost = Just $ cmdHost cmdline , insecurePort = cmdPort cmdline } }
src/Network/GRPC/Common/HTTP2Settings.hs view
@@ -39,6 +39,15 @@ -- information. , http2ConnectionWindowSize :: Word32 + -- | Restrict IPv6 sockets to IPv6 only (@IPV6_V6ONLY@)+ --+ -- Only relevant when binding to an IPv6 address. When 'False' (the+ -- default, per RFC 3493), a server bound to the IPv6 wildcard @::@ also+ -- accepts IPv4 connections.+ --+ -- Ignored on OpenBSD.+ , http2IPv6Only :: Bool+ -- | Enable @TCP_NODELAY@ -- -- Send out TCP segments as soon as possible, even if there is only a@@ -186,6 +195,7 @@ , http2StreamWindowSize = defInitialStreamWindowSize , http2ConnectionWindowSize = defInitialConnectionWindowSize , http2TcpAbortiveClose = False+ , http2IPv6Only = False , http2TcpNoDelay = True , http2OverridePingRateLimit = Just 100 , http2OverrideEmptyFrameRateLimit = Nothing
src/Network/GRPC/Server/Run.hs view
@@ -444,11 +444,20 @@ k sock where openServerSocket :: AddrInfo -> IO Socket- openServerSocket = Run.openTCPServerSocketWithOptions $ concat [- [ (Socket.NoDelay, 1)- | http2TcpNoDelay http2Settings- ]- ]+ openServerSocket addr =+ Run.openTCPServerSocketWithOptions+ ( concat [+ [ (Socket.NoDelay, 1)+ | http2TcpNoDelay http2Settings+ ]+#if !defined(openbsd_HOST_OS)+ , [ (Socket.IPv6Only, if http2IPv6Only http2Settings then 1 else 0)+ | Socket.addrFamily addr == Socket.AF_INET6+ ]+#endif+ ]+ )+ addr -- | Create a Unix domain socket --
test-grapesy/Main.hs view
@@ -6,6 +6,7 @@ import Test.Util.Exception import Test.Common.Exception qualified as Exception+import Test.Meta.FrameLevelServer qualified as FrameLevelServer import Test.Prop.Dialogue qualified as Dialogue import Test.Regression.Issue102 qualified as Issue102 import Test.Regression.Issue238 qualified as Issue238@@ -14,19 +15,24 @@ import Test.Sanity.Cancellation qualified as Cancellation import Test.Sanity.Compression qualified as Compression import Test.Sanity.EndOfStream qualified as EndOfStream+import Test.Sanity.FramesAfterReset qualified as FramesAfterReset import Test.Sanity.Interop qualified as Interop import Test.Sanity.Metadata qualified as Metadata import Test.Sanity.NoIsLabel qualified as NoIsLabel import Test.Sanity.Reclamation qualified as Reclamation import Test.Sanity.StreamingType.CustomFormat qualified as StreamingType.CustomFormat import Test.Sanity.StreamingType.NonStreaming qualified as StreamingType.NonStreaming+import Test.Sanity.Trailers qualified as Trailers main :: IO () main = do setUncaughtExceptionHandler uncaughtExceptionHandler defaultMain $ testGroup "grapesy" [- testGroup "Sanity" [+ testGroup "Meta" [+ FrameLevelServer.tests+ ]+ , testGroup "Sanity" [ EndOfStream.tests , testGroup "StreamingType" [ StreamingType.NonStreaming.tests@@ -40,6 +46,8 @@ , NoIsLabel.tests , Metadata.tests , Cancellation.tests+ , Trailers.tests+ , FramesAfterReset.tests ] , testGroup "Regression" [ Issue102.tests
+ test-grapesy/Test/Meta/FrameLevelServer.hs view
@@ -0,0 +1,134 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Test.Meta.FrameLevelServer (tests) where++import Data.ByteString.Lazy qualified as BS.Lazy+import Data.ByteString.Lazy qualified as Lazy (ByteString)+import Data.ByteString.Lazy.Char8 qualified as BS.Lazy.Char8+import Data.Word+import Test.Tasty+import Test.Tasty.HUnit++import Network.GRPC.Client qualified as Client+import Network.GRPC.Common+import Network.GRPC.Common.Binary++import Test.Util.FrameLevelServer (Script, Frame(..), FrameHeader(..))+import Test.Util.FrameLevelServer qualified as Frame++{-------------------------------------------------------------------------------+ List of tests+-------------------------------------------------------------------------------}++tests :: TestTree+tests = testGroup "Test.Meta.FrameLevelServer" [+ testCase "trailersOnly" test_trailersOnly+ , testCase "echo" test_echo+ ]++{-------------------------------------------------------------------------------+ Tests proper+-------------------------------------------------------------------------------}++-- | Simplest exchange: the response is a single Trailers-Only frame+test_trailersOnly :: Assertion+test_trailersOnly =+ Frame.withScript Nothing trailersOnlyScript $ \server getHandlerResults -> do+ _trailers <-+ Client.withConnection def server $ \conn ->+ Client.withRPC conn def (Proxy @TestRpc) $ \call -> do+ Client.sendFinalInput call BS.Lazy.empty+ Client.recvTrailers call+ results <- getHandlerResults+ assertEqual "handler results" [()] results++-- | Full response (headers, message, trailers), echoing the request message+test_echo :: Assertion+test_echo =+ Frame.withScript Nothing echoScript $ \server getHandlerResults -> do+ (output, _trailers) <-+ Client.withConnection def server $ \conn ->+ Client.withRPC conn def (Proxy @TestRpc) $ \call -> do+ Client.sendFinalInput call (ascii "ping")+ Client.recvFinalOutput call+ assertEqual "output" (ascii "ping") output+ results <- getHandlerResults+ assertEqual "handler results" [()] results++{-------------------------------------------------------------------------------+ Test RPC+-------------------------------------------------------------------------------}++type TestRpc = RawRpc "FrameLevelServer" "ping"++type instance RequestMetadata TestRpc = [CustomMetadata]+type instance ResponseInitialMetadata TestRpc = [CustomMetadata]+type instance ResponseTrailingMetadata TestRpc = [CustomMetadata]++{-------------------------------------------------------------------------------+ Scripts+-------------------------------------------------------------------------------}++-- | Receive the request, respond with a single Trailers-Only frame+trailersOnlyScript :: Script ()+trailersOnlyScript = do+ Frame.handshake+ recvRequestHeaders+ _msg <- Frame.recvUntilEndStream 1+ Frame.send $ Frame.mkFrame 0x1 0x5 1 trailersOnly -- END_STREAM | END_HEADERS++-- | Receive the request, respond with headers, the same message, and trailers+--+-- The gRPC length-prefixed message format is the same in both directions, so+-- the request message can be sent back verbatim. This relies on the request+-- being uncompressed; we never advertise @grpc-accept-encoding@, so the client+-- has no reason to compress.+echoScript :: Script ()+echoScript = do+ Frame.handshake+ recvRequestHeaders+ msg <- Frame.recvUntilEndStream 1+ Frame.send $ Frame.mkFrame 0x1 0x4 1 responseHeaders -- END_HEADERS+ Frame.send $ Frame.mkFrame 0x0 0x0 1 msg+ Frame.send $ Frame.mkFrame 0x1 0x5 1 responseTrailers -- END_STREAM | END_HEADERS++-- | Request headers on stream 1 (not decoded)+recvRequestHeaders :: Script ()+recvRequestHeaders = Frame.recv $ \frame ->+ case frameHeader frame of+ FrameHeader{frameType = 0x1, frameStreamId = 1} -> Right ()+ _otherwise -> Left $ "Expected HEADERS on stream 1, got " ++ show frame++{-------------------------------------------------------------------------------+ Header blocks++ Only static-table references and literals without indexing, so none of these+ responses changes the client's dynamic table.+-------------------------------------------------------------------------------}++-- | Trailers-Only: status, content-type and trailers in a single block+trailersOnly :: Lazy.ByteString+trailersOnly = responseHeaders <> responseTrailers++responseHeaders :: Lazy.ByteString+responseHeaders = mconcat [+ bytes [0x88] -- :status 200 (static index 8)+ , bytes [0x00, 0x0c], ascii "content-type" -- literal, no indexing, new name+ , bytes [0x14], ascii "application/grpc+raw"+ ]++responseTrailers :: Lazy.ByteString+responseTrailers = mconcat [+ bytes [0x00, 0x0b], ascii "grpc-status" -- literal, no indexing, new name+ , bytes [0x01], ascii "0"+ ]++{-------------------------------------------------------------------------------+ Internal auxiliary+-------------------------------------------------------------------------------}++bytes :: [Word8] -> Lazy.ByteString+bytes = BS.Lazy.pack++ascii :: String -> Lazy.ByteString+ascii = BS.Lazy.Char8.pack
+ test-grapesy/Test/Sanity/FramesAfterReset.hs view
@@ -0,0 +1,262 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Tests for HTTP2 frames sent by the server after client sends RST_STREAM+--+-- Normally after a client sends RST_STREAM to a server, the server will not+-- send any more frames on that stream. However, some frames might already have+-- been put on the wire, or enqueued internally by the server, before it gets+-- the RST_STREAM, and so some frames might still arrive.+--+-- Such frames can be dropped, but only after their effect on the+-- connection-level state is taken into account:+--+-- * HPACK state must be updated for HEADERS and CONTINUATION frames+-- * Connection-level window size must be updated for DATA frames+--+-- In this module we use a scripted server ("Test.Util.FrameLevelServer") to+-- simulate some scenarios:+--+-- 1. Client opens a stream, sends its final input, then sends RST_STREAM,+-- after which the server responds with gRPC Trailers-Only headers. For+-- example, this can happen with a gRPC deadline on a unary call: the+-- deadline expires on both the client and the server at roughly the same+-- time, and the RST_STREAM/Trailers-Only cross each other.+-- 2. A variation on (1) where the server's trailers span two frames; the test+-- case is designed so that the two frames cannot be decoded separately but+-- must be decoded as one block.+-- 3. Variation on (1) where the server responds with an initial set of regular+-- headers (not trailers), which the client receives before sending its+-- final message and the RST_STREAM. This mimics cancellation after the+-- response has started, e.g. a deadline on a streaming call.+--+-- In all of these tests, the server is set up to explicitly wait for the+-- RST_STREAM before sending the frames under test; this is intended to mimic+-- the race condition described above, but in a deterministic way.+--+-- TODO: Also test for window size problems.+module Test.Sanity.FramesAfterReset (tests) where++import Control.Exception+import Data.Bits+import Data.ByteString.Char8 qualified as BS.Strict.Char8+import Data.ByteString.Lazy qualified as BS.Lazy+import Data.ByteString.Lazy qualified as Lazy (ByteString)+import Data.ByteString.Lazy.Char8 qualified as BS.Lazy.Char8+import Data.String+import Data.Word+import Test.Tasty+import Test.Tasty.HUnit++import Network.GRPC.Client qualified as Client+import Network.GRPC.Common+import Network.GRPC.Common.Binary++import Test.Util.FrameLevelServer (Script, Frame(..), FrameHeader(..))+import Test.Util.FrameLevelServer qualified as Frame++{-------------------------------------------------------------------------------+ List of tests+-------------------------------------------------------------------------------}++tests :: TestTree+tests = testGroup "FramesAfterReset" [+ testCase "trailersOnlySingleFrame" $+ test_framesAfterReset cancelBeforeHeaders ignoreRequest sendTrailersOnly+ , testCase "trailersOnlyTwoFrames" $+ test_framesAfterReset cancelBeforeHeaders ignoreRequest sendTrailersOnlyTwoFrames+ , testCase "trailersAfterHeaders" $+ test_framesAfterReset cancelAfterHeaders respondWithHeaders sendTrailers+ ]++{-------------------------------------------------------------------------------+ Tests proper+-------------------------------------------------------------------------------}++-- | Call 1 is cancelled, and the server sends a header block on stream 1 after+-- the reset. That block contains a dynamic table insertion, which call 2's+-- response references: it resolves only if the client decoded the late block.+test_framesAfterReset ::+ (Client.Call TestRpc -> IO ()) -- ^ Call 1 (leaving it sends RST_STREAM)+ -> Script () -- ^ Server side of stream 1, before the reset+ -> Script () -- ^ Late block on stream 1, after the reset+ -> Assertion+test_framesAfterReset call1 beforeReset sendLate =+ Frame.withScript Nothing (script beforeReset sendLate) $ \server getHandlerResults -> do+ trailers <- Client.withConnection def server $ \conn -> do+ expectCancelled $ Client.withRPC conn def (Proxy @TestRpc) call1+ Client.withRPC conn def (Proxy @TestRpc) $ \call -> do+ Client.sendFinalInput call BS.Lazy.empty+ Client.recvTrailers call+ assertBool "x-foo: bar in call 2's trailers" $+ CustomMetadata (fromString "x-foo") (BS.Strict.Char8.pack "bar") `elem` trailers+ results <- getHandlerResults+ assertEqual "handler results" [()] results++-- | Scenarios (1) and (2): send the final message, leave without reading+cancelBeforeHeaders :: Client.Call TestRpc -> IO ()+cancelBeforeHeaders call =+ Client.sendFinalInput call BS.Lazy.empty++-- | Scenario (3)+cancelAfterHeaders :: Client.Call TestRpc -> IO ()+cancelAfterHeaders call = do+ _ <- Client.recvResponseInitialMetadata call+ Client.sendFinalInput call BS.Lazy.empty++{-------------------------------------------------------------------------------+ Scripts+-------------------------------------------------------------------------------}++script :: Script () -> Script () -> Script ()+script beforeReset sendLate = do+ Frame.handshake+ beforeReset+ awaitResetAndRequest+ sendLate+ Frame.send $ Frame.mkFrame 0x1 0x5 3 probe -- END_STREAM | END_HEADERS++-- | Wait for the reset of stream 1 and the end of the request on stream 3+--+-- These can arrive in either order: grapesy does not guarantee that call 1's+-- final message has reached http2 by the time the call is cancelled, and+-- depending on that, http2 sends the reset from one of two places. Either way+-- it removes the stream /before/ sending the reset, so once we have seen it,+-- the client has forgotten stream 1.+awaitResetAndRequest :: Script ()+awaitResetAndRequest = go False False+ where+ go :: Bool -> Bool -> Script ()+ go reset endOfRequest+ | reset && endOfRequest = return ()+ | otherwise = do+ (reset', endOfRequest') <- Frame.recv classify+ go (reset || reset') (endOfRequest || endOfRequest')++ classify :: Frame -> Either String (Bool, Bool)+ classify frame =+ case frameHeader frame of+ FrameHeader{frameType = 0x3, frameStreamId = 1} ->+ Right (True, False)+ FrameHeader{frameType, frameFlags, frameStreamId = 3}+ | frameType `elem` [0x0, 0x1] ->+ Right (False, testBit frameFlags 0) -- END_STREAM+ _otherwise ->+ Left $ "Expected RST_STREAM on stream 1 or request on stream 3, got "+ ++ show frame++-- | Scenarios (1) and (2): skip the request on stream 1+ignoreRequest :: Script ()+ignoreRequest =+ Frame.ignore $ \frame ->+ Frame.defaultNoiseFilter frame+ || ( frameStreamId (frameHeader frame) == 1+ && frameType (frameHeader frame) `elem` [0x0, 0x1]+ )++-- | Scenario (3): respond with initial headers, then skip the request message+respondWithHeaders :: Script ()+respondWithHeaders = do+ recvRequestHeaders 1+ Frame.send $ Frame.mkFrame 0x1 0x4 1 responseHeaders -- END_HEADERS+ Frame.ignore $ \frame ->+ Frame.defaultNoiseFilter frame+ || ( frameStreamId (frameHeader frame) == 1+ && frameType (frameHeader frame) == 0x0+ )++sendTrailersOnly :: Script ()+sendTrailersOnly =+ Frame.send $ Frame.mkFrame 0x1 0x5 1 lateTrailersOnly -- END_STREAM | END_HEADERS++-- | Split inside the @x-foo@ literal, so that neither fragment decodes on its own+sendTrailersOnlyTwoFrames :: Script ()+sendTrailersOnlyTwoFrames = do+ Frame.send $ Frame.mkFrame 0x1 0x1 1 (BS.Lazy.take 5 lateTrailersOnly) -- END_STREAM+ Frame.send $ Frame.mkFrame 0x9 0x4 1 (BS.Lazy.drop 5 lateTrailersOnly) -- END_HEADERS++sendTrailers :: Script ()+sendTrailers =+ Frame.send $ Frame.mkFrame 0x1 0x5 1 lateTrailers -- END_STREAM | END_HEADERS++recvRequestHeaders :: Word32 -> Script ()+recvRequestHeaders sid = Frame.recv $ \frame ->+ case frameHeader frame of+ FrameHeader{frameType = 0x1, frameStreamId}+ | frameStreamId == sid -> Right ()+ _otherwise -> Left $ "Expected HEADERS on stream " ++ show sid ++ ", got " ++ show frame++{-------------------------------------------------------------------------------+ Header blocks++ The late blocks are the only ones that insert into the client's dynamic table.+-------------------------------------------------------------------------------}++-- | Initial headers (scenario 3); no insertion+responseHeaders :: Lazy.ByteString+responseHeaders = status200 <> contentType++-- | Late Trailers-Only response (scenarios 1 and 2)+--+-- @x-foo@ comes first after @:status@, so that the split in+-- 'sendTrailersOnlyTwoFrames' falls inside it.+lateTrailersOnly :: Lazy.ByteString+lateTrailersOnly = status200 <> xFooInsert <> contentType <> grpcStatusOk++-- | Late trailers (scenario 3); no pseudo-headers+lateTrailers :: Lazy.ByteString+lateTrailers = xFooInsert <> grpcStatusOk++-- | Call 2's Trailers-Only response, referencing the late block's insertion+probe :: Lazy.ByteString+probe = status200 <> xFooIndexed <> contentType <> grpcStatusOk++status200 :: Lazy.ByteString+status200 = bytes [0x88] -- static index 8++contentType :: Lazy.ByteString+contentType = mconcat [+ bytes [0x00, 0x0c], ascii "content-type" -- literal, no indexing, new name+ , bytes [0x14], ascii "application/grpc+raw"+ ]++grpcStatusOk :: Lazy.ByteString+grpcStatusOk = mconcat [+ bytes [0x00, 0x0b], ascii "grpc-status" -- literal, no indexing, new name+ , bytes [0x01], ascii "0"+ ]++xFooInsert :: Lazy.ByteString+xFooInsert = mconcat [+ bytes [0x40, 0x05], ascii "x-foo" -- literal, incremental indexing, new name+ , bytes [0x03], ascii "bar" -- -> dynamic index 62+ ]++xFooIndexed :: Lazy.ByteString+xFooIndexed = bytes [0xbe] -- indexed, dynamic index 62++{-------------------------------------------------------------------------------+ Test RPC+-------------------------------------------------------------------------------}++type TestRpc = RawRpc "FramesAfterReset" "ping"++type instance RequestMetadata TestRpc = [CustomMetadata]+type instance ResponseInitialMetadata TestRpc = [CustomMetadata]+type instance ResponseTrailingMetadata TestRpc = [CustomMetadata]++{-------------------------------------------------------------------------------+ Internal auxiliary+-------------------------------------------------------------------------------}++bytes :: [Word8] -> Lazy.ByteString+bytes = BS.Lazy.pack++ascii :: String -> Lazy.ByteString+ascii = BS.Lazy.Char8.pack++expectCancelled :: IO () -> IO ()+expectCancelled =+ handleJust isCancelled return+ where+ isCancelled :: GrpcException -> Maybe ()+ isCancelled e = if grpcError e == GrpcCancelled then Just () else Nothing
+ test-grapesy/Test/Sanity/Trailers.hs view
@@ -0,0 +1,210 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Test.Sanity.Trailers (tests) where++import Control.Monad+import Data.Binary (Binary)+import Data.ByteString qualified as BSS+import Data.List qualified as List+import Data.String+import GHC.Generics+import Test.Tasty+import Test.Tasty.HUnit+import Text.Printf++import Network.GRPC.Client qualified as Client+import Network.GRPC.Client.Binary qualified as Client.Binary+import Network.GRPC.Common+import Network.GRPC.Common.Binary+import Network.GRPC.Server qualified as Server+import Network.GRPC.Server.Binary qualified as Server.Binary++import Test.Driver.ClientServer++{-------------------------------------------------------------------------------+ Testcases++ These are primarily tests of the underlying http2 substrate. We test for+ three regressions specifically:++ A. HPACK desync on reset streams. A header block arrives for a stream we've+ already removed from the stream table; getStream returns Nothing and+ controlOrStream's otherwise -> return () drops it instead of feeding it to+ the decoder. Connection-global table, so everything after is wrong.++ B. Trailers spanning CONTINUATION can't be received. The trailers clause in+ stream tests endOfStream and never endOfHeader, so it decodes only the+ first fragment.++ C. A single field line larger than the frame payload can't be sent. The+ encoder splits at header boundaries, so an oversized field yields "cannot+ compress the header" as a connection error.+-------------------------------------------------------------------------------}++tests :: TestTree+tests = testGroup "Trailers" [+ testCase (testName params) $ testWithParams params+ | params <- testParams+ ]++data TestParams = TestParams{+ paramsNumCalls :: Int+ , paramsNumTrailers :: Int+ , paramsTrailerSize :: Int+ }++testParams :: [TestParams]+testParams = [+ -- Controls: everything fits in one frame. Should pass today.+ TestParams 1 2 1000 -- ~2706+ , TestParams 3 2 1000 -- same, 3 calls: is the multi-call harness itself sound?+ , TestParams 1 20 100 -- ~3060, many small — control for the block below++ -- Bracket the CONTINUATION threshold (~1525 at n=2)+ , TestParams 1 2 1400 -- ~3770, one frame -> pass+ , TestParams 1 2 1600 -- ~4300, two frames -> B++ -- Bug B, unambiguous+ , TestParams 1 2 2000 -- silently loses trailer1++ -- Bracket the B/C threshold (~3050)+ , TestParams 1 2 2900 -- field ~3886 < 4087 -> B+ , TestParams 1 2 3200 -- field ~4286 > 4087 -> C++ -- Bug C, unambiguous+ , TestParams 1 2 4000 -- "cannot compress the header"++ -- Cross-call desync: entries small enough to persist (~181 each, table holds ~22)+ , TestParams 1 40 100 -- ~6120, 2 frames; loses ~14 trailers silently+ , TestParams 2 40 100 -- the payoff: call 2 resolves indices against a wrong table+ , TestParams 3 40 100 -- does it compound, or error?+ , TestParams 2 80 100 -- ~12240, 3 frames; more divergence++ -- Post-fix only: exercises multi-frame reassembly properly+ , TestParams 1 200 100 -- ~30600, 8 frames — under continuationLimit (10)+ ]++{-------------------------------------------------------------------------------+ Test output+-------------------------------------------------------------------------------}++testName :: TestParams -> TestName+testName params = List.intercalate "." . map show $ [+ paramsNumCalls params+ , paramsNumTrailers params+ , paramsTrailerSize params+ ]++type Error = String++-- | Compare received trailers against expected+--+-- We deliberately avoid @show@ing the trailers: at the top end of 'testParams'+-- that is tens of kilobytes of escaped bytes. Instead we exploit the fact that+-- 'mkTrailers' fills each value with the trailer's own index, so @"100 x 17"@+-- both describes the value and identifies which trailer it came from. A desync+-- then reads directly as @expected "100 x 17", got "100 x 21"@.+checkTrailers :: Int -> [CustomMetadata] -> [CustomMetadata] -> [Error]+checkTrailers callIx expected actual = concat [+ [ inCall $ concat [+ "number of trailers: "+ , "expected " , show (length expected)+ , ", got " , show (length actual)+ ]+ | length expected /= length actual+ ]++ , [ inCall $ concat [+ "trailer " , show i+ , ": expected " , describe e+ , ", got " , describe a+ ]+ | (i, e, a) <- zip3 [0 :: Int ..] expected actual+ , e /= a+ ]+ ]+ where+ inCall :: String -> String+ inCall msg = "call " ++ show callIx ++ ": " ++ msg++ describe :: CustomMetadata -> String+ describe md = concat [+ show (customMetadataName md), " = "+ , describeValue (customMetadataValue md)+ ]++ describeValue :: BSS.ByteString -> String+ describeValue bs =+ case BSS.uncons bs of+ Nothing -> "<empty>"+ Just (b, rest)+ | BSS.all (== b) rest -> show (BSS.length bs) ++ " x " ++ show b+ | otherwise -> show (BSS.length bs) ++ " bytes (mixed)"++{-------------------------------------------------------------------------------+ Test proper / gRPC client+-------------------------------------------------------------------------------}++testWithParams :: TestParams -> Assertion+testWithParams params = testClientServer ClientServerTest{+ config = def+ , server = [Server.someRpcHandler @TestRpc sendTrailers]+ , client = simpleTestClient $ \conn -> do+ errs <- fmap concat $ forM [0 .. paramsNumCalls params - 1] $ \callIx -> do+ Client.withRPC conn def (Proxy @TestRpc) $ \call -> do+ Client.Binary.sendFinalInput call serverParams+ ((), actual) <- Client.Binary.recvFinalOutput call+ return $ checkTrailers callIx (mkTrailers serverParams) actual+ unless (null errs) $ assertFailure $ List.intercalate "\n" errs+ }+ where+ serverParams :: ServerParams+ serverParams = ServerParams{+ serverNumTrailers = paramsNumTrailers params+ , serverTrailerSize = paramsTrailerSize params+ }++{-------------------------------------------------------------------------------+ Server handler+-------------------------------------------------------------------------------}++type TestRpc = RawRpc "TestTrailers" "Test"++type instance RequestMetadata TestRpc = [CustomMetadata]+type instance ResponseInitialMetadata TestRpc = [CustomMetadata]+type instance ResponseTrailingMetadata TestRpc = [CustomMetadata]++data ServerParams = ServerParams{+ serverNumTrailers :: Int+ , serverTrailerSize :: Int+ }+ deriving stock (Show, Eq, Generic)+ deriving anyclass (Binary)++sendTrailers :: Server.RpcHandler IO TestRpc+sendTrailers = Server.mkRpcHandlerNoDefMetadata $ \call -> do+ params <- Server.Binary.recvFinalInput call+ let trailers = mkTrailers params++ -- We do /not/ announce the trailers ahead of time.+ --+ -- The @Trailer@ header is optional, and we skip it here: with many trailers,+ -- it would /itself/ get large, which would confound the test.+ Server.setResponseInitialMetadataAndTrailers call [] . Just $+ map customMetadataName trailers++ -- Send the trailers proper+ Server.Binary.sendFinalOutput @() call ((), trailers)++mkTrailers :: ServerParams -> [CustomMetadata]+mkTrailers params = [+ metadata i (serverTrailerSize params)+ | i <- [0 .. serverNumTrailers params - 1]+ ]+ where+ metadata :: Int -> Int -> CustomMetadata+ metadata i sz =+ CustomMetadata+ (fromString $ "trailer" ++ printf "%03d" i ++ "-bin")+ (BSS.pack . replicate sz $ fromIntegral i)+
+ test-grapesy/Test/Util/FrameLevelServer.hs view
@@ -0,0 +1,506 @@+{-# LANGUAGE CPP #-}++-- | Test servers that process individual HTTP2 frames+--+-- Main reference: <https://www.rfc-editor.org/rfc/rfc9113.html>+--+-- Instead for qualified import.+--+-- > import Test.Util.FrameLevelServer (Script, Frame(..), FrameHeader(..))+-- > import Test.Util.FrameLevelServer qualified as Frame+module Test.Util.FrameLevelServer (+ -- * Frames+ FrameHeader(..)+ , Frame(..)+ , mkFrame+ -- * Scripts+ , Script -- opaque+ , withScript+ -- ** Primitives+ , recv+ , ignore+ , send+ -- ** Standard building blocks+ , handshake+ , recvUntilEndStream+ , defaultNoiseFilter+ ) where++import Control.Concurrent+import Control.Concurrent.Async+import Control.Concurrent.Async.Internal qualified as Async.Internal+import Control.Concurrent.STM qualified as STM+import Control.Exception (SomeException)+import Control.Exception qualified as Exception+import Control.Monad+import Data.Binary (Binary)+import Data.Binary qualified as Binary+import Data.Binary.Get qualified as Binary+import Data.Binary.Put qualified as Binary+import Data.Bits+import Data.ByteString qualified as BS.Strict+import Data.ByteString qualified as Strict (ByteString)+import Data.ByteString.Lazy qualified as BS.Lazy+import Data.ByteString.Lazy qualified as Lazy (ByteString)+import Data.Either (partitionEithers)+import Data.Kind+import Data.List.NonEmpty qualified as NE+import Data.Maybe (catMaybes)+import Data.Void+import Data.Word+import Network.GRPC.Client qualified as Client+import Network.Socket+import Network.Socket.ByteString qualified as Socket+import System.IO (fixIO)++#if MIN_VERSION_base(4,20,0)+import Control.Exception.Annotation+#endif++import Network.GRPC.Common.Exception++{-------------------------------------------------------------------------------+ Scripts+-------------------------------------------------------------------------------}++data Script :: Type -> Type where+ Recv :: (Frame -> Either String a) -> (a -> Script b) -> Script b+ Ignore :: (Frame -> Bool) -> Script a -> Script a+ Send :: Frame -> Script a -> Script a+ Done :: a -> Script a++-- | Receive frame of specified shape, or fail on unexpected frames+recv :: (Frame -> Either String a) -> Script a+recv p = Recv p Done++-- | Install new noise filter+ignore :: (Frame -> Bool) -> Script ()+ignore p = Ignore p $ Done ()++-- | Send frame+send :: Frame -> Script ()+send f = Send f $ Done ()++instance Functor Script where+ fmap = liftM++instance Applicative Script where+ pure = Done+ (<*>) = ap++instance Monad Script where+ Recv p k >>= l = Recv p (k >=> l)+ Ignore p k >>= l = Ignore p (k >>= l)+ Send f k >>= l = Send f (k >>= l)+ Done x >>= l = l x++withScript :: forall a r.+ Maybe ServiceName+ -> Script a+ -> (Client.Server -> GetHandlerResults a -> IO r)+ -> IO r+withScript service script k =+ withServer service handler $ \_host port getHandlerResults -> do+ let server :: Client.Server+ server = Client.ServerInsecure $ Client.Address{+ addressHost = "127.0.0.1"+ , addressPort = port+ , addressAuthority = Nothing+ }+ k server getHandlerResults+ where+ handler :: ServerHandler a+ handler clientSock clientAddr = do+ consumePreface clientSock+ runScript clientSock clientAddr script++ consumePreface :: Socket -> IO ()+ consumePreface clientSock = do+ mPreface <- fmap BS.Lazy.unpack <$> recvExact clientSock 24+ unless (mPreface == Just preface) $+ fail $ "Expected preface, got " ++ show mPreface++ preface :: [Word8]+ preface = [+ 0x50, 0x52, 0x49, 0x20, 0x2a, 0x20+ , 0x48, 0x54, 0x54, 0x50, 0x2f, 0x32+ , 0x2e, 0x30, 0x0d, 0x0a, 0x0d, 0x0a+ , 0x53, 0x4d, 0x0d, 0x0a, 0x0d, 0x0a+ ]++runScript :: Socket -> SockAddr -> Script a -> IO a+runScript clientSock _clientAddr = go (const False)+ where+ go :: (Frame -> Bool) -> Script a -> IO a+ go noiseFilter = \case+ Recv p k -> do+ mFrame <- recvFrame clientSock+ case mFrame of+ Nothing ->+ fail "Unexpected EOF"+ Just frame | noiseFilter frame ->+ go noiseFilter (Recv p k)+ Just frame ->+ case p frame of+ Left err -> fail err+ Right a -> go noiseFilter $ k a+ Ignore p k -> do+ go p k+ Send f k -> do+ sendFrame clientSock f+ go noiseFilter k+ Done a -> do+ skipRemainder noiseFilter+ return a++ skipRemainder :: (Frame -> Bool) -> IO ()+ skipRemainder noiseFilter = do+ mFrame <- recvFrame clientSock+ case mFrame of+ Nothing ->+ return ()+ Just frame | noiseFilter frame ->+ skipRemainder noiseFilter+ Just frame ->+ fail $ "Expected EOF, but got " ++ show frame++{-------------------------------------------------------------------------------+ Script building blocks+-------------------------------------------------------------------------------}++-- | Frames that may arrive at any point, and that scripts don't care about+--+-- * SETTINGS with ACK: the client acknowledging ours (see 'handshake')+-- * WINDOW_UPDATE: flow-control credit; needs no reply+-- * GOAWAY with NO_ERROR: the client's clean shutdown+--+-- Deliberately excluded: SETTINGS without ACK ('handshake' waits for it),+-- GOAWAY with an error code (that is information, not noise), and PING+-- (a PING without ACK requires a reply, RFC 9113 section 6.7, which a+-- filter cannot give).+defaultNoiseFilter :: Frame -> Bool+defaultNoiseFilter frame =+ case frameType of+ 0x4 -> frameFlags .&. 0x1 /= 0 -- SETTINGS ACK+ 0x8 -> True -- WINDOW_UPDATE+ 0x7 -> errorCode == noError -- GOAWAY+ _ -> False+ where+ Frame{+ frameHeader = FrameHeader{frameType, frameFlags}+ , framePayload+ } = frame++ -- GOAWAY payload: last stream ID (4 octets), error code (4 octets), debug+ errorCode = BS.Lazy.take 4 (BS.Lazy.drop 4 framePayload)+ noError = BS.Lazy.replicate 4 0++-- | Connection preface exchange (RFC 9113 section 3.4)+--+-- The client's SETTINGS is guaranteed to be its first frame, so this can be+-- straight-line. Sending our SETTINGS means the client's ACK of it arrives at+-- some unpredictable later point, so we install the default noise filter from+-- here on; scripts needing more can call 'ignore' afterwards.+handshake :: Script ()+handshake = do+ send $ Frame (FrameHeader 0 0x4 0x0 0) BS.Lazy.empty -- our SETTINGS+ recv $ \frame ->+ case frameHeader frame of+ FrameHeader{frameType = 0x4, frameFlags, frameStreamId = 0}+ | frameFlags .&. 0x1 == 0 -> Right ()+ _otherwise -> Left $ "Expected client SETTINGS, got " ++ show frame+ send $ Frame (FrameHeader 0 0x4 0x1 0) BS.Lazy.empty -- ACK theirs+ ignore defaultNoiseFilter++-- | Receive DATA frames on the given stream, up to and including END_STREAM+--+-- Returns the concatenated payloads.+recvUntilEndStream :: Word32 -> Script Lazy.ByteString+recvUntilEndStream sid = go []+ where+ go :: [Lazy.ByteString] -> Script Lazy.ByteString+ go acc = do+ (payload, endStream) <- recv $ \frame ->+ case frameHeader frame of+ FrameHeader{frameType = 0x0, frameFlags, frameStreamId}+ | frameStreamId == sid ->+ Right (framePayload frame, frameFlags .&. 0x1 /= 0)+ _otherwise ->+ Left $ "Expected DATA on stream " ++ show sid ++ ", got " ++ show frame+ let acc' = payload : acc+ if endStream+ then return $ BS.Lazy.concat (reverse acc')+ else go acc'++{-------------------------------------------------------------------------------+ HTTP2 frames++ > HTTP Frame {+ > Length (24),+ > Type (8),+ >+ > Flags (8),+ >+ > Reserved (1),+ > Stream Identifier (31),+ >+ > Frame Payload (..),+ > }+-------------------------------------------------------------------------------}++data FrameHeader = FrameHeader{+ frameLength :: Word16 -- really 24 bits+ , frameType :: Word8+ , frameFlags :: Word8+ , frameStreamId :: Word32 -- really 31 bits+ }+ deriving stock (Show)++-- | HTTP2 frame+--+-- Invariant: frameLength frameHeader == length framePayload+data Frame = Frame{+ frameHeader :: FrameHeader+ , framePayload :: Lazy.ByteString+ }+ deriving stock (Show)++mkFrame ::+ Word8 -- ^ Frame type+ -> Word8 -- ^ Flags+ -> Word32 -- ^ Stream ID+ -> Lazy.ByteString -- ^ Payload+ -> Frame+mkFrame frameType frameFlags frameStreamId framePayload+ | BS.Lazy.length framePayload >= 65536+ = error "too large"++ | otherwise+ = Frame{+ frameHeader = FrameHeader{+ frameLength = fromIntegral $ BS.Lazy.length framePayload+ , frameType+ , frameFlags+ , frameStreamId+ }+ , framePayload+ }++instance Binary FrameHeader where+ get = do+ -- The spec already treats 2^14 the default upper limit, so we just+ -- restrict ourselves to 16-bit sizes here+ sizeMSB <- Binary.getWord8+ frameLength <- Binary.getWord16be+ frameType <- Binary.getWord8+ frameFlags <- Binary.getWord8+ frameStreamId <- (.&. 0x7FFFFFFF) <$> Binary.getWord32be+ unless (sizeMSB == 0) $ fail "too large"+ return FrameHeader{+ frameLength+ , frameType+ , frameFlags+ , frameStreamId+ }++ put header = mconcat [+ Binary.putWord8 0+ , Binary.putWord16be frameLength+ , Binary.putWord8 frameType+ , Binary.putWord8 frameFlags+ , Binary.putWord32be frameStreamId+ ]+ where+ FrameHeader{+ frameLength+ , frameType+ , frameFlags+ , frameStreamId+ } = header++recvFrame :: Socket -> IO (Maybe Frame)+recvFrame sock = do+ mHeader <- recvBinary sock 9+ case mHeader of+ Nothing -> return Nothing+ Just header -> do+ mPayload <- recvExact sock (fromIntegral $ frameLength header)+ case mPayload of+ Nothing -> fail "Missing payload"+ Just payload -> return $ Just Frame{+ frameHeader = header+ , framePayload = payload+ }++sendFrame :: Socket -> Frame -> IO ()+sendFrame sock Frame{frameHeader, framePayload} = do+ sendBinary sock frameHeader+ Socket.sendMany sock $ BS.Lazy.toChunks framePayload++{-------------------------------------------------------------------------------+ Server+-------------------------------------------------------------------------------}++-- | Get the results of all handlers+--+-- Should only be called once all clients have disconnected.+type GetHandlerResults a = IO [a]++withServer :: forall a r.+ Maybe ServiceName+ -> ServerHandler a+ -> (HostAddress -> PortNumber -> GetHandlerResults a -> IO r)+ -> IO r+withServer service handler k = do+ serverState <- initServerState+ let server :: IO Void+ server = runServer (Just "127.0.0.1") service serverState handler++ withAsync server $ \serverThread -> do+ link serverThread+ (addr, port) <- readMVar (serverAddress serverState)+ let getHandlerResults :: IO [a]+ getHandlerResults = do+ handlers <- readMVar (serverHandlers serverState)+ mapM wait handlers+ k addr port getHandlerResults `catchExact` \e -> do+ -- Check for failed handlers, but avoid waiting+ handlers <- readMVar (serverHandlers serverState)+ results <- mapM poll handlers+ let failed = fst $ partitionEithers $ catMaybes results+ annotateIO (FailedHandlers failed) $ throwExact e++data FailedHandlers = FailedHandlers [SomeException]+ deriving stock (Show)+#if MIN_VERSION_base(4,20,0)+ deriving anyclass (ExceptionAnnotation)+#endif++type ServerHandler a = Socket -> SockAddr -> IO a++data ServerState a = ServerState{+ -- | Server address, once it's running+ serverAddress :: MVar (HostAddress, PortNumber)++ -- | All server handlers ever spawned+ --+ -- This is an obvious memory leak, but that's irrelevant for a testing+ -- server: this allows to inspect the result of each handler in the test.+ , serverHandlers :: MVar [Async a]+ }++initServerState :: IO (ServerState a)+initServerState =+ pure ServerState+ <*> newEmptyMVar+ <*> newMVar []++runServer :: forall a.+ Maybe HostName+ -> Maybe ServiceName+ -> ServerState a+ -> ServerHandler a+ -> IO Void+runServer host service serverState handler = do+ addrInfo <- NE.head <$> getAddrInfo (Just hints) host service+ Exception.bracket (openSocket addrInfo) close $ \serverSock -> do+ setSocketOption serverSock ReuseAddr 1+ bind serverSock $ addrAddress addrInfo+ listen serverSock maxListenQueue++ serverAddr <- getSocketName serverSock+ case serverAddr of+ SockAddrInet port addr -> putMVar (serverAddress serverState) (addr, port)+ SockAddrInet6{} -> error "unexpected IPv6 socket"+ SockAddrUnix{} -> error "unexpected unix socket"++ forever $ Exception.mask_ $ do+ (clientSock, clientAddr) <- accept serverSock -- interruptible call+ let handler' :: (forall x. IO x -> IO x) -> IO a+ handler' unmask = unmask $ do+ a <- handler clientSock clientAddr+ gracefulClose clientSock gracefulTimeout+ return a+ -- We use 'asyncFinally' to ensure that if an exception is thrown in the+ -- handler, it is recorded /before/ the socket is closed, so that if+ -- that socket closure results in an exception in the test (client)+ -- code, we are sure that the handler exception /has/ been recorded.+ asyncFinally+ (serverHandlers serverState)+ handler'+ (\_ -> close clientSock)+ where+ hints :: AddrInfo+ hints = defaultHints{+ addrFlags = [AI_PASSIVE] -- socket suitable for 'accept'+ , addrFamily = AF_INET -- IPv4 only+ , addrSocketType = Stream -- TCP, not UDP+ }++ gracefulTimeout :: Int+ gracefulTimeout = 5000 -- ms++{-------------------------------------------------------------------------------+ Internal auxiliary: network+-------------------------------------------------------------------------------}++recvExact :: Socket -> Int -> IO (Maybe Lazy.ByteString)+recvExact sock = \n -> go n []+ where+ go :: Int -> [Strict.ByteString] -> IO (Maybe Lazy.ByteString)+ go 0 acc = return $ Just $ BS.Lazy.fromChunks (reverse acc)+ go n acc = do+ chunk <- Socket.recv sock (min n 4096)+ if BS.Strict.null chunk then+ case acc of+ [] -> return Nothing+ _ -> fail "Peer closed connection"+ else+ go (n - BS.Strict.length chunk) (chunk : acc)++recvBinary :: Binary a => Socket -> Int -> IO (Maybe a)+recvBinary sock sz = do+ mBytes <- recvExact sock sz+ case mBytes of+ Nothing -> return Nothing+ Just bytes -> do+ case Binary.decodeOrFail bytes of+ Left (_, _, err) -> fail err+ Right (unconsumed, sz', a) -> do+ unless (BS.Lazy.null unconsumed) $+ fail $ "Unexpected unconsumed bytes " ++ show unconsumed+ unless (fromIntegral sz == sz') $+ fail $ "Unexpected size " ++ show sz' ++ ". Expected " ++ show sz+ return (Just a)++sendBinary :: Binary a => Socket -> a -> IO ()+sendBinary sock = Socket.sendMany sock . BS.Lazy.toChunks . Binary.encode++{-------------------------------------------------------------------------------+ Internal auxiliary: async+-------------------------------------------------------------------------------}++-- | Generalization of 'asyncWithUnmask'+asyncFinally ::+ MVar [Async a]+ -- ^ Registry to add the new 'Async' to+ --+ -- This is similar to the @Warden@ concept in recent versions of @async@,+ -- but we do not remove the 'Async' from the registry when it completes.+ -> ((forall b . IO b -> IO b) -> IO a)+ -- ^ Body of the new thread+ -> (Either SomeException a -> IO ())+ -- ^ Cleanup handler to be run /after/ the result of the async has been+ -- recorded. This is sometimes useful to make teardown more deterministic.+ -- Exceptions thrown by the cleanup handler are silently discarded.+ -> IO (Async a)+asyncFinally registry action cleanup =+ Exception.mask_ $ fixIO $ \me -> do+ var <- STM.newEmptyTMVarIO+ tid <- forkIOWithUnmask $ \unmask -> do+ modifyMVar_ registry $ return . (me:)+ result <- Exception.try (action unmask)+ STM.atomically $ STM.putTMVar var result+ cleanup result `Exception.catch` \(_e :: SomeException) ->+ return ()+ return (Async.Internal.Async tid (STM.readTMVar var))