diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 5657729a..bb623c34 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.20241202 # -# REGENDATA ("0.19.20240708",["github","cabal.project.ci"]) +# REGENDATA ("0.19.20241202",["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 }} @@ -235,7 +239,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 +317,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..0985272d 100644 --- a/cabal.project +++ b/cabal.project @@ -1,4 +1,4 @@ -packages: +packages: ./grpc-spec , ./grapesy , ./tutorials/quickstart @@ -16,11 +16,12 @@ package grpc-spec package grapesy tests: True benchmarks: True - flags: +build-demo +build-stress-test + flags: +build-demo +build-stress-test --- --- ghc 9.10 --- - -allow-newer: proto-lens:base -allow-newer: proto-lens-runtime:base +-- proto-lens support for ghc 9.10 +-- https://github.com/google/proto-lens/pull/494 +source-repository-package + type: git + location: https://github.com/google/proto-lens + tag: c927e0341715a2ff7f87f219c9a36517f06cef80 + subdir: proto-lens proto-lens-runtime proto-lens-setup proto-lens-protoc diff --git a/cabal.project.ci b/cabal.project.ci index 9ffcd013..812c883b 100644 --- a/cabal.project.ci +++ b/cabal.project.ci @@ -1,4 +1,4 @@ -packages: +packages: ./grpc-spec , ./grapesy , ./tutorials/quickstart @@ -17,7 +17,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 f262dfc3..3f406ddd 100644 --- a/grapesy/grapesy.cabal +++ b/grapesy/grapesy.cabal @@ -48,6 +48,7 @@ common lang DataKinds DeriveAnyClass DeriveFunctor + DeriveGeneric DeriveTraversable DerivingStrategies DerivingVia @@ -155,17 +156,17 @@ library , exceptions >= 0.10 && < 0.11 , grpc-spec >= 0.1 && < 0.2 , http-types >= 0.12 && < 0.13 - , http2-tls >= 0.4.1 && < 0.5 + , http2-tls >= 0.4.5 && < 0.5 , lens >= 5.0 && < 5.4 , mtl >= 2.2 && < 2.4 , network >= 3.2.4 && < 3.3 - , network-run >= 0.4.1 && < 0.5 + , network-run >= 0.4.3 && < 0.5 , proto-lens >= 0.7 && < 0.8 , random >= 1.2 && < 1.3 , recv >= 0.1 && < 0.2 , stm >= 2.5 && < 2.6 , text >= 1.2 && < 2.2 - , time-manager >= 0.1 && < 0.2 + , time-manager >= 0.2.1 && < 0.3 , tls >= 1.7 && < 2.2 , unbounded-delays >= 0.1.1 && < 0.2 , unordered-containers >= 0.2 && < 0.3 @@ -173,9 +174,9 @@ library -- We pin very specific versions of http2. -- - -- Other versions should be tested against the full grapesy test suite + -- New versions should be tested against the full grapesy test suite -- (regular tests and stress tests). - , http2 == 5.3.5 + , http2 == 5.3.9 test-suite test-record-dot import: lang, common-executable-flags @@ -229,6 +230,7 @@ test-suite test-grapesy Test.Sanity.Disconnect Test.Sanity.EndOfStream Test.Sanity.Interop + Test.Sanity.Reclamation Test.Sanity.StreamingType.CustomFormat Test.Sanity.StreamingType.NonStreaming Test.Util @@ -304,6 +306,7 @@ test-suite test-stress , exceptions , http2 , network + , text , tls build-depends: @@ -314,8 +317,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/Handler.hs b/grapesy/src/Network/GRPC/Server/Handler.hs index 3e25e49c..ad897be2 100644 --- a/grapesy/src/Network/GRPC/Server/Handler.hs +++ b/grapesy/src/Network/GRPC/Server/Handler.hs @@ -24,7 +24,7 @@ import Control.Monad.IO.Class import Data.Kind import Data.Proxy import GHC.Stack -import Network.HTTP2.Internal qualified as HTTP2 +import System.ThreadManager (KilledByThreadManager(..)) import Network.GRPC.Common import Network.GRPC.Server.Call @@ -242,7 +242,7 @@ waitForHandler unmask call handlerThread = loop handleException :: SomeException -> IO () handleException err - | Just (HTTP2.KilledByHttp2ThreadManager mErr) <- fromException err = do + | Just (KilledByThreadManager mErr) <- fromException err = do let exitReason :: ExitCase () exitReason = case mErr of 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 64510c3b..4b50a0aa 100644 --- a/grapesy/test-grapesy/Main.hs +++ b/grapesy/test-grapesy/Main.hs @@ -21,6 +21,7 @@ import Test.Sanity.Compression qualified as Compression import Test.Sanity.Disconnect qualified as Disconnect import Test.Sanity.EndOfStream qualified as EndOfStream 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 , Interop.tests + , Reclamation.tests , BrokenDeployments.tests ] , testGroup "Regression" [ 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/Disconnect.hs b/grapesy/test-grapesy/Test/Sanity/Disconnect.hs index 32c8ff9a..0c76d69d 100644 --- a/grapesy/test-grapesy/Test/Sanity/Disconnect.hs +++ b/grapesy/test-grapesy/Test/Sanity/Disconnect.hs @@ -11,7 +11,7 @@ -- When a client disconnects, we expect: -- -- 1. The handlers dealing with that client (i.e. on that connection) should --- fail with 'Server.ClientDisonnected' +-- fail with 'Server.ClientDisconnected' -- 2. Future calls (after reconnection) succeed module Test.Sanity.Disconnect (tests) where 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