Reproducer

grapesy.cabal

@@ -309,14 +309,17 @@ 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
       Test.Util
       Test.Util.Awkward
       Test.Util.Orphans
       Test.Util.Protobuf
+      Test.Util.RawTestServer
 
       -- Internals we're testing
       Network.GRPC.Util.Parser

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

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

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
           ]

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

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: <https://github.com/well-typed/grapesy/issues/209>
+            --
             -- 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

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'
 

test-grapesy/Test/Sanity/BrokenDeployments.hs

@@ -3,27 +3,20 @@
 
 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
 
 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