From 75bb0b843d15e8722167fca38a2f55172e88cf63 Mon Sep 17 00:00:00 2001 From: Finley McIlwaine Date: Thu, 1 Aug 2024 09:06:13 -0700 Subject: [PATCH] Reproducer --- grapesy.cabal | 3 + .../Interop/Client/TestCase/CustomMetadata.hs | 2 +- src/Network/GRPC/Server/Handler.hs | 2 + test-grapesy/Main.hs | 2 + test-grapesy/Test/Driver/ClientServer.hs | 2 +- .../Test/Driver/Dialogue/Execution.hs | 15 ++- test-grapesy/Test/Prop/Dialogue.hs | 97 ++++++++------ test-grapesy/Test/Sanity/BrokenDeployments.hs | 117 +---------------- test-grapesy/Test/Sanity/Disconnect.hs | 9 ++ test-grapesy/Test/Sanity/Exception.hs | 121 ++++++++++++++++++ test-grapesy/Test/Util/RawTestServer.hs | 115 +++++++++++++++++ 11 files changed, 326 insertions(+), 159 deletions(-) create mode 100644 test-grapesy/Test/Sanity/Disconnect.hs create mode 100644 test-grapesy/Test/Sanity/Exception.hs create mode 100644 test-grapesy/Test/Util/RawTestServer.hs diff --git a/grapesy.cabal b/grapesy.cabal index e42f773d..4a988731 100644 --- a/grapesy.cabal +++ b/grapesy.cabal @@ -309,7 +309,9 @@ test-suite test-grapesy Test.Prop.IncrementalParsing Test.Prop.Serialization Test.Sanity.BrokenDeployments + Test.Sanity.Disconnect Test.Sanity.EndOfStream + Test.Sanity.Exception Test.Sanity.Interop Test.Sanity.StreamingType.CustomFormat Test.Sanity.StreamingType.NonStreaming @@ -317,6 +319,7 @@ test-suite test-grapesy Test.Util.Awkward Test.Util.Orphans Test.Util.Protobuf + Test.Util.RawTestServer -- Internals we're testing Network.GRPC.Util.Parser diff --git a/interop/Interop/Client/TestCase/CustomMetadata.hs b/interop/Interop/Client/TestCase/CustomMetadata.hs index a567298f..20daf465 100644 --- a/interop/Interop/Client/TestCase/CustomMetadata.hs +++ b/interop/Interop/Client/TestCase/CustomMetadata.hs @@ -21,7 +21,7 @@ import Proto.API.Interop -- For both UnaryCall and FullDuplexCall, the reference server (at least some) -- does not return any initial metadata until we send the first request. The -- test spec does not specify whether this is expected behaviour or not, so we --- play it save and only ask for the initial metadata after sending the request. +-- play it safe and only ask for the initial metadata after sending the request. runTest :: Cmdline -> IO () runTest cmdline = do withConnection def (testServer cmdline) $ \conn -> do diff --git a/src/Network/GRPC/Server/Handler.hs b/src/Network/GRPC/Server/Handler.hs index 8aeaea15..e076ff18 100644 --- a/src/Network/GRPC/Server/Handler.hs +++ b/src/Network/GRPC/Server/Handler.hs @@ -33,6 +33,7 @@ import Network.GRPC.Spec import Network.GRPC.Util.GHC import Network.GRPC.Util.HTTP2.Stream (ClientDisconnected(..)) import Network.GRPC.Util.Session qualified as Session +import Debug.Trace (traceM) {------------------------------------------------------------------------------- Handlers @@ -244,6 +245,7 @@ waitForHandler unmask call handlerThread = loop handleException :: SomeException -> IO () handleException err | Just (HTTP2.KilledByHttp2ThreadManager mErr) <- fromException err = do + traceM $ "handleException: " ++ show mErr let exitReason :: ExitCase () exitReason = case mErr of diff --git a/test-grapesy/Main.hs b/test-grapesy/Main.hs index a3575150..8d2ea9bb 100644 --- a/test-grapesy/Main.hs +++ b/test-grapesy/Main.hs @@ -18,6 +18,7 @@ import Test.Prop.IncrementalParsing qualified as IncrementalParsing import Test.Prop.Serialization qualified as Serialization import Test.Sanity.BrokenDeployments qualified as BrokenDeployments import Test.Sanity.EndOfStream qualified as EndOfStream +import Test.Sanity.Exception qualified as Exception import Test.Sanity.Interop qualified as Interop import Test.Sanity.StreamingType.CustomFormat qualified as StreamingType.CustomFormat import Test.Sanity.StreamingType.NonStreaming qualified as StreamingType.NonStreaming @@ -33,6 +34,7 @@ main = do StreamingType.NonStreaming.tests , StreamingType.CustomFormat.tests ] + , Exception.tests , Interop.tests , BrokenDeployments.tests ] diff --git a/test-grapesy/Test/Driver/ClientServer.hs b/test-grapesy/Test/Driver/ClientServer.hs index d9d70bb4..ca59c6c3 100644 --- a/test-grapesy/Test/Driver/ClientServer.hs +++ b/test-grapesy/Test/Driver/ClientServer.hs @@ -232,7 +232,7 @@ isExpectedClientException cfg e | Just (DeliberateException _) <- fromException e = True - -- Server threw deliberat exception + -- Server threw deliberate exception | Just grpcException <- fromException e , Just msg <- grpcErrorMessage grpcException , "DeliberateException" `Text.isInfixOf` msg diff --git a/test-grapesy/Test/Driver/Dialogue/Execution.hs b/test-grapesy/Test/Driver/Dialogue/Execution.hs index 25f2ba03..99be14ec 100644 --- a/test-grapesy/Test/Driver/Dialogue/Execution.hs +++ b/test-grapesy/Test/Driver/Dialogue/Execution.hs @@ -29,6 +29,7 @@ import Test.Driver.Dialogue.Definition import Test.Driver.Dialogue.TestClock (TestClock) import Test.Driver.Dialogue.TestClock qualified as TestClock import Test.Util +import Debug.Trace (traceM) {------------------------------------------------------------------------------- Endpoints @@ -191,8 +192,9 @@ clientLocal clock call = \(LocalSteps steps) -> peerHealth <- get case peerHealth of PeerTerminated _ -> return () - PeerAlive -> within timeoutGreenLight action $ - TestClock.waitForGreenLight clock tick + PeerAlive -> do + within timeoutGreenLight action $ + TestClock.waitForGreenLight clock tick case mException of Just ex -> throwM $ DeliberateException ex Nothing -> return False @@ -413,6 +415,8 @@ serverLocal clock call = \(LocalSteps steps) -> do Terminate mErr -> do mInp <- liftIO $ try $ within timeoutReceive action $ Server.Binary.recvInput call + -- TODO: + -- -- On the server side we cannot distinguish regular client -- termination from an exception when receiving. let expectation = isExpectedElem $ NoMoreElems NoMetadata @@ -487,8 +491,8 @@ serverGlobal clock globalStepsVar call = do Top-level -------------------------------------------------------------------------------} -execGlobalSteps :: GlobalSteps -> IO ClientServerTest -execGlobalSteps steps = do +execGlobalSteps :: Bool -> GlobalSteps -> IO ClientServerTest +execGlobalSteps connPerRPC steps = do globalStepsVar <- newMVar (order steps) clock <- TestClock.new @@ -516,9 +520,6 @@ execGlobalSteps steps = do clientTerminatesEarly, serverTerminatesEarly :: Bool (clientTerminatesEarly, serverTerminatesEarly) = hasEarlyTermination steps - connPerRPC :: Bool - connPerRPC = serverTerminatesEarly || clientTerminatesEarly - -- For 'clientGlobal' the order doesn't matter, because it spawns a thread -- for each 'LocalSteps'. The server however doesn't get this option; the -- threads /get/ spawnwed for each incoming connection, and must feel off diff --git a/test-grapesy/Test/Prop/Dialogue.hs b/test-grapesy/Test/Prop/Dialogue.hs index d7bab278..b00e19ad 100644 --- a/test-grapesy/Test/Prop/Dialogue.hs +++ b/test-grapesy/Test/Prop/Dialogue.hs @@ -15,39 +15,46 @@ import Test.Driver.Dialogue tests :: TestTree tests = testGroup "Test.Prop.Dialogue" [ testGroup "Regression" [ - testCase "trivial1" $ regression trivial1 - , testCase "trivial2" $ regression trivial2 - , testCase "trivial3" $ regression trivial3 - , testCase "concurrent1" $ regression concurrent1 - , testCase "concurrent2" $ regression concurrent2 - , testCase "concurrent3" $ regression concurrent3 - , testCase "concurrent4" $ regression concurrent4 - , testCase "exception1" $ regression exception1 - , testCase "exception2" $ regression exception2 - , testCase "earlyTermination01" $ regression earlyTermination01 - , testCase "earlyTermination02" $ regression earlyTermination02 - , testCase "earlyTermination03" $ regression earlyTermination03 - , testCase "earlyTermination04" $ regression earlyTermination04 - , testCase "earlyTermination05" $ regression earlyTermination05 - , testCase "earlyTermination06" $ regression earlyTermination06 - , testCase "earlyTermination07" $ regression earlyTermination07 - , testCase "earlyTermination08" $ regression earlyTermination08 - , testCase "earlyTermination09" $ regression earlyTermination09 - , testCase "earlyTermination10" $ regression earlyTermination10 - , testCase "earlyTermination11" $ regression earlyTermination11 - , testCase "earlyTermination12" $ regression earlyTermination12 - , testCase "earlyTermination13" $ regression earlyTermination13 - , testCase "earlyTermination14" $ regression earlyTermination14 - , testCase "allowHalfClosed1" $ regression allowHalfClosed1 - , testCase "allowHalfClosed2" $ regression allowHalfClosed2 - , testCase "allowHalfClosed3" $ regression allowHalfClosed3 + testCase "trivial1" $ regression False trivial1 + , testCase "trivial2" $ regression False trivial2 + , testCase "trivial3" $ regression False trivial3 + , testCase "concurrent1" $ regression False concurrent1 + , testCase "concurrent2" $ regression False concurrent2 + , testCase "concurrent3" $ regression False concurrent3 + , testCase "concurrent4" $ regression False concurrent4 + , testCase "exception1" $ regression True exception1 + , testCase "exception2" $ regression True exception2 + , testCase "earlyTermination01" $ regression True earlyTermination01 + , testCase "earlyTermination02" $ regression True earlyTermination02 + , testCase "earlyTermination03" $ regression True earlyTermination03 + , testCase "earlyTermination04" $ regression True earlyTermination04 + , testCase "earlyTermination05" $ regression True earlyTermination05 + , testCase "earlyTermination06" $ regression True earlyTermination06 + , testCase "earlyTermination07" $ regression True earlyTermination07 + , testCase "earlyTermination08" $ regression True earlyTermination08 + , testCase "earlyTermination09" $ regression True earlyTermination09 + , testCase "earlyTermination10" $ regression True earlyTermination10 + , testCase "earlyTermination11" $ regression True earlyTermination11 + , testCase "earlyTermination12" $ regression True earlyTermination12 + , testCase "earlyTermination13" $ regression True earlyTermination13 + , testCase "earlyTermination14" $ regression True earlyTermination14 + , testCase "earlyTermination15" $ regression False earlyTermination15 + , testCase "allowHalfClosed1" $ regression False allowHalfClosed1 + , testCase "allowHalfClosed2" $ regression False allowHalfClosed2 + , testCase "allowHalfClosed3" $ regression True allowHalfClosed3 ] , testGroup "Setup" [ testProperty "shrinkingWellFounded" prop_shrinkingWellFounded ] , testGroup "Arbitrary" [ - testProperty "withoutExceptions" arbitraryWithoutExceptions - , testProperty "withExceptions" arbitraryWithExceptions + testGroup "WithoutExceptions" [ + testProperty "connPerRPC" (arbitraryWithoutExceptions True) + , testProperty "sharedConn" (arbitraryWithoutExceptions False) + ] + , testGroup "WithExceptions" [ + testProperty "connPerRPC" (arbitraryWithExceptions True) + , testProperty "sharedConn" (arbitraryWithExceptions False) + ] ] ] @@ -66,26 +73,26 @@ prop_shrinkingWellFounded = Running the tests -------------------------------------------------------------------------------} -arbitraryWithoutExceptions :: DialogueWithoutExceptions -> Property -arbitraryWithoutExceptions (DialogueWithoutExceptions dialogue) = - propDialogue dialogue +arbitraryWithoutExceptions :: Bool -> DialogueWithoutExceptions -> Property +arbitraryWithoutExceptions connPerRPC (DialogueWithoutExceptions dialogue) = + propDialogue connPerRPC dialogue -arbitraryWithExceptions :: DialogueWithExceptions -> Property -arbitraryWithExceptions (DialogueWithExceptions dialogue) = - propDialogue dialogue +arbitraryWithExceptions :: Bool -> DialogueWithExceptions -> Property +arbitraryWithExceptions connPerRPC (DialogueWithExceptions dialogue) = + propDialogue connPerRPC dialogue -propDialogue :: Dialogue -> Property -propDialogue dialogue = +propDialogue :: Bool -> Dialogue -> Property +propDialogue connPerRPC dialogue = counterexample (show globalSteps) $ - propClientServer $ execGlobalSteps globalSteps + propClientServer $ execGlobalSteps connPerRPC globalSteps where globalSteps :: GlobalSteps globalSteps = dialogueGlobalSteps dialogue -regression :: Dialogue -> IO () -regression dialogue = +regression :: Bool -> Dialogue -> IO () +regression connPerRPC dialogue = handle (throwIO . RegressionTestFailed globalSteps) $ - testClientServer =<< execGlobalSteps globalSteps + testClientServer =<< execGlobalSteps connPerRPC globalSteps where globalSteps :: GlobalSteps globalSteps = dialogueGlobalSteps dialogue @@ -359,6 +366,16 @@ earlyTermination14 = NormalizedDialogue [ , (0, ServerAction $ Terminate (Just (SomeServerException 0))) ] +earlyTermination15 :: Dialogue +earlyTermination15 = NormalizedDialogue [ + (0, ClientAction $ Initiate (def, RPC1)) + , (0, ClientAction $ Terminate (Just (SomeClientException 0))) + , (1, ClientAction $ Initiate (def, RPC1)) + , (1, ClientAction $ Send (FinalElem 0 NoMetadata)) + , (0, ServerAction $ Send (NoMoreElems def)) + , (1, ServerAction $ Send (NoMoreElems def)) + ] + {------------------------------------------------------------------------------- Dealing correctly with 'AllowHalfClosed' diff --git a/test-grapesy/Test/Sanity/BrokenDeployments.hs b/test-grapesy/Test/Sanity/BrokenDeployments.hs index a36bb613..04d43c7e 100644 --- a/test-grapesy/Test/Sanity/BrokenDeployments.hs +++ b/test-grapesy/Test/Sanity/BrokenDeployments.hs @@ -3,20 +3,11 @@ module Test.Sanity.BrokenDeployments (tests) where -import Control.Concurrent -import Control.Concurrent.Async import Control.Exception -import Data.ByteString qualified as BS.Strict -import Data.ByteString qualified as Strict (ByteString) -import Data.ByteString.Builder qualified as BS.Builder import Data.ByteString.Char8 qualified as BS.Strict.Char8 import Data.ByteString.UTF8 qualified as BS.Strict.UTF8 -import Data.String (fromString) import Data.Text qualified as Text import Network.HTTP.Types qualified as HTTP -import Network.HTTP2.Server qualified as HTTP2 -import Network.Run.TCP qualified as NetworkRun -import Network.Socket import Test.Tasty import Test.Tasty.HUnit @@ -24,6 +15,8 @@ import Network.GRPC.Client qualified as Client import Network.GRPC.Common import Network.GRPC.Common.Protobuf +import Test.Util.RawTestServer + import Proto.API.Ping {------------------------------------------------------------------------------- @@ -54,6 +47,11 @@ tests = testGroup "Test.Sanity.BrokenDeployments" [ ] ] +connParams :: Client.ConnParams +connParams = def { + Client.connVerifyHeaders = True + } + {------------------------------------------------------------------------------- HTTP Status -------------------------------------------------------------------------------} @@ -321,104 +319,3 @@ test_invalidTrailerMetadata = respondWith response $ \addr -> do someInvalidMetadata :: String someInvalidMetadata = "This is invalid: 你好" - -{------------------------------------------------------------------------------- - Test server - - This allows us to simulate broken /servers/. --------------------------------------------------------------------------------} - -data Response = Response { - responseStatus :: HTTP.Status - , responseHeaders :: [HTTP.Header] - , responseBody :: Strict.ByteString - , responseTrailers :: [HTTP.Header] - } - -instance Default Response where - def = Response { - responseStatus = HTTP.ok200 - , responseHeaders = [ asciiHeader "content-type" "application/grpc" ] - , responseBody = BS.Strict.empty - , responseTrailers = [ asciiHeader "grpc-status" "0" ] - } - --- | Server that responds with the given 'Response', independent of the request -respondWith :: Response -> (Client.Address -> IO a) -> IO a -respondWith response = withTestServer $ \_req _aux respond -> - respond http2Response [] - where - http2Response :: HTTP2.Response - http2Response = - flip HTTP2.setResponseTrailersMaker trailersMaker $ - HTTP2.responseBuilder - (responseStatus response) - (responseHeaders response) - (BS.Builder.byteString $ responseBody response) - - trailersMaker :: HTTP2.TrailersMaker - trailersMaker Nothing = return $ HTTP2.Trailers (responseTrailers response) - trailersMaker (Just _) = return $ HTTP2.NextTrailersMaker trailersMaker - --- | Low-level test server --- --- We bypass the entire grapesy machinery for constructing the server, because --- we need to mock a broken deployment. --- --- The grapesy client can auto reconnect when the server is not (yet) up and --- running, but to keep things simple, and since the server anyway runs in the --- same process, we just signal when the server is ready. This also allows us --- to avoid binding to a specific port in the tests (which might already be in --- use on the machine running the tests, leading to spurious test failures). -testServer :: HTTP2.Server -> MVar PortNumber -> IO () -testServer server serverPort = do - addr <- NetworkRun.resolve Stream (Just "127.0.0.1") "0" [AI_PASSIVE] - bracket (NetworkRun.openTCPServerSocket addr) close $ \listenSock -> do - addr' <- getSocketName listenSock - port <- case addr' of - SockAddrInet port _host -> return port - SockAddrInet6 port _ _host _ -> return port - SockAddrUnix{} -> error "respondWith: unexpected unix socket" - putMVar serverPort port - NetworkRun.runTCPServerWithSocket listenSock $ \clientSock -> - bracket (HTTP2.allocSimpleConfig clientSock 4096) - HTTP2.freeSimpleConfig $ \config -> - HTTP2.run HTTP2.defaultServerConfig config server - -withTestServer :: HTTP2.Server -> (Client.Address -> IO a) -> IO a -withTestServer server k = do - serverPort <- newEmptyMVar - withAsync (testServer server serverPort) $ \_serverThread -> do - port <- readMVar serverPort - let addr :: Client.Address - addr = Client.Address { - addressHost = "127.0.0.1" - , addressPort = port - , addressAuthority = Nothing - } - k addr - -{------------------------------------------------------------------------------- - Auxiliary --------------------------------------------------------------------------------} - -connParams :: Client.ConnParams -connParams = def { - Client.connVerifyHeaders = True - } - --- | Header with ASCII value --- --- (Header /names/ are always ASCII.) -asciiHeader :: String -> String -> HTTP.Header -asciiHeader name value = (fromString name, BS.Strict.Char8.pack value) - --- | Header with UTF-8 encoded value -utf8Header :: String -> String -> HTTP.Header -utf8Header name value = (fromString name, BS.Strict.UTF8.fromString value) - -grpcMessageContains :: GrpcException -> String -> Bool -grpcMessageContains GrpcException{grpcErrorMessage} str = - case grpcErrorMessage of - Just msg -> Text.pack str `Text.isInfixOf` msg - Nothing -> False diff --git a/test-grapesy/Test/Sanity/Disconnect.hs b/test-grapesy/Test/Sanity/Disconnect.hs new file mode 100644 index 00000000..f03bf045 --- /dev/null +++ b/test-grapesy/Test/Sanity/Disconnect.hs @@ -0,0 +1,9 @@ +module Test.Sanity.Disconnect where + +-- Server disconnects: +-- 1. Current call and concurrent calls fail with ServerDisconnected +-- 2. Future calls (on reconnect, which happens transparently) succeed +-- +-- Client disconnects: +-- 1. All handlers dealing with that particular client (and only those handlers) +-- should get a ClientDisconnected exception. \ No newline at end of file diff --git a/test-grapesy/Test/Sanity/Exception.hs b/test-grapesy/Test/Sanity/Exception.hs new file mode 100644 index 00000000..1ab164c0 --- /dev/null +++ b/test-grapesy/Test/Sanity/Exception.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Sanity.Exception where + +import Control.Concurrent.Async +import Control.Exception ( try, throw, Exception ) +import Data.Either +import Data.Word +import Test.Tasty +import Test.Tasty.HUnit + +import Network.GRPC.Client qualified as Client +import Network.GRPC.Client.Binary qualified as Binary +import Network.GRPC.Common +import Network.GRPC.Server qualified as Server +import Network.GRPC.Server.Binary qualified as Binary +import Network.GRPC.Spec + +import Test.Driver.ClientServer hiding (DeliberateException) +import Test.Driver.ClientServer (ClientServerConfig(expectEarlyServerTermination)) + +-- Server handler throws an exception: +-- 1. Current call should get that exception, concurrent calls should stay alive +-- (implying the other handlers stay alive) +-- 2. Future calls should succeed + +-- Close 102 if this block and the property checks below pass: +-- Client throws an exception in the scope of withRPC (this is #102): +-- 1. Concurrent calls should stay alive, withRPC should not swallow the +-- exception (this implies that the handlers continue running) +-- 2. Future calls should succeed + +-- 1. No exceptions, connection per RPC (simplest case) +-- 2. No exceptions, shared connection +-- 3. Exceptions, connection per RPC +-- 4. Exceptions, shared connection + + +tests :: TestTree +tests = testGroup "Test.Sanity.Exception" [ + testCase "client" test_clientException + ] + +test_clientException :: IO () +test_clientException = testClientServer $ ClientServerTest { + config = def -- { expectEarlyServerTermination = True } + , client = simpleTestClient $ \conn -> do + -- Make 100 concurrent calls. 99 of them counting to 50, and one + -- more that throws an exception once it reaches 10. + let + predicate = (> 50) + predicates = + replicate 99 predicate ++ + [ \n -> (n > 10) && throw DeliberateException + ] + + results <- + mapConcurrently + ( try @DeliberateException + . Client.withRPC conn def (Proxy @Trivial) + . countUntil + ) + predicates + + -- Only one of the calls failed + assertEqual "" (length $ lefts results) 1 + + -- All others terminated with results satisfying the predicate + assertBool "" (all predicate $ rights results) + + -- New calls still succeed + assertBool "" . predicate + =<< Client.withRPC conn def (Proxy @Trivial) (countUntil predicate) + , server = [ + Server.someRpcHandler $ + Server.mkRpcHandler @Trivial incUntilFinal + ] + } + where + countUntil :: (Word64 -> Bool) -> Client.Call Trivial -> IO Word64 + countUntil = go 0 + where + go :: Word64 -> (Word64 -> Bool) -> Client.Call Trivial -> IO Word64 + go next p call + | p next + = do + Binary.sendFinalInput @Word64 call next + (_final, NoMetadata) <- Binary.recvFinalOutput @Word64 call + return next + | otherwise + = do + Binary.sendNextInput @Word64 call next + next' <- Binary.recvNextOutput @Word64 call + go next' p call + + incUntilFinal :: Server.Call Trivial -> IO () + incUntilFinal call = do + Binary.recvInput call >>= \case + StreamElem n -> do + Binary.sendNextOutput @Word64 call $ succ n + incUntilFinal call + FinalElem n _ -> do + Binary.sendFinalOutput @Word64 call (succ n, NoMetadata) + NoMoreElems _ -> do + -- TODO: + -- + -- We shouldn't need to handle this case, since our client never + -- explicitly sends 'NoMoreElems'. However, see discussion in the + -- ticket above. + -- Server.sendTrailers call NoMetadata + return () + +type Trivial = RawRpc "trivial" "trivial" + +data DeliberateException = DeliberateException + deriving (Show, Exception) + +type instance RequestMetadata Trivial = NoMetadata +type instance ResponseInitialMetadata Trivial = NoMetadata +type instance ResponseTrailingMetadata Trivial = NoMetadata diff --git a/test-grapesy/Test/Util/RawTestServer.hs b/test-grapesy/Test/Util/RawTestServer.hs new file mode 100644 index 00000000..d1adb9a0 --- /dev/null +++ b/test-grapesy/Test/Util/RawTestServer.hs @@ -0,0 +1,115 @@ +module Test.Util.RawTestServer where + + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Exception +import Data.ByteString qualified as BS.Strict +import Data.ByteString qualified as Strict (ByteString) +import Data.ByteString.Builder qualified as BS.Builder +import Data.ByteString.Char8 qualified as BS.Strict.Char8 +import Data.ByteString.UTF8 qualified as BS.Strict.UTF8 +import Data.String (fromString) +import Data.Text qualified as Text +import Network.HTTP2.Server qualified as HTTP2 +import Network.Run.TCP qualified as NetworkRun +import Network.Socket + +import Network.GRPC.Client qualified as Client +import Network.HTTP.Types qualified as HTTP +import Network.GRPC.Common + +{------------------------------------------------------------------------------- + Test server + + This allows us to simulate broken /servers/. +-------------------------------------------------------------------------------} + +-- | Low-level test server +-- +-- We bypass the entire grapesy machinery for constructing the server, for added +-- flexibility. This allows us to mock broken deployments or run the server in +-- another thread that we throw asynchronous exceptions to, for example. +-- +-- The grapesy client can auto reconnect when the server is not (yet) up and +-- running, but to keep things simple, and since the server anyway runs in the +-- same process, we just signal when the server is ready. This also allows us to +-- avoid binding to a specific port in the tests (which might already be in use +-- on the machine running the tests, leading to spurious test failures). +rawTestServer :: MVar PortNumber -> HTTP2.Server -> IO () +rawTestServer serverPort server = do + addr <- NetworkRun.resolve Stream (Just "127.0.0.1") "0" [AI_PASSIVE] + bracket (NetworkRun.openTCPServerSocket addr) close $ \listenSock -> do + addr' <- getSocketName listenSock + port <- case addr' of + SockAddrInet port _host -> return port + SockAddrInet6 port _ _host _ -> return port + SockAddrUnix{} -> error "rawTestServer: unexpected unix socket" + putMVar serverPort port + NetworkRun.runTCPServerWithSocket listenSock $ \clientSock -> + bracket (HTTP2.allocSimpleConfig clientSock 4096) + HTTP2.freeSimpleConfig $ \config -> + HTTP2.run HTTP2.defaultServerConfig config server + +-- | Run the server and apply the continuation to an 'Client.Address' holding +-- the running server's host and port. +withTestServer :: HTTP2.Server -> (Client.Address -> IO a) -> IO a +withTestServer server k = do + serverPort <- newEmptyMVar + withAsync (rawTestServer serverPort server) $ \_serverThread -> do + port <- readMVar serverPort + let addr :: Client.Address + addr = Client.Address { + addressHost = "127.0.0.1" + , addressPort = port + , addressAuthority = Nothing + } + k addr + +-- | Server that responds with the given 'Response', independent of the request +respondWith :: Response -> (Client.Address -> IO a) -> IO a +respondWith response = withTestServer $ \_req _aux respond -> + respond (toHTTP2Response response) [] + +data Response = Response { + responseStatus :: HTTP.Status + , responseHeaders :: [HTTP.Header] + , responseBody :: Strict.ByteString + , responseTrailers :: [HTTP.Header] + } + +instance Default Response where + def = Response { + responseStatus = HTTP.ok200 + , responseHeaders = [ asciiHeader "content-type" "application/grpc" ] + , responseBody = BS.Strict.empty + , responseTrailers = [ asciiHeader "grpc-status" "0" ] + } + +toHTTP2Response :: Response -> HTTP2.Response +toHTTP2Response response = + flip HTTP2.setResponseTrailersMaker trailersMaker $ + HTTP2.responseBuilder + (responseStatus response) + (responseHeaders response) + (BS.Builder.byteString $ responseBody response) + where + trailersMaker :: HTTP2.TrailersMaker + trailersMaker Nothing = return $ HTTP2.Trailers (responseTrailers response) + trailersMaker (Just _) = return $ HTTP2.NextTrailersMaker trailersMaker + +-- | Header with ASCII value +-- +-- (Header /names/ are always ASCII.) +asciiHeader :: String -> String -> HTTP.Header +asciiHeader name value = (fromString name, BS.Strict.Char8.pack value) + +-- | Header with UTF-8 encoded value +utf8Header :: String -> String -> HTTP.Header +utf8Header name value = (fromString name, BS.Strict.UTF8.fromString value) + +grpcMessageContains :: GrpcException -> String -> Bool +grpcMessageContains GrpcException{grpcErrorMessage} str = + case grpcErrorMessage of + Just msg -> Text.pack str `Text.isInfixOf` msg + Nothing -> False