Sanity tests for server/client exception/disconnect

See module headers of `Test.Sanity.Disconnect` and `Test.Sanity.Exception`

grapesy.cabal

@@ -309,14 +309,18 @@ 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.Exception
       Test.Util.Orphans
       Test.Util.Protobuf
+      Test.Util.RawTestServer
 
       -- Internals we're testing
       Network.GRPC.Util.Parser
@@ -342,6 +346,7 @@ test-suite test-grapesy
     , bytestring                  >= 0.10  && < 0.13
     , case-insensitive            >= 1.2   && < 1.3
     , containers                  >= 0.6   && < 0.8
+    , directory                   >= 1.3   && < 1.4
     , exceptions                  >= 0.10  && < 0.11
     , http-types                  >= 0.12  && < 0.13
     , http2                       >= 5.3.1 && < 5.4
@@ -363,6 +368,7 @@ test-suite test-grapesy
     , text                        >= 1.2   && < 2.2
     , tls                         >= 1.7   && < 2.2
     , tree-diff                   >= 0.3   && < 0.4
+    , unix                        >= 2.7   && < 2.9
     , utf8-string                 >= 1.0   && < 1.1
 
 executable demo-client

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/Call.hs

@@ -628,7 +628,7 @@ recvEndOfInput call@Call{} = do
 
 -- | Send 'ProperTrailers'
 --
--- This function is not part of the public API: we use it the top-level
+-- This function is not part of the public API: we use it as the top-level
 -- exception handler in "Network.GRPC.Server" to forward exceptions in server
 -- handlers to the client.
 --

src/Network/GRPC/Server/Handler.hs

@@ -272,7 +272,7 @@ waitForHandler unmask call handlerThread = loop
 --
 -- The attempt to forward it to the client is a best-effort only:
 --
--- * The nature of the exception might mean that we we cannot send anything to
+-- * The nature of the exception might mean that we cannot send anything to
 --   the client at all.
 -- * It is possible the exception was thrown /after/ the handler already send
 --   the trailers to the client.

test-grapesy/Main.hs

@@ -17,7 +17,9 @@ import Test.Prop.Dialogue                     qualified as Dialogue
 import Test.Prop.IncrementalParsing           qualified as IncrementalParsing
 import Test.Prop.Serialization                qualified as Serialization
 import Test.Sanity.BrokenDeployments          qualified as BrokenDeployments
+import Test.Sanity.Disconnect                 qualified as Disconnect
 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
@@ -28,11 +30,13 @@ main = do
 
     defaultMain $ testGroup "grapesy" [
         testGroup "Sanity" [
-            EndOfStream.tests
+            Disconnect.tests
+          , EndOfStream.tests
           , testGroup "StreamingType" [
                 StreamingType.NonStreaming.tests
               , StreamingType.CustomFormat.tests
               ]
+          , Exception.tests
           , Interop.tests
           , BrokenDeployments.tests
           ]

test-grapesy/Test/Driver/ClientServer.hs

@@ -40,6 +40,7 @@ import Network.GRPC.Common
 import Network.GRPC.Common.Compression qualified as Compr
 import Network.GRPC.Server qualified as Server
 import Network.GRPC.Server.Run qualified as Server
+import Test.Util.Exception
 
 import Paths_grapesy
 
@@ -168,12 +169,6 @@ data TlsFail =
     we don't see these exceptions server-side.
 -------------------------------------------------------------------------------}
 
--- | Exception thrown by client or handler to test exception handling
-data DeliberateException = forall e. Exception e => DeliberateException e
-  deriving anyclass (Exception)
-
-deriving stock instance Show DeliberateException
-
 isExpectedServerException :: ClientServerConfig -> SomeException -> Bool
 isExpectedServerException cfg e
   --
@@ -232,7 +227,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/Definition.hs

@@ -20,14 +20,14 @@ module Test.Driver.Dialogue.Definition (
   , hasEarlyTermination
   ) where
 
-import Control.Exception
 import Control.Monad.State (StateT, execStateT, modify)
 import Data.Bifunctor
 import Data.ByteString qualified as Strict (ByteString)
 
 import Network.GRPC.Common
 
 import Test.Driver.Dialogue.TestClock qualified as TestClock
+import Test.Util.Exception
 import Control.Monad.Catch
 import GHC.Show (appPrec1, showCommaSpace)
 
@@ -154,25 +154,6 @@ newtype GlobalSteps = GlobalSteps {
     }
   deriving stock (Show)
 
-{-------------------------------------------------------------------------------
-  User exceptions
-
-  When a test calls for the client or the server to throw an exception, we throw
-  one of these. Their sole purpose is to be "any" kind of exception (not a
-  specific one).
--------------------------------------------------------------------------------}
-
-data SomeServerException = SomeServerException ExceptionId
-  deriving stock (Show, Eq)
-  deriving anyclass (Exception)
-
-data SomeClientException = SomeClientException ExceptionId
-  deriving stock (Show, Eq)
-  deriving anyclass (Exception)
-
--- | We distinguish exceptions from each other simply by a number
-type ExceptionId = Int
-
 {-------------------------------------------------------------------------------
   Utility
 -------------------------------------------------------------------------------}

test-grapesy/Test/Driver/Dialogue/Execution.hs

@@ -413,6 +413,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
@@ -426,6 +428,12 @@ serverLocal clock call = \(LocalSteps steps) -> do
     -- terminate more-or-less immediately, this does not necessarily indicate
     -- any kind of failure: the client may simply have put the call in
     -- half-closed mode.
+    --
+    -- TODO: <https://github.com/well-typed/grapesy/issues/209>
+    -- However, when the client terminates early and we are not using one
+    -- connection per RPC (i.e. we are sharing a connection), the server will
+    -- /never/ realize that the client has disappeared. See the discussion in
+    -- the issue above.
     waitForClientDisconnect :: IO ()
     waitForClientDisconnect =
         within timeoutFailure () $ loop

test-grapesy/Test/Sanity/BrokenDeployments.hs

@@ -3,26 +3,18 @@
 
 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 +46,11 @@ tests = testGroup "Test.Sanity.BrokenDeployments" [
         ]
     ]
 
+connParams :: Client.ConnParams
+connParams = def {
+      Client.connVerifyHeaders = True
+    }
+
 {-------------------------------------------------------------------------------
   HTTP Status
 -------------------------------------------------------------------------------}
@@ -322,101 +319,6 @@ 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