From 36121840bd6a59a676be3a1b3e6d54c45ba25fa0 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Sat, 9 Nov 2024 11:01:09 +0100 Subject: [PATCH] Add test for #257, improve testing The problem is fixed in latest `http2` (`7036a3429fb08bfcd5947230c37d1f3e63dfb3a6`). See https://github.com/kazu-yamamoto/http2/issues/151 for the `http2` bug report. Closes #257. --- .github/workflows/haskell-ci.yml | 43 +++++---- cabal.project | 9 +- cabal.project.ci | 9 +- grapesy/grapesy.cabal | 7 +- .../Client/TestCase/SpecialStatusMessage.hs | 4 +- .../Client/TestCase/StatusCodeAndMessage.hs | 4 +- grapesy/interop/Interop/Server/Common.hs | 4 +- grapesy/src/Network/GRPC/Server/Context.hs | 2 +- grapesy/src/Network/GRPC/Server/Run.hs | 7 +- grapesy/src/Network/GRPC/Util/TLS.hs | 3 +- grapesy/test-grapesy/Main.hs | 2 + .../Test/Driver/Dialogue/Execution.hs | 9 +- grapesy/test-grapesy/Test/Sanity/Interop.hs | 2 +- .../test-grapesy/Test/Sanity/Reclamation.hs | 63 +++++++++++++ grapesy/test-stress/Main.hs | 30 ++++++- grapesy/test-stress/Test/Stress/Cmdline.hs | 60 ++++++++++--- grapesy/test-stress/Test/Stress/Server.hs | 19 ++-- grpc-spec/grpc-spec.cabal | 1 - grpc-spec/src/Network/GRPC/Spec.hs | 5 ++ .../src/Network/GRPC/Spec/Serialization.hs | 4 - .../Spec/Serialization/Headers/Response.hs | 5 +- .../Network/GRPC/Spec/Serialization/Status.hs | 54 ----------- grpc-spec/src/Network/GRPC/Spec/Status.hs | 89 ++++++++++++++++++- 23 files changed, 314 insertions(+), 121 deletions(-) create mode 100644 grapesy/test-grapesy/Test/Sanity/Reclamation.hs delete mode 100644 grpc-spec/src/Network/GRPC/Spec/Serialization/Status.hs diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 5657729a..f8a61320 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -8,9 +8,9 @@ # # For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.19.20240708 +# version: 0.19.20241121 # -# REGENDATA ("0.19.20240708",["github","cabal.project.ci"]) +# REGENDATA ("0.19.20241121",["github","cabal.project.ci"]) # name: Haskell-CI on: @@ -64,17 +64,30 @@ jobs: allow-failure: false fail-fast: false steps: - - name: apt + - name: apt-get install run: | apt-get update apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 + apt-get install -y libsnappy-dev protobuf-compiler + - name: Install GHCup + run: | mkdir -p "$HOME/.ghcup/bin" curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup" chmod a+x "$HOME/.ghcup/bin/ghcup" - "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) + - name: Install cabal-install + run: | "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) - apt-get update - apt-get install -y libsnappy-dev protobuf-compiler + echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" + - name: Install GHC (GHCup) + if: matrix.setup-method == 'ghcup' + run: | + "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) + HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") + HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') + HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') + echo "HC=$HC" >> "$GITHUB_ENV" + echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" + echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" env: HCKIND: ${{ matrix.compilerKind }} HCNAME: ${{ matrix.compiler }} @@ -85,21 +98,12 @@ jobs: echo "LANG=C.UTF-8" >> "$GITHUB_ENV" echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" - HCDIR=/opt/$HCKIND/$HCVER - HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") - HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') - HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') - echo "HC=$HC" >> "$GITHUB_ENV" - echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" - echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" - echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" echo "HEADHACKAGE=false" >> "$GITHUB_ENV" echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" - echo "GHCJSARITH=0" >> "$GITHUB_ENV" env: HCKIND: ${{ matrix.compilerKind }} HCNAME: ${{ matrix.compiler }} @@ -227,6 +231,11 @@ jobs: allow-newer: proto-lens:base allow-newer: proto-lens-runtime:base + source-repository-package + type: git + location: https://github.com/edsko/http2 + tag: a38646dee7e77e826cc218d45a2818a86959cf23 + package grpc-spec tests: True flags: +snappy @@ -235,7 +244,7 @@ jobs: package grapesy tests: True benchmarks: True - flags: +build-demo +build-stress-test + flags: +build-demo +build-stress-test ghc-options: -Werror package quickstart-tutorial @@ -313,8 +322,8 @@ jobs: rm -f cabal.project.local $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all - name: save cache - uses: actions/cache/save@v4 if: always() + uses: actions/cache/save@v4 with: key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} path: ~/.cabal/store diff --git a/cabal.project b/cabal.project index 7123e82b..23caf41b 100644 --- a/cabal.project +++ b/cabal.project @@ -1,4 +1,4 @@ -packages: +packages: ./grpc-spec , ./grapesy , ./tutorials/quickstart @@ -9,6 +9,11 @@ packages: , ./tutorials/conduit , ./tutorials/trailers-only +source-repository-package + type: git + location: https://github.com/edsko/http2 + tag: a38646dee7e77e826cc218d45a2818a86959cf23 + package grpc-spec tests: True flags: +snappy @@ -16,7 +21,7 @@ package grpc-spec package grapesy tests: True benchmarks: True - flags: +build-demo +build-stress-test + flags: +build-demo +build-stress-test -- -- ghc 9.10 diff --git a/cabal.project.ci b/cabal.project.ci index 9ffcd013..4e33b589 100644 --- a/cabal.project.ci +++ b/cabal.project.ci @@ -1,4 +1,4 @@ -packages: +packages: ./grpc-spec , ./grapesy , ./tutorials/quickstart @@ -9,6 +9,11 @@ packages: , ./tutorials/conduit , ./tutorials/trailers-only +source-repository-package + type: git + location: https://github.com/edsko/http2 + tag: a38646dee7e77e826cc218d45a2818a86959cf23 + package grpc-spec tests: True flags: +snappy @@ -17,7 +22,7 @@ package grpc-spec package grapesy tests: True benchmarks: True - flags: +build-demo +build-stress-test + flags: +build-demo +build-stress-test ghc-options: -Werror package quickstart-tutorial diff --git a/grapesy/grapesy.cabal b/grapesy/grapesy.cabal index 7e0fa0e6..bd811796 100644 --- a/grapesy/grapesy.cabal +++ b/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: diff --git a/grapesy/interop/Interop/Client/TestCase/SpecialStatusMessage.hs b/grapesy/interop/Interop/Client/TestCase/SpecialStatusMessage.hs index e54f76c4..3263a2e7 100644 --- a/grapesy/interop/Interop/Client/TestCase/SpecialStatusMessage.hs +++ b/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 diff --git a/grapesy/interop/Interop/Client/TestCase/StatusCodeAndMessage.hs b/grapesy/interop/Interop/Client/TestCase/StatusCodeAndMessage.hs index 77e3daac..61f0183f 100644 --- a/grapesy/interop/Interop/Client/TestCase/StatusCodeAndMessage.hs +++ b/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 diff --git a/grapesy/interop/Interop/Server/Common.hs b/grapesy/interop/Interop/Server/Common.hs index 38df58ba..9a59d297 100644 --- a/grapesy/interop/Interop/Server/Common.hs +++ b/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 echoStatus :: Proto EchoStatus -> IO () echoStatus status = - case parseGrpcStatus code of + case toGrpcStatus code of Just GrpcOk -> return () Just (GrpcError err) -> diff --git a/grapesy/src/Network/GRPC/Server/Context.hs b/grapesy/src/Network/GRPC/Server/Context.hs index 5fbe41e8..59e152c8 100644 --- a/grapesy/src/Network/GRPC/Server/Context.hs +++ b/grapesy/src/Network/GRPC/Server/Context.hs @@ -109,4 +109,4 @@ defaultServerTopLevel h unmask req resp = -- See . defaultServerExceptionToClient :: SomeException -> IO (Maybe Text) defaultServerExceptionToClient (SomeException e) = - return $ Just (Text.pack $ displayException e) \ No newline at end of file + return $ Just (Text.pack $ "Server-side exception: " ++ displayException e) \ No newline at end of file diff --git a/grapesy/src/Network/GRPC/Server/Run.hs b/grapesy/src/Network/GRPC/Server/Run.hs index af110832..11e64885 100644 --- a/grapesy/src/Network/GRPC/Server/Run.hs +++ b/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 diff --git a/grapesy/src/Network/GRPC/Util/TLS.hs b/grapesy/src/Network/GRPC/Util/TLS.hs index 1074218a..ee9ff0b7 100644 --- a/grapesy/src/Network/GRPC/Util/TLS.hs +++ b/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 diff --git a/grapesy/test-grapesy/Main.hs b/grapesy/test-grapesy/Main.hs index 4792bdb1..9ea78749 100644 --- a/grapesy/test-grapesy/Main.hs +++ b/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" [ diff --git a/grapesy/test-grapesy/Test/Driver/Dialogue/Execution.hs b/grapesy/test-grapesy/Test/Driver/Dialogue/Execution.hs index c07811ae..9647dd20 100644 --- a/grapesy/test-grapesy/Test/Driver/Dialogue/Execution.hs +++ b/grapesy/test-grapesy/Test/Driver/Dialogue/Execution.hs @@ -264,9 +264,12 @@ clientLocal clock call = \(LocalSteps steps) -> -> Bool isGrpcException mErr (Left err) = and [ grpcError err == GrpcUnknown - , grpcErrorMessage err == Just (case mErr of - Nothing -> "HandlerTerminated" - Just err' -> Text.pack $ show err') + , grpcErrorMessage err == Just (mconcat [ + "Server-side exception: " + , case mErr of + Nothing -> "HandlerTerminated" + Just err' -> Text.pack $ show err' + ]) ] isGrpcException _ (Right _) = False diff --git a/grapesy/test-grapesy/Test/Sanity/Interop.hs b/grapesy/test-grapesy/Test/Sanity/Interop.hs index 17949426..6a8363b6 100644 --- a/grapesy/test-grapesy/Test/Sanity/Interop.hs +++ b/grapesy/test-grapesy/Test/Sanity/Interop.hs @@ -262,7 +262,7 @@ test_cancellation_server = Left err -> do assertEqual "grpcError" GrpcUnknown $ grpcError err - assertEqual "grpcErrorMessage" (Just "HandlerTerminated") $ + assertEqual "grpcErrorMessage" (Just "Server-side exception: HandlerTerminated") $ grpcErrorMessage err Right _ -> assertFailure "Expected exception" diff --git a/grapesy/test-grapesy/Test/Sanity/Reclamation.hs b/grapesy/test-grapesy/Test/Sanity/Reclamation.hs new file mode 100644 index 00000000..9a47ca7b --- /dev/null +++ b/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 . +-------------------------------------------------------------------------------} + +-- | 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" + } diff --git a/grapesy/test-stress/Main.hs b/grapesy/test-stress/Main.hs index 0217cedd..0f415b04 100644 --- a/grapesy/test-stress/Main.hs +++ b/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 + diff --git a/grapesy/test-stress/Test/Stress/Cmdline.hs b/grapesy/test-stress/Test/Stress/Cmdline.hs index d010e354..770a03f6 100644 --- a/grapesy/test-stress/Test/Stress/Cmdline.hs +++ b/grapesy/test-stress/Test/Stress/Cmdline.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Test.Stress.Cmdline ( -- * Types @@ -15,14 +16,20 @@ module Test.Stress.Cmdline , Security(..) , TlsOpts(..) + -- ** Auxiliary + , NotPretty(..) + -- * Parser , getCmdline ) where import Control.Applicative ((<|>)) import Data.Foldable (asum, toList) +import Data.Maybe (fromMaybe) +import GHC.Generics (Generic) import Network.Socket (HostName, PortNumber) import Options.Applicative qualified as Opt +import Text.Show.Pretty (PrettyVal(..), parseValue) import Network.GRPC.Client qualified as Client import Network.GRPC.Common @@ -41,19 +48,20 @@ data Cmdline = Cmdline { cmdRole :: Role , cmdGlobalOpts :: GlobalOpts } - deriving (Show) + deriving stock (Show, Generic) + deriving anyclass (PrettyVal) -- | Should we run the client, servers, or both? data Role = -- | Run the clients Client { -- | Connect over TLS? - clientSecurity :: Maybe Client.ServerValidation + clientSecurity :: Maybe (NotPretty Client.ServerValidation) , clientServerPort :: PortNumber , clientConnects :: [Connect] -- | Insist on this compression scheme for all messages - , clientCompression :: Maybe Compression + , clientCompression :: Maybe (NotPretty Compression) } -- | Run the server @@ -67,7 +75,8 @@ data Role = , driverDuration :: Int , driverGenCharts :: Bool } - deriving (Show) + deriving stock (Show, Generic) + deriving anyclass (PrettyVal) -- | Connections to execute data Connect = Connect { @@ -83,11 +92,13 @@ data Connect = Connect { -- | Calls to make on the connections , connectCalls :: [Call] } - deriving (Show) + deriving stock (Show, Generic) + deriving anyclass (PrettyVal) -- | Concurrent or sequential execution data Exec = Concurrent | Sequential - deriving (Show) + deriving stock (Show, Generic) + deriving anyclass (PrettyVal) -- | Types of RPCs data Call = @@ -102,19 +113,22 @@ data Call = -- | Client and server send @N@ messages to each other | BiDiStreaming Int - deriving (Show) + deriving stock (Show, Generic) + deriving anyclass (PrettyVal) data Security = Insecure | Secure - deriving (Show) + deriving stock (Show, Generic) + deriving anyclass (PrettyVal) data TlsOpts = TlsOpts { tlsPubCert :: FilePath , tlsChainCerts :: [FilePath] , tlsPrivKey :: FilePath } - deriving (Show) + deriving stock (Show, Generic) + deriving anyclass (PrettyVal) mkConfig :: Maybe TlsOpts -> HostName -> PortNumber -> ServerConfig mkConfig mtls host port = @@ -137,7 +151,8 @@ mkConfig mtls host port = data GlobalOpts = GlobalOpts { optsTracing :: Bool } - deriving (Show) + deriving stock (Show, Generic) + deriving anyclass (PrettyVal) ------------------------------------------------------------------------------- -- Top-level parsers @@ -183,10 +198,10 @@ parseRole defaultPub defaultPriv = Opt.subparser $ mconcat [ parseClientRole :: FilePath -> Opt.Parser Role parseClientRole defaultPub = Client - <$> parseClientSecurity defaultPub + <$> (fmap WrapNotPretty <$> parseClientSecurity defaultPub) <*> parseClientPort <*> parseClientConnects - <*> Opt.optional parseCompression + <*> Opt.optional (WrapNotPretty <$> parseCompression) parseClientSecurity :: FilePath -> Opt.Parser (Maybe Client.ServerValidation) parseClientSecurity defaultPub = @@ -410,3 +425,24 @@ sub :: String -> String -> Opt.Parser a -> Opt.Mod Opt.CommandFields a sub cmd desc parser = Opt.command cmd $ Opt.info (parser Opt.<**> Opt.helper) (Opt.progDesc desc) + +------------------------------------------------------------------------------- +-- Auxiliary: pretty-val +------------------------------------------------------------------------------- + +newtype NotPretty a = WrapNotPretty { unwrapNotPretty :: a } + deriving newtype (Show) + +instance Show a => PrettyVal (NotPretty a) where + prettyVal (WrapNotPretty x) = + fromMaybe + (error $ "prettyVal: could not parse " ++ show x) + (parseValue $ show x) + +instance PrettyVal PortNumber where + prettyVal = prettyVal . (fromIntegral :: PortNumber -> Integer) + +deriving anyclass instance PrettyVal ServerConfig +deriving anyclass instance PrettyVal InsecureConfig +deriving anyclass instance PrettyVal SecureConfig +deriving anyclass instance PrettyVal SslKeyLog \ No newline at end of file diff --git a/grapesy/test-stress/Test/Stress/Server.hs b/grapesy/test-stress/Test/Stress/Server.hs index a98904f0..dcc8751f 100644 --- a/grapesy/test-stress/Test/Stress/Server.hs +++ b/grapesy/test-stress/Test/Stress/Server.hs @@ -6,6 +6,8 @@ import Control.Exception import Control.Monad import Data.ByteString.Lazy.Char8 qualified as BS.Char8 import Data.IORef +import Data.Text qualified as Text +import System.Exit (exitFailure) import Network.GRPC.Common import Network.GRPC.Server @@ -13,7 +15,6 @@ import Network.GRPC.Server.Run import Proto.API.Trivial import Test.Stress.Common -import System.Exit (exitFailure) {------------------------------------------------------------------------------- Top-level @@ -22,7 +23,7 @@ import System.Exit (exitFailure) server :: Bool -> ServerConfig -> IO () server v config = handle swallowInterruptOrKilled $ do idRef <- newIORef "unknown" - s <- mkGrpcServer def (handlers v idRef) + s <- mkGrpcServer params (handlers v idRef) forkServer def config s $ \runningServer -> do p <- getServerPort runningServer writeIORef idRef $ show p @@ -40,6 +41,13 @@ server v config = handle swallowInterruptOrKilled $ do putStrLn $ "got unexpected server exception: " ++ show e exitFailure + params :: ServerParams + params = def { + -- Show exception including backtrace + serverExceptionToClient = \e -> + return $ Just (Text.pack $ displayException e) + } + {------------------------------------------------------------------------------- Handlers -------------------------------------------------------------------------------} @@ -105,11 +113,8 @@ handlers v idRef = [ clientDisconnectOkay :: IO () -> IO () clientDisconnectOkay = - handle $ \case - e | Just ClientDisconnected{} <- fromException e -> do - say' "client disconnected" - | otherwise -> - throwIO e + handle $ \ClientDisconnected{} -> + say' "client disconnected" say' :: String -> IO () say' msg = do diff --git a/grpc-spec/grpc-spec.cabal b/grpc-spec/grpc-spec.cabal index 21df49fe..a400ef7e 100644 --- a/grpc-spec/grpc-spec.cabal +++ b/grpc-spec/grpc-spec.cabal @@ -114,7 +114,6 @@ library Network.GRPC.Spec.Serialization.Headers.Request Network.GRPC.Spec.Serialization.Headers.Response Network.GRPC.Spec.Serialization.LengthPrefixed - Network.GRPC.Spec.Serialization.Status Network.GRPC.Spec.Serialization.Timeout Network.GRPC.Spec.Serialization.TraceContext Network.GRPC.Spec.Status diff --git a/grpc-spec/src/Network/GRPC/Spec.hs b/grpc-spec/src/Network/GRPC/Spec.hs index 91cfd573..4ca8a87c 100644 --- a/grpc-spec/src/Network/GRPC/Spec.hs +++ b/grpc-spec/src/Network/GRPC/Spec.hs @@ -103,6 +103,11 @@ module Network.GRPC.Spec ( -- * Status , GrpcStatus(..) , GrpcError(..) + -- ** Numerical status codes + , fromGrpcStatus + , fromGrpcError + , toGrpcStatus + , toGrpcError -- ** Exceptions , GrpcException(..) , throwGrpcError diff --git a/grpc-spec/src/Network/GRPC/Spec/Serialization.hs b/grpc-spec/src/Network/GRPC/Spec/Serialization.hs index 72c0ba48..e4de6638 100644 --- a/grpc-spec/src/Network/GRPC/Spec/Serialization.hs +++ b/grpc-spec/src/Network/GRPC/Spec/Serialization.hs @@ -14,9 +14,6 @@ module Network.GRPC.Spec.Serialization ( , buildOutput , parseOutput -- * Headers - -- ** Status - , buildGrpcStatus - , parseGrpcStatus -- ** Pseudoheaders , RawResourceHeaders(..) , InvalidResourceHeaders(..) @@ -62,6 +59,5 @@ import Network.GRPC.Spec.Serialization.Headers.PseudoHeaders import Network.GRPC.Spec.Serialization.Headers.Request import Network.GRPC.Spec.Serialization.Headers.Response import Network.GRPC.Spec.Serialization.LengthPrefixed -import Network.GRPC.Spec.Serialization.Status import Network.GRPC.Spec.Serialization.Timeout import Network.GRPC.Spec.Serialization.TraceContext diff --git a/grpc-spec/src/Network/GRPC/Spec/Serialization/Headers/Response.hs b/grpc-spec/src/Network/GRPC/Spec/Serialization/Headers/Response.hs index 0915f857..aec0e752 100644 --- a/grpc-spec/src/Network/GRPC/Spec/Serialization/Headers/Response.hs +++ b/grpc-spec/src/Network/GRPC/Spec/Serialization/Headers/Response.hs @@ -49,7 +49,6 @@ import Network.GRPC.Spec import Network.GRPC.Spec.PercentEncoding qualified as PercentEncoding import Network.GRPC.Spec.Serialization.CustomMetadata import Network.GRPC.Spec.Serialization.Headers.Common -import Network.GRPC.Spec.Serialization.Status import Network.GRPC.Spec.Util.HKD qualified as HKD import Network.GRPC.Spec.Util.Protobuf qualified as Protobuf @@ -360,7 +359,7 @@ buildProperTrailers ProperTrailers{ -- NOTE: If we add additional (reserved) headers here, we also need to add -- them to 'buildTrailer'. [ ( "grpc-status" - , BS.Strict.C8.pack $ show $ buildGrpcStatus properTrailersGrpcStatus + , BS.Strict.C8.pack $ show $ fromGrpcStatus properTrailersGrpcStatus ) ] , [ ("grpc-message", PercentEncoding.encode x) @@ -491,7 +490,7 @@ parseTrailersOnly' proxy = | name == "grpc-status" = modify $ liftProperTrailers $ \x -> x{ properTrailersGrpcStatus = throwInvalidHeader hdr $ - case parseGrpcStatus =<< readMaybe (BS.Strict.C8.unpack value) of + case toGrpcStatus =<< readMaybe (BS.Strict.C8.unpack value) of Nothing -> throwError $ "Invalid status: " ++ show value Just v -> return v } diff --git a/grpc-spec/src/Network/GRPC/Spec/Serialization/Status.hs b/grpc-spec/src/Network/GRPC/Spec/Serialization/Status.hs deleted file mode 100644 index 133331ee..00000000 --- a/grpc-spec/src/Network/GRPC/Spec/Serialization/Status.hs +++ /dev/null @@ -1,54 +0,0 @@ -module Network.GRPC.Spec.Serialization.Status ( - buildGrpcStatus - , parseGrpcStatus - ) where - -import Network.GRPC.Spec - -{------------------------------------------------------------------------------- - Serialization --------------------------------------------------------------------------------} - --- | Translate 'GrpcStatus to numerical code --- --- See -buildGrpcStatus :: GrpcStatus -> Word -buildGrpcStatus GrpcOk = 0 -buildGrpcStatus (GrpcError GrpcCancelled) = 1 -buildGrpcStatus (GrpcError GrpcUnknown) = 2 -buildGrpcStatus (GrpcError GrpcInvalidArgument) = 3 -buildGrpcStatus (GrpcError GrpcDeadlineExceeded) = 4 -buildGrpcStatus (GrpcError GrpcNotFound) = 5 -buildGrpcStatus (GrpcError GrpcAlreadyExists) = 6 -buildGrpcStatus (GrpcError GrpcPermissionDenied) = 7 -buildGrpcStatus (GrpcError GrpcResourceExhausted) = 8 -buildGrpcStatus (GrpcError GrpcFailedPrecondition) = 9 -buildGrpcStatus (GrpcError GrpcAborted) = 10 -buildGrpcStatus (GrpcError GrpcOutOfRange) = 11 -buildGrpcStatus (GrpcError GrpcUnimplemented) = 12 -buildGrpcStatus (GrpcError GrpcInternal) = 13 -buildGrpcStatus (GrpcError GrpcUnavailable) = 14 -buildGrpcStatus (GrpcError GrpcDataLoss) = 15 -buildGrpcStatus (GrpcError GrpcUnauthenticated) = 16 - --- | Inverse to 'buildGrpcStatus' -parseGrpcStatus :: Word -> Maybe GrpcStatus -parseGrpcStatus 0 = Just $ GrpcOk -parseGrpcStatus 1 = Just $ GrpcError $ GrpcCancelled -parseGrpcStatus 2 = Just $ GrpcError $ GrpcUnknown -parseGrpcStatus 3 = Just $ GrpcError $ GrpcInvalidArgument -parseGrpcStatus 4 = Just $ GrpcError $ GrpcDeadlineExceeded -parseGrpcStatus 5 = Just $ GrpcError $ GrpcNotFound -parseGrpcStatus 6 = Just $ GrpcError $ GrpcAlreadyExists -parseGrpcStatus 7 = Just $ GrpcError $ GrpcPermissionDenied -parseGrpcStatus 8 = Just $ GrpcError $ GrpcResourceExhausted -parseGrpcStatus 9 = Just $ GrpcError $ GrpcFailedPrecondition -parseGrpcStatus 10 = Just $ GrpcError $ GrpcAborted -parseGrpcStatus 11 = Just $ GrpcError $ GrpcOutOfRange -parseGrpcStatus 12 = Just $ GrpcError $ GrpcUnimplemented -parseGrpcStatus 13 = Just $ GrpcError $ GrpcInternal -parseGrpcStatus 14 = Just $ GrpcError $ GrpcUnavailable -parseGrpcStatus 15 = Just $ GrpcError $ GrpcDataLoss -parseGrpcStatus 16 = Just $ GrpcError $ GrpcUnauthenticated -parseGrpcStatus _ = Nothing - diff --git a/grpc-spec/src/Network/GRPC/Spec/Status.hs b/grpc-spec/src/Network/GRPC/Spec/Status.hs index 24714bcf..f80b06d3 100644 --- a/grpc-spec/src/Network/GRPC/Spec/Status.hs +++ b/grpc-spec/src/Network/GRPC/Spec/Status.hs @@ -2,16 +2,22 @@ module Network.GRPC.Spec.Status ( -- * GRPC status GrpcStatus(..) , GrpcError(..) + , fromGrpcStatus + , fromGrpcError + , toGrpcStatus + , toGrpcError -- * Exceptions , GrpcException(..) , throwGrpcError ) where import Control.Exception +import Data.List (intercalate) import Data.Text (Text) import GHC.Generics (Generic) import Network.GRPC.Spec.CustomMetadata.Raw (CustomMetadata) +import Data.Text qualified as Text {------------------------------------------------------------------------------- gRPC status @@ -174,6 +180,63 @@ data GrpcError = deriving stock (Show, Eq, Generic) deriving anyclass (Exception) +{------------------------------------------------------------------------------- + Status codes +-------------------------------------------------------------------------------} + +-- | Translate 'GrpcStatus' to numerical status code +-- +-- See +fromGrpcStatus :: GrpcStatus -> Word +fromGrpcStatus GrpcOk = 0 +fromGrpcStatus (GrpcError err) = fromGrpcError err + +-- | Translate 'GrpcError' to numerical status code +-- +-- See also 'fromGrpcStatus' +fromGrpcError :: GrpcError -> Word +fromGrpcError GrpcCancelled = 1 +fromGrpcError GrpcUnknown = 2 +fromGrpcError GrpcInvalidArgument = 3 +fromGrpcError GrpcDeadlineExceeded = 4 +fromGrpcError GrpcNotFound = 5 +fromGrpcError GrpcAlreadyExists = 6 +fromGrpcError GrpcPermissionDenied = 7 +fromGrpcError GrpcResourceExhausted = 8 +fromGrpcError GrpcFailedPrecondition = 9 +fromGrpcError GrpcAborted = 10 +fromGrpcError GrpcOutOfRange = 11 +fromGrpcError GrpcUnimplemented = 12 +fromGrpcError GrpcInternal = 13 +fromGrpcError GrpcUnavailable = 14 +fromGrpcError GrpcDataLoss = 15 +fromGrpcError GrpcUnauthenticated = 16 + +-- | Inverse to 'fromGrpcStatus' +toGrpcStatus :: Word -> Maybe GrpcStatus +toGrpcStatus 0 = Just $ GrpcOk +toGrpcStatus s = GrpcError <$> toGrpcError s + +-- | Inverse to 'fromGrpcError' +toGrpcError :: Word -> Maybe GrpcError +toGrpcError 1 = Just $ GrpcCancelled +toGrpcError 2 = Just $ GrpcUnknown +toGrpcError 3 = Just $ GrpcInvalidArgument +toGrpcError 4 = Just $ GrpcDeadlineExceeded +toGrpcError 5 = Just $ GrpcNotFound +toGrpcError 6 = Just $ GrpcAlreadyExists +toGrpcError 7 = Just $ GrpcPermissionDenied +toGrpcError 8 = Just $ GrpcResourceExhausted +toGrpcError 9 = Just $ GrpcFailedPrecondition +toGrpcError 10 = Just $ GrpcAborted +toGrpcError 11 = Just $ GrpcOutOfRange +toGrpcError 12 = Just $ GrpcUnimplemented +toGrpcError 13 = Just $ GrpcInternal +toGrpcError 14 = Just $ GrpcUnavailable +toGrpcError 15 = Just $ GrpcDataLoss +toGrpcError 16 = Just $ GrpcUnauthenticated +toGrpcError _ = Nothing + {------------------------------------------------------------------------------- gRPC exceptions -------------------------------------------------------------------------------} @@ -188,7 +251,31 @@ data GrpcException = GrpcException { , grpcErrorMetadata :: [CustomMetadata] } deriving stock (Show, Eq) - deriving anyclass (Exception) + +instance Exception GrpcException where + displayException GrpcException{ + grpcError + , grpcErrorMessage + , grpcErrorMetadata + } = (intercalate "\n" . concat) [ + [ concat [ + "gRPC exception " + , show grpcError + , " (" + , show (fromGrpcError grpcError) + , ")" + ] + ] + , [ intercalate "\n" $ + "Error message:" + : (map ("| " ++) . lines $ Text.unpack msg) + | Just msg <- [grpcErrorMessage] + ] + , [ show md + | md <- grpcErrorMetadata + ] + ] + -- | Convenience function to throw an t'GrpcException' with the specified error throwGrpcError :: GrpcError -> IO a