Add test for #257, improve testing

The problem is fixed in latest `http2`
(`7036a3429fb08bfcd5947230c37d1f3e63dfb3a6`).  See
kazu-yamamoto/http2#151 for the `http2` bug report.

Closes #257.

cabal.project

@@ -1,4 +1,4 @@
-packages: 
+packages:
     ./grpc-spec
   , ./grapesy
   , ./tutorials/quickstart
@@ -16,7 +16,12 @@ package grpc-spec
 package grapesy
   tests: True
   benchmarks: True
-  flags: +build-demo +build-stress-test 
+  flags: +build-demo +build-stress-test
+
+source-repository-package
+  type: git
+  location: https://github.com/edsko/http2
+  tag: a38646dee7e77e826cc218d45a2818a86959cf23
 
 --
 -- ghc 9.10

grapesy/grapesy.cabal

@@ -48,6 +48,7 @@ common lang
       DataKinds
       DeriveAnyClass
       DeriveFunctor
+      DeriveGeneric
       DeriveTraversable
       DerivingStrategies
       DerivingVia
@@ -175,7 +176,7 @@ library
       --
       -- Other versions should be tested against the full grapesy test suite
       -- (regular tests and stress tests).
-    , http2 == 5.3.5
+    , http2 == 5.3.7
 
 test-suite test-record-dot
   import:         lang, common-executable-flags
@@ -228,6 +229,7 @@ test-suite test-grapesy
       Test.Sanity.EndOfStream
       Test.Sanity.Exception
       Test.Sanity.Interop
+      Test.Sanity.Reclamation
       Test.Sanity.StreamingType.CustomFormat
       Test.Sanity.StreamingType.NonStreaming
       Test.Util
@@ -301,6 +303,7 @@ test-suite test-stress
     , exceptions
     , http2
     , network
+    , text
     , tls
 
   build-depends:
@@ -311,8 +314,10 @@ test-suite test-stress
     , filepath             >= 1.4.2.1 && < 1.6
     , ghc-events           >= 0.17    && < 0.20
     , optparse-applicative >= 0.16    && < 0.19
+    , pretty-show          >= 1.10    && < 1.11
     , process              >= 1.6.12  && < 1.7
     , random               >= 1.2     && < 1.3
+    , temporary            >= 1.3     && < 1.4
 
   if !flag(build-stress-test)
     buildable:

grapesy/interop/Interop/Client/TestCase/SpecialStatusMessage.hs

@@ -7,7 +7,7 @@ import Data.Text (Text)
 import Network.GRPC.Client
 import Network.GRPC.Common
 import Network.GRPC.Common.Protobuf
-import Network.GRPC.Spec.Serialization (buildGrpcStatus)
+import Network.GRPC.Spec (fromGrpcStatus)
 
 import Interop.Client.Connect
 import Interop.Cmdline
@@ -30,7 +30,7 @@ runTest cmdline = do
     echoStatus :: Proto EchoStatus
     echoStatus =
         defMessage
-          & #code    .~ fromIntegral (buildGrpcStatus $ GrpcError GrpcUnknown)
+          & #code    .~ fromIntegral (fromGrpcStatus $ GrpcError GrpcUnknown)
           & #message .~ statusMessage
 
     statusMessage :: Text

grapesy/interop/Interop/Client/TestCase/StatusCodeAndMessage.hs

@@ -7,7 +7,7 @@ import Data.Text (Text)
 import Network.GRPC.Client
 import Network.GRPC.Common
 import Network.GRPC.Common.Protobuf
-import Network.GRPC.Spec.Serialization (buildGrpcStatus)
+import Network.GRPC.Spec (fromGrpcStatus)
 
 import Interop.Client.Connect
 import Interop.Cmdline
@@ -39,7 +39,7 @@ runTest cmdline = do
     echoStatus :: Proto EchoStatus
     echoStatus =
         defMessage
-          & #code    .~ fromIntegral (buildGrpcStatus $ GrpcError GrpcUnknown)
+          & #code    .~ fromIntegral (fromGrpcStatus $ GrpcError GrpcUnknown)
           & #message .~ statusMessage
 
     statusMessage :: Text

grapesy/interop/Interop/Server/Common.hs

@@ -12,7 +12,7 @@ import Control.Exception
 import Network.GRPC.Common
 import Network.GRPC.Common.Protobuf
 import Network.GRPC.Server
-import Network.GRPC.Spec.Serialization (parseGrpcStatus)
+import Network.GRPC.Spec (toGrpcStatus)
 
 import Interop.Util.Exceptions
 
@@ -54,7 +54,7 @@ constructResponseMetadata call = do
 -- See <https://github.com/grpc/grpc/blob/master/doc/interop-test-descriptions.md#status_code_and_message>
 echoStatus :: Proto EchoStatus -> IO ()
 echoStatus status =
-    case parseGrpcStatus code of
+    case toGrpcStatus code of
       Just GrpcOk ->
         return ()
       Just (GrpcError err) ->

grapesy/src/Network/GRPC/Server/Run.hs

@@ -30,6 +30,7 @@ import Control.Concurrent.STM
 import Control.Exception
 import Control.Monad
 import Data.Default
+import GHC.Generics (Generic)
 import Network.HTTP2.Server qualified as HTTP2
 import Network.HTTP2.TLS.Server qualified as HTTP2.TLS
 import Network.Run.TCP qualified as Run
@@ -62,7 +63,7 @@ data ServerConfig = ServerConfig {
       -- Set to 'Nothing' to disable.
     , serverSecure :: Maybe SecureConfig
     }
-  deriving (Show)
+  deriving stock (Show, Generic)
 
 -- | Offer insecure connection (no TLS)
 data InsecureConfig = InsecureConfig {
@@ -76,7 +77,7 @@ data InsecureConfig = InsecureConfig {
       -- 'getInsecureSocket' for a way to figure out what this port actually is.
     , insecurePort :: PortNumber
     }
-  deriving (Show)
+  deriving stock (Show, Generic)
 
 -- | Offer secure connection (over TLS)
 data SecureConfig = SecureConfig {
@@ -107,7 +108,7 @@ data SecureConfig = SecureConfig {
       -- | SSL key log
     , secureSslKeyLog :: SslKeyLog
     }
-  deriving (Show)
+  deriving stock (Show, Generic)
 
 {-------------------------------------------------------------------------------
   Simple interface

grapesy/src/Network/GRPC/Util/TLS.hs

@@ -26,6 +26,7 @@ import Control.Exception
 import Data.Default
 import Data.X509 qualified as X509
 import Data.X509.CertificateStore qualified as X509
+import GHC.Generics (Generic)
 import System.Environment
 import System.X509 qualified as X509
 
@@ -134,7 +135,7 @@ data SslKeyLog =
     --
     -- This is the default.
   | SslKeyLogFromEnv
-  deriving (Show, Eq)
+  deriving stock (Show, Eq, Generic)
 
 instance Default SslKeyLog where
   def = SslKeyLogFromEnv

grapesy/test-grapesy/Main.hs

@@ -20,6 +20,7 @@ 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.Reclamation                qualified as Reclamation
 import Test.Sanity.StreamingType.CustomFormat qualified as StreamingType.CustomFormat
 import Test.Sanity.StreamingType.NonStreaming qualified as StreamingType.NonStreaming
 
@@ -38,6 +39,7 @@ main = do
           , Compression.tests
           , Exception.tests
           , Interop.tests
+          , Reclamation.tests
           , BrokenDeployments.tests
           ]
       , testGroup "Prop" [

grapesy/test-grapesy/Test/Sanity/Reclamation.hs

@@ -0,0 +1,63 @@
+module Test.Sanity.Reclamation (tests) where
+
+import Control.Exception
+import Control.Monad
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import Network.GRPC.Client qualified as Client
+import Network.GRPC.Common
+import Network.GRPC.Common.Protobuf
+import Network.GRPC.Server qualified as Server
+
+import Test.Driver.ClientServer
+
+import Proto.API.Ping
+
+tests :: TestTree
+tests = testGroup "Test.Sanity.Reclamation" [
+      testCase "serverException1" serverException1
+    , testCase "serverException2" serverException2
+    ]
+
+{-------------------------------------------------------------------------------
+  Server-side exception
+
+  Test for <https://github.com/well-typed/grapesy/issues/257>.
+-------------------------------------------------------------------------------}
+
+-- | Handler that throws immediately
+brokenHandler :: Server.Call Ping -> IO ()
+brokenHandler _call = throwIO $ DeliberateException $ userError "Broken handler"
+
+serverException1 :: Assertion
+serverException1 = testClientServer $ ClientServerTest {
+      config = def
+    , server = [Server.someRpcHandler $ Server.mkRpcHandler brokenHandler]
+    , client = \params testServer delimitTestScope -> delimitTestScope $
+        replicateM_ 1000 $ do
+          Client.withConnection params testServer $ \conn ->
+            Client.withRPC conn def (Proxy @Ping) $ \call -> do
+              resp <- try $ Client.recvFinalOutput call
+              case resp of
+                Left GrpcException{} -> return ()
+                Right _ -> assertFailure "Unexpected response"
+    }
+
+serverException2 :: Assertion
+serverException2 = testClientServer $ ClientServerTest {
+      config = def
+    , server = [Server.someRpcHandler $ Server.mkRpcHandler brokenHandler]
+    , client = \params testServer delimitTestScope -> delimitTestScope $
+        replicateM_ 1000 $
+          Client.withConnection params testServer $ \conn ->
+            Client.withRPC conn def (Proxy @Ping) $ \call -> do
+
+              -- The only difference between serverException1 is this line:
+              Client.sendFinalInput call defMessage
+
+              resp <- try $ Client.recvFinalOutput call
+              case resp of
+                Left GrpcException{} -> return ()
+                Right _ -> assertFailure "Unexpected response"
+    }

grapesy/test-stress/Main.hs

@@ -1,5 +1,16 @@
+{-# LANGUAGE CPP #-}
+
 module Main (main) where
 
+import Control.Exception
+import GHC.Conc (setUncaughtExceptionHandler)
+import System.IO.Temp (writeSystemTempFile)
+import Text.Show.Pretty (dumpStr)
+
+#if defined(PROFILING) && MIN_VERSION_base(4,20,0)
+import Control.Exception.Backtrace
+#endif
+
 import Test.Stress.Client
 import Test.Stress.Cmdline
 import Test.Stress.Driver
@@ -15,18 +26,24 @@ import Test.Stress.Server
 
 main :: IO ()
 main = do
+#if defined(PROFILING) && MIN_VERSION_base(4,20,0)
+    setBacktraceMechanismState CostCentreBacktrace True
+#endif
+
     -- Parse command-line options
     cmdline@Cmdline{..} <- getCmdline
     say (optsTracing cmdGlobalOpts) $
       "parsed command-line options: " ++ show cmdline
 
+    setUncaughtExceptionHandler $ handleUncaughtExceptions cmdline
+
     case cmdRole of
       Client{..} ->
         client
           (optsTracing cmdGlobalOpts)
-          clientSecurity
+          (unwrapNotPretty <$> clientSecurity)
           clientServerPort
-          clientCompression
+          (unwrapNotPretty <$> clientCompression)
           clientConnects
       Server{..} ->
         server
@@ -38,3 +55,12 @@ main = do
           driverGenCharts
           driverWorkingDir
           driverDuration
+
+handleUncaughtExceptions :: Cmdline -> SomeException -> IO ()
+handleUncaughtExceptions cmdline e = do
+    fp <- writeSystemTempFile "test-stress" $ unlines [
+        dumpStr cmdline
+      , displayException e
+      ]
+    putStrLn $ "Abnormal termination. See " ++ show fp
+