diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,25 @@ # Revision history for grapesy +## 1.2.0 -- 2026-09-02 + +* Use `http2-5.4.4` (which brings in `crypton-1.1.*`). +* Improve handling of of `http2` exceptions +* Reduce test-suite flakiness +* `recvNextOutputElem` checks trailing metadata [#369] +* Send `RST_STREAM` even if client has already sent their final message [#372]. + The RST_STREAM tells the server that the client is no longer interested in + receiving any more messages from the server; it's therefore independent from + whether or not the client has sent _its_ final message _to_ the server. +* The set of trailers included in a response no longer need to be static per + RPC, but can vary based on the request; see + `setResponseInitialMetadataAndTrailers` [#375] +* HTTP `Trailer` header (which announces which trailers a server might send) + can now be inspected by clients +* Improve documentation of `exponentialBackoff` [#332, Mako Bates] +* Support for GHC 9.12 and 9.14 +* Various other bounds [#348, Erik de Castro Lopo; and others] +* Test against v1.83 of the official gRPC interop tests [#371] + ## 1.1.1 -- 2025-10-09 * Support `openConnection/closeConnection` diff --git a/data/grpc-demo.key b/data/grpc-demo.key --- a/data/grpc-demo.key +++ b/data/grpc-demo.key @@ -1,28 +1,28 @@ -----BEGIN PRIVATE KEY----- -MIIEvAIBADANBgkqhkiG9w0BAQEFAASCBKYwggSiAgEAAoIBAQCsQo73KVoCJ8fh -+CwdxiXewRBtnd/SeyKJxsskM90YRfO9BFxODW9mFkEvQx8tui9BE5Kbw3wV4Kxk -lc4bnj38E3Q6zqo2nJavNtI2U6/Edm5/ZcFfHrpAw97wRxek7rabSke8bvYtrz3y -wZEwt9hIWddPOQi43rKGPpOCyaDNmZpne+BpJPhW7/VqqQebGyDXRBZ8Wl1y1b4n -nem6MZ66zwLr01MWIWXKk+Fgog3zZFX8W4TdMBX4aaYgs3pqQvBnaxWyxQkPnWAR -P4IrfZVimjR4yP8DbLeMKzvq21sLEBUSvbB5JLt/gNTrWBnBOIMZ8vMBTMJRKMnb -wGWoCINFAgMBAAECggEAFOO3aaKynxtK4ozRcMTkN8iq4Ngp2eED1bhtTxUZBUYK -Ykwik3aOoU8mlYAqykVPULF6cHg61n5Z+ZKvHWtJsgV77Vu9iYTgwxu/T0ZDxOvl -x35D/nB//rWiFfpRFDe8nkVaQLAmG3EqboNpw4Iv8MowUZOliqG6/YueINiprvTz -v3/T0u8Ry/oEFae/YNFME41Q+glYxOptEVkXMN89KccEl+W2eFNv3BdCukQKhpoE -fGR1+qRLv3uuRmDENDFw+Agp7XQ/9MucZSoklh1vuw1998p3JmaSlyurRoUDFiBE -YXRH/TFXoi6nitFdaGjh6K+1BekdZt+7bNoZZyvG+wKBgQDwMbWIvLeOgwbex4NN -gQk03WcvUpP56LrXrpkQ+JaO46FatengmGcTLPqQ56atNV0uNvHd8JwEYg2lBJWw -LSWhGV1Sa2CkXfp4LFgJ0Y3xxST7sfP4/HxnK3fg9f0nXOFmRdup96CI5LUVCtAC -jBbjwXQXy5rXy/4jY0k1YCjdAwKBgQC3mG+SGLm7GHp9GKCxXtXudg6vTBoUjHdh -NJSrVuRC2MRYmlZPVMYniDDHM/G8v+DzKCBPlGQPqWorRcvsD95xrOE7W+/zuiNT -lYSa9EKWolzq6aOAHNG2pBxVfZiW85IFw5GQLaCU3V4YP/oYeJa3eESxHyy+gPFN -6zOmMqw4FwKBgHzynuieoy3zYyOIzfkHYu6pLgAkCO477tY78UwuxMNYDpvNffhj -z1reTwoKN15rICnmUzOM8twk1cw98lBPa/+93hn92awnZyAUkUeqRxi54V89Vxjy -3xQcPKQ90o8jde1p8bcdJdmQf9KOaV6p2U5pWCb4t3gCmhV2lKK7fwZZAoGAB8Bg -3Ys7tEGJUmTKzBJT9/h2EEKnSzzPAYSlzkIh6wyZ5Z/GixzqLNscLBzuVOjJB5sn -GhUK0Hp3qBIPVQ0qeCQzcj0keWbffPTwH1a2xQNf5u8sXwlYdVyicZ2W5rCr9qBW -Mf8rK33ZLi7tUUEuI9rpE41cZ0KsbXzDtn2nNcsCgYBfqjgh8KOuE4firXNeMKBR -elhVFiCogJ8pzduq4yJBJs+PGwHuCH7JZNQTOVyrULJ43MhG0/xSf1EmraRKLOOK -DnqmdyNyeH0aZVMzsrzL+L5I7TPiu/3h6uKfrnloOJ7OBcg8lVEREhtDPfHY1s0M -bxpcu7Q5sa3qrG9pZ62DIw== +MIIEvwIBADANBgkqhkiG9w0BAQEFAASCBKkwggSlAgEAAoIBAQDVOd3q2ge6CTyo +AlSqkXz18MP4iyHVZnV7NchVe5thKs84UuQWUTcTtGHvvPOZkAF9JLl6cvxO2tVu +enA1XM1sT4EPXglmqLA/riFE69k/Lql1aUxqJKpc5J+4vV39T6wAwHVdpIqJpgye +saZwGfmS84v9hoaxzUaLFYOE6G0purUEX88WEI0TnLwx6Nd57sxUSLalkb8+H3iv +gH1pVRxFY+sQVD4ZsWgnD0QmIsTUgUp4YqgY3CpqbXjo273D0I8dFZa9U7XbBtBp +H5LmPvM8rPhTVJyVrQC2rsE00Jf25Lh6wybvRpN/jc7QjsaBf1m3gzEJiIewyr3D +ZhB9bZa5AgMBAAECggEAEM7aP/Us6IzQc7v8GZZhxjwfu2Ix6hHRqMM635/G37He +TaXQss1D7RedV40XZ/j/YD9UKAnG+tGEQ1lMEODLLqkIihusqQnntTVdDDZKCBF9 +35jL1cG+Wv4Ip/YbFRwOxnmYjUFEGTxC888albnU2X3ws8aP32Jh/hYiXNU6wBaB +u0m+60BdxX9xXhZykpVMCeS1eR7wirbLWfMg2wT7iCstxZ2vgCvXexR3Zr53dHCf +qhkCzbRuNTYhDrexh+pegMXpyCHa9scMwogg08m3S4cmwmgiR7q3CQxZWB3PAVy+ +fUrt3c0vQ/trjIYgobOxUjt14AONTrpWQuXMNMAZCwKBgQDvInBUCF3lN9zswFTl +hCkkFa93Kua57sn75aWIh6tum4SIUQo7vHOllYK4TCjia0TE+H8aX9iymM214e1j +JO1Lsd04RPsMVwzRBXxEsoN//Pov42H5uxKI8j/0spxP3ng+RFGrySFwWbzBg3xG +mFwt3dSovriuR6To6KrnOl0zdwKBgQDkQ6basARg9B/DWyEYoqHX9JZvWgV33aLH +PGjtkedvTCu2IvvMMG15C2J4mCaAs1XWm7Mf5VKozPvnW402EwMdmiqrbMiZd+eR +Esqbz/48FpngucdDKEtK4NpKmFZZSsIQbun1VRR1iFhd9mxybjuYYH0oFvelFn1j +fk4q2GYzTwKBgQCCKlPMWfWKJHs734EWoXanbqphClgm0yTc2WbeR0L4ZOyiKsKQ +O4cTlate2A3VGSCIut6so4lXxbcLjtvhgKMt9bX9wAaK9ANE72ByIF1V2ITydinJ +fpubMYnAj0xoaSc4dYWjJUrvVdlZ2FFYN+zNBpeP9qieLN9F7AfC71D2BwKBgQCp +nUOM2KJIUN6RUVPkdGSCjfKCx4esq/paxZ7KeVJZt2X7rz8fWRTfjwAa0CQ8GgY8 +s/GET+j+GWNNZRAnEDWOd5IhU3Iz548gk7AN2530lG6/OAzC8FwSRcavC0eOjihq +AaDDdfb/5tKS75th5FtQPNKDSZ23BGEj3yTCXY6DrQKBgQCGTQxKeSyKUMSm8LTA +dr0KCy2Kv/5e0Tm8Rtw+COvKLDHKlf6AZfGRPSrdTT2P2fBJwswHI5HvAUTWVgrd +CiCnYHuCdzYqrJ9wdVDmjdD6bmWRtngob5busaFSqJZffRrbFrvyegTyom2bsU7c +rbZ0sOJ0/2ftvhMnG9K18PvDug== -----END PRIVATE KEY----- diff --git a/data/grpc-demo.pem b/data/grpc-demo.pem --- a/data/grpc-demo.pem +++ b/data/grpc-demo.pem @@ -1,19 +1,19 @@ -----BEGIN CERTIFICATE----- -MIIDCTCCAfGgAwIBAgIUJUaCdYsL0XZo/YVU22eiVgsCt5UwDQYJKoZIhvcNAQEL -BQAwFDESMBAGA1UEAwwJMTI3LjAuMC4xMB4XDTI1MDcxNTEyMzIzM1oXDTI2MDcx -NTEyMzIzM1owFDESMBAGA1UEAwwJMTI3LjAuMC4xMIIBIjANBgkqhkiG9w0BAQEF -AAOCAQ8AMIIBCgKCAQEArEKO9ylaAifH4fgsHcYl3sEQbZ3f0nsiicbLJDPdGEXz -vQRcTg1vZhZBL0MfLbovQROSm8N8FeCsZJXOG549/BN0Os6qNpyWrzbSNlOvxHZu -f2XBXx66QMPe8EcXpO62m0pHvG72La898sGRMLfYSFnXTzkIuN6yhj6TgsmgzZma -Z3vgaST4Vu/1aqkHmxsg10QWfFpdctW+J53pujGeus8C69NTFiFlypPhYKIN82RV -/FuE3TAV+GmmILN6akLwZ2sVssUJD51gET+CK32VYpo0eMj/A2y3jCs76ttbCxAV -Er2weSS7f4DU61gZwTiDGfLzAUzCUSjJ28BlqAiDRQIDAQABo1MwUTAdBgNVHQ4E -FgQUjOfzmF9JJNoZcL82V79PWWy7qH8wHwYDVR0jBBgwFoAUjOfzmF9JJNoZcL82 -V79PWWy7qH8wDwYDVR0TAQH/BAUwAwEB/zANBgkqhkiG9w0BAQsFAAOCAQEAHqdY -wn+go05bD0I85owKiLvvFB5TROJXJCAJpEaXrDD16fbU28xLEvG44FqJ5/WRGUTy -odr3HOTlPuWkjlLk2y90m0NkVM6Jc+VS/HuAF26GYWGpB+cMsjjuXGInV4+Vy/BQ -1Yu/oH9tFMEtGDQHVaV/dYd2iORf/ANf2Iu9VAf2pZ2muFoWqd8LXvtrjWnkrQOk -jiGs7khc/H7apn7yx+7F3D2lHwK1eiZXJnqaTMyJfkcDFyphAMgp93kAt8lEJvU9 -DFIyFuybUtCCN4f5NAYi+p4GaOilgFYGpRYm9WntH5PiHSVTgibfVX/4uISHU16W -DXpIaptTShhjG8iXGQ== +MIIDCTCCAfGgAwIBAgIUYT7PE1pfA0Wj//ClG/pdWJ4LiEgwDQYJKoZIhvcNAQEL +BQAwFDESMBAGA1UEAwwJMTI3LjAuMC4xMB4XDTI2MDcyMjA4MzQ0MFoXDTI3MDcy +MjA4MzQ0MFowFDESMBAGA1UEAwwJMTI3LjAuMC4xMIIBIjANBgkqhkiG9w0BAQEF +AAOCAQ8AMIIBCgKCAQEA1Tnd6toHugk8qAJUqpF89fDD+Ish1WZ1ezXIVXubYSrP +OFLkFlE3E7Rh77zzmZABfSS5enL8TtrVbnpwNVzNbE+BD14JZqiwP64hROvZPy6p +dWlMaiSqXOSfuL1d/U+sAMB1XaSKiaYMnrGmcBn5kvOL/YaGsc1GixWDhOhtKbq1 +BF/PFhCNE5y8MejXee7MVEi2pZG/Ph94r4B9aVUcRWPrEFQ+GbFoJw9EJiLE1IFK +eGKoGNwqam146Nu9w9CPHRWWvVO12wbQaR+S5j7zPKz4U1Scla0Atq7BNNCX9uS4 +esMm70aTf43O0I7GgX9Zt4MxCYiHsMq9w2YQfW2WuQIDAQABo1MwUTAdBgNVHQ4E +FgQU7fiGRnHHW4Rok8HLWvECiNaJ7XYwHwYDVR0jBBgwFoAU7fiGRnHHW4Rok8HL +WvECiNaJ7XYwDwYDVR0TAQH/BAUwAwEB/zANBgkqhkiG9w0BAQsFAAOCAQEAPbBH +JmWkRggAhQxryuN8OSN2gdxi6S5nQ+G5ceIpbjv/U8MNiYPOatD4awtzAyZMSB+I +LMQWyTc92yrSCw5OMI9LjVD3qlxIL/lka78p1C84F8BFnk9ArzzR4WDX2J4l7upg +rY1AzzJ9ASjoalysaXj2dCly1gqHp2vC/a4Edje9E3U0OznAKSxtARJq0swmC7A/ +6+FR22WpiKo342xjYxv7cp23MzczDQefMcXXnS4pXcOfa8mcr4mS430uDwdsO9Vf +s58RTmvwrZkyvFH8PgGBHAOold3C1T/M480n/b04wW/zEzNvtDZyQnVwp+5mvbW+ +tvOytjvkSu3KMbRuKQ== -----END CERTIFICATE----- diff --git a/grapesy.cabal b/grapesy.cabal --- a/grapesy.cabal +++ b/grapesy.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: grapesy -version: 1.1.1 +version: 1.2.0 synopsis: Native Haskell implementation of the gRPC framework description: This is a fully compliant and feature complete native Haskell implementation of gRPC, Google's RPC framework. @@ -12,18 +12,20 @@ build-type: Simple extra-doc-files: CHANGELOG.md data-dir: data -data-files: route_guide_db.json - grpc-demo.pem - grpc-demo.key - interop.pem - interop.key - interop-ca.pem +extra-source-files: data/route_guide_db.json + data/grpc-demo.pem + data/grpc-demo.key + data/interop.pem + data/interop.key + data/interop-ca.pem tested-with: GHC==8.10.7 , GHC==9.2.8 , GHC==9.4.8 - , GHC==9.6.6 - , GHC==9.8.2 - , GHC==9.10.1 + , GHC==9.6.7 + , GHC==9.8.4 + , GHC==9.10.3 + , GHC==9.12.4 + , GHC==9.14.1 source-repository head type: git @@ -38,13 +40,14 @@ -Widentities -Wmissing-export-lists build-depends: - base >= 4.14 && < 4.22 + base >= 4.14 && < 4.23 default-language: Haskell2010 default-extensions: BangPatterns ConstraintKinds DataKinds + DefaultSignatures DeriveAnyClass DeriveFunctor DeriveGeneric @@ -52,6 +55,7 @@ DerivingStrategies DerivingVia DisambiguateRecordFields + EmptyCase FlexibleContexts FlexibleInstances GADTs @@ -63,6 +67,7 @@ MultiWayIf NamedFieldPuns NumericUnderscores + PatternSynonyms PolyKinds RankNTypes ScopedTypeVariables @@ -87,8 +92,7 @@ library import: lang - autogen-modules: Paths_grapesy - hs-source-dirs: src, proto + hs-source-dirs: src exposed-modules: Network.GRPC.Client @@ -100,6 +104,7 @@ Network.GRPC.Common Network.GRPC.Common.Binary Network.GRPC.Common.Compression + Network.GRPC.Common.Exception Network.GRPC.Common.Headers Network.GRPC.Common.HTTP2Settings Network.GRPC.Common.JSON @@ -118,8 +123,10 @@ Network.GRPC.Client.Call Network.GRPC.Client.Connection Network.GRPC.Client.Meta + Network.GRPC.Client.Run Network.GRPC.Client.Session Network.GRPC.Client.StreamType + Network.GRPC.Common.ProtocolException Network.GRPC.Server.Call Network.GRPC.Server.Context Network.GRPC.Server.Handler @@ -128,57 +135,81 @@ Network.GRPC.Server.RequestHandler.API Network.GRPC.Server.Session Network.GRPC.Util.AccumulatedByteString + Network.GRPC.Util.ClientStream Network.GRPC.Util.GHC + Network.GRPC.Util.HeaderTable Network.GRPC.Util.HTTP2 - Network.GRPC.Util.HTTP2.Stream + Network.GRPC.Util.Imports Network.GRPC.Util.RedundantConstraint - Network.GRPC.Util.Session + Network.GRPC.Util.ServerStream Network.GRPC.Util.Session.API Network.GRPC.Util.Session.Channel Network.GRPC.Util.Session.Client Network.GRPC.Util.Session.Server + Network.GRPC.Util.Stream Network.GRPC.Util.Thread + Network.GRPC.Util.TimeManager Network.GRPC.Util.TLS + Network.GRPC.Util.Version - Paths_grapesy + -- Exception utilities + -- + -- Perhaps this could become its own little library? + Network.GRPC.Util.Exception.Doc + Network.GRPC.Util.Exception.Exact + Network.GRPC.Util.Exception.FormatCtx + Network.GRPC.Util.Exception.Shims + Network.GRPC.Util.Exception.ToExceptionDoc + build-depends: - , aeson >= 1.5 && < 2.3 - , async >= 2.2 && < 2.3 - , binary >= 0.8 && < 0.9 - , bytestring >= 0.10.12 && < 0.13 - , conduit >= 1.3 && < 1.4 - , containers >= 0.6 && < 0.8 - , crypton-x509 >= 1.7 && < 1.8 - , crypton-x509-store >= 1.6 && < 1.7 - , crypton-x509-system >= 1.6 && < 1.7 - , data-default >= 0.7 && < 0.9 - , deepseq >= 1.4 && < 1.6 - , exceptions >= 0.10 && < 0.11 - , grpc-spec >= 1.0 && < 1.1 - , http-types >= 0.12 && < 0.13 - , http2-tls >= 0.4.9 && < 0.5 - , lens >= 5.0 && < 5.4 - , mtl >= 2.2 && < 2.4 - , network >= 3.2.4 && < 3.3 - , network-run >= 0.4.3 && < 0.5 - , proto-lens >= 0.7 && < 0.8 - , proto-lens-protobuf-types >= 0.7 && < 0.8 - , random >= 1.2 && < 1.4 - , recv >= 0.1 && < 0.2 - , stm >= 2.5 && < 2.6 - , text >= 1.2 && < 2.2 - , time-manager >= 0.2.2 && < 0.3 - , tls >= 1.7 && < 2.2 - , unbounded-delays >= 0.1.1 && < 0.2 - , unordered-containers >= 0.2 && < 0.3 - , utf8-string >= 1.0 && < 1.1 + , aeson >= 1.5 && < 2.4 + , async >= 2.2 && < 2.3 + , binary >= 0.8 && < 0.9 + , bytestring >= 0.10.12 && < 0.13 + , conduit >= 1.3 && < 1.4 + , containers >= 0.6 && < 0.9 + , crypton-x509 >= 1.7 && < 1.10 + , crypton-x509-store >= 1.6 && < 1.10 + , crypton-x509-system >= 1.6 && < 1.10 + , data-default >= 0.7 && < 0.9 + , deepseq >= 1.4 && < 1.6 + , grpc-spec >= 1.1 && < 1.2 + , http-types >= 0.12 && < 0.13 + , lens >= 5.0 && < 5.4 + , mtl >= 2.2 && < 2.4 + , network >= 3.2.4 && < 3.3 + , proto-lens >= 0.7 && < 0.8 + , random >= 1.2 && < 1.4 + , recv >= 0.1 && < 0.2 + , stm >= 2.5 && < 2.6 + , text >= 1.2 && < 2.2 + , time-manager >= 0.3.2 && < 0.4 + , tls >= 1.7 && < 2.5 + , unbounded-delays >= 0.1.1 && < 0.2 + , unordered-containers >= 0.2 && < 0.3 + , utf8-string >= 1.0 && < 1.1 - -- We pin very specific versions of http2. - -- - -- New versions should be tested against the full grapesy test suite - -- (regular tests and stress tests). - , http2 == 5.3.9 + -- NOTE: If you want good backtraces, you'll want exceptions >= 0.10.12 + , exceptions >= 0.10 && < 0.11 + -- NOTE: If you want to avoid bringing in unnecessary IsLabel instances, + -- you'll want proto-lens-protobuf-types >= 0.7.2.3. + -- See also . + , proto-lens-protobuf-types >= 0.7 && < 0.8 + + -- The following set of packages are all tightly coupled, and should be + -- bumped all at once. Moreover, we pin a very specific version of http2; + -- any new version should be tested against the full grapesy test suite + -- (regular tests, stress tests and interop tests). + build-depends: + , http2 == 5.4.4 + , http-semantics >= 0.4 && < 0.5 + , http2-tls >= 0.5 && < 0.6 + , network-run >= 0.5 && < 0.6 + + if(flag(patched-ghc-for-exception-debugging)) + cpp-options: -DPATCHED_GHC_FOR_EXCEPTION_DEBUGGING + test-suite test-record-dot import: lang, common-executable-flags type: exitcode-stdio-1.0 @@ -211,12 +242,13 @@ test-suite test-grapesy import: lang, common-executable-flags type: exitcode-stdio-1.0 - hs-source-dirs: test-grapesy, proto + hs-source-dirs: test-grapesy, proto, paths main-is: Main.hs - autogen-modules: Paths_grapesy build-depends: grapesy + ghc-options: -with-rtsopts=-N other-modules: + Test.Common.Exception Test.Driver.ClientServer Test.Driver.Dialogue Test.Driver.Dialogue.Definition @@ -228,10 +260,11 @@ Test.Regression.Issue238 Test.Sanity.Any Test.Sanity.BrokenDeployments + Test.Sanity.Cancellation Test.Sanity.Compression - Test.Sanity.Disconnect Test.Sanity.EndOfStream Test.Sanity.Interop + Test.Sanity.Metadata Test.Sanity.NoIsLabel Test.Sanity.Reclamation Test.Sanity.StreamingType.CustomFormat @@ -240,7 +273,7 @@ Test.Util.Exception Test.Util.RawTestServer - Paths_grapesy + Paths_ Proto.API.Helloworld Proto.API.Interop @@ -259,10 +292,12 @@ build-depends: -- Inherited dependencies , async + , binary , bytestring , containers , deepseq , exceptions + , grpc-spec , http-types , http2 , mtl @@ -271,6 +306,7 @@ , proto-lens-protobuf-types , stm , text + , time-manager , tls , utf8-string @@ -278,20 +314,56 @@ -- Additional dependencies , filepath >= 1.4.2.1 && < 1.6 , proto-lens-runtime >= 0.7 && < 0.8 - , QuickCheck >= 2.14 && < 2.16 + , QuickCheck >= 2.14 && < 2.19 , serialise >= 0.2 && < 0.3 , tasty >= 1.4 && < 1.6 , tasty-hunit >= 0.10 && < 0.11 , tasty-quickcheck >= 0.10 && < 0.12 , temporary >= 1.3 && < 1.4 - , unix >= 2.7 && < 2.9 + , tree-diff >= 0.4.1 && < 0.5 + if(flag(test-no-islabel)) + build-depends: proto-lens-protobuf-types >= 0.7.2.3 + cpp-options: -DTEST_NO_ISLABEL + +test-suite test-disconnect + import: lang, common-executable-flags + type: exitcode-stdio-1.0 + hs-source-dirs: test-disconnect, proto + main-is: Main.hs + build-depends: grapesy + + -- 'forkProcess' does not like multiple capabilities + ghc-options: -with-rtsopts=-N1 + + other-modules: + Test.Disconnect.Echo.Client + Test.Disconnect.Echo.RPC + Test.Disconnect.Echo.Server + Test.Disconnect.Util.Client + Test.Disconnect.Util.Exception + Test.Disconnect.Util.Process + Test.Disconnect.Util.Server + + Proto.API.Trivial + + build-depends: + -- Inherited dependencies + , http2 + , network + , stm + + build-depends: + -- Additional dependencies + , HUnit >= 1.6 && < 1.7 + , temporary >= 1.3 && < 1.4 + , unix >= 2.7 && < 2.9 + test-suite test-stress import: lang, common-executable-flags type: exitcode-stdio-1.0 - hs-source-dirs: test-stress, proto + hs-source-dirs: test-stress, proto, paths main-is: Main.hs - autogen-modules: Paths_grapesy build-depends: grapesy default-extensions: RecordWildCards @@ -305,7 +377,7 @@ Proto.API.Trivial - Paths_grapesy + Paths_ build-depends: -- Inherited dependencies @@ -323,8 +395,8 @@ , Chart-diagrams >= 1.9 && < 1.10 , directory >= 1.3 && < 1.4 , filepath >= 1.4.2.1 && < 1.6 - , ghc-events >= 0.17 && < 0.21 - , optparse-applicative >= 0.16 && < 0.19 + , ghc-events >= 0.17 && < 0.22 + , optparse-applicative >= 0.16 && < 0.20 , pretty-show >= 1.10 && < 1.11 , process >= 1.6.12 && < 1.7 , random >= 1.2 && < 1.4 @@ -337,9 +409,8 @@ test-suite grapesy-interop import: lang, common-executable-flags type: exitcode-stdio-1.0 - hs-source-dirs: interop, proto + hs-source-dirs: interop, proto, paths main-is: Main.hs - autogen-modules: Paths_grapesy build-depends: grapesy default-extensions: OverloadedLabels @@ -379,8 +450,9 @@ Interop.Util.ANSI Interop.Util.Exceptions Interop.Util.Messages + Interop.Util.NonInterleaved - Paths_grapesy + Paths_ Proto.API.Interop Proto.API.Ping @@ -398,19 +470,19 @@ , network , proto-lens , text + , filepath build-depends: -- Additional dependencies , ansi-terminal >= 1.1 && < 1.2 - , optparse-applicative >= 0.16 && < 0.19 + , optparse-applicative >= 0.16 && < 0.20 , proto-lens-runtime >= 0.7 && < 0.8 benchmark grapesy-kvstore import: lang, common-executable-flags type: exitcode-stdio-1.0 main-is: Main.hs - hs-source-dirs: kvstore, proto - autogen-modules: Paths_grapesy + hs-source-dirs: kvstore, proto, paths build-depends: grapesy default-extensions: OverloadedLabels @@ -428,7 +500,7 @@ Proto.Kvstore - Paths_grapesy + Paths_ build-depends: -- Inherited dependencies @@ -439,13 +511,14 @@ , proto-lens , text , unordered-containers + , filepath build-depends: -- Additional dependencies , base16-bytestring >= 1.0 && < 1.1 , base64-bytestring >= 1.2 && < 1.3 , hashable >= 1.3 && < 1.6 - , optparse-applicative >= 0.16 && < 0.19 + , optparse-applicative >= 0.16 && < 0.20 , proto-lens-runtime >= 0.7 && < 0.8 , splitmix >= 0.1 && < 0.2 @@ -460,5 +533,15 @@ Flag strace description: Write events to /dev/null in @grapesy-kvstore@ so that they show up in strace + default: False + manual: True + +Flag test-no-islabel + description: Enable the test that checks that no IsLabel instances are in scope + default: True + manual: False + +Flag patched-ghc-for-exception-debugging + description: Use custom patched GHC with some exception improvements (probably useful for grapesy devs only) default: False manual: True diff --git a/interop/Interop/Client.hs b/interop/Interop/Client.hs --- a/interop/Interop/Client.hs +++ b/interop/Interop/Client.hs @@ -11,6 +11,7 @@ import Interop.Cmdline import Interop.Util.ANSI import Interop.Util.Exceptions +import Interop.Util.NonInterleaved qualified as NI import Interop.Client.TestCase.EmptyUnary qualified as EmptyUnary import Interop.Client.TestCase.LargeUnary qualified as LargeUnary @@ -119,7 +120,7 @@ testOK :: IORef TestStats -> TestCase -> IO () testOK statsRef test = do - putDocLn $ mconcat [ + NI.putDocLn $ mconcat [ Show test , ": " , Color Green "OK" @@ -129,7 +130,7 @@ testFailed :: IORef TestStats -> TestCase -> String -> IO () testFailed statsRef test err = do - putDocLn $ mconcat [ + NI.putDocLn $ mconcat [ Show test , ": " , Color Red "Failed: " @@ -140,7 +141,7 @@ testSkipped :: IORef TestStats -> TestCase -> String -> IO () testSkipped statsRef test reason = do - putDocLn $ mconcat [ + NI.putDocLn $ mconcat [ Show test , ": " , Color Yellow "Skipped: " @@ -154,7 +155,7 @@ stats <- readIORef statsRef when (numSucceeded stats + numFailed stats > 1 || numSkipped stats > 0) $ - putStrLn $ concat [ + NI.putStrLn $ concat [ show $ numSucceeded stats , " succeeded, " , show $ numFailed stats diff --git a/interop/Interop/Client/TestCase/EmptyUnary.hs b/interop/Interop/Client/TestCase/EmptyUnary.hs --- a/interop/Interop/Client/TestCase/EmptyUnary.hs +++ b/interop/Interop/Client/TestCase/EmptyUnary.hs @@ -1,8 +1,10 @@ module Interop.Client.TestCase.EmptyUnary (runTest) where +import Control.Monad import Data.Proxy import Network.GRPC.Client +import Network.GRPC.Client qualified as Client import Network.GRPC.Common import Network.GRPC.Common.Protobuf import Network.GRPC.Common.StreamElem qualified as StreamElem @@ -15,11 +17,12 @@ -- | runTest :: Cmdline -> IO () -runTest cmdline = +runTest cmdline = do withConnection def (testServer cmdline) $ \conn -> withRPC conn def (Proxy @EmptyCall) $ \call -> do sendFinalInput call empty streamElem <- StreamElem.value <$> recvOutputWithMeta call + void $ Client.waitForTrailers call -- The test description asks us to also verify the size of the /outgoing/ -- message if possible. This information is not readily available in diff --git a/interop/Interop/Client/TestCase/ServerCompressedUnary.hs b/interop/Interop/Client/TestCase/ServerCompressedUnary.hs --- a/interop/Interop/Client/TestCase/ServerCompressedUnary.hs +++ b/interop/Interop/Client/TestCase/ServerCompressedUnary.hs @@ -1,8 +1,10 @@ module Interop.Client.TestCase.ServerCompressedUnary (runTest) where +import Control.Monad import Data.Maybe (isJust) import Network.GRPC.Client +import Network.GRPC.Client qualified as Client import Network.GRPC.Common import Network.GRPC.Common.Protobuf import Network.GRPC.Common.StreamElem qualified as StreamElem @@ -22,11 +24,13 @@ withRPC conn def (Proxy @UnaryCall) $ \call -> do sendInputWithMeta call $ FinalElem (request True) NoMetadata resp <- recvOutputWithMeta call + void $ Client.waitForTrailers call verifyResponse True (StreamElem.value resp) withRPC conn def (Proxy @UnaryCall) $ \call -> do sendInputWithMeta call $ FinalElem (request False) NoMetadata resp <- recvOutputWithMeta call + void $ Client.waitForTrailers call verifyResponse False (StreamElem.value resp) where -- To keep the test simple, we disable /outbound/ compression diff --git a/interop/Interop/Cmdline.hs b/interop/Interop/Cmdline.hs --- a/interop/Interop/Cmdline.hs +++ b/interop/Interop/Cmdline.hs @@ -15,7 +15,7 @@ import Network.GRPC.Common -import Paths_grapesy +import Paths_ (getDataFileName) {------------------------------------------------------------------------------- Definition @@ -145,9 +145,9 @@ defaultCmdline :: IO Cmdline defaultCmdline = do - rootCA <- getDataFileName "interop-ca.pem" - pubCert <- getDataFileName "interop.pem" - privKey <- getDataFileName "interop.key" + rootCA <- getDataFileName "grapesy" "interop-ca.pem" + pubCert <- getDataFileName "grapesy" "interop.pem" + privKey <- getDataFileName "grapesy" "interop.key" return Cmdline { cmdMode = error "cmdMode: no default" diff --git a/interop/Interop/Server.hs b/interop/Interop/Server.hs --- a/interop/Interop/Server.hs +++ b/interop/Interop/Server.hs @@ -13,6 +13,7 @@ import Network.GRPC.Server.StreamType import Interop.Cmdline +import Interop.Util.NonInterleaved qualified as NI import Interop.Server.PingService.Ping qualified as Ping import Interop.Server.TestService.EmptyCall qualified as EmptyCall @@ -123,10 +124,10 @@ (\() -> act) where start :: IO () - start = putStrLn "grapesy interop server started" + start = NI.putStrLn "grapesy interop server started" stop :: ExitCase a -> IO () - stop (ExitCaseSuccess _) = putStrLn $ "server terminated normally" - stop (ExitCaseException e) = putStrLn $ "server exception: " ++ show e + stop (ExitCaseSuccess _) = NI.putStrLn $ "server terminated normally" + stop (ExitCaseException e) = NI.putStrLn $ "server exception: " ++ show e stop ExitCaseAbort = error "impossible in IO" diff --git a/interop/Interop/Server/Common.hs b/interop/Interop/Server/Common.hs --- a/interop/Interop/Server/Common.hs +++ b/interop/Interop/Server/Common.hs @@ -7,7 +7,6 @@ , checkInboundCompression ) where -import Control.Exception import Data.ProtoLens.Labels () import Network.GRPC.Common diff --git a/interop/Interop/Util/Exceptions.hs b/interop/Interop/Util/Exceptions.hs --- a/interop/Interop/Util/Exceptions.hs +++ b/interop/Interop/Util/Exceptions.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module Interop.Util.Exceptions ( TestSkipped(..) , TestUnimplemented(..) @@ -9,16 +11,33 @@ , assertEqual , assertThrows , assertTerminatesWithinSeconds + -- * Uncaught exception handler + , uncaughtExceptionHandler -- * Re-exports , HasCallStack , throwIO ) where -import Control.Exception +import Control.Concurrent +import Control.Exception (Exception(..)) +import Control.Exception qualified as E import Data.List (intercalate) +import Data.Maybe (fromMaybe) import GHC.Stack +import Network.GRPC.Common.Exception +import System.IO import System.Timeout +#if MIN_VERSION_base(4,18,0) +import GHC.Conc.Sync (threadLabel) +#endif + +import Interop.Util.NonInterleaved qualified as NI + +{------------------------------------------------------------------------------- + Exceptions thrown by the tests +-------------------------------------------------------------------------------} + data TestSkipped = TestSkipped String deriving stock (Show) deriving anyclass (Exception) @@ -69,7 +88,7 @@ assertThrows :: (HasCallStack, Exception e) => (e -> IO ()) -> IO a -> IO () assertThrows p io = do - ma <- try io + ma <- E.try io case ma of Right _ -> assertFailure "Expected exception" Left err -> p err @@ -82,3 +101,24 @@ Just () -> return () +{------------------------------------------------------------------------------- + Uncaught exception handler +-------------------------------------------------------------------------------} + +uncaughtExceptionHandler :: E.SomeException -> IO () +uncaughtExceptionHandler e = do + tid <- myThreadId + mLabel :: Maybe String <- +#if MIN_VERSION_base(4,18,0) + threadLabel tid +#else + return $ Just "unknown label" +#endif + NI.hPutStrLn stderr $ concat [ + "Uncaught exception in " + , show tid + , " (" + , fromMaybe "unlabelled" mLabel + , "): " + , renderAnyException defaultFormatCtx e + ] diff --git a/interop/Interop/Util/NonInterleaved.hs b/interop/Interop/Util/NonInterleaved.hs new file mode 100644 --- /dev/null +++ b/interop/Interop/Util/NonInterleaved.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Non-interleaved output +-- +-- Intended for qualified import. +-- +-- > import Interop.Util.NonInterleaved qualified as NI +module Interop.Util.NonInterleaved ( + putStrLn + , hPutStrLn + , putDocLn + ) where + +import Prelude hiding (putStrLn) +import Prelude qualified + +import Control.Concurrent +import System.IO (Handle) +import System.IO qualified +import System.IO.Unsafe (unsafePerformIO) + +import Interop.Util.ANSI qualified as ANSI + +{------------------------------------------------------------------------------- + Internal: output lock +-------------------------------------------------------------------------------} + +outputLock :: MVar () +{-# NOINLINE outputLock #-} +outputLock = unsafePerformIO $ newMVar () + +withOutputLock :: IO a -> IO a +withOutputLock k = withMVar outputLock $ \() -> k + +{------------------------------------------------------------------------------- + Wrappers +-------------------------------------------------------------------------------} + +putStrLn :: String -> IO () +putStrLn str = withOutputLock $ Prelude.putStrLn str + +hPutStrLn :: Handle -> String -> IO () +hPutStrLn h str = withOutputLock $ System.IO.hPutStrLn h str + +putDocLn :: ANSI.Doc -> IO () +putDocLn doc = withOutputLock $ ANSI.putDocLn doc diff --git a/interop/Main.hs b/interop/Main.hs --- a/interop/Main.hs +++ b/interop/Main.hs @@ -8,6 +8,7 @@ import Interop.Cmdline import Interop.SelfTest (selfTest) import Interop.Server (runInteropServer) +import Interop.Util.Exceptions {------------------------------------------------------------------------------- Top-level application driver @@ -15,9 +16,7 @@ main :: IO () main = do - setUncaughtExceptionHandler $ \err -> do - hPutStrLn stderr $ "Uncaught exception: " ++ show err - hFlush stderr + setUncaughtExceptionHandler uncaughtExceptionHandler -- Ensure we see server output when running inside docker hSetBuffering stdout NoBuffering diff --git a/kvstore/KVStore/Server.hs b/kvstore/KVStore/Server.hs --- a/kvstore/KVStore/Server.hs +++ b/kvstore/KVStore/Server.hs @@ -15,7 +15,7 @@ import KVStore.Util.Store (Store) import KVStore.Util.Store qualified as Store -import Paths_grapesy +import Paths_ {------------------------------------------------------------------------------- Server proper @@ -32,8 +32,8 @@ config :: ServerConfig <- if cmdSecure then do - pub <- getDataFileName "grpc-demo.pem" - priv <- getDataFileName "grpc-demo.key" + pub <- getDataFileName "grapesy" "grpc-demo.pem" + priv <- getDataFileName "grapesy" "grpc-demo.key" return ServerConfig { serverInsecure = Nothing , serverSecure = Just $ SecureConfig { diff --git a/paths/Paths_.hs b/paths/Paths_.hs new file mode 100644 --- /dev/null +++ b/paths/Paths_.hs @@ -0,0 +1,24 @@ +module Paths_ ( + getDataDir, + getDataFileName, +) where + +import System.FilePath (()) +import System.Environment (lookupEnv) + +getDataFileName + :: String -- ^ Package name + -> FilePath -- ^ filename + -> IO FilePath +getDataFileName pn path = fmap ( path) (getDataDir pn) + +getDataDir :: String -> IO FilePath +getDataDir pn = do + -- @cabal-install@ sets `_datadir` variable, + -- that is what true Paths_ modules look for as well. + mpath <- lookupEnv (pn ++ "_datadir") + case mpath of + Just path -> return path + -- if environment variable is not set, use current directory + -- TODO: maybe look around for `.cabal` + Nothing -> return "." diff --git a/src/Network/GRPC/Client.hs b/src/Network/GRPC/Client.hs --- a/src/Network/GRPC/Client.hs +++ b/src/Network/GRPC/Client.hs @@ -56,6 +56,7 @@ , recvNextOutput , recvFinalOutput , recvTrailers + , waitForTrailers -- ** Low-level\/specialized API , ResponseHeaders_(..) @@ -84,10 +85,11 @@ import Network.GRPC.Client.Call import Network.GRPC.Client.Connection +import Network.GRPC.Client.Run import Network.GRPC.Client.Session (CallSetupFailure(..), InvalidTrailers(..)) import Network.GRPC.Client.StreamType (rpc, rpcWith) import Network.GRPC.Spec -import Network.GRPC.Util.HTTP2.Stream (ServerDisconnected(..)) +import Network.GRPC.Util.Stream (ServerDisconnected(..)) import Network.GRPC.Util.TLS qualified as Util.TLS {------------------------------------------------------------------------------- diff --git a/src/Network/GRPC/Client/Binary.hs b/src/Network/GRPC/Client/Binary.hs --- a/src/Network/GRPC/Client/Binary.hs +++ b/src/Network/GRPC/Client/Binary.hs @@ -13,13 +13,14 @@ , recvFinalOutput ) where -import Control.Monad.IO.Class -import Data.Binary +import Network.GRPC.Util.Imports + +import Data.Binary (Binary, encode) import Data.ByteString.Lazy qualified as Lazy (ByteString) -import Network.GRPC.Client (Call) -import Network.GRPC.Client qualified as Client -import Network.GRPC.Common +import Network.GRPC.Client.Call (Call) +import Network.GRPC.Client.Call qualified as Client +import Network.GRPC.Common.StreamElem (StreamElem(..)) import Network.GRPC.Common.Binary (decodeOrThrow) {------------------------------------------------------------------------------- diff --git a/src/Network/GRPC/Client/Call.hs b/src/Network/GRPC/Client/Call.hs --- a/src/Network/GRPC/Client/Call.hs +++ b/src/Network/GRPC/Client/Call.hs @@ -21,6 +21,7 @@ , recvNextOutput , recvFinalOutput , recvTrailers + , waitForTrailers -- ** Low-level\/specialized API , sendInputWithMeta @@ -29,37 +30,32 @@ , recvInitialResponse ) where +import Network.GRPC.Util.Imports + import Control.Concurrent -import Control.Concurrent.STM +import Control.Concurrent.STM (STM) +import Control.Concurrent.STM qualified as STM import Control.Concurrent.Thread.Delay qualified as UnboundedDelays -import Control.Monad -import Control.Monad.Catch -import Control.Monad.IO.Class -import Data.Bifunctor -import Data.Bitraversable +import Control.Monad.Catch (MonadMask) +import Control.Monad.Catch qualified as Exceptions import Data.ByteString.Char8 qualified as BS.Strict.C8 -import Data.Foldable (asum) -import Data.List (intersperse) -import Data.Maybe (fromMaybe) -import Data.Proxy import Data.Text qualified as Text -import Data.Version -import GHC.Stack import Network.GRPC.Client.Connection (Connection, ConnParams(..)) import Network.GRPC.Client.Connection qualified as Connection import Network.GRPC.Client.Session -import Network.GRPC.Common import Network.GRPC.Common.Compression qualified as Compression +import Network.GRPC.Common.Exception +import Network.GRPC.Common.ProtocolException +import Network.GRPC.Common.StreamElem (StreamElem(..)) import Network.GRPC.Common.StreamElem qualified as StreamElem -import Network.GRPC.Spec import Network.GRPC.Spec.Util.HKD qualified as HKD import Network.GRPC.Util.GHC -import Network.GRPC.Util.HTTP2.Stream (ServerDisconnected(..)) -import Network.GRPC.Util.Session qualified as Session +import Network.GRPC.Util.Session.API qualified as Session +import Network.GRPC.Util.Session.Channel qualified as Session +import Network.GRPC.Util.Session.Client qualified as Session import Network.GRPC.Util.Thread qualified as Thread - -import Paths_grapesy qualified as Grapesy +import Network.GRPC.Util.Version qualified as Grapesy {------------------------------------------------------------------------------- Open a call @@ -117,7 +113,7 @@ (MonadMask m, MonadIO m, SupportsClientRpc rpc, HasCallStack) => Connection -> CallParams rpc -> Proxy rpc -> (Call rpc -> m a) -> m a withRPC conn callParams proxy k = fmap fst $ - generalBracket + Exceptions.generalBracket (liftIO $ startRPC conn proxy callParams) (\(Call{callChannel}, cancelRequest) exitCase -> liftIO $ @@ -149,9 +145,10 @@ let serverClosedConnection :: Either (TrailersOnly' HandledSynthesized) ProperTrailers' - -> SomeException + -> ExactException serverClosedConnection = - either toException toException + WrapExactException + . either toException toException . grpcClassifyTermination . either trailersOnlyToProperTrailers' id @@ -188,41 +185,39 @@ Nothing -> return Nothing Just t -> fmap Just $ forkLabelled "grapesy:clientSideTimeout" $ do UnboundedDelays.delay (timeoutToMicro t) - let timeout :: SomeException - timeout = toException $ GrpcException { + let timeout :: ExactException + timeout = WrapExactException $ toException $ GrpcException { grpcError = GrpcDeadlineExceeded , grpcErrorMessage = Nothing , grpcErrorDetails = Nothing , grpcErrorMetadata = [] } + timeoutExitCase :: ExitCase () + timeoutExitCase = ExitCaseException (unwrapExactException timeout) + -- We recognized client-side that the timeout we imposed on the server - -- has passed. Acting on this is however tricky: + -- has passed, and don't want to rely on a compliant server + -- implementation to enforce that timeout. We will therefore close the + -- connection in the client, but the normal procedure for closing the + -- connection (implemented in 'closeRPC'), is not quite right here: -- - -- o A call to 'closeRPC' will only terminate the /outbound/ thread; - -- the idea is the inbound thread might still be reading in-flight - -- messages, and it will terminate once the last message is read or - -- the thread notices a broken connection. - -- o Unfortunately, this does not work in the timeout case: /if/ the - -- outbound thread has not yet terminated (that is, the client has - -- not yet sent their final message), then calling 'closeRPC' will - -- result in a RST_STREAM being sent to the server, which /should/ - -- result in the inbound connection being closed also, but may not, - -- in the case of a non-compliant server. - -- o Worse, if the client /did/ already send their final message, the - -- outbound thread has already terminated, no RST_STREAM will be - -- sent, and the we will continue to wait for messages from the - -- server. + -- o Unless the client has sent their final message to the server, + -- closing the connection is normally considered a cancellation, + -- which should result in a RST_STREAM frame being sent to the + -- server and 'GrpcCancelled' cancelled raised in the client. + -- o We normally terminate only the /outbound/ thread, to allow the + -- inbound thread to continue to read any messages that might still + -- be in-flight; we then rely on the serve closing the connection + -- (normally or abnormally) to close the inbound thread. -- - -- Ideally we'd inform the receiving thread that a timeout has been - -- reached and to "continue until it would block", but that is hard - -- to do. So instead we just kill the receiving thread, which means + -- Neither of these apply in the case of a timeout, so instead we just + -- terminate both the inbound and the output thread. This /does/ mean -- that once the timeout is reached, the client will not be able to - -- receive any further messages (even if that is because the /client/ - -- was slow, rather than the server). - - void $ Thread.cancelThread (Session.channelInbound channel) timeout - closeRPC channel cancelRequest $ ExitCaseException timeout + -- receive any further messages, even if that is because the /client/ + -- was slow, rather than the server. + Thread.cancelThread (Session.channelInbound channel) timeout + Session.close channel timeoutExitCase -- Spawn a thread to monitor the connection, and close the new channel when -- the connection is closed. To prevent a memory leak by hanging on to the @@ -232,21 +227,22 @@ status <- atomically $ do (Left <$> Thread.waitForNormalOrAbnormalThreadTermination (Session.channelInbound channel)) - `orElse` - (Right <$> readTMVar connClosed) + `STM.orElse` + (Right <$> STM.readTMVar connClosed) forM_ mClientSideTimeout killThread case status of Left _ -> return () -- Channel closed before the connection Right mErr -> do + backtrace <- collectBacktraces let exitReason :: ExitCase () exitReason = case mErr of - Nothing -> ExitCaseSuccess () + Nothing -> + ExitCaseSuccess () Just exitWithException -> ExitCaseException . toException $ - ServerDisconnected exitWithException callStack - _mAlreadyClosed <- Session.close channel exitReason - return () + serverDisconnected backtrace exitWithException + Session.close channel exitReason return (Call channel, cancelRequest) where @@ -273,9 +269,7 @@ , requestUserAgent = Just $ mconcat [ "grpc-haskell-grapesy/" - , mconcat . intersperse "." $ - map (BS.Strict.C8.pack . show) $ - versionBranch Grapesy.version + , BS.Strict.C8.pack Grapesy.version ] , requestIncludeTE = True @@ -292,6 +286,12 @@ clientConnection = conn } + serverDisconnected :: Backtraces -> ExactException -> ServerDisconnected + serverDisconnected backtrace e = ServerDisconnected{ + serverDisconnectedException = e + , serverDisconnectedBacktrace = Just backtrace + } + -- | Close the RPC (internal API only) -- -- This is more subtle than one might think. The spec mandates that when a @@ -302,7 +302,7 @@ -- which could mean one of two things: -- -- o The client received the final message from the server --- o The server threw an exception (and the client saw this) +-- o The server threw an exception, and the client saw this -- -- We can check for the former using 'channelRecvFinal', and the latter using -- 'hasThreadTerminated'. By checking both, we avoid race conditions: @@ -322,56 +322,55 @@ -- o -- o closeRPC :: - Session.Channel rpc + HasCallStack + => Session.Channel rpc -> Session.CancelRequest -> ExitCase a + -- ^ Reason for closing the connection + -- + -- This serves two purposes: + -- + -- o Further interaction with the connection will throw an exception + -- reflecting the reason that the connection was closed. + -- + -- o If 'closeRPC' is called /before/ the client sent their final message + -- to the server, the server is sent a @RST_FRAME@. The error code in + -- the @RST_FRAME@ depends on the 'ExitCase': + -- + -- a. If the 'ExitCase' is 'ExitCaseSuccess', indicating that the client + -- terminated normally, this is interpreted as the client cancelling + -- the request. The error code in the @RST_FRAME@ will therefore be + -- @CANCEL@, and a 'GrpcCancelled' exception is raised in the thread + -- calling 'closeRPC' (as mandated by the gRPC spec). + -- b. If not, the client terminated with an exception; since gRPC does + -- not support client-side trailers, we have no way of communicating + -- the nature of the client error to the client; instead, the + -- @RST_FRAME@ will have error code @INTERNAL_ERROR@. -> IO () -closeRPC callChannel cancelRequest exitCase = liftIO $ do - -- /Before/ we do anything else (see below), check if we have evidence - -- that we can discard the connection. +closeRPC callChannel cancelRequest exitCase = do + backtrace <- collectBacktraces canDiscard <- checkCanDiscard - -- Send the RST_STREAM frame /before/ closing the outbound thread. + -- Send the @RST_STREAM@ prior to calling 'Session.close' to ensure that the + -- server receives @RST_STREAM@ /before/ receiving @END_STREAM@. -- - -- When we call 'Session.close', we will terminate the - -- 'sendMessageLoop', @http2@ will interpret this as a clean termination - -- of the stream. We must therefore cancel this stream before calling - -- 'Session.close'. /If/ the final message has already been sent, - -- @http2@ guarantees (as a postcondition of @outBodyPushFinal@) that - -- cancellation will be a no-op. - sendResetFrame + -- The opposite order is permitted by the HTTP2 spec (it merely means that + -- the client tells the server that it won't /send/ any further messages + -- before telling the server that it doesn't want to /receive/ any further + -- messages), but some servers might interpret this as a clean client + -- termination rather than a cancellation. + unless canDiscard $ sendResetFrame backtrace + Session.close callChannel exitCase - -- Now close the /outbound/ thread, see docs of 'Session.close' for - -- details. - mException <- liftIO $ Session.close callChannel exitCase - case mException of - Nothing -> - -- The outbound thread had already terminated - return () - Just ex -> - case fromException ex of - Nothing -> - -- We are leaving the scope of 'withRPC' because of an exception - -- in the client, just rethrow that exception. - throwM ex - Just discarded -> - -- We are leaving the scope of 'withRPC' without having sent the - -- final message. - -- - -- If the server was closed before we cancelled the stream, this - -- means that the server unilaterally closed the connection. - -- This should be regarded as normal termination of the RPC (see - -- the docs for 'withRPC') - -- - -- Otherwise, the client left the scope of 'withRPC' before the - -- RPC was complete, which the gRPC spec mandates to result in a - -- 'GrpcCancelled' exception. See docs of 'throwCancelled'. - unless canDiscard $ - throwCancelled discarded + -- Throw the gRPC mandated local 'GrpcCancelled' exception, unless the + -- client itself already terminated with an exception + unless canDiscard $ + case exitCase of + ExitCaseException e -> throwIO e + _otherwise -> throwCancelled backtrace where - -- Send a @RST_STREAM@ frame if necessary - sendResetFrame :: IO () - sendResetFrame = + sendResetFrame :: Backtraces -> IO () + sendResetFrame backtrace = do cancelRequest $ case exitCase of ExitCaseSuccess _ -> @@ -383,18 +382,20 @@ -- that something has gone wrong (i.e. INTERNAL_ERROR), so we must -- pass an exception, however the exact nature of the exception is -- not particularly important as it is only recorded locally. - Just . toException $ Session.ChannelAborted callStack + Just . WrapExactException $ + toException $ Session.ChannelAborted backtrace ExitCaseException e -> -- Error code will be INTERNAL_ERROR - Just e + Just . WrapExactException $ + e - throwCancelled :: ChannelDiscarded -> IO () - throwCancelled (ChannelDiscarded cs) = do + throwCancelled :: Backtraces -> IO () + throwCancelled backtrace = do throwM $ GrpcException { grpcError = GrpcCancelled , grpcErrorMessage = Just $ mconcat [ "Channel discarded by client at " - , Text.pack $ prettyCallStack cs + , Text.pack $ displayBacktraces backtrace ] , grpcErrorDetails = Nothing , grpcErrorMetadata = [] @@ -403,7 +404,7 @@ checkCanDiscard :: IO Bool checkCanDiscard = do mRecvFinal <- atomically $ - readTVar $ Session.channelRecvFinal callChannel + STM.readTVar $ Session.channelRecvFinal callChannel let onNotRunning :: STM () onNotRunning = return () mTerminated <- atomically $ @@ -425,7 +426,8 @@ , case mTerminated of Thread.ThreadNotYetRunning_ () -> False Thread.ThreadRunning_ -> False - Thread.ThreadDone_ -> True + Thread.ThreadDone_ _ -> True + Thread.ThreadTrivial_ _ -> True Thread.ThreadException_ _ -> True ] @@ -483,9 +485,15 @@ recvNextOutputElem :: (MonadIO m, HasCallStack) => Call rpc -> m (NextElem (Output rpc)) -recvNextOutputElem = - fmap (either (const NoNextElem) (NextElem . snd)) - . recvEither +recvNextOutputElem call = do + mOut <- recvEither call + case mOut of + Left trailers -> do + -- Rethrow any exceptions that the server handler might have thrown + _trailingMetadata <- responseTrailingMetadata call trailers + return NoNextElem + Right (_env, out) -> + return $ NextElem out -- | Generalization of 'recvOutput', providing additional meta-information -- @@ -559,8 +567,8 @@ MonadIO m => Call rpc -> m ( Either (TrailersOnly' HandledSynthesized) - (ResponseHeaders' HandledSynthesized) - ) + (ResponseHeaders' HandledSynthesized) + ) recvInitialResponse Call{callChannel} = liftIO $ fmap inbHeaders <$> Session.getInboundHeaders callChannel @@ -612,7 +620,7 @@ ResponseTrailingMetadata md' -> err $ UnexpectedTrailersOnly md' where - err :: ProtocolException rpc -> IO a + err :: HasCallStack => ProtocolException rpc -> IO a err = throwM . ProtocolException -- | Receive the next output @@ -630,7 +638,7 @@ Right (_env, out) -> return out where - err :: ProtocolException rpc -> IO a + err :: HasCallStack => ProtocolException rpc -> IO a err = throwM . ProtocolException -- | Receive output, which we expect to be the /final/ output @@ -655,7 +663,7 @@ FinalElem out' _ -> err $ TooManyOutputs @rpc out' StreamElem out' -> err $ TooManyOutputs @rpc out' where - err :: ProtocolException rpc -> IO a + err :: HasCallStack => ProtocolException rpc -> IO a err = throwM . ProtocolException -- | Receive trailers @@ -671,9 +679,39 @@ FinalElem out _ts -> err $ TooManyOutputs @rpc out StreamElem out -> err $ TooManyOutputs @rpc out where - err :: ProtocolException rpc -> IO a + err :: HasCallStack => ProtocolException rpc -> IO a err = throwM . ProtocolException +-- | Wait to receive the trailers, discarding any outputs +-- +-- The gRPC spec mandates that when a client terminates a connection early, +-- this is considered a cancellation, which raises a 'GrpcCancelled' exception +-- in the client and a @RST_STREAM@ message sent to the server. Most clients +-- don't need to worry about this, since they will /either/ anyway wait for +-- that final message from the server, /or/ intentionally terminate early, in +-- which case regarding this as cancellation is in fact correct. +-- +-- In some cases, however, a client might want to /wait/ for the trailers, +-- discarding any further outputs, prior to termination. One case where this can +-- be useful is when a client /has/ received the final message, but may or may +-- not have received the trailers also (that is, 'StreamElem' vs 'FinalElem'); +-- calling 'recvTrailers' after 'FinalElem' is a bug, so client code would have +-- to distingush between these two cases. By contrast, 'waitForTrailers' is +-- idemponent and can be called at any point, though be aware that /if/ the +-- server is stil sending messages, they will all be discarded, and this can +-- of course take an unbounded time. +waitForTrailers :: forall rpc m. + (MonadIO m, HasCallStack) + => Call rpc -> m (ResponseTrailingMetadata rpc) +waitForTrailers call@Call{} = liftIO $ go + where + go :: IO (ResponseTrailingMetadata rpc) + go = do + mOut <- recvEither call + case mOut of + Left trailers -> responseTrailingMetadata call trailers + Right (_meta, _out) -> go + {------------------------------------------------------------------------------- Internal auxiliary: deal with final message -------------------------------------------------------------------------------} @@ -725,7 +763,6 @@ parseMetadata $ grpcTerminatedMetadata terminatedNormally Left exception -> throwM exception - -- | Forget that we are in the Trailers-Only case -- diff --git a/src/Network/GRPC/Client/Connection.hs b/src/Network/GRPC/Client/Connection.hs --- a/src/Network/GRPC/Client/Connection.hs +++ b/src/Network/GRPC/Client/Connection.hs @@ -9,10 +9,8 @@ -- > import Network.GRPC.Client.Connection qualified as Connection module Network.GRPC.Client.Connection ( -- * Definition - Connection -- opaque - , withConnection - , openConnection - , closeConnection + Connection(..) + , ConnectionState(..) -- * Configuration , Server(..) , ServerValidation(..) @@ -25,35 +23,25 @@ , ReconnectTo(..) , exponentialBackoff -- * Using the connection - , connParams , getConnectionToServer , getOutboundCompression , updateConnectionMeta ) where -import Control.Concurrent -import Control.Concurrent.STM -import Control.Monad -import Control.Monad.Catch -import Data.Default -import GHC.Stack -import Network.HPACK qualified as HPACK -import Network.HTTP2.Client qualified as HTTP2.Client -import Network.HTTP2.TLS.Client qualified as HTTP2.TLS.Client -import Network.Run.TCP qualified as Run -import Network.Socket -import Network.TLS (TLSException) -import System.Random +import Network.GRPC.Util.Imports +import Control.Concurrent.MVar (MVar, readMVar, modifyMVar_) +import Control.Concurrent.STM (TVar, TMVar) +import Control.Concurrent.STM qualified as STM +import System.Random (randomRIO) + import Network.GRPC.Client.Meta (Meta) import Network.GRPC.Client.Meta qualified as Meta import Network.GRPC.Common.Compression qualified as Compr +import Network.GRPC.Common.Exception import Network.GRPC.Common.HTTP2Settings -import Network.GRPC.Spec -import Network.GRPC.Util.GHC -import Network.GRPC.Util.Session qualified as Session +import Network.GRPC.Util.Session.Client qualified as Session import Network.GRPC.Util.TLS (ServerValidation(..), SslKeyLog(..)) -import Network.GRPC.Util.TLS qualified as Util.TLS {---------------------------------------------------2---------------------------- Connection API @@ -269,7 +257,9 @@ -> Double -- ^ Exponent -> (Double, Double) - -- ^ Initial delay + -- ^ Initial delay (in seconds) will be chosen randomly from this range; + -- the exponent will be applied to these bounds each iteration, + -- and a new delay will be chosen from the new range. -> Word -- ^ Maximum number of attempts -> ReconnectPolicy @@ -287,18 +277,6 @@ } {------------------------------------------------------------------------------- - Fatal exceptions (no point reconnecting) --------------------------------------------------------------------------------} - -isFatalException :: SomeException -> Bool -isFatalException err - | Just (_tlsException :: TLSException) <- fromException err - = True - - | otherwise - = False - -{------------------------------------------------------------------------------- Server address -------------------------------------------------------------------------------} @@ -314,80 +292,6 @@ deriving stock (Show) {------------------------------------------------------------------------------- - Open a new connection --------------------------------------------------------------------------------} - --- | Open a connection to the server. --- --- See 'Network.GRPC.Client.withRPC' for making individual RPCs on the new --- connection. --- --- The connection to the server is set up asynchronously; the first call to --- 'withRPC' will block until the connection has been established. --- --- If the server cannot be reached, the behaviour depends on --- 'connReconnectPolicy': if the policy allows reconnection attempts, we will --- wait the time specified by the policy and try again. This implements the gRPC --- "Wait for ready" semantics. --- --- If the connection to the server is lost /after/ it has been established, any --- currently ongoing RPC calls will be closed; attempts at further communication --- on any of these calls will result in a 'ServerDisconnected' exception being --- thrown. If that exception is caught, and the 'ReconnectPolicy' allows, we --- will automatically try to re-establish a connection to the server. This can --- be especially important when there is a proxy between the client and the --- server, which may drop an existing connection after a certain period. --- --- NOTE: The /default/ 'ReconnectPolicy' is 'DontReconnect', as per the gRPC --- specification of "Wait for ready" semantics. You may wish to override this --- default. --- --- Clients should prefer sending many calls on a single connection, rather than --- sending few calls on many connections, as minimizing the number of --- connections used via this interface results in better memory behavior. See --- [well-typed/grapesy#134](https://github.com/well-typed/grapesy/issues/133) --- for discussion. -withConnection :: - ConnParams - -> Server - -> (Connection -> IO a) - -> IO a -withConnection connParams server k = do - bracket (openConnection connParams server) closeConnection k - --- | Open a connection to the server. --- --- See 'withConnection' for details. --- --- __Warning:__ --- Connections hold open resources and must be closed using 'closeConnection'. --- To prevent resource and memory leaks due to asynchronous exceptions, it is --- recommended to use the bracketed function 'withConnection' whenever --- possible, and otherwise run functions that allocate and release a resource --- with asynchronous exceptions masked, and ensure that every use allocate --- operation is followed by the corresponding release operation even in the --- presence of asynchronous exceptions, e.g., using 'bracket'. -openConnection :: ConnParams -> Server -> IO Connection -openConnection connParams server = do - connMetaVar <- newMVar $ Meta.init (connInitCompression connParams) - connStateVar <- newTVarIO ConnectionNotReady - - connOutOfScope <- newEmptyMVar - let stayConnectedThread :: IO () - stayConnectedThread = - stayConnected connParams server connStateVar connOutOfScope - - -- We don't use withAsync because we want the thread to terminate cleanly - -- when we no longer need the connection (which we indicate by writing to - -- connOutOfScope). - void $ forkLabelled "grapesy:stayConnected" $ stayConnectedThread - pure Connection {connParams, connMetaVar, connStateVar, connOutOfScope} - --- | Close a connection to the server. -closeConnection :: Connection -> IO () -closeConnection conn = putMVar (connOutOfScope conn) () - -{------------------------------------------------------------------------------- Making use of the connection -------------------------------------------------------------------------------} @@ -398,13 +302,13 @@ getConnectionToServer :: forall. HasCallStack => Connection - -> IO (TMVar (Maybe SomeException), Session.ConnectionToServer) + -> IO (TMVar (Maybe ExactException), Session.ConnectionToServer) getConnectionToServer Connection{connStateVar} = atomically $ do - connState <- readTVar connStateVar + connState <- STM.readTVar connStateVar case connState of - ConnectionNotReady -> retry + ConnectionNotReady -> STM.retry ConnectionReady connClosed conn -> return (connClosed, conn) - ConnectionAbandoned err -> throwSTM err + ConnectionAbandoned err -> STM.throwSTM err ConnectionOutOfScope -> error "impossible" -- | Get outbound compression algorithm @@ -438,300 +342,10 @@ -- | The connection is ready -- -- The nested @TMVar@ is written to when the connection is closed. - | ConnectionReady (TMVar (Maybe SomeException)) Session.ConnectionToServer + | ConnectionReady (TMVar (Maybe ExactException)) Session.ConnectionToServer -- | We gave up trying to (re)establish the connection - | ConnectionAbandoned SomeException + | ConnectionAbandoned ExactException -- | The connection was closed because it is no longer needed. | ConnectionOutOfScope - --- | Connection attempt --- --- This is an internal data structure used only in 'stayConnected' and helpers. -data Attempt = ConnectionAttempt { - attemptParams :: ConnParams - , attemptOnConnection :: OnConnection - , attemptState :: TVar ConnectionState - , attemptOutOfScope :: MVar () - , attemptClosed :: TMVar (Maybe SomeException) - } - -newConnectionAttempt :: - ConnParams - -> OnConnection - -> TVar ConnectionState - -> MVar () - -> IO Attempt -newConnectionAttempt attemptParams - attemptOnConnection - attemptState - attemptOutOfScope = do - attemptClosed <- newEmptyTMVarIO - return ConnectionAttempt{ - attemptParams - , attemptOnConnection - , attemptState - , attemptOutOfScope - , attemptClosed - } - --- | Stay connected to the server -stayConnected :: - ConnParams - -> Server - -> TVar ConnectionState - -> MVar () - -> IO () -stayConnected connParams initialServer connStateVar connOutOfScope = do - loop - initialServer - (connOnConnection connParams) - (connReconnectPolicy connParams) - where - loop :: Server -> OnConnection -> ReconnectPolicy -> IO () - loop server onConnection remainingReconnectPolicy = do - -- Start new attempt (this just allocates some internal state) - attempt <- newConnectionAttempt connParams onConnection connStateVar connOutOfScope - - -- Just like in 'runHandler' on the server side, it is important that - -- 'stayConnected' runs in a separate thread. If it does not, then the - -- moment we disconnect @http2[-tls]@ will throw an exception and we - -- will not get the chance to process any other messages. This is - -- especially important when we fail to setup a call: the server will - -- respond with an informative gRPC error message (which we will raise - -- as a 'GrpcException' in the client), and then disconnect. If we do - -- not call @run@ in a separate thread, the only exception we will see - -- is the low-level exception reported by @http2@ (something about - -- stream errors), rather than the informative gRPC exception we want. - - mRes <- try $ - case server of - ServerInsecure addr -> - connectInsecure connParams attempt addr - ServerSecure validation sslKeyLog addr -> - connectSecure connParams attempt validation sslKeyLog addr - ServerUnix path -> - connectUnix connParams attempt path - - thisReconnectPolicy <- atomically $ do - putTMVar (attemptClosed attempt) $ either Just (\() -> Nothing) mRes - connState <- readTVar connStateVar - return $ case connState of - ConnectionReady{}-> - -- Suppose we have a maximum of 5x to try and connect to a server. - -- Then if we manage to connect, and /then/ lose the connection, - -- we should have those same 5x tries again. - connReconnectPolicy connParams - _otherwise -> - remainingReconnectPolicy - - case mRes of - Right () -> do - atomically $ writeTVar connStateVar $ ConnectionOutOfScope - Left err - | isFatalException err -> - atomically $ writeTVar connStateVar $ ConnectionAbandoned err - | otherwise -> do - -- Mark the connection as not ready /before/ running the reconnt - -- policy. This prevents any attempts to use the connection - -- while the policy is running. - atomically $ writeTVar connStateVar $ ConnectionNotReady - runReconnectPolicy thisReconnectPolicy >>= \case - DontReconnect -> do - atomically $ writeTVar connStateVar $ ConnectionAbandoned err - DoReconnect reconnect -> do - let - nextServer = - case reconnectTo reconnect of - ReconnectToPrevious -> server - ReconnectToOriginal -> initialServer - ReconnectToNew new -> new - - onReconnect' = - case onReconnect reconnect of - Just act -> act - Nothing -> connOnConnection connParams - - loop nextServer onReconnect' $ nextPolicy reconnect - --- | Unix domain socket connection -connectUnix :: ConnParams -> Attempt -> FilePath -> IO () -connectUnix connParams attempt path = do - client <- socket AF_UNIX Stream defaultProtocol - connect client $ SockAddrUnix path - connectSocket connParams attempt "localhost" client - --- | Insecure connection (no TLS) -connectInsecure :: ConnParams -> Attempt -> Address -> IO () -connectInsecure connParams attempt addr = do - Run.runTCPClientWithSettings - runSettings - (addressHost addr) - (show $ addressPort addr) - $ connectSocket connParams attempt (authority addr) - where - ConnParams{connHTTP2Settings} = connParams - - runSettings :: Run.Settings - runSettings = Run.defaultSettings { - Run.settingsOpenClientSocket = openClientSocket connHTTP2Settings - } - --- | Insecure connection over the given socket -connectSocket :: ConnParams -> Attempt -> String -> Socket -> IO () -connectSocket connParams attempt connAuthority sock = do - bracket (HTTP2.Client.allocSimpleConfig sock writeBufferSize) - HTTP2.Client.freeSimpleConfig $ \conf -> - HTTP2.Client.run clientConfig conf $ \sendRequest _aux -> do - let conn = Session.ConnectionToServer sendRequest - atomically $ - writeTVar (attemptState attempt) $ - ConnectionReady (attemptClosed attempt) conn - runOnConnection $ attemptOnConnection attempt - takeMVar $ attemptOutOfScope attempt - where - ConnParams{connHTTP2Settings} = connParams - - settings :: HTTP2.Client.Settings - settings = HTTP2.Client.defaultSettings { - HTTP2.Client.maxConcurrentStreams = - Just . fromIntegral $ - http2MaxConcurrentStreams connHTTP2Settings - , HTTP2.Client.initialWindowSize = - fromIntegral $ - http2StreamWindowSize connHTTP2Settings - } - - clientConfig :: HTTP2.Client.ClientConfig - clientConfig = overrideRateLimits connParams $ - HTTP2.Client.defaultClientConfig { - HTTP2.Client.authority = connAuthority - , HTTP2.Client.settings = settings - , HTTP2.Client.connectionWindowSize = - fromIntegral $ - http2ConnectionWindowSize connHTTP2Settings - } - --- | Secure connection (using TLS) -connectSecure :: - ConnParams - -> Attempt - -> ServerValidation - -> SslKeyLog - -> Address - -> IO () -connectSecure connParams attempt validation sslKeyLog addr = do - keyLogger <- Util.TLS.keyLogger sslKeyLog - caStore <- Util.TLS.validationCAStore validation - - let settings :: HTTP2.TLS.Client.Settings - settings = HTTP2.TLS.Client.defaultSettings { - HTTP2.TLS.Client.settingsKeyLogger = keyLogger - , HTTP2.TLS.Client.settingsCAStore = caStore - , HTTP2.TLS.Client.settingsAddrInfoFlags = [] - - , HTTP2.TLS.Client.settingsValidateCert = - case validation of - ValidateServer _ -> True - NoServerValidation -> False - , HTTP2.TLS.Client.settingsOpenClientSocket = - openClientSocket connHTTP2Settings - , HTTP2.TLS.Client.settingsConcurrentStreams = fromIntegral $ - http2MaxConcurrentStreams connHTTP2Settings - , HTTP2.TLS.Client.settingsStreamWindowSize = fromIntegral $ - http2StreamWindowSize connHTTP2Settings - , HTTP2.TLS.Client.settingsConnectionWindowSize = fromIntegral $ - http2ConnectionWindowSize connHTTP2Settings - } - - clientConfig :: HTTP2.Client.ClientConfig - clientConfig = overrideRateLimits connParams $ - HTTP2.TLS.Client.defaultClientConfig - settings - (authority addr) - - HTTP2.TLS.Client.runWithConfig - clientConfig - settings - (addressHost addr) - (addressPort addr) - $ \sendRequest _aux -> do - let conn = Session.ConnectionToServer sendRequest - atomically $ - writeTVar (attemptState attempt) $ - ConnectionReady (attemptClosed attempt) conn - runOnConnection $ attemptOnConnection attempt - takeMVar $ attemptOutOfScope attempt - where - ConnParams{connHTTP2Settings} = connParams - --- | Authority --- --- We omit the port number in the authority, for compatibility with TLS --- SNI as well as the gRPC spec (the HTTP2 spec says the port number is --- optional in the authority). -authority :: Address -> String -authority addr = - case addressAuthority addr of - Nothing -> addressHost addr - Just auth -> auth - --- | Override rate limits imposed by @http2@ -overrideRateLimits :: - ConnParams - -> HTTP2.Client.ClientConfig -> HTTP2.Client.ClientConfig -overrideRateLimits connParams clientConfig = clientConfig { - HTTP2.Client.settings = settings { - HTTP2.Client.pingRateLimit = - case http2OverridePingRateLimit (connHTTP2Settings connParams) of - Nothing -> HTTP2.Client.pingRateLimit settings - Just limit -> limit - , HTTP2.Client.emptyFrameRateLimit = - case http2OverrideEmptyFrameRateLimit (connHTTP2Settings connParams) of - Nothing -> HTTP2.Client.emptyFrameRateLimit settings - Just limit -> limit - , HTTP2.Client.settingsRateLimit = - case http2OverrideSettingsRateLimit (connHTTP2Settings connParams) of - Nothing -> HTTP2.Client.settingsRateLimit settings - Just limit -> limit - , HTTP2.Client.rstRateLimit = - case http2OverrideRstRateLimit (connHTTP2Settings connParams) of - Nothing -> HTTP2.Client.rstRateLimit settings - Just limit -> limit - } - } - where - settings :: HTTP2.Client.Settings - settings = HTTP2.Client.settings clientConfig - -{------------------------------------------------------------------------------- - Auxiliary http2 --------------------------------------------------------------------------------} - -openClientSocket :: HTTP2Settings -> AddrInfo -> IO Socket -openClientSocket http2Settings = - Run.openClientSocketWithOpts socketOptions - where - socketOptions :: [(SocketOption, SockOptValue)] - socketOptions = concat [ - [ ( NoDelay - , SockOptValue @Int 1 - ) - | http2TcpNoDelay http2Settings - ] - , [ ( Linger - , SockOptValue $ StructLinger { sl_onoff = 1, sl_linger = 0 } - ) - | http2TcpAbortiveClose http2Settings - ] - ] - --- | Write-buffer size --- --- See docs of 'confBufferSize', but importantly: "this value is announced --- via SETTINGS_MAX_FRAME_SIZE to the peer." --- --- Value of 4KB is taken from the example code. -writeBufferSize :: HPACK.BufferSize -writeBufferSize = 4096 diff --git a/src/Network/GRPC/Client/Meta.hs b/src/Network/GRPC/Client/Meta.hs --- a/src/Network/GRPC/Client/Meta.hs +++ b/src/Network/GRPC/Client/Meta.hs diff --git a/src/Network/GRPC/Client/Run.hs b/src/Network/GRPC/Client/Run.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Client/Run.hs @@ -0,0 +1,430 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Establishing connection to a server +-- +module Network.GRPC.Client.Run ( + -- * Definition + Connection -- opaque + , withConnection + , openConnection + , closeConnection + -- * Configuration + , Server(..) + , ServerValidation(..) + , SslKeyLog(..) + , ConnParams(..) + , ReconnectPolicy(..) + , ReconnectDecision(..) + , Reconnect(..) + , OnConnection(..) + , ReconnectTo(..) + , exponentialBackoff + -- * Using the connection + , connParams + , getConnectionToServer + , getOutboundCompression + , updateConnectionMeta + ) where + +import Network.GRPC.Client.Connection + +import Network.GRPC.Util.Imports + +import Control.Concurrent.MVar (MVar, newMVar, newEmptyMVar, putMVar, takeMVar) +import Control.Concurrent.STM (TVar, TMVar) +import Control.Concurrent.STM qualified as STM +import Network.HPACK qualified as HPACK +import Network.HTTP2.Client qualified as HTTP2.Client +import Network.HTTP2.TLS.Client qualified as HTTP2.TLS.Client +import Network.Run.TCP qualified as Run +import Network.Socket (Socket, AddrInfo, StructLinger (..), SocketOption (..), SockOptValue (..)) +import Network.Socket qualified as Socket +import Network.TLS (TLSException) + +import Network.GRPC.Client.Meta qualified as Meta +import Network.GRPC.Common.Exception +import Network.GRPC.Common.HTTP2Settings +import Network.GRPC.Util.GHC +import Network.GRPC.Util.Session.Client qualified as Session +import Network.GRPC.Util.TLS qualified as Util.TLS + +{------------------------------------------------------------------------------- + Open a new connection +-------------------------------------------------------------------------------} + +-- | Open a connection to the server. +-- +-- See 'Network.GRPC.Client.withRPC' for making individual RPCs on the new +-- connection. +-- +-- The connection to the server is set up asynchronously; the first call to +-- 'withRPC' will block until the connection has been established. +-- +-- If the server cannot be reached, the behaviour depends on +-- 'connReconnectPolicy': if the policy allows reconnection attempts, we will +-- wait the time specified by the policy and try again. This implements the gRPC +-- "Wait for ready" semantics. +-- +-- If the connection to the server is lost /after/ it has been established, any +-- currently ongoing RPC calls will be closed; attempts at further communication +-- on any of these calls will result in a 'ServerDisconnected' exception being +-- thrown. If that exception is caught, and the 'ReconnectPolicy' allows, we +-- will automatically try to re-establish a connection to the server. This can +-- be especially important when there is a proxy between the client and the +-- server, which may drop an existing connection after a certain period. +-- +-- NOTE: The /default/ 'ReconnectPolicy' is 'DontReconnect', as per the gRPC +-- specification of "Wait for ready" semantics. You may wish to override this +-- default. +-- +-- Clients should prefer sending many calls on a single connection, rather than +-- sending few calls on many connections, as minimizing the number of +-- connections used via this interface results in better memory behavior. See +-- [well-typed/grapesy#134](https://github.com/well-typed/grapesy/issues/133) +-- for discussion. +withConnection :: + ConnParams + -> Server + -> (Connection -> IO a) + -> IO a +withConnection connParams server k = do + bracket (openConnection connParams server) closeConnection k + +-- | Open a connection to the server. +-- +-- See 'withConnection' for details. +-- +-- __Warning:__ +-- Connections hold open resources and must be closed using 'closeConnection'. +-- To prevent resource and memory leaks due to asynchronous exceptions, it is +-- recommended to use the bracketed function 'withConnection' whenever +-- possible, and otherwise run functions that allocate and release a resource +-- with asynchronous exceptions masked, and ensure that every use allocate +-- operation is followed by the corresponding release operation even in the +-- presence of asynchronous exceptions, e.g., using 'bracket'. +openConnection :: ConnParams -> Server -> IO Connection +openConnection connParams server = do + connMetaVar <- newMVar $ Meta.init (connInitCompression connParams) + connStateVar <- STM.newTVarIO ConnectionNotReady + + connOutOfScope <- newEmptyMVar + let stayConnectedThread :: IO () + stayConnectedThread = + stayConnected connParams server connStateVar connOutOfScope + + -- We don't use withAsync because we want the thread to terminate cleanly + -- when we no longer need the connection (which we indicate by writing to + -- connOutOfScope). + void $ forkLabelled "grapesy:stayConnected" $ stayConnectedThread + pure Connection {connParams, connMetaVar, connStateVar, connOutOfScope} + +-- | Close a connection to the server. +closeConnection :: Connection -> IO () +closeConnection conn = putMVar (connOutOfScope conn) () + +{------------------------------------------------------------------------------- + Fatal exceptions (no point reconnecting) +-------------------------------------------------------------------------------} + +isFatalException :: ExactException -> Bool +isFatalException (WrapExactException err) + | Just (_tlsException :: TLSException) <- fromException err + = True + + | otherwise + = False + +{------------------------------------------------------------------------------- + Internal auxiliary +-------------------------------------------------------------------------------} + +-- | Connection attempt +-- +-- This is an internal data structure used only in 'stayConnected' and helpers. +data Attempt = ConnectionAttempt { + attemptParams :: ConnParams + , attemptOnConnection :: OnConnection + , attemptState :: TVar ConnectionState + , attemptOutOfScope :: MVar () + , attemptClosed :: TMVar (Maybe ExactException) + } + +newConnectionAttempt :: + ConnParams + -> OnConnection + -> TVar ConnectionState + -> MVar () + -> IO Attempt +newConnectionAttempt attemptParams + attemptOnConnection + attemptState + attemptOutOfScope = do + attemptClosed <- STM.newEmptyTMVarIO + return ConnectionAttempt{ + attemptParams + , attemptOnConnection + , attemptState + , attemptOutOfScope + , attemptClosed + } + +-- | Stay connected to the server +stayConnected :: + ConnParams + -> Server + -> TVar ConnectionState + -> MVar () + -> IO () +stayConnected connParams initialServer connStateVar connOutOfScope = do + loop + initialServer + (connOnConnection connParams) + (connReconnectPolicy connParams) + where + loop :: Server -> OnConnection -> ReconnectPolicy -> IO () + loop server onConnection remainingReconnectPolicy = do + -- Start new attempt (this just allocates some internal state) + attempt <- newConnectionAttempt connParams onConnection connStateVar connOutOfScope + + -- Just like in 'runHandler' on the server side, it is important that + -- 'stayConnected' runs in a separate thread. If it does not, then the + -- moment we disconnect @http2[-tls]@ will throw an exception and we + -- will not get the chance to process any other messages. This is + -- especially important when we fail to setup a call: the server will + -- respond with an informative gRPC error message (which we will raise + -- as a 'GrpcException' in the client), and then disconnect. If we do + -- not call @run@ in a separate thread, the only exception we will see + -- is the low-level exception reported by @http2@ (something about + -- stream errors), rather than the informative gRPC exception we want. + + mRes <- tryExact $ + case server of + ServerInsecure addr -> + connectInsecure connParams attempt addr + ServerSecure validation sslKeyLog addr -> + connectSecure connParams attempt validation sslKeyLog addr + ServerUnix path -> + connectUnix connParams attempt path + + thisReconnectPolicy <- atomically $ do + STM.putTMVar (attemptClosed attempt) $ either Just (\() -> Nothing) mRes + connState <- STM.readTVar connStateVar + return $ case connState of + ConnectionReady{}-> + -- Suppose we have a maximum of 5x to try and connect to a server. + -- Then if we manage to connect, and /then/ lose the connection, + -- we should have those same 5x tries again. + connReconnectPolicy connParams + _otherwise -> + remainingReconnectPolicy + + case mRes of + Right () -> do + atomically $ STM.writeTVar connStateVar $ ConnectionOutOfScope + Left err + | isFatalException err -> + atomically $ STM.writeTVar connStateVar $ ConnectionAbandoned err + | otherwise -> do + -- Mark the connection as not ready /before/ running the reconnt + -- policy. This prevents any attempts to use the connection + -- while the policy is running. + atomically $ STM.writeTVar connStateVar $ ConnectionNotReady + runReconnectPolicy thisReconnectPolicy >>= \case + DontReconnect -> do + atomically $ STM.writeTVar connStateVar $ ConnectionAbandoned err + DoReconnect reconnect -> do + let + nextServer = + case reconnectTo reconnect of + ReconnectToPrevious -> server + ReconnectToOriginal -> initialServer + ReconnectToNew new -> new + + onReconnect' = + case onReconnect reconnect of + Just act -> act + Nothing -> connOnConnection connParams + + loop nextServer onReconnect' $ nextPolicy reconnect + +-- | Unix domain socket connection +connectUnix :: ConnParams -> Attempt -> FilePath -> IO () +connectUnix connParams attempt path = do + client <- Socket.socket Socket.AF_UNIX Socket.Stream Socket.defaultProtocol + Socket.connect client $ Socket.SockAddrUnix path + connectSocket connParams attempt "localhost" client + +-- | Insecure connection (no TLS) +connectInsecure :: ConnParams -> Attempt -> Address -> IO () +connectInsecure connParams attempt addr = do + Run.runTCPClientWithSettings + runSettings + (addressHost addr) + (show $ addressPort addr) + $ connectSocket connParams attempt (authority addr) + where + ConnParams{connHTTP2Settings} = connParams + + runSettings :: Run.Settings + runSettings = Run.defaultSettings { + Run.settingsOpenClientSocket = openClientSocket connHTTP2Settings + } + +-- | Insecure connection over the given socket +connectSocket :: ConnParams -> Attempt -> String -> Socket -> IO () +connectSocket connParams attempt connAuthority sock = do + bracket (HTTP2.Client.allocSimpleConfig sock writeBufferSize) + HTTP2.Client.freeSimpleConfig $ \conf -> + HTTP2.Client.run clientConfig conf $ \sendRequest _aux -> do + let conn = Session.ConnectionToServer sendRequest + atomically $ + STM.writeTVar (attemptState attempt) $ + ConnectionReady (attemptClosed attempt) conn + runOnConnection $ attemptOnConnection attempt + takeMVar $ attemptOutOfScope attempt + where + ConnParams{connHTTP2Settings} = connParams + + settings :: HTTP2.Client.Settings + settings = HTTP2.Client.defaultSettings { + HTTP2.Client.maxConcurrentStreams = + Just . fromIntegral $ + http2MaxConcurrentStreams connHTTP2Settings + , HTTP2.Client.initialWindowSize = + fromIntegral $ + http2StreamWindowSize connHTTP2Settings + } + + clientConfig :: HTTP2.Client.ClientConfig + clientConfig = overrideRateLimits connParams $ + HTTP2.Client.defaultClientConfig { + HTTP2.Client.authority = connAuthority + , HTTP2.Client.settings = settings + , HTTP2.Client.connectionWindowSize = + fromIntegral $ + http2ConnectionWindowSize connHTTP2Settings + } + +-- | Secure connection (using TLS) +connectSecure :: + ConnParams + -> Attempt + -> ServerValidation + -> SslKeyLog + -> Address + -> IO () +connectSecure connParams attempt validation sslKeyLog addr = do + keyLogger <- Util.TLS.keyLogger sslKeyLog + caStore <- Util.TLS.validationCAStore validation + + let settings :: HTTP2.TLS.Client.Settings + settings = HTTP2.TLS.Client.defaultSettings { + HTTP2.TLS.Client.settingsKeyLogger = keyLogger + , HTTP2.TLS.Client.settingsCAStore = caStore + , HTTP2.TLS.Client.settingsAddrInfoFlags = [] + + , HTTP2.TLS.Client.settingsValidateCert = + case validation of + ValidateServer _ -> True + NoServerValidation -> False + , HTTP2.TLS.Client.settingsOpenClientSocket = + openClientSocket connHTTP2Settings + , HTTP2.TLS.Client.settingsConcurrentStreams = fromIntegral $ + http2MaxConcurrentStreams connHTTP2Settings + , HTTP2.TLS.Client.settingsStreamWindowSize = fromIntegral $ + http2StreamWindowSize connHTTP2Settings + , HTTP2.TLS.Client.settingsConnectionWindowSize = fromIntegral $ + http2ConnectionWindowSize connHTTP2Settings + } + + clientConfig :: HTTP2.Client.ClientConfig + clientConfig = overrideRateLimits connParams $ + HTTP2.TLS.Client.defaultClientConfig + settings + (authority addr) + + HTTP2.TLS.Client.runWithConfig + clientConfig + settings + (addressHost addr) + (addressPort addr) + $ \sendRequest _aux -> do + let conn = Session.ConnectionToServer sendRequest + atomically $ + STM.writeTVar (attemptState attempt) $ + ConnectionReady (attemptClosed attempt) conn + runOnConnection $ attemptOnConnection attempt + takeMVar $ attemptOutOfScope attempt + where + ConnParams{connHTTP2Settings} = connParams + +-- | Authority +-- +-- We omit the port number in the authority, for compatibility with TLS +-- SNI as well as the gRPC spec (the HTTP2 spec says the port number is +-- optional in the authority). +authority :: Address -> String +authority addr = + case addressAuthority addr of + Nothing -> addressHost addr + Just auth -> auth + +-- | Override rate limits imposed by @http2@ +overrideRateLimits :: + ConnParams + -> HTTP2.Client.ClientConfig -> HTTP2.Client.ClientConfig +overrideRateLimits connParams clientConfig = clientConfig { + HTTP2.Client.settings = settings { + HTTP2.Client.pingRateLimit = + case http2OverridePingRateLimit (connHTTP2Settings connParams) of + Nothing -> HTTP2.Client.pingRateLimit settings + Just limit -> limit + , HTTP2.Client.emptyFrameRateLimit = + case http2OverrideEmptyFrameRateLimit (connHTTP2Settings connParams) of + Nothing -> HTTP2.Client.emptyFrameRateLimit settings + Just limit -> limit + , HTTP2.Client.settingsRateLimit = + case http2OverrideSettingsRateLimit (connHTTP2Settings connParams) of + Nothing -> HTTP2.Client.settingsRateLimit settings + Just limit -> limit + , HTTP2.Client.rstRateLimit = + case http2OverrideRstRateLimit (connHTTP2Settings connParams) of + Nothing -> HTTP2.Client.rstRateLimit settings + Just limit -> limit + } + } + where + settings :: HTTP2.Client.Settings + settings = HTTP2.Client.settings clientConfig + +{------------------------------------------------------------------------------- + Auxiliary http2 +-------------------------------------------------------------------------------} + +openClientSocket :: HTTP2Settings -> AddrInfo -> IO Socket +openClientSocket http2Settings = + Run.openClientSocketWithOpts socketOptions + where + socketOptions :: [(SocketOption, SockOptValue)] + socketOptions = concat [ + [ ( NoDelay + , SockOptValue @Int 1 + ) + | http2TcpNoDelay http2Settings + ] + , [ ( Linger + , SockOptValue $ StructLinger { sl_onoff = 1, sl_linger = 0 } + ) + | http2TcpAbortiveClose http2Settings + ] + ] + +-- | Write-buffer size +-- +-- See docs of 'confBufferSize', but importantly: "this value is announced +-- via SETTINGS_MAX_FRAME_SIZE to the peer." +-- +-- Value of 4KB is taken from the example code. +writeBufferSize :: HPACK.BufferSize +writeBufferSize = 4096 diff --git a/src/Network/GRPC/Client/Session.hs b/src/Network/GRPC/Client/Session.hs --- a/src/Network/GRPC/Client/Session.hs +++ b/src/Network/GRPC/Client/Session.hs @@ -10,19 +10,17 @@ , InvalidTrailers(..) ) where -import Control.Exception -import Data.Proxy -import Data.Void +import Network.GRPC.Util.Imports + import Network.HTTP.Types qualified as HTTP import Network.GRPC.Client.Connection (Connection, ConnParams(..)) import Network.GRPC.Client.Connection qualified as Connection -import Network.GRPC.Common import Network.GRPC.Common.Compression qualified as Compr +import Network.GRPC.Common.Exception import Network.GRPC.Common.Headers -import Network.GRPC.Spec -import Network.GRPC.Spec.Serialization -import Network.GRPC.Util.Session +import Network.GRPC.Util.Session.API +import Network.GRPC.Util.Session.Client {------------------------------------------------------------------------------- Definition diff --git a/src/Network/GRPC/Client/StreamType.hs b/src/Network/GRPC/Client/StreamType.hs --- a/src/Network/GRPC/Client/StreamType.hs +++ b/src/Network/GRPC/Client/StreamType.hs @@ -18,17 +18,15 @@ , rpcWith ) where -import Control.Monad.Catch -import Control.Monad.IO.Class -import Control.Monad.Reader -import Data.Proxy +import Network.GRPC.Util.Imports +import Control.Monad.Catch (MonadMask) +import Control.Monad.Reader (ReaderT, ask) + import Network.GRPC.Client.Call import Network.GRPC.Client.Connection -import Network.GRPC.Common +import Network.GRPC.Common.StreamElem (StreamElem(..)) import Network.GRPC.Common.NextElem qualified as NextElem -import Network.GRPC.Common.StreamType -import Network.GRPC.Spec {------------------------------------------------------------------------------ Constructing client handlers (used internally only) diff --git a/src/Network/GRPC/Client/StreamType/Conduit.hs b/src/Network/GRPC/Client/StreamType/Conduit.hs --- a/src/Network/GRPC/Client/StreamType/Conduit.hs +++ b/src/Network/GRPC/Client/StreamType/Conduit.hs @@ -7,14 +7,13 @@ , biDiStreaming ) where -import Control.Monad.Reader -import Data.Conduit -import Data.ProtoLens.Service.Types +import Network.GRPC.Util.Imports -import Network.GRPC.Client +import Control.Monad.Reader (ReaderT, lift) +import Data.Conduit (ConduitT, yield, await) + +import Network.GRPC.Client.Connection import Network.GRPC.Client.StreamType.IO qualified as IO -import Network.GRPC.Common -import Network.GRPC.Spec {------------------------------------------------------------------------------- Conduits for different kinds of streaming types (communication patterns) diff --git a/src/Network/GRPC/Client/StreamType/IO.hs b/src/Network/GRPC/Client/StreamType/IO.hs --- a/src/Network/GRPC/Client/StreamType/IO.hs +++ b/src/Network/GRPC/Client/StreamType/IO.hs @@ -10,13 +10,11 @@ , biDiStreaming ) where -import Control.Monad.Reader +import Network.GRPC.Util.Imports +import Control.Monad.Reader (ReaderT, runReaderT, lift) -import Network.GRPC.Client +import Network.GRPC.Client.Connection import Network.GRPC.Client.StreamType.CanCallRPC qualified as CanCallRPC -import Network.GRPC.Common -import Network.GRPC.Common.StreamType -import Network.GRPC.Spec {------------------------------------------------------------------------------- Run client handlers diff --git a/src/Network/GRPC/Client/StreamType/IO/Binary.hs b/src/Network/GRPC/Client/StreamType/IO/Binary.hs --- a/src/Network/GRPC/Client/StreamType/IO/Binary.hs +++ b/src/Network/GRPC/Client/StreamType/IO/Binary.hs @@ -14,16 +14,15 @@ , biDiStreaming ) where -import Control.Monad.Reader -import Data.Binary +import Network.GRPC.Util.Imports + +import Control.Monad.Reader (ReaderT) +import Data.Binary (Binary, encode) import Data.ByteString.Lazy qualified as Lazy (ByteString) -import Network.GRPC.Client (Connection) +import Network.GRPC.Client.Connection (Connection) import Network.GRPC.Client.StreamType.IO qualified as IO -import Network.GRPC.Common import Network.GRPC.Common.Binary (decodeOrThrow) -import Network.GRPC.Common.StreamType -import Network.GRPC.Spec {------------------------------------------------------------------------------- Run client handlers diff --git a/src/Network/GRPC/Common.hs b/src/Network/GRPC/Common.hs --- a/src/Network/GRPC/Common.hs +++ b/src/Network/GRPC/Common.hs @@ -26,6 +26,7 @@ , customMetadataName , customMetadataValue , HeaderName(BinaryHeader, AsciiHeader) + , getHeaderName , NoMetadata(..) -- ** Typed , RequestMetadata @@ -80,16 +81,15 @@ , Default(..) ) where -import Data.Default -import Data.Proxy -import Network.Socket (PortNumber) +import Network.GRPC.Util.Imports -import Control.Exception +import Network.Socket (PortNumber) import Network.GRPC.Common.HTTP2Settings +import Network.GRPC.Common.ProtocolException import Network.GRPC.Common.StreamElem (StreamElem(..)) -import Network.GRPC.Spec -import Network.GRPC.Util.Session qualified as Session +import Network.GRPC.Util.Session.API qualified as Session +import Network.GRPC.Util.Session.Channel qualified as Session import Network.GRPC.Util.TLS {------------------------------------------------------------------------------- @@ -109,43 +109,4 @@ defaultSecurePort :: PortNumber defaultSecurePort = 50052 -{------------------------------------------------------------------------------- - Exceptions --------------------------------------------------------------------------------} --- | Protocol exception --- --- A protocol exception arises when the client and the server disagree on the --- sequence of inputs and outputs exchanged. This agreement might be part of a --- formal specification such as Protobuf, or it might be implicit in the --- implementation of a specific RPC. -data ProtocolException rpc = - -- | We expected an input but got none - TooFewInputs - - -- | We received an input when we expected no more inputs - | TooManyInputs (Input rpc) - - -- | We expected an output, but got trailers instead - | TooFewOutputs (ResponseTrailingMetadata rpc) - - -- | We expected trailers, but got an output instead - | TooManyOutputs (Output rpc) - - -- | The server unexpectedly used the Trailers-Only case - | UnexpectedTrailersOnly (ResponseTrailingMetadata rpc) - -deriving stock instance IsRPC rpc => Show (ProtocolException rpc) - --- | Existential wrapper around 'ProtocolException' --- --- This makes it easier to catch these exceptions (without this, you'd have to --- catch the exception for a /specific/ instance of @rpc@). -data SomeProtocolException where - ProtocolException :: forall rpc. - IsRPC rpc - => ProtocolException rpc - -> SomeProtocolException - -deriving stock instance Show SomeProtocolException -deriving anyclass instance Exception SomeProtocolException diff --git a/src/Network/GRPC/Common/Binary.hs b/src/Network/GRPC/Common/Binary.hs --- a/src/Network/GRPC/Common/Binary.hs +++ b/src/Network/GRPC/Common/Binary.hs @@ -43,6 +43,3 @@ deriving stock (Show) deriving anyclass (Exception) - - - diff --git a/src/Network/GRPC/Common/Compression.hs b/src/Network/GRPC/Common/Compression.hs --- a/src/Network/GRPC/Common/Compression.hs +++ b/src/Network/GRPC/Common/Compression.hs @@ -21,14 +21,11 @@ , insist ) where -import Data.Default -import Data.Foldable (toList) -import Data.List.NonEmpty (NonEmpty(..)) +import Network.GRPC.Util.Imports + import Data.List.NonEmpty qualified as NE import Data.Map (Map) import Data.Map qualified as Map - -import Network.GRPC.Spec {------------------------------------------------------------------------------- Negotation diff --git a/src/Network/GRPC/Common/Exception.hs b/src/Network/GRPC/Common/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Common/Exception.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Exception utilities +-- +-- Most users will never need to import from this module; it's mostly here to +-- facilitate debugging, primarily of @grapesy@ itself and the libraries it +-- depends on, such as @http2@. +module Network.GRPC.Common.Exception ( + -- * Key exception types + ClientDisconnected(..) + , ServerDisconnected(..) + + -- * Rendering + , grapesyFormatCtx + + -- * Re-exports + , module X + ) where + +import Data.Typeable +import GHC.Generics +import System.ThreadManager qualified as TimeManager + +#if MIN_VERSION_base(4,20,0) +import Control.Exception (backtraceDesired) +#endif + +import Network.GRPC.Util.Imports + +import Network.GRPC.Util.Exception.Doc as X +import Network.GRPC.Util.Exception.Exact as X +import Network.GRPC.Util.Exception.FormatCtx as X +import Network.GRPC.Util.Exception.Shims as X +import Network.GRPC.Util.Exception.ToExceptionDoc as X + +{------------------------------------------------------------------------------- + Key exception types + + TODO: /All/ exceptions that indicate a client disconnect or a server + disconnect should be wrapped in these two types, so that client code does not + have to deal with many exception types. + +-------------------------------------------------------------------------------} + +-- | Client disconnected unexpectedly +data ClientDisconnected = ClientDisconnected { + -- | The exception as reported by the transport (typically @http2@) + clientDisconnectedException :: ExactException + + -- | Backtrace, /if/ different + -- + -- In most cases we wrap the underlying exception the moment it arises. + -- When this happens, there is no meaningful difference between the + -- backtrace associated with the exception and the backtrace to where we + -- wrap it. + -- + -- Sometimes, however, transport exceptions are thrown asynchronously. For + -- example, @http2@ will throw 'KilledByThreadManager' to server handlers + -- when a client disconnects. In this case the backtrace of the exception + -- and where we catch it might be quite different. + , clientDisconnectedBacktrace :: Maybe Backtraces + } + deriving stock (Generic, Show) + deriving anyclass ToExceptionDoc + +-- | Server disconnected unexpectedly +-- +-- See also 'ClientDisconnected' for additional discussion. +data ServerDisconnected = ServerDisconnected { + -- | The exception as reported by the transport (typically @http2@) + serverDisconnectedException :: ExactException + + -- | Backtrace, /if/ different + -- + -- As discussed in 'clientDisconnectedBacktrace', normally we there is + -- no meaningful difference between the backtrace of the exception and the + -- backtrace to where we wrap it. An example where they /are/ different is + -- when the entire connection to the server is closed, and we notice this + -- elsewhere and close individual RPCs on that connection; the backtrace + -- of the latter will be different to the former. + , serverDisconnectedBacktrace :: Maybe Backtraces + } + deriving stock (Generic, Show) + deriving anyclass ToExceptionDoc + +#if MIN_VERSION_base(4,20,0) +-- See discussion of 'clientDisconnectedBacktrace' +instance Exception ClientDisconnected where backtraceDesired _ = False +instance Exception ServerDisconnected where backtraceDesired _ = False +#else +instance Exception ClientDisconnected +instance Exception ServerDisconnected +#endif + +{------------------------------------------------------------------------------- + Orphans +-------------------------------------------------------------------------------} + +instance ToExceptionDoc TimeManager.KilledByThreadManager where + toExceptionDoc ctx = \case + TimeManager.KilledByThreadManager mse -> + withHeader "KilledByThreadManager" $ toExceptionDoc ctx mse + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} + +grapesyFormatCtx :: FormatCtx +grapesyFormatCtx = defaultFormatCtx + & insertFormatCtx_ (Proxy @ClientDisconnected) + & insertFormatCtx_ (Proxy @ServerDisconnected) + & insertFormatCtx_ (Proxy @TimeManager.KilledByThreadManager) diff --git a/src/Network/GRPC/Common/Headers.hs b/src/Network/GRPC/Common/Headers.hs --- a/src/Network/GRPC/Common/Headers.hs +++ b/src/Network/GRPC/Common/Headers.hs @@ -7,11 +7,10 @@ , verifyAllIf ) where -import Data.Functor.Identity -import Data.Kind -import Data.Void +import Network.GRPC.Util.Imports -import Network.GRPC.Spec +import Data.Functor.Identity (Identity (..)) + import Network.GRPC.Spec.Util.HKD (Undecorated, Checked) import Network.GRPC.Spec.Util.HKD qualified as HKD diff --git a/src/Network/GRPC/Common/Protobuf.hs b/src/Network/GRPC/Common/Protobuf.hs --- a/src/Network/GRPC/Common/Protobuf.hs +++ b/src/Network/GRPC/Common/Protobuf.hs @@ -27,22 +27,18 @@ , Message(defMessage) ) where -import Control.Exception +import Network.GRPC.Util.Imports + import Control.Lens ((.~), (^.), (%~)) -import Control.Monad -import Control.Monad.Except -import Data.Bifunctor -import Data.Function ((&)) -import Data.Int -import Data.Maybe (fromMaybe) +import Control.Monad ((<=<)) +import Control.Monad.Except (throwError) +import Data.Int (Int32) import Data.ProtoLens.Field (HasField(..), field) import Data.ProtoLens.Message (FieldDefault(..), Message(defMessage)) -import Data.Text (Text) +import Network.GRPC.Common.Exception import Network.GRPC.Common.Protobuf.Any (Any) import Network.GRPC.Common.Protobuf.Any qualified as Any -import Network.GRPC.Spec -import Network.GRPC.Spec.Serialization {------------------------------------------------------------------------------- Protobuf-specific errors diff --git a/src/Network/GRPC/Common/Protobuf/Any.hs b/src/Network/GRPC/Common/Protobuf/Any.hs --- a/src/Network/GRPC/Common/Protobuf/Any.hs +++ b/src/Network/GRPC/Common/Protobuf/Any.hs @@ -15,12 +15,11 @@ , unpack ) where -import Data.Bifunctor +import Network.GRPC.Util.Imports + import Data.ProtoLens.Any (Any, UnpackError(..)) import Data.ProtoLens.Any qualified as Any import Data.ProtoLens.Message (Message) - -import Network.GRPC.Spec {------------------------------------------------------------------------------- Pack and unpack diff --git a/src/Network/GRPC/Common/ProtocolException.hs b/src/Network/GRPC/Common/ProtocolException.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Common/ProtocolException.hs @@ -0,0 +1,47 @@ +module Network.GRPC.Common.ProtocolException ( + ProtocolException(..), + SomeProtocolException(..), +) where + +import Network.GRPC.Util.Imports + +{------------------------------------------------------------------------------- + Exceptions +-------------------------------------------------------------------------------} + +-- | Protocol exception +-- +-- A protocol exception arises when the client and the server disagree on the +-- sequence of inputs and outputs exchanged. This agreement might be part of a +-- formal specification such as Protobuf, or it might be implicit in the +-- implementation of a specific RPC. +data ProtocolException rpc = + -- | We expected an input but got none + TooFewInputs + + -- | We received an input when we expected no more inputs + | TooManyInputs (Input rpc) + + -- | We expected an output, but got trailers instead + | TooFewOutputs (ResponseTrailingMetadata rpc) + + -- | We expected trailers, but got an output instead + | TooManyOutputs (Output rpc) + + -- | The server unexpectedly used the Trailers-Only case + | UnexpectedTrailersOnly (ResponseTrailingMetadata rpc) + +deriving stock instance IsRPC rpc => Show (ProtocolException rpc) + +-- | Existential wrapper around 'ProtocolException' +-- +-- This makes it easier to catch these exceptions (without this, you'd have to +-- catch the exception for a /specific/ instance of @rpc@). +data SomeProtocolException where + ProtocolException :: forall rpc. + IsRPC rpc + => ProtocolException rpc + -> SomeProtocolException + +deriving stock instance Show SomeProtocolException +deriving anyclass instance Exception SomeProtocolException diff --git a/src/Network/GRPC/Common/StreamElem.hs b/src/Network/GRPC/Common/StreamElem.hs --- a/src/Network/GRPC/Common/StreamElem.hs +++ b/src/Network/GRPC/Common/StreamElem.hs @@ -6,12 +6,13 @@ -- -- "Network.GRPC.Common" (intended for unqualified import) exports -- @StreamElem(..)@, but none of the operations on 'StreamElem'. +-- +-- See also "Network.GRPC.Common.NextElem" for a slightly simpler API. module Network.GRPC.Common.StreamElem ( StreamElem(..) -- * Conversion , value -- * Iteration - -- * Iteration , mapM_ , forM_ , whileNext_ @@ -22,9 +23,9 @@ import Prelude hiding (mapM_) import Control.Monad.State (StateT, runStateT, lift, modify) -import Data.Bifoldable -import Data.Bifunctor -import Data.Bitraversable +import Data.Bifoldable (Bifoldable (..)) +import Data.Bifunctor (Bifunctor (..)) +import Data.Bitraversable (Bitraversable (..)) import Data.Tuple (swap) {------------------------------------------------------------------------------- @@ -129,7 +130,7 @@ forM_ :: Monad m => [a] -> b -> (StreamElem b a -> m ()) -> m () forM_ as b f = mapM_ f as b --- | Invoke a function on each 'NextElem', until 'FinalElem' or 'NoMoreElems' +-- | Invoke a function on each 'StreamElem', until 'FinalElem' or 'NoMoreElems' whileNext_ :: forall m a b. Monad m => m (StreamElem b a) -> (a -> m ()) -> m b whileNext_ f g = go where diff --git a/src/Network/GRPC/Server.hs b/src/Network/GRPC/Server.hs --- a/src/Network/GRPC/Server.hs +++ b/src/Network/GRPC/Server.hs @@ -25,6 +25,7 @@ , sendGrpcException , getRequestMetadata , setResponseInitialMetadata + , setResponseInitialMetadataAndTrailers -- ** Protocol specific wrappers , sendNextOutput @@ -49,7 +50,7 @@ , ResponseAlreadyInitiated(..) ) where -import Network.HTTP2.Server qualified as HTTP2 +import Network.HTTP.Semantics.Server qualified as Server import Network.GRPC.Server.Call import Network.GRPC.Server.Context @@ -59,7 +60,7 @@ import Network.GRPC.Server.RequestHandler import Network.GRPC.Server.Session (CallSetupFailure(..)) import Network.GRPC.Spec -import Network.GRPC.Util.HTTP2.Stream (ClientDisconnected(..)) +import Network.GRPC.Util.Stream (ClientDisconnected(..)) {------------------------------------------------------------------------------- Server proper @@ -77,7 +78,7 @@ -- 'Network.GRPC.Server.StreamType.fromMethods' or -- 'Network.GRPC.Server.StreamType.fromServices') to construct the set of -- handlers. -mkGrpcServer :: ServerParams -> [SomeRpcHandler IO] -> IO HTTP2.Server +mkGrpcServer :: ServerParams -> [SomeRpcHandler IO] -> IO Server.Server mkGrpcServer params@ServerParams{serverTopLevel} handlers = do ctxt <- newServerContext params return $ diff --git a/src/Network/GRPC/Server/Binary.hs b/src/Network/GRPC/Server/Binary.hs --- a/src/Network/GRPC/Server/Binary.hs +++ b/src/Network/GRPC/Server/Binary.hs @@ -13,11 +13,12 @@ , recvFinalInput ) where -import Data.Binary +import Network.GRPC.Util.Imports + +import Data.Binary (Binary, encode) import Data.ByteString.Lazy qualified as Lazy (ByteString) -import GHC.Stack -import Network.GRPC.Common +import Network.GRPC.Common.StreamElem (StreamElem(..)) import Network.GRPC.Common.Binary (decodeOrThrow) import Network.GRPC.Server (Call) import Network.GRPC.Server qualified as Server diff --git a/src/Network/GRPC/Server/Call.hs b/src/Network/GRPC/Server/Call.hs --- a/src/Network/GRPC/Server/Call.hs +++ b/src/Network/GRPC/Server/Call.hs @@ -15,6 +15,7 @@ , sendGrpcException , getRequestMetadata , setResponseInitialMetadata + , setResponseInitialMetadataAndTrailers -- ** Protocol specific wrappers , sendNextOutput @@ -41,27 +42,24 @@ , ResponseAlreadyInitiated(..) ) where -import Control.Concurrent.STM -import Control.Exception (throwIO) -import Control.Monad -import Control.Monad.Catch -import Data.Bitraversable -import Data.List.NonEmpty (NonEmpty) -import Data.Void -import GHC.Stack +import Network.GRPC.Util.Imports + +import Control.Concurrent.STM (TVar, TMVar) +import Control.Concurrent.STM qualified as STM import Network.HTTP.Types qualified as HTTP -import Network.HTTP2.Server qualified as HTTP2 +import Network.HTTP.Semantics.Server qualified as Server -import Network.GRPC.Common import Network.GRPC.Common.Compression qualified as Compr +import Network.GRPC.Common.Exception import Network.GRPC.Common.Headers +import Network.GRPC.Common.ProtocolException +import Network.GRPC.Common.StreamElem (StreamElem(..)) import Network.GRPC.Common.StreamElem qualified as StreamElem import Network.GRPC.Server.Context import Network.GRPC.Server.Session -import Network.GRPC.Spec -import Network.GRPC.Spec.Serialization -import Network.GRPC.Util.HTTP2 (fromHeaderTable) -import Network.GRPC.Util.Session qualified as Session +import Network.GRPC.Util.HeaderTable (fromHeaderTable) +import Network.GRPC.Util.Session.API qualified as Session +import Network.GRPC.Util.Session.Channel qualified as Session import Network.GRPC.Util.Session.Server qualified as Server {------------------------------------------------------------------------------- @@ -88,7 +86,7 @@ -- -- Can be updated until the first message (see 'callFirstMessage'), at -- which point it /must/ have been set (if not, an exception is thrown). - , callResponseMetadata :: TVar (CallInitialMetadata rpc) + , callResponseMetadata :: TVar (Maybe (CallInitialMetadata rpc)) -- | What kicked off the response? -- @@ -99,15 +97,17 @@ -- | Initial metadata -- -- See 'callResponseMetadata' for discussion. -data CallInitialMetadata rpc = - -- | Initial metadata not yet set - CallInitialMetadataNotSet +data CallInitialMetadata rpc = CallInitialMetadata{ + -- | Initial response metadata + callInitialResponseMetadata :: ResponseInitialMetadata rpc - -- | Initial metadata has been set - -- - -- We record the 'CallStack' of where the metadata was set. - | CallInitialMetadataSet (ResponseInitialMetadata rpc) CallStack + -- | The set of trailers that the client can expect + , callInitialExpectedTrailers :: Maybe [HeaderName] + -- | Backtrace of where the metadata was set. + , callInitialMetadataBacktrace :: Backtraces + } + deriving stock instance IsRPC rpc => Show (CallInitialMetadata rpc) -- | What kicked off the response? @@ -125,15 +125,15 @@ -- We only need distinguish between (1 or 2) versus (3), corresponding precisely -- to the two constructors of 'FlowStart'. -- --- We record the 'CallStack' of the call that initiated the response. +-- We record the backtrace of the call that initiated the response. data Kickoff = - KickoffRegular CallStack - | KickoffTrailersOnly CallStack TrailersOnly + KickoffRegular Backtraces + | KickoffTrailersOnly Backtraces TrailersOnly deriving (Show) -kickoffCallStack :: Kickoff -> CallStack -kickoffCallStack (KickoffRegular cs ) = cs -kickoffCallStack (KickoffTrailersOnly cs _) = cs +kickoffBacktrace :: Kickoff -> Backtraces +kickoffBacktrace (KickoffRegular backtrace ) = backtrace +kickoffBacktrace (KickoffTrailersOnly backtrace _) = backtrace {------------------------------------------------------------------------------- Open a call @@ -150,8 +150,8 @@ -> ServerContext -> IO (Call rpc, Maybe Timeout) setupCall conn callContext@ServerContext{serverParams} = do - callResponseMetadata <- newTVarIO CallInitialMetadataNotSet - callResponseKickoff <- newEmptyTMVarIO + callResponseMetadata <- STM.newTVarIO Nothing + callResponseKickoff <- STM.newEmptyTMVarIO (inboundHeaders, timeout) <- determineInbound callSession req let callRequestHeaders = inbHeaders inboundHeaders @@ -165,7 +165,7 @@ requestAcceptCompression callRequestHeaders callChannel :: Session.Channel (ServerSession rpc) <- - Session.setupResponseChannel + Server.setupResponseChannel callSession conn (Session.FlowStartRegular inboundHeaders) @@ -193,14 +193,14 @@ serverSessionContext = callContext } - req :: HTTP2.Request + req :: Server.Request req = Server.request conn -- | Parse inbound headers determineInbound :: forall rpc. SupportsServerRpc rpc => ServerSession rpc - -> HTTP2.Request + -> Server.Request -> IO (Headers (ServerInbound rpc), Maybe Timeout) determineInbound session req = do requestHeaders' <- throwSynthesized throwIO parsed @@ -222,7 +222,7 @@ parsed :: RequestHeaders' GrpcException parsed = parseRequestHeaders' (Proxy @rpc) $ - fromHeaderTable $ HTTP2.requestHeaders req + fromHeaderTable $ Server.requestHeaders req -- | Determine outbound flow start -- @@ -230,74 +230,84 @@ startOutbound :: forall rpc. SupportsServerRpc rpc => ServerParams - -> TVar (CallInitialMetadata rpc) + -> TVar (Maybe (CallInitialMetadata rpc)) -> TMVar Kickoff -> Compression -> IO (Session.FlowStart (ServerOutbound rpc), Session.ResponseInfo) startOutbound serverParams metadataVar kickoffVar cOut = do -- Wait for kickoff (see 'Kickoff' for discussion) - kickoff <- atomically $ readTMVar kickoffVar + kickoff <- atomically $ STM.readTMVar kickoffVar -- Session start - flowStart :: Session.FlowStart (ServerOutbound rpc) <- - case kickoff of - KickoffRegular _cs -> do - -- Get response metadata (see 'setResponseMetadata') - -- - -- It is important we do this only for 'KickoffRegular', because the - -- initial metadata is not used in the Trailers-Only case, and we - -- should not unecessarily throw the 'ResponseInitialMetadataNotSet' - -- exception. This is especially important when that Trailers-Only - -- case was triggered by an exception in the handler, because the - -- handler might not yet have had the opportunity to set the initial - -- metdata prior to the error. - responseMetadata <- do - mMetadata <- atomically $ readTVar metadataVar - case mMetadata of - CallInitialMetadataSet md _cs -> buildMetadataIO md - CallInitialMetadataNotSet -> throwIO $ ResponseInitialMetadataNotSet - - return $ Session.FlowStartRegular $ OutboundHeaders { - outHeaders = ResponseHeaders { - responseCompression = - Just $ Compr.compressionId cOut - , responseAcceptCompression = - Just $ Compr.offer compr - , responseContentType = - serverContentType serverParams - , responseMetadata = - customMetadataMapFromList responseMetadata - , responseUnrecognized = - () - } - , outCompression = cOut - } - KickoffTrailersOnly _cs trailers -> - return $ Session.FlowStartNoMessages trailers + case kickoff of + KickoffRegular _backtrace -> do + -- Get response metadata (see 'setResponseInitialMetadata') + -- + -- It is important we do this only for 'KickoffRegular', because the + -- initial metadata is not used in the Trailers-Only case, and we + -- should not unecessarily throw the 'ResponseInitialMetadataNotSet' + -- exception. This is especially important when that Trailers-Only + -- case was triggered by an exception in the handler, because the + -- handler might not yet have had the opportunity to set the initial + -- metdata prior to the error. + (responseMetadata, trailers) <- do + mMetadata <- atomically $ STM.readTVar metadataVar + case mMetadata of + Just md -> + (, callInitialExpectedTrailers md) <$> + buildMetadataIO (callInitialResponseMetadata md) + Nothing -> + throwIO ResponseInitialMetadataNotSet - return (flowStart, buildResponseInfo flowStart) + let headers :: Headers (ServerOutbound rpc) + headers = OutboundHeaders { + outHeaders = ResponseHeaders { + responseCompression = + Just $ Compr.compressionId cOut + , responseAcceptCompression = + Just $ Compr.offer compr + , responseContentType = + serverContentType serverParams + , responseTrailerNames = + allPotentialTrailers <$> trailers + , responseMetadata = + customMetadataMapFromList responseMetadata + , responseUnrecognized = + () + } + , outCompression = cOut + } + return ( + Session.FlowStartRegular headers + , responseInfoRegular headers + ) + KickoffTrailersOnly _backtrace trailers -> + return ( + Session.FlowStartNoMessages trailers + , responseInfoTrailersOnly trailers + ) where compr :: Compr.Negotation compr = serverCompression serverParams - buildResponseInfo :: - Session.FlowStart (ServerOutbound rpc) - -> Session.ResponseInfo - buildResponseInfo start = Session.ResponseInfo { + responseInfoRegular :: Headers (ServerOutbound rpc) -> Session.ResponseInfo + responseInfoRegular headers = Session.ResponseInfo { responseStatus = HTTP.ok200 - , responseHeaders = - case start of - Session.FlowStartRegular headers -> - buildResponseHeaders - (Proxy @rpc) - (outHeaders headers) - Session.FlowStartNoMessages trailers -> - buildTrailersOnly - (Just . chooseContentType (Proxy @rpc)) - trailers - , responseBody = Nothing + , responseHeaders = buildResponseHeaders + (Proxy @rpc) + (outHeaders headers) + , responseBody = Nothing } + responseInfoTrailersOnly :: TrailersOnly -> Session.ResponseInfo + responseInfoTrailersOnly trailers = Session.ResponseInfo { + responseStatus = HTTP.ok200 + , responseHeaders = buildTrailersOnly + (Just . chooseContentType (Proxy @rpc)) + trailers + , responseBody = Nothing + } + -- | Determine compression used by the peer for messages to us getInboundCompression :: ServerSession rpc @@ -332,12 +342,12 @@ ServerParams{serverCompression} = serverParams -- | Turn exception raised in server handler to error to be sent to the client -serverExceptionToClientError :: ServerParams -> SomeException -> IO ProperTrailers -serverExceptionToClientError params err +serverExceptionToClientError :: ServerParams -> ExactException -> IO ProperTrailers +serverExceptionToClientError params exact@(WrapExactException err) | Just (err' :: GrpcException) <- fromException err = return $ grpcExceptionToTrailers err' | otherwise = do - mMsg <- serverExceptionToClient params err + mMsg <- serverExceptionToClient params exact return $ simpleProperTrailers (GrpcError GrpcUnknown) mMsg Nothing mempty {------------------------------------------------------------------------------- @@ -514,20 +524,72 @@ -- -- Note that this is about the /initial/ metadata; additional metadata can be -- sent after the final message; see 'sendOutput'. -setResponseInitialMetadata :: - HasCallStack - => Call rpc -> ResponseInitialMetadata rpc -> IO () -setResponseInitialMetadata Call{ callResponseMetadata - , callResponseKickoff - } - md = atomically $ do - mKickoff <- fmap kickoffCallStack <$> tryReadTMVar callResponseKickoff - case mKickoff of - Nothing -> - writeTVar callResponseMetadata (CallInitialMetadataSet md callStack) - Just cs -> - throwSTM $ ResponseAlreadyInitiated cs callStack +setResponseInitialMetadata :: forall rpc. + ( StaticMetadata (ResponseTrailingMetadata rpc) + , HasCallStack + ) + => Call rpc + -> ResponseInitialMetadata rpc + -> IO () +setResponseInitialMetadata call md = + setResponseInitialMetadataAndTrailers call md $ + Just $ metadataHeaderNames (Proxy @(ResponseTrailingMetadata rpc)) +-- | Generalization of 'setResponseInitialMetadata' +-- +-- Trailers are HTTP headers that come /after/ the response body; a typical +-- example is a trailer containing a checksum of the body. Clients must be told +-- /ahead of time/ which trailers to expect (that is, their names). For most +-- RPCs this set of trailers is static, determined only by the endpoint (indeed, +-- the vast majority of gRPC endpoints don't use custom trailers at all, using +-- only the standard gRPC trailers @grpc-status@, @grpc-message@, and +-- @grpc-status-details-bin@); this is why 'setResponseInitialMetadata' needs +-- +-- > StaticMetadata (ResponseTrailingMetadata rpc) +-- +-- Occassionally however the set of trailers can vary from request to request, +-- even for the same RPC; 'setResponseInitialMetadataAndTrailers' can be used to +-- declare which trailers the client can expect in such a case. Note that this +-- does not mean that those trailers /must/ be present, only that they /can/ be; +-- to quote RFC9110: +-- +-- > The "Trailer" header field (Section 6.6.2) can be sent to indicate fields +-- > likely to be sent in the trailer section, which allows recipients to +-- > prepare for their receipt before processing the content. +setResponseInitialMetadataAndTrailers :: + HasCallStack + => Call rpc + -> ResponseInitialMetadata rpc + -> Maybe [HeaderName] + -- ^ Trailers + -- + -- If 'Just', the standard gRPC trailers will be added automatically. + -- + -- Use 'Nothing' if you do not want to announce the trailers ahead of time; + -- this is permitted by the HTTP2 spec, but it is not recommended: it can + -- result in trailers being dropped, for example by some proxies. + -> IO () +setResponseInitialMetadataAndTrailers call md trailers = do + newBacktrace <- collectBacktraces + atomically $ do + mKickoff <- fmap kickoffBacktrace <$> STM.tryReadTMVar callResponseKickoff + case mKickoff of + Nothing -> + STM.writeTVar callResponseMetadata $ Just CallInitialMetadata{ + callInitialResponseMetadata = md + , callInitialExpectedTrailers = trailers + , callInitialMetadataBacktrace = newBacktrace + } + Just oldBacktrace -> + STM.throwSTM $ ResponseAlreadyInitiated { + responseInitiatedFirst = oldBacktrace + , responseInitiatedAgain = newBacktrace + } + where + Call{ + callResponseMetadata + , callResponseKickoff + } = call {------------------------------------------------------------------------------- Low-level API -------------------------------------------------------------------------------} @@ -535,14 +597,15 @@ -- | Initiate the response -- -- This will cause the initial response metadata to be sent --- (see also 'setResponseMetadata'). +-- (see also 'setResponseInitialMetadata'). -- -- Does nothing if the response was already initated (that is, the response -- headers, or trailers in the case of 'sendTrailersOnly', have already been -- sent). initiateResponse :: HasCallStack => Call rpc -> IO () -initiateResponse Call{callResponseKickoff} = void $ - atomically $ tryPutTMVar callResponseKickoff $ KickoffRegular callStack +initiateResponse Call{callResponseKickoff} = void $ do + backtrace <- collectBacktraces + atomically $ STM.tryPutTMVar callResponseKickoff $ KickoffRegular backtrace -- | Use the gRPC @Trailers-Only@ case for non-error responses -- @@ -570,13 +633,18 @@ HasCallStack => Call rpc -> ResponseTrailingMetadata rpc -> IO () sendTrailersOnly Call{callContext, callResponseKickoff} metadata = do - metadata' <- buildMetadataIO metadata + metadata' <- buildMetadataIO metadata + newBacktrace <- collectBacktraces atomically $ do - previously <- fmap kickoffCallStack <$> tryReadTMVar callResponseKickoff + previously <- fmap kickoffBacktrace <$> STM.tryReadTMVar callResponseKickoff case previously of - Nothing -> putTMVar callResponseKickoff $ - KickoffTrailersOnly callStack (trailers metadata') - Just cs -> throwSTM $ ResponseAlreadyInitiated cs callStack + Nothing -> + STM.putTMVar callResponseKickoff $ + KickoffTrailersOnly newBacktrace (trailers metadata') + Just oldBacktrace -> STM.throwSTM $ ResponseAlreadyInitiated { + responseInitiatedFirst = oldBacktrace + , responseInitiatedAgain = newBacktrace + } where ServerContext{serverParams} = callContext @@ -639,7 +707,7 @@ NoNextElem -> err $ TooFewInputs @rpc NextElem inp -> return inp where - err :: ProtocolException rpc -> IO a + err :: HasCallStack => ProtocolException rpc -> IO a err = throwIO . ProtocolException -- | Receive input, which we expect to be the /final/ input @@ -661,7 +729,7 @@ FinalElem inp' NoMetadata -> err $ TooManyInputs @rpc inp' StreamElem inp' -> err $ TooManyInputs @rpc inp' where - err :: ProtocolException rpc -> IO a + err :: HasCallStack => ProtocolException rpc -> IO a err = throwIO . ProtocolException -- | Wait for the client to indicate that there are no more inputs @@ -675,7 +743,7 @@ FinalElem inp NoMetadata -> err $ TooManyInputs @rpc inp StreamElem inp -> err $ TooManyInputs @rpc inp where - err :: ProtocolException rpc -> IO a + err :: HasCallStack => ProtocolException rpc -> IO a err = throwIO . ProtocolException {------------------------------------------------------------------------------- @@ -689,14 +757,15 @@ -- handlers to the client. -- -- If no messages have been sent yet, we make use of the @Trailers-Only@ case. -sendProperTrailers :: Call rpc -> ProperTrailers -> IO () +sendProperTrailers :: HasCallStack => Call rpc -> ProperTrailers -> IO () sendProperTrailers Call{callContext, callResponseKickoff, callChannel} trailers = do + backtrace <- collectBacktraces updated <- atomically $ - tryPutTMVar callResponseKickoff $ + STM.tryPutTMVar callResponseKickoff $ KickoffTrailersOnly - callStack + backtrace ( properTrailersToTrailersOnly ( trailers , serverContentType serverParams @@ -764,10 +833,10 @@ data ResponseAlreadyInitiated = ResponseAlreadyInitiated { -- | When was the response first initiated? - responseInitiatedFirst :: CallStack + responseInitiatedFirst :: Backtraces -- | Where did we attempt to initiate the response a second time? - , responseInitiatedAgain :: CallStack + , responseInitiatedAgain :: Backtraces } deriving stock (Show) deriving anyclass (Exception) diff --git a/src/Network/GRPC/Server/Context.hs b/src/Network/GRPC/Server/Context.hs --- a/src/Network/GRPC/Server/Context.hs +++ b/src/Network/GRPC/Server/Context.hs @@ -9,15 +9,13 @@ , ServerParams(..) ) where -import Control.Exception -import System.IO +import Data.Text qualified as Text +import System.IO (stderr, hPrint) -import Network.GRPC.Common import Network.GRPC.Common.Compression qualified as Compr +import Network.GRPC.Common.Exception import Network.GRPC.Server.RequestHandler.API -import Network.GRPC.Spec -import Data.Text (Text) -import Data.Text qualified as Text +import Network.GRPC.Util.Imports {------------------------------------------------------------------------------- Context @@ -65,7 +63,7 @@ -- exception happens to contain sensitive information, this information -- will also be visible on the client. You may therefore wish to override -- the default behaviour. - , serverExceptionToClient :: SomeException -> IO (Maybe Text) + , serverExceptionToClient :: ExactException -> IO (Maybe Text) -- | Override content-type for response to client. -- @@ -98,15 +96,16 @@ defaultServerTopLevel h unmask req resp = h unmask req resp `catch` handler where - handler :: SomeException -> IO () + handler :: ExactException -> IO () handler = hPrint stderr -- | Default implementation for 'serverExceptionToClient' -- --- We unwrap the 'SomeException' wrapper so that we do not include the exception --- context in the output to the client (relevant for @ghc >= 9.10@ only). --- --- See . -defaultServerExceptionToClient :: SomeException -> IO (Maybe Text) -defaultServerExceptionToClient (SomeException e) = - return $ Just (Text.pack $ "Server-side exception: " ++ displayException e) +-- Exception annotations are not included: these reveal server implementation +-- details and are not typicall relevant or even meaningful to clients. +defaultServerExceptionToClient :: ExactException -> IO (Maybe Text) +defaultServerExceptionToClient exact = return $ + withoutAnnotations exact $ \e -> Just . Text.pack $ concat [ + "Server-side exception: " + , displayException e + ] diff --git a/src/Network/GRPC/Server/Handler.hs b/src/Network/GRPC/Server/Handler.hs --- a/src/Network/GRPC/Server/Handler.hs +++ b/src/Network/GRPC/Server/Handler.hs @@ -15,23 +15,15 @@ , runHandler ) where -import Prelude hiding (lookup) - -import Control.Concurrent.Async -import Control.Monad -import Control.Monad.Catch -import Control.Monad.IO.Class -import Data.Kind -import Data.Proxy -import GHC.Stack +import Control.Exception qualified as E import System.ThreadManager (KilledByThreadManager(..)) -import Network.GRPC.Common +import Network.GRPC.Common.Exception import Network.GRPC.Server.Call import Network.GRPC.Server.Context import Network.GRPC.Util.GHC -import Network.GRPC.Util.HTTP2.Stream (ClientDisconnected(..)) -import Network.GRPC.Util.Session qualified as Session +import Network.GRPC.Util.Imports +import Network.GRPC.Util.Session.Channel qualified as Session {------------------------------------------------------------------------------- Handlers @@ -73,9 +65,12 @@ -- the client as 'GrpcException' with 'GrpcUnknown' error code. data RpcHandler (m :: Type -> Type) (rpc :: k) = RpcHandler { -- | Handler proper - runRpcHandler :: Call rpc -> m () + runRpcHandler_ :: HasCallStack => Call rpc -> m () } +runRpcHandler :: HasCallStack => RpcHandler m rpc -> Call rpc -> m () +runRpcHandler RpcHandler{runRpcHandler_} = runRpcHandler_ + -- | Hoist an 'RpcHandler' to a different monad -- -- We do not make 'RpcHandler' an instance of @MFunctor@ (from the @mmorph@ @@ -106,10 +101,12 @@ -- response metadata needs the request metadata from the client, or even some -- messages from the client), you can use 'mkRpcHandlerNoDefMetadata'. mkRpcHandler :: - ( Default (ResponseInitialMetadata rpc) + ( Default (ResponseInitialMetadata rpc) + , StaticMetadata (ResponseTrailingMetadata rpc) , MonadIO m ) - => (Call rpc -> m ()) -> RpcHandler m rpc + => (HasCallStack => Call rpc -> m ()) + -> RpcHandler m rpc mkRpcHandler k = RpcHandler $ \call -> do liftIO $ setResponseInitialMetadata call def k call @@ -169,24 +166,25 @@ -- The handler itself will run in a separate thread handler' :: IO () handler' = do - result <- try $ runRpcHandler handler call + result <- tryExact $ runRpcHandler handler call handlerTeardown result -- Deal with any exceptions thrown in the handler - handlerTeardown :: Either SomeException () -> IO () + handlerTeardown :: Either ExactException () -> IO () handlerTeardown (Right ()) = do -- Handler terminated successfully, but may not have sent final message. -- /If/ the final message was sent, 'forwardException' does nothing. - forwarded <- forwardException call $ toException HandlerTerminated + forwarded <- forwardException call . WrapExactException $ + toException HandlerTerminated ignoreUncleanClose call $ ExitCaseSuccess () when forwarded $ -- The handler terminated before it sent the final message. - throwM HandlerTerminated + throwIO HandlerTerminated handlerTeardown (Left err) = do -- The handler threw an exception. Attempt to tell the client. _forwarded <- forwardException call err - ignoreUncleanClose call $ ExitCaseException err - throwM err + ignoreUncleanClose call $ ExitCaseException (unwrapExactException err) + throwExact err -- | Close the connection to the client, ignoring errors -- @@ -207,7 +205,7 @@ -- the exception in 'serverTopLevel'). ignoreUncleanClose :: Call rpc -> ExitCase a -> IO () ignoreUncleanClose Call{callChannel} reason = - void $ Session.close callChannel reason + Session.close callChannel reason -- | Wait for the handler to terminate -- @@ -238,32 +236,48 @@ waitForHandler unmask call handlerThread = loop where loop :: IO () - loop = unmask (wait handlerThread) `catch` handleException - - handleException :: SomeException -> IO () - handleException err - | Just (KilledByThreadManager mErr) <- fromException err = do - let exitReason :: ExitCase () - exitReason = - case mErr of - Nothing -> ExitCaseSuccess () - Just exitWithException -> - ExitCaseException . toException $ - ClientDisconnected exitWithException callStack - ignoreUncleanClose call exitReason - loop + loop = do + status <- waitAsyncStatus unmask handlerThread + case status of + AsyncDone () -> + -- Handler terminated + return () + AsyncFailed exact -> do + -- Handler /itself/ failed + throwExact exact + WaitInterrupted exact@(WrapExactException se) -> + -- /We/ received an exception whilst waiting for the handler + -- + -- We now distinguish between two cases: + -- + -- o If the exception we received was 'KilledByThreadManager', + -- then this is http2 telling us the client disappeared. We leave + -- the handler running, but mark the connection as broken. /If/ + -- the handler tries to communicate with the client, it will + -- receive an exception at that point. + -- o In all other cases, we cancel the handler. This might be when + -- someone is shutting down the server, for example. + case fromException se of + Just (KilledByThreadManager mErr) -> do + backtrace <- collectBacktraces + let exitReason :: ExitCase () + exitReason = + case mErr of + Nothing -> ExitCaseSuccess () + Just _exitWithException -> + ExitCaseException . toException $ + clientDisconnected backtrace exact + ignoreUncleanClose call exitReason + loop + Nothing -> do + cancelWith handlerThread exact + throwExact exact - | otherwise = do - -- If we get an exception while waiting on the handler, there - -- are two possibilities: - -- - -- 1. The exception was an asynchronous exception, thrown to us - -- externally. In this case @cancalWith@ will throw the - -- exception to the handler (and wait for it to terminate). - -- 2. The exception was thrown by the handler itself. In this - -- case @cancelWith@ is a no-op. - cancelWith handlerThread err - throwM err + clientDisconnected :: Backtraces -> ExactException -> ClientDisconnected + clientDisconnected backtrace e = ClientDisconnected{ + clientDisconnectedException = e + , clientDisconnectedBacktrace = Just backtrace + } -- | Process exception thrown by a handler -- @@ -278,10 +292,39 @@ -- -- We therefore catch and suppress all exceptions here. Returns @True@ if the -- forwarding was successful, @False@ if it raised an exception. -forwardException :: Call rpc -> SomeException -> IO Bool +forwardException :: HasCallStack => Call rpc -> ExactException -> IO Bool forwardException call@Call{callContext} err = do trailers <- serverExceptionToClientError (serverParams callContext) err (True <$ sendProperTrailers call trailers) `catch` handler where - handler :: SomeException -> IO Bool + handler :: ExactException -> IO Bool handler _e = return False + +{------------------------------------------------------------------------------- + Internal auxiliary +-------------------------------------------------------------------------------} + +data AsyncStatus a = + AsyncDone a + | AsyncFailed ExactException + | WaitInterrupted ExactException + deriving stock (Show) + +waitAsyncStatus :: + HasCallStack + => (forall x. IO x -> IO x) + -> Async a -> IO (AsyncStatus a) +waitAsyncStatus unmask async = + E.handle (return . WaitInterrupted) $ + either AsyncFailed AsyncDone <$> + unmask (tryAgain $ atomically $ waitCatchExact async) + where + -- Ignore "blocked indefinitely" exceptions + -- + -- This follows the implementation of `waitCatch` in async + -- . + -- + -- See also blog post “When "blocked indefinitely" is not indefinite” + -- . + tryAgain :: forall x. IO x -> IO x + tryAgain f = f `catch` \E.BlockedIndefinitelyOnSTM -> f diff --git a/src/Network/GRPC/Server/HandlerMap.hs b/src/Network/GRPC/Server/HandlerMap.hs --- a/src/Network/GRPC/Server/HandlerMap.hs +++ b/src/Network/GRPC/Server/HandlerMap.hs @@ -17,11 +17,10 @@ ) where import Prelude hiding (lookup) +import Network.GRPC.Util.Imports -import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HashMap -import Network.GRPC.Spec import Network.GRPC.Server.Handler {------------------------------------------------------------------------------- diff --git a/src/Network/GRPC/Server/Protobuf.hs b/src/Network/GRPC/Server/Protobuf.hs --- a/src/Network/GRPC/Server/Protobuf.hs +++ b/src/Network/GRPC/Server/Protobuf.hs @@ -8,11 +8,8 @@ , ProtobufMethods ) where -import Data.Kind import Data.ProtoLens.Service.Types -import GHC.TypeLits - -import Network.GRPC.Spec +import Network.GRPC.Util.Imports {------------------------------------------------------------------------------- Compute full Protobuf API diff --git a/src/Network/GRPC/Server/RequestHandler.hs b/src/Network/GRPC/Server/RequestHandler.hs --- a/src/Network/GRPC/Server/RequestHandler.hs +++ b/src/Network/GRPC/Server/RequestHandler.hs @@ -13,20 +13,19 @@ , requestHandler ) where -import Control.Concurrent +import Network.GRPC.Util.Imports + +import Control.Concurrent (forkIO, throwTo, killThread, myThreadId) import Control.Concurrent.Thread.Delay qualified as UnboundedDelays -import Control.Exception (evaluate) -import Control.Monad.Catch -import Data.Bifunctor + import Data.ByteString.Builder qualified as Builder import Data.ByteString.Char8 qualified as BS.Char8 import Data.ByteString.UTF8 qualified as BS.UTF8 -import Data.Maybe (fromMaybe) -import Data.Proxy import Data.Text qualified as Text import Network.HTTP.Types qualified as HTTP -import Network.HTTP2.Server qualified as HTTP2 +import Network.HTTP.Semantics.Server qualified as Server +import Network.GRPC.Common.Exception import Network.GRPC.Server.Call import Network.GRPC.Server.Context (ServerContext (..), ServerParams(..)) import Network.GRPC.Server.Handler @@ -34,8 +33,6 @@ import Network.GRPC.Server.HandlerMap qualified as HandlerMap import Network.GRPC.Server.RequestHandler.API import Network.GRPC.Server.Session (CallSetupFailure(..)) -import Network.GRPC.Spec -import Network.GRPC.Spec.Serialization import Network.GRPC.Util.GHC import Network.GRPC.Util.Session.Server @@ -78,29 +75,29 @@ -- Throws 'CallSetupFailure' if no handler could be found. findHandler :: HandlerMap IO - -> HTTP2.Request + -> Server.Request -> IO (SomeRpcHandler IO) findHandler handlers req = do -- TODO: -- We should do some request logging. resourceHeaders <- - either throwM return . first CallSetupInvalidResourceHeaders $ + either (throwIO . CallSetupInvalidResourceHeaders) return $ parseResourceHeaders rawHeaders let path = resourcePath resourceHeaders -- We have to be careful looking up the handler; there might be pure -- exceptions in the list of handlers (most commonly @undefined@). - mHandler <- try $ evaluate $ HandlerMap.lookup path handlers + mHandler <- tryExact $ evaluate $ HandlerMap.lookup path handlers case mHandler of Right (Just h) -> return h - Right Nothing -> throwM $ CallSetupUnimplementedMethod path - Left err -> throwM $ CallSetupHandlerLookupException err + Right Nothing -> throwIO $ CallSetupUnimplementedMethod path + Left err -> throwIO $ CallSetupHandlerLookupException err where rawHeaders :: RawResourceHeaders rawHeaders = RawResourceHeaders { - rawPath = fromMaybe "" $ HTTP2.requestPath req - , rawMethod = fromMaybe "" $ HTTP2.requestMethod req + rawPath = fromMaybe "" $ Server.requestPath req + , rawMethod = fromMaybe "" $ Server.requestMethod req } -- | Call setup failure @@ -110,13 +107,13 @@ -- exceptions that might arise from doing so. setupFailure :: ServerParams - -> (HTTP2.Response -> IO ()) + -> (Server.Response -> IO ()) -> CallSetupFailure -> IO a setupFailure params sendResponse failure = do response <- mkFailureResponse params failure - _ :: Either SomeException () <- try $ sendResponse response - throwM failure + void $ tryExact $ sendResponse response + throwIO failure {------------------------------------------------------------------------------- Failures @@ -140,11 +137,11 @@ -- Testing out-of-spec errors can be bit awkward. One option is @curl@: -- -- > curl --verbose --http2 --http2-prior-knowledge http://127.0.0.1:50051/ -mkFailureResponse :: ServerParams -> CallSetupFailure -> IO HTTP2.Response +mkFailureResponse :: ServerParams -> CallSetupFailure -> IO Server.Response mkFailureResponse params = \case CallSetupInvalidResourceHeaders (InvalidMethod method) -> return $ - HTTP2.responseBuilder + Server.responseBuilder HTTP.methodNotAllowed405 [("Allow", "POST")] (Builder.byteString . mconcat $ [ @@ -153,15 +150,15 @@ ]) CallSetupInvalidResourceHeaders (InvalidPath path) -> return $ - HTTP2.responseBuilder HTTP.badRequest400 [] . Builder.byteString $ + Server.responseBuilder HTTP.badRequest400 [] . Builder.byteString $ "Invalid path " <> path CallSetupInvalidRequestHeaders invalid -> return $ - HTTP2.responseBuilder (statusInvalidHeaders invalid) [] $ + Server.responseBuilder (statusInvalidHeaders invalid) [] $ prettyInvalidHeaders invalid CallSetupUnsupportedCompression cid -> return $ - HTTP2.responseBuilder HTTP.badRequest400 [] . Builder.byteString $ + Server.responseBuilder HTTP.badRequest400 [] . Builder.byteString $ "Unsupported compression: " <> BS.UTF8.fromString (show cid) CallSetupUnimplementedMethod path -> do let trailersOnly :: TrailersOnly @@ -170,7 +167,7 @@ , serverContentType ) return $ - HTTP2.responseNoBody HTTP.ok200 $ + Server.responseNoBody HTTP.ok200 $ buildTrailersOnly contentTypeForUnknown trailersOnly CallSetupHandlerLookupException err -> do msg <- serverExceptionToClient err @@ -185,7 +182,7 @@ , serverContentType ) return $ - HTTP2.responseNoBody HTTP.ok200 $ + Server.responseNoBody HTTP.ok200 $ buildTrailersOnly contentTypeForUnknown trailersOnly where ServerParams{ diff --git a/src/Network/GRPC/Server/RequestHandler/API.hs b/src/Network/GRPC/Server/RequestHandler/API.hs --- a/src/Network/GRPC/Server/RequestHandler/API.hs +++ b/src/Network/GRPC/Server/RequestHandler/API.hs @@ -10,7 +10,7 @@ import Control.Exception -import Network.HTTP2.Server qualified as HTTP2 +import Network.HTTP.Semantics.Server qualified as Server {------------------------------------------------------------------------------- Definition @@ -19,8 +19,8 @@ -- | HTTP2 request handler type RequestHandler a = (forall x. IO x -> IO x) - -> HTTP2.Request - -> (HTTP2.Response -> IO ()) + -> Server.Request + -> (Server.Response -> IO ()) -> IO a -- | Construct @http2@ handler @@ -33,7 +33,7 @@ -- which is not always the right thing to do; see detailed comments in -- 'runHandler'). It is the responsibility of 'serverTopLevel' (prior to -- calling 'requestHandlerToServer') to catch any remaining exceptions. - -> HTTP2.Server + -> Server.Server requestHandlerToServer handler req _aux respond = -- We start by masking asynchronous exceptions. It is possible that -- http2 kills us /before/ this call to @mask@, but if it does, no harm diff --git a/src/Network/GRPC/Server/Run.hs b/src/Network/GRPC/Server/Run.hs --- a/src/Network/GRPC/Server/Run.hs +++ b/src/Network/GRPC/Server/Run.hs @@ -26,25 +26,27 @@ , CouldNotLoadCredentials(..) ) where -import Control.Concurrent.Async -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.GRPC.Util.Imports + +import Control.Concurrent.STM (STM, TMVar) +import Control.Concurrent.STM qualified as STM +import Network.HTTP.Semantics.Server qualified as Server +import Network.HTTP2.Server qualified as HTTP2 (ServerConfig, run) import Network.HTTP2.TLS.Server qualified as HTTP2.TLS import Network.Run.TCP qualified as Run -import Network.Socket +import Network.Socket (Socket, AddrInfo, HostName, PortNumber) +import Network.Socket qualified as Socket import Network.TLS qualified as TLS #if MIN_VERSION_network_run(0,4,4) import Data.List.NonEmpty qualified as NE #endif +import Network.GRPC.Common.Exception import Network.GRPC.Common.HTTP2Settings import Network.GRPC.Server import Network.GRPC.Util.HTTP2 +import Network.GRPC.Util.TimeManager import Network.GRPC.Util.TLS (SslKeyLog(..)) import Network.GRPC.Util.TLS qualified as Util.TLS @@ -136,7 +138,7 @@ -- -- See also 'runServerWithHandlers', which handles the creation of the -- 'HTTP2.Server' for you. -runServer :: HTTP2Settings -> ServerConfig -> HTTP2.Server -> IO () +runServer :: HTTP2Settings -> ServerConfig -> Server.Server -> IO () runServer http2 cfg server = forkServer http2 cfg server $ waitServer -- | Convenience function that combines 'runServer' with 'mkGrpcServer' @@ -189,12 +191,12 @@ forkServer :: HTTP2Settings -> ServerConfig - -> HTTP2.Server + -> Server.Server -> (RunningServer -> IO a) -> IO a forkServer http2 ServerConfig{serverInsecure, serverSecure} server k = do - runningSocketInsecure <- newEmptyTMVarIO - runningSocketSecure <- newEmptyTMVarIO + runningSocketInsecure <- STM.newEmptyTMVarIO + runningSocketSecure <- STM.newEmptyTMVarIO let secure, insecure :: IO () insecure = @@ -221,12 +223,12 @@ -- Note that under normal circumstances the server /never/ terminates. waitServerSTM :: RunningServer - -> STM ( Either SomeException () - , Either SomeException () + -> STM ( Either ExactException () + , Either ExactException () ) waitServerSTM server = do - insecure <- waitCatchSTM (runningServerInsecure server) - secure <- waitCatchSTM (runningServerSecure server) + insecure <- waitCatchExact (runningServerInsecure server) + secure <- waitCatchExact (runningServerSecure server) return (insecure, secure) -- | IO version of 'waitServerSTM' that rethrows exceptions @@ -234,8 +236,8 @@ waitServer server = atomically (waitServerSTM server) >>= \case (Right (), Right ()) -> return () - (Left e , _ ) -> throwIO e - (_ , Left e ) -> throwIO e + (Left e , _ ) -> throwExact e + (_ , Left e ) -> throwExact e -- | Get the socket used by the insecure server -- @@ -264,15 +266,15 @@ -- Precondition: only one server must be enabled (secure or insecure). getServerSocket :: RunningServer -> STM Socket getServerSocket server = do - insecure <- catchSTM (Right <$> getInsecureSocket server) (return . Left) - secure <- catchSTM (Right <$> getSecureSocket server) (return . Left) + insecure <- STM.catchSTM (Right <$> getInsecureSocket server) (return . Left) + secure <- STM.catchSTM (Right <$> getSecureSocket server) (return . Left) case (insecure, secure) of (Right sock, Left ServerTerminated) -> return sock (Left ServerTerminated, Right sock) -> return sock (Left ServerTerminated, Left ServerTerminated) -> - throwSTM ServerTerminated + STM.throwSTM ServerTerminated (Right _, Right _) -> error $ "getServerSocket: precondition violated" @@ -282,20 +284,20 @@ getServerPort :: RunningServer -> IO PortNumber getServerPort server = do sock <- atomically $ getServerSocket server - addr <- getSocketName sock + addr <- Socket.getSocketName sock case addr of - SockAddrInet port _host -> return port - SockAddrInet6 port _ _host _ -> return port - SockAddrUnix{} -> error "getServerPort: unexpected unix socket" + Socket.SockAddrInet port _host -> return port + Socket.SockAddrInet6 port _ _host _ -> return port + Socket.SockAddrUnix{} -> error "getServerPort: unexpected unix socket" -- | Internal generalization of 'getInsecureSocket'/'getSecureSocket' getSocket :: Async () -> TMVar Socket -> STM Socket getSocket serverAsync socketTMVar = do - status <- (Left <$> waitCatchSTM serverAsync) - `orElse` (Right <$> readTMVar socketTMVar) + status <- (Left <$> waitCatchExact serverAsync) + `STM.orElse` (Right <$> STM.readTMVar socketTMVar) case status of - Left (Left err) -> throwSTM err - Left (Right ()) -> throwSTM $ ServerTerminated + Left (Left err) -> STM.throwSTM err + Left (Right ()) -> STM.throwSTM $ ServerTerminated Right sock -> return sock {------------------------------------------------------------------------------- @@ -306,7 +308,7 @@ HTTP2Settings -> InsecureConfig -> TMVar Socket - -> HTTP2.Server + -> Server.Server -> IO () runInsecure http2 cfg socketTMVar server = do openSock cfg $ \listenSock -> @@ -314,10 +316,10 @@ Run.runTCPServerWithSocket listenSock $ \clientSock -> do when (http2TcpNoDelay http2 && not isUnixSocket) $ do -- See description of 'withServerSocket' - setSocketOption clientSock NoDelay 1 + Socket.setSocketOption clientSock Socket.NoDelay 1 when (http2TcpAbortiveClose http2) $ do - setSockOpt clientSock Linger - (StructLinger { sl_onoff = 1, sl_linger = 0 }) + Socket.setSockOpt clientSock Socket.Linger + (Socket.StructLinger { Socket.sl_onoff = 1, Socket.sl_linger = 0 }) withConfigForInsecure mgr clientSock $ \config -> HTTP2.run serverConfig config server where @@ -348,7 +350,7 @@ HTTP2Settings -> SecureConfig -> TMVar Socket - -> HTTP2.Server + -> Server.Server -> IO () runSecure http2 cfg socketTMVar server = do cred :: TLS.Credential <- @@ -379,10 +381,10 @@ "h2" $ \mgr backend -> do when (http2TcpNoDelay http2) $ -- See description of 'withServerSocket' - setSocketOption (HTTP2.TLS.requestSock backend) NoDelay 1 + Socket.setSocketOption (HTTP2.TLS.requestSock backend) Socket.NoDelay 1 when (http2TcpAbortiveClose http2) $ do - setSockOpt (HTTP2.TLS.requestSock backend) Linger - (StructLinger { sl_onoff = 1, sl_linger = 0 }) + Socket.setSockOpt (HTTP2.TLS.requestSock backend) Socket.Linger + (Socket.StructLinger { Socket.sl_onoff = 1, Socket.sl_linger = 0 }) withConfigForSecure mgr backend $ \config -> HTTP2.run serverConfig config server @@ -433,17 +435,17 @@ -> IO a withServerSocket http2Settings socketTMVar host port k = do #if MIN_VERSION_network_run(0,4,4) - addr <- Run.resolve Stream host (show port) [AI_PASSIVE] NE.head + addr <- Run.resolve Socket.Stream host (show port) [Socket.AI_PASSIVE] NE.head #else - addr <- Run.resolve Stream host (show port) [AI_PASSIVE] + addr <- Run.resolve Socket.Stream host (show port) [Socket.AI_PASSIVE] #endif - bracket (openServerSocket addr) close $ \sock -> do - atomically $ putTMVar socketTMVar sock + bracket (openServerSocket addr) Socket.close $ \sock -> do + atomically $ STM.putTMVar socketTMVar sock k sock where openServerSocket :: AddrInfo -> IO Socket openServerSocket = Run.openTCPServerSocketWithOptions $ concat [ - [ (NoDelay, 1) + [ (Socket.NoDelay, 1) | http2TcpNoDelay http2Settings ] ] @@ -454,15 +456,15 @@ -- otherwise clients would get their connection closed immediately. withUnixSocket :: FilePath -> TMVar Socket -> (Socket -> IO a) -> IO a withUnixSocket path socketTMVar k = do - bracket openServerSocket close $ \sock -> do - atomically $ putTMVar socketTMVar sock + bracket openServerSocket Socket.close $ \sock -> do + atomically $ STM.putTMVar socketTMVar sock k sock where openServerSocket :: IO Socket openServerSocket = do - sock <- socket AF_UNIX Stream 0 - setSocketOption sock ReuseAddr 1 - withFdSocket sock setCloseOnExecIfNeeded - bind sock $ SockAddrUnix path - listen sock 1024 + sock <- Socket.socket Socket.AF_UNIX Socket.Stream 0 + Socket.setSocketOption sock Socket.ReuseAddr 1 + Socket.withFdSocket sock Socket.setCloseOnExecIfNeeded + Socket.bind sock $ Socket.SockAddrUnix path + Socket.listen sock 1024 return sock diff --git a/src/Network/GRPC/Server/Session.hs b/src/Network/GRPC/Server/Session.hs --- a/src/Network/GRPC/Server/Session.hs +++ b/src/Network/GRPC/Server/Session.hs @@ -7,14 +7,10 @@ , CallSetupFailure(..) ) where -import Control.Exception -import Data.Proxy -import Data.Void - +import Network.GRPC.Common.Exception import Network.GRPC.Server.Context -import Network.GRPC.Spec -import Network.GRPC.Spec.Serialization -import Network.GRPC.Util.Session +import Network.GRPC.Util.Imports +import Network.GRPC.Util.Session.API {------------------------------------------------------------------------------- Definition @@ -102,7 +98,7 @@ -- | An exception arose while we tried to look up the handler -- -- This can arise when the list of handlers /itself/ is @undefined@. - | CallSetupHandlerLookupException SomeException + | CallSetupHandlerLookupException ExactException deriving stock instance Show CallSetupFailure deriving anyclass instance Exception CallSetupFailure diff --git a/src/Network/GRPC/Server/StreamType.hs b/src/Network/GRPC/Server/StreamType.hs --- a/src/Network/GRPC/Server/StreamType.hs +++ b/src/Network/GRPC/Server/StreamType.hs @@ -23,13 +23,11 @@ , simpleMethods ) where -import Control.Monad.IO.Class -import Data.Kind +import Network.GRPC.Util.Imports -import Network.GRPC.Common +import Network.GRPC.Common.StreamElem (StreamElem(..)) import Network.GRPC.Common.NextElem qualified as NextElem import Network.GRPC.Server -import Network.GRPC.Spec {------------------------------------------------------------------------------- Construct server handler @@ -115,6 +113,7 @@ -- specification of the server's API, you can use 'fromStreamingHandler'. fromStreamingHandler :: forall k (rpc :: k) m. ( SupportsServerRpc rpc + , StaticMetadata (ResponseTrailingMetadata rpc) , Default (ResponseInitialMetadata rpc) , Default (ResponseTrailingMetadata rpc) , MonadIO m @@ -234,6 +233,7 @@ -- the example above). Method :: ( SupportsServerRpc rpc + , StaticMetadata (ResponseTrailingMetadata rpc) , Default (ResponseInitialMetadata rpc) , Default (ResponseTrailingMetadata rpc) , SupportsStreamingType rpc styp @@ -297,9 +297,10 @@ -- > Server.fromMethod @Ping $ Server.mkNonStreaming $ .. fromMethod :: forall rpc styp m. ( SupportsServerRpc rpc - , ValidStreamingType styp + , StaticMetadata (ResponseTrailingMetadata rpc) , Default (ResponseInitialMetadata rpc) , Default (ResponseTrailingMetadata rpc) + , ValidStreamingType styp , MonadIO m ) => ServerHandler' styp m rpc -> SomeRpcHandler m @@ -387,6 +388,7 @@ instance ( -- Requirements inherited from the 'Method' constructor SupportsServerRpc rpc + , StaticMetadata (ResponseTrailingMetadata rpc) , Default (ResponseInitialMetadata rpc) , Default (ResponseTrailingMetadata rpc) , SupportsStreamingType rpc (RpcStreamingType rpc) diff --git a/src/Network/GRPC/Server/StreamType/Binary.hs b/src/Network/GRPC/Server/StreamType/Binary.hs --- a/src/Network/GRPC/Server/StreamType/Binary.hs +++ b/src/Network/GRPC/Server/StreamType/Binary.hs @@ -6,15 +6,13 @@ , mkBiDiStreaming ) where -import Control.Monad.IO.Class -import Data.Binary +import Network.GRPC.Util.Imports + +import Data.Binary (Binary, encode) import Data.ByteString.Lazy qualified as Lazy (ByteString) -import Network.GRPC.Common import Network.GRPC.Common.Binary (decodeOrThrow) -import Network.GRPC.Common.StreamType import Network.GRPC.Server.StreamType qualified as StreamType -import Network.GRPC.Spec {------------------------------------------------------------------------------- Handlers for specific streaming types diff --git a/src/Network/GRPC/Util/ClientStream.hs b/src/Network/GRPC/Util/ClientStream.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Util/ClientStream.hs @@ -0,0 +1,45 @@ +module Network.GRPC.Util.ClientStream ( + -- ** Client API + clientInputStream, + clientOutputStream, +) where + +import Network.GRPC.Util.Stream + +import Network.HTTP.Semantics.Client qualified as Client +import Network.HTTP.Semantics (OutBodyIface) +import Network.HTTP.Semantics qualified as HTTP + +import Network.GRPC.Util.HeaderTable (fromHeaderTable) + +{------------------------------------------------------------------------------- + Client API +-------------------------------------------------------------------------------} + +clientInputStream :: Client.Response -> IO InputStream +clientInputStream resp = do + return InputStream { + _getChunk = + wrapServerDisconnected $ + Client.getResponseBodyChunk' resp + , _getTrailers = + wrapServerDisconnected $ + maybe [] fromHeaderTable <$> Client.getResponseTrailers resp + } + +-- | Construct a client 'OutputStream' +-- +-- We do not wrap the members of the 'OutputStream' with +-- 'wrapStreamExceptionsWith', since we do this around the entire +-- 'sendMessageLoop'. See the comment for @outboundThread@ in +-- 'Network.GRPC.Util.Session.Client.setupRequestChannel'. +clientOutputStream :: OutBodyIface -> IO OutputStream +clientOutputStream iface = + return OutputStream { + _writeChunk = \c -> + HTTP.outBodyPush iface c + , _writeChunkFinal = \c -> + HTTP.outBodyPushFinal iface c + , _flush = + HTTP.outBodyFlush iface + } diff --git a/src/Network/GRPC/Util/Exception/Doc.hs b/src/Network/GRPC/Util/Exception/Doc.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Util/Exception/Doc.hs @@ -0,0 +1,65 @@ +-- | Barebones rendering abstraction for nested indentation +module Network.GRPC.Util.Exception.Doc ( + Doc(..) + -- * Construction + , fromLines + , withHeader + -- * Rendering + , renderDoc + ) where + +import Data.String +import Data.Semigroup + +import Data.Foldable qualified as Foldable + +{------------------------------------------------------------------------------- + Definition +-------------------------------------------------------------------------------} + +data Doc = + FromString String + | VCat [Doc] + | Indent Int Doc + +{------------------------------------------------------------------------------- + Construction +-------------------------------------------------------------------------------} + +instance IsString Doc where + fromString = FromString + +instance Monoid Doc where + mempty = VCat [] + mconcat = VCat + +instance Semigroup Doc where + a <> b = VCat [a, b] + sconcat = VCat . Foldable.toList + +fromLines :: String -> Doc +fromLines = mconcat . map fromString . lines + +withHeader :: String -> Doc -> Doc +withHeader header body = mconcat [ + fromString header + , Indent 2 body + ] + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} + +renderDoc :: Doc -> String +renderDoc = \d -> + unlines + $ map (\(i, str) -> replicate i ' ' ++ str) + $ go [(0, d)] + where + go :: [(Int, Doc)] -> [(Int, String)] + go [] = [] + go ((i, d) : ds) = + case d of + FromString str -> (i, str) : go ds + VCat ds' -> go $ map (i,) ds' ++ ds + Indent i' d' -> go $ (i + i', d') : ds diff --git a/src/Network/GRPC/Util/Exception/Exact.hs b/src/Network/GRPC/Util/Exception/Exact.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Util/Exception/Exact.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE CPP #-} + +module Network.GRPC.Util.Exception.Exact ( + ExactException(..) + -- * Catching + , catchExact + , tryExact + , waitCatchExact + -- * Utilities + , throwExact + , withoutAnnotations + , catchAndWrap + ) where + +import Control.Concurrent.Async +import Control.Concurrent.STM (STM) +import Control.Exception (Exception(..)) +import Control.Exception qualified as Base +import Data.Bifunctor +import GHC.Stack + +import Network.GRPC.Util.Exception.Shims + +{------------------------------------------------------------------------------- + Definition +-------------------------------------------------------------------------------} + +-- | Exception with emphasis on accurate annotations +-- +-- When this type appears in the @grapesy@ API, it emphasises that we have tried +-- to ensure that any exception annotations are taken seriously. +-- +-- Unlike the 'Exception' instance for 'SomeException', the instance for +-- 'ExactException' can be used with 'throwIO', 'throwTo', 'cancelWith', etc., +-- without losing any annotations. +-- +-- See also 'catchExact', 'tryExact', 'waitCatchExact'. +newtype ExactException = WrapExactException { + unwrapExactException :: Base.SomeException + } + deriving stock (Show) + +instance Exception ExactException where + fromException = Just . WrapExactException + toException = unwrapExactException + displayException = displayException . unwrapExactException +#if MIN_VERSION_base(4,20,0) + backtraceDesired = const False +#endif + +{------------------------------------------------------------------------------- + Catching 'ExactException' + + This is primarily useful to avoid accidentally throwing 'SomeException'. +-------------------------------------------------------------------------------} + +-- | Catch 'ExactException' +-- +-- Won't install any other kind of exception handler (i.e., no 'WhileHandling' +-- annotation will be added). This is comparable to 'catchNoPropagate' (see +-- discussion in 'ExactException'); there is no analogue of 'rethrowIO', +-- since 'throwIO' /itself/ can be used safely with 'ExactException'. +catchExact :: IO a -> (ExactException -> IO a) -> IO a +#if !MIN_VERSION_base(4,21,0) +catchExact = Base.catch +#else +catchExact action handler = + Base.catchNoPropagate action (handler . aux) + where + -- NOTE: only used in GHC 9.12 and up + aux :: Base.ExceptionWithContext Base.SomeException -> ExactException + aux (Base.ExceptionWithContext _ctxt se) = WrapExactException se +#endif + +tryExact :: IO a -> IO (Either ExactException a) +tryExact = Base.try + +waitCatchExact :: Async a -> STM (Either ExactException a) +waitCatchExact = fmap (first WrapExactException) . waitCatchSTM + +{------------------------------------------------------------------------------- + Utilities +-------------------------------------------------------------------------------} + +-- | Type-specialized wrapper around throwIO, to avoid mistakes +-- +-- This does not need a `HasCallSTack` constraint, because no backtrace is +-- added to `ExactException`. +throwExact :: ExactException -> IO a +throwExact = Base.throwIO + +withoutAnnotations :: ExactException -> (forall e. Exception e => e -> r) -> r +withoutAnnotations (WrapExactException (Base.SomeException e)) k = k e + +-- | Wrap an exception +-- +-- Notes: +-- +-- * Since the original exception is wrapped as-is, including any annotations, +-- we use 'catchExact' to avoid adding a 'WhileHandling' annotation. +-- * We use 'throwIO' to throw the new wrapped exception, so that /if/ the +-- exception wrapper has 'backtraceDesired', we get a backtrace to the wrap. +catchAndWrap :: + (HasCallStack, Exception e) + => (ExactException -> e) -> IO a -> IO a +catchAndWrap f io = io `catchExact` (throwIO . f) diff --git a/src/Network/GRPC/Util/Exception/FormatCtx.hs b/src/Network/GRPC/Util/Exception/FormatCtx.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Util/Exception/FormatCtx.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE CPP #-} + +-- | Custom overrides for exception rendering +module Network.GRPC.Util.Exception.FormatCtx ( + FormatCtx -- opaque + -- * Construction + , emptyFormatCtx + , insertFormatCtx + -- * Use + , formatException +#if MIN_VERSION_base(4,20,0) + , formatExceptionAnnotation +#endif + ) where + +import Control.Exception +import Data.Typeable +import Type.Reflection qualified as Reflection + +#if MIN_VERSION_base(4,20,0) +import Control.Exception.Annotation +#endif + +import Network.GRPC.Util.Exception.Doc + +{------------------------------------------------------------------------------- + Definition + + TODO: It would be nicer to use dependent-map for 'FormatCtx' but it doesn't + support GHC-9.14. +-------------------------------------------------------------------------------} + +-- | Custom renderers +-- +-- This can be used to dynamically dispatch rendering for exception or +-- exception annotations to user-specified renderers, overriding any instances +-- that may (or may not) be in scope. +newtype FormatCtx = FormatCtx [Renderer] + +data Renderer where + Renderer :: Reflection.TypeRep e -> (FormatCtx -> e -> Doc) -> Renderer + +{------------------------------------------------------------------------------- + Construction +-------------------------------------------------------------------------------} + +emptyFormatCtx :: FormatCtx +emptyFormatCtx = FormatCtx [] + +insertFormatCtx :: Typeable e => (FormatCtx -> e -> Doc) -> FormatCtx -> FormatCtx +insertFormatCtx f (FormatCtx xs) = FormatCtx (Renderer Reflection.typeRep f : xs) + +{------------------------------------------------------------------------------- + Use +-------------------------------------------------------------------------------} + +formatException :: Exception e => FormatCtx -> e -> Doc +formatException ctx e = case lookupFormatCtx ty ctx of + Just f -> f ctx e + Nothing -> withHeader (show ty) $ fromLines $ displayException e + where + ty = Reflection.typeOf e + +#if MIN_VERSION_base(4,20,0) +formatExceptionAnnotation :: ExceptionAnnotation ann => FormatCtx -> ann -> Doc +formatExceptionAnnotation ctx ann = case lookupFormatCtx ty ctx of + Just f -> f ctx ann + Nothing -> withHeader (show ty) $ fromLines $ displayExceptionAnnotation ann + where + ty = Reflection.typeOf ann +#endif + +{------------------------------------------------------------------------------- + Internal auxiliary +-------------------------------------------------------------------------------} + +lookupFormatCtx :: Reflection.TypeRep e -> FormatCtx -> Maybe (FormatCtx -> e -> Doc) +lookupFormatCtx ty (FormatCtx xs) = go xs where + go [] = Nothing + go (Renderer ty' f : xs') = case Reflection.eqTypeRep ty ty' of + Just HRefl -> Just f + Nothing -> go xs' diff --git a/src/Network/GRPC/Util/Exception/Shims.hs b/src/Network/GRPC/Util/Exception/Shims.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Util/Exception/Shims.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ImplicitParams #-} + +module Network.GRPC.Util.Exception.Shims ( + -- * Throwing + throwIO + , throwM + -- * Showable wrapper for 'Backtraces' (or 'CallStack' for GHC < 9.10) + , Backtraces + , collectBacktraces + , displayBacktraces + -- * Make `annotateIO` a no-op for GHC < 9.10 + , annotateIO + , addExceptionContext + -- * Bug-free version of 'ExceptionWithContext' + , WithAnnotations + , pattern WithAnnotations + -- * STM +#ifndef PATCHED_GHC_FOR_EXCEPTION_DEBUGGING + , AtomicallyBacktrace(..) + , atomically +#else + , STM.atomically +#endif + ) where + +import Control.Concurrent.STM qualified as STM +import Control.Exception (Exception(..)) +import Control.Exception qualified as Base +import Control.Monad.Catch qualified as Exceptions +import GHC.Stack + +#if MIN_VERSION_base(4,20,0) +import Control.Exception.Annotation +import Control.Exception.Backtrace qualified as Backtrace +import Control.Exception.Context +#endif + +#ifndef PATCHED_GHC_FOR_EXCEPTION_DEBUGGING +import Control.Concurrent.STM (STM) +import GHC.Generics +#endif + +{------------------------------------------------------------------------------- + Throwing + + This just adds the @HasCallStack@ constraint, even when it is technically + speaking redundant (in older GHC). Avoids redundant constraints warnings + upstream. +-------------------------------------------------------------------------------} + +throwIO :: (Exception e, HasCallStack) => e -> IO a +throwIO = Base.throwIO +#if !MIN_VERSION_base(4,20,0) + where + _suppressRedundantConstraintWarning = callStack +#endif + +throwM :: (Exception e, Exceptions.MonadThrow m, HasCallStack) => e -> m a +throwM = Exceptions.throwM +#if !MIN_VERSION_exceptions(0,10,6) + where + _suppressRedundantConstraintWarning = callStack +#endif + +{------------------------------------------------------------------------------- + Showable wrapper for 'Backtraces' (or 'CallStack' for GHC < 9.10) +-------------------------------------------------------------------------------} + +#if !MIN_VERSION_base(4,20,0) +newtype Backtraces = WrapBacktraces { + unwrapBacktraces :: CallStack + } + deriving stock (Show) + +collectBacktraces :: HasCallStack => IO Backtraces +collectBacktraces = return $ WrapBacktraces GHC.Stack.callStack + +displayBacktraces :: Backtraces -> String +displayBacktraces = prettyCallStack . unwrapBacktraces + +#else + +newtype Backtraces = WrapBacktraces { + unwrapBacktraces :: Backtrace.Backtraces + } + +-- Frustratingly, 'Backtraces' does not have a law-abiding 'Show' instance +instance Show Backtraces where + show = displayBacktraces + +collectBacktraces :: HasCallStack => IO Backtraces +collectBacktraces = WrapBacktraces <$> Backtrace.collectBacktraces + +displayBacktraces :: Backtraces -> String +displayBacktraces = Backtrace.displayBacktraces . unwrapBacktraces + +#endif + +{------------------------------------------------------------------------------- + Make `annotateIO` a no-op for GHC < 9.10 +-------------------------------------------------------------------------------} + +#if !MIN_VERSION_base(4,20,0) + +annotateIO :: ann -> IO a -> IO a +annotateIO _ = id + +addExceptionContext :: ann -> Base.SomeException -> Base.SomeException +addExceptionContext _ = id + +#else + +annotateIO :: + ExceptionAnnotation ann + => ann -> IO a -> IO a +annotateIO = Base.annotateIO + +addExceptionContext :: + ExceptionAnnotation ann + => ann -> Base.SomeException -> Base.SomeException +addExceptionContext = Base.addExceptionContext + +#endif + +{------------------------------------------------------------------------------- + Bug-free version of 'ExceptionWithContext' + + In GHC 9.10 'ExceptionWithContext' is broken (throwing something of type + @ExceptionWithContext SomeException@ will result in nested @SomeException@, + breaking exception handlers). Prior to GHC 9.10 it is not available at all. + The implementation here stays as close as possible to the one in GHC 9.14. +-------------------------------------------------------------------------------} + +#if !MIN_VERSION_base(4,20,0) + +data ExceptionContext = EmptyExceptionContext + deriving stock (Show) + +data WithAnnotations a = WithAnnotations ExceptionContext a + deriving stock (Show) + +instance Exception e => Exception (WithAnnotations e) where + toException (WithAnnotations EmptyExceptionContext e) = + toException e + + fromException se = do + e <- fromException se + return (WithAnnotations EmptyExceptionContext e) + + displayException = displayException . toException + +#elif !MIN_VERSION_base(4,21,0) + +-- | Bug-free replacement for 'ExceptionWithContext' in GHC 9.10 +data WithAnnotations e = WithAnnotations ExceptionContext e + deriving stock Generic + +instance Exception a => Show (WithAnnotations a) where + show (WithAnnotations _ctxt e) = show e + +instance Exception a => Exception (WithAnnotations a) where + toException (WithAnnotations ctxt e) = + case toException e of + Base.SomeException c -> + let ?exceptionContext = ctxt + in Base.SomeException c + fromException se = do + e <- fromException se + return (WithAnnotations (Base.someExceptionContext se) e) + backtraceDesired (WithAnnotations _ e) = backtraceDesired e + displayException = displayException . toException + +#else + +type WithAnnotations = Base.ExceptionWithContext + +pattern WithAnnotations :: ExceptionContext -> a -> WithAnnotations a +pattern WithAnnotations ctxt e = Base.ExceptionWithContext ctxt e + +#endif + +{------------------------------------------------------------------------------- + STM +-------------------------------------------------------------------------------} + +#ifdef PATCHED_GHC_FOR_EXCEPTION_DEBUGGING +-- Nothing to do, part of the patch +#else +-- | Backtrace to a call to 'atomically' +-- +-- When an STM transaction throws an exception, this will tell us where that +-- tranaction was invoked (though not where /within/ the transaction it +-- threw an exception). +newtype AtomicallyBacktrace = AtomicallyBacktrace Backtraces + deriving stock (Generic, Show) +#if MIN_VERSION_base(4,20,0) + deriving anyclass (ExceptionAnnotation) +#endif + +atomically :: HasCallStack => STM a -> IO a +atomically stm = do + backtraces <- collectBacktraces + annotateIO (AtomicallyBacktrace backtraces) $ + STM.atomically stm +#endif diff --git a/src/Network/GRPC/Util/Exception/ToExceptionDoc.hs b/src/Network/GRPC/Util/Exception/ToExceptionDoc.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Util/Exception/ToExceptionDoc.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.GRPC.Util.Exception.ToExceptionDoc ( + ToExceptionDoc(..) + , LinesToExceptionDoc(..) + -- * Top-level rendering functions + , renderKnown + , renderAnyException +#if MIN_VERSION_base(4,20,0) + , renderAnyExceptionAnnotation +#endif + -- * Interaction with the 'FormatCtx' + , insertFormatCtx_ + , defaultFormatCtx + ) where + +import Control.Exception (Exception) +import Control.Exception qualified as Base +import Data.Function +import Data.Proxy +import Data.Typeable +import GHC.Generics +import GHC.Stack +import GHC.TypeLits + +#if MIN_VERSION_base(4,20,0) +import Control.Exception.Annotation +import Control.Exception.Context +#endif + +import Network.GRPC.Util.Exception.Doc +import Network.GRPC.Util.Exception.Exact +import Network.GRPC.Util.Exception.FormatCtx +import Network.GRPC.Util.Exception.Shims + +{------------------------------------------------------------------------------- + Definition +-------------------------------------------------------------------------------} + +-- | 'ToExceptionDoc' is a convenience class +class ToExceptionDoc a where + toExceptionDoc :: FormatCtx -> a -> Doc + + default toExceptionDoc :: (Generic a, GToDoc (Rep a)) => FormatCtx -> a -> Doc + toExceptionDoc d = gToDoc d . from + +-- | Deriving-via support for 'ToExceptionDoc' +newtype LinesToExceptionDoc a = LinesToExceptionDoc a + +instance Show a => ToExceptionDoc (LinesToExceptionDoc a) where + toExceptionDoc _ (LinesToExceptionDoc x) = fromLines (show x) + +{------------------------------------------------------------------------------- + Top-level rendering functions +-------------------------------------------------------------------------------} + +-- | Render known exception or exception annotation +-- +-- By default there are two ways to render an exception: 'show' gives us a +-- Haskell value (or is supposed to), perhaps useful to copy/paste into a +-- regression test, and 'displayException' gives us a user-friendly string. +-- Neither of these is particularly useful for developers: 'show' is often +-- unreadable, and 'displayException' may omit information (such as backtraces). +-- We therefore introduce a third way to render an exception, with the +-- additional benefit that we will see all nested exceptions (see also blog post +-- "Exception Annotations: Lay of the Land", +-- ). +renderKnown :: + ToExceptionDoc e + => FormatCtx -> e -> String +renderKnown ctx = renderDoc . toExceptionDoc ctx + +-- | Render exception of arbitrary type (see also 'renderKnown') +-- +-- Unlike 'renderKnown', this does /not/ depend on 'ToExceptionDoc'. Instead, +-- the 'FormatCtx' argument allows user to add ways to print the exceptions they +-- are interested about. 'Exception's being 'Typeable' allows us to not rely on +-- static / type-class mechanisms which in turn allows us to not depend on all +-- downstream packages "too early". +renderAnyException :: + Exception e + => FormatCtx -> e -> String +renderAnyException ctx = renderDoc . formatException ctx + +#if MIN_VERSION_base(4,20,0) +-- | Render exception annotation of arbitrary type (see also 'renderKnown') +-- +-- See 'renderAnyException' for detailed discussion. +renderAnyExceptionAnnotation :: + ExceptionAnnotation ann + => FormatCtx -> ann -> String +renderAnyExceptionAnnotation ctx = renderDoc . formatExceptionAnnotation ctx +#endif + +{------------------------------------------------------------------------------- + "Container"-like instances +-------------------------------------------------------------------------------} + +instance ToExceptionDoc a => ToExceptionDoc (Maybe a) where + toExceptionDoc ctx = foldMap (toExceptionDoc ctx) + +instance ToExceptionDoc a => ToExceptionDoc [a] where + toExceptionDoc ctx = foldMap (toExceptionDoc ctx) + +{------------------------------------------------------------------------------- + Generics for 'ToDoc' +-------------------------------------------------------------------------------} + +class GToDoc p where + gToDoc :: FormatCtx -> p a -> Doc + +instance ( GToDoc p + , KnownSymbol typ + , KnownSymbol modl + ) => GToDoc (D1 ('MetaData typ modl pkg isNewtype) p) where + gToDoc ctx (M1 x) = + withHeader (symbolVal (Proxy @modl) ++ "." ++ symbolVal (Proxy @typ)) $ + gToDoc ctx x + +instance ( GToDoc p + , KnownSymbol constr + ) => GToDoc (C1 ('MetaCons constr fixity hasFields) p) where + gToDoc ctx (M1 x) = + withHeader (symbolVal (Proxy @constr)) $ + gToDoc ctx x + +instance ( GToDoc p + , KnownSymbol fieldSel + ) => GToDoc (S1 ('MetaSel (Just fieldSel) unpack strict lazy) p) where + gToDoc ctx (M1 x) = + withHeader (symbolVal (Proxy @fieldSel)) $ + gToDoc ctx x + +instance GToDoc p => GToDoc (S1 ('MetaSel Nothing unpack strict lazy) p) where + gToDoc ctx (M1 x) = gToDoc ctx x + +instance (GToDoc f, GToDoc g) => GToDoc (f :*: g) where + gToDoc ctx (x :*: y) = gToDoc ctx x <> gToDoc ctx y + +instance (GToDoc f, GToDoc g) => GToDoc (f :+: g) where + gToDoc ctx (L1 x) = gToDoc ctx x + gToDoc ctx (R1 x) = gToDoc ctx x + +instance GToDoc U1 where + gToDoc _ U1 = mempty + +instance ToExceptionDoc a => GToDoc (K1 r a) where + gToDoc ctx (K1 x) = toExceptionDoc ctx x + +{------------------------------------------------------------------------------- + Instances for common exception /annotations/ +-------------------------------------------------------------------------------} + +instance ToExceptionDoc CallStack where + toExceptionDoc _ cs = + fromLines $ prettyCallStack cs + +instance ToExceptionDoc Backtraces where + toExceptionDoc _ bt = + fromLines $ displayBacktraces bt + +#if MIN_VERSION_base(4,20,0) +instance ToExceptionDoc ExceptionContext where + toExceptionDoc ctx (ExceptionContext anns) = toExceptionDoc ctx anns +#endif + +#ifdef PATCHED_GHC_FOR_EXCEPTION_DEBUGGING +instance ToExceptionDoc Base.WhileHandling where + toExceptionDoc ctx (Base.WhileHandling cs e) = + withHeader "WhileHandling" $ mconcat [ + fromLines $ prettyCallStack cs + , toExceptionDoc ctx e + ] +#elif MIN_VERSION_base(4,21,0) +instance ToExceptionDoc Base.WhileHandling where + toExceptionDoc ctx (Base.WhileHandling e) = + withHeader "WhileHandling" $ toExceptionDoc ctx e +#endif + +#if MIN_VERSION_base(4,20,0) +instance ToExceptionDoc SomeExceptionAnnotation where + toExceptionDoc ctx (SomeExceptionAnnotation ann) = + formatExceptionAnnotation ctx ann +#endif + +#ifndef PATCHED_GHC_FOR_EXCEPTION_DEBUGGING +deriving anyclass instance ToExceptionDoc AtomicallyBacktrace +#endif + +{------------------------------------------------------------------------------- + Instances for common /exceptions/ + + NOTE: It is important that for every instance we provide here we also provide + an entry in the 'defaultFormatCtx'. +-------------------------------------------------------------------------------} + +instance ToExceptionDoc Base.SomeException where + toExceptionDoc ctx (Base.SomeException e) = + mconcat [ + formatException ctx e +#if MIN_VERSION_base(4,20,0) + , toExceptionDoc ctx ?exceptionContext +#endif + ] + +instance ToExceptionDoc Base.SomeAsyncException where + toExceptionDoc ctx (Base.SomeAsyncException e) = + withHeader "SomeAsyncException" $ formatException ctx e + +deriving newtype instance ToExceptionDoc ExactException + +{------------------------------------------------------------------------------- + Interaction with the 'FormatCtx' +-------------------------------------------------------------------------------} + +insertFormatCtx_ :: forall e. + (Typeable e, ToExceptionDoc e) + => Proxy e -> FormatCtx -> FormatCtx +insertFormatCtx_ _ = insertFormatCtx (toExceptionDoc @e) + +-- | Default 'FormatCtx' +-- +-- Notes: +-- +-- * If we have an exception or exception annotation of known type, and that +-- type has a 'ToExceptionDoc' instance, we can call 'renderKnown'. +-- +-- * If we are dealing with exceptions or annotations of unknown type, perhaps +-- defined in other libraries, there /might/ be a 'ToExceptionDoc' instance; +-- but we're not aware of it! This is the purpose of 'renderAnyException' and +-- 'renderAnyExceptionAnnotation': instead of doing a static lookup, we accept +-- a 'FormatCtx' as argument which upstream code might have populated with +-- suitable renderers. +-- +-- The true upstream solution to this would be to make something add a +-- 'ToExceptionDoc' (or similiar) constraint to 'SomeException'l this would +-- obsolete the need for 'FormatCtx'. +-- +-- * Since 'renderAnyException' and 'renderAnyExceptionAnnotation' do not have +-- any information to work with other than an 'Exception' or +-- 'ExceptionAnnotation' instance, they cannot even take advantage of any +-- instances that we provide here. Therefore it is very important that any +-- 'ToExceptionDoc' instance we define gets an entry in this list; without it, +-- if we catch say 'SomeException' somewhere, and call 'renderAnyException' on +-- it, even if it happens to be one of our own types, and that type has a +-- 'ToExceptionDoc' instance, we'd still not be able to take advantage of it. +-- +-- * The entries for 'SomeException', 'ExactException' and +-- 'SomeExceptionAnnotation' are mostly for convenience: /if/ a user calls +-- 'renderAnyException' on an argument of type 'SomeException', we'll still get +-- the correct result (the user could call 'renderKnown' instead of course). +defaultFormatCtx :: FormatCtx +defaultFormatCtx = emptyFormatCtx + + -- + -- Exception annotations + -- + + & insertFormatCtx_ (Proxy @CallStack) + & insertFormatCtx_ (Proxy @Backtraces) +#if MIN_VERSION_base(4,20,0) + & insertFormatCtx_ (Proxy @ExceptionContext) + & insertFormatCtx_ (Proxy @SomeExceptionAnnotation) +#endif +#if MIN_VERSION_base(4,21,0) + & insertFormatCtx_ (Proxy @Base.WhileHandling) +#endif +#ifndef PATCHED_GHC_FOR_EXCEPTION_DEBUGGING + & insertFormatCtx_ (Proxy @AtomicallyBacktrace) +#endif + + -- + -- Exceptions + -- + + & insertFormatCtx_ (Proxy @Base.SomeException) + & insertFormatCtx_ (Proxy @Base.SomeAsyncException) + & insertFormatCtx_ (Proxy @ExactException) diff --git a/src/Network/GRPC/Util/GHC.hs b/src/Network/GRPC/Util/GHC.hs --- a/src/Network/GRPC/Util/GHC.hs +++ b/src/Network/GRPC/Util/GHC.hs @@ -6,10 +6,11 @@ , asyncLabelled ) where -import Control.Concurrent.Async -import Control.Exception -import Control.Monad.IO.Class -import GHC.Conc +import Control.Concurrent (ThreadId, myThreadId, forkIOWithUnmask) +import Control.Concurrent.Async (Async, asyncWithUnmask) +import Control.Exception (mask_) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import GHC.Conc (labelThread) {------------------------------------------------------------------------------- Thread labelling diff --git a/src/Network/GRPC/Util/HTTP2.hs b/src/Network/GRPC/Util/HTTP2.hs --- a/src/Network/GRPC/Util/HTTP2.hs +++ b/src/Network/GRPC/Util/HTTP2.hs @@ -1,42 +1,27 @@ +-- Note: atm this module is used only by Server.Run module Network.GRPC.Util.HTTP2 ( - -- * General auxiliary - fromHeaderTable -- * Configuration - , withConfigForInsecure - , withConfigForSecure + withConfigForInsecure, + withConfigForSecure, -- * Settings - , mkServerConfig - , mkTlsSettings - -- * Timeouts - , withTimeManager + mkServerConfig, + mkTlsSettings, ) where -import Control.Exception -import Data.Bifunctor +import Network.GRPC.Util.Imports + import Data.ByteString qualified as Strict (ByteString) import Foreign (mallocBytes, free) import Network.HPACK (BufferSize) -import Network.HPACK qualified as HPACK -import Network.HPACK.Token qualified as HPACK -import Network.HTTP.Types qualified as HTTP import Network.HTTP2.Server qualified as Server import Network.HTTP2.TLS.Server qualified as Server.TLS import Network.Socket (Socket, SockAddr) import Network.Socket qualified as Socket -import Network.Socket.BufferPool (Recv) import Network.Socket.BufferPool qualified as Recv import Network.Socket.ByteString qualified as Socket -import System.TimeManager qualified as Time (Manager) -import System.TimeManager qualified as TimeManager import Network.GRPC.Common.HTTP2Settings - -{------------------------------------------------------------------------------- - General auxiliary --------------------------------------------------------------------------------} - -fromHeaderTable :: HPACK.TokenHeaderTable -> [HTTP.Header] -fromHeaderTable = map (first HPACK.tokenKey) . fst +import Network.GRPC.Util.TimeManager (TimeManager, disableTimeout) {------------------------------------------------------------------------------- Configuration @@ -48,7 +33,7 @@ -- instead create a config that is very similar to the config created by -- 'allocConfigForSecure'. withConfigForInsecure :: - Time.Manager + TimeManager -> Socket -> (Server.Config -> IO a) -> IO a @@ -67,20 +52,17 @@ peersa k where - def :: Server.TLS.Settings - def = Server.TLS.defaultSettings - -- Use the defaults from @http2-tls@ readBufferLowerLimit, readBufferSize :: Int - readBufferLowerLimit = Server.TLS.settingsReadBufferLowerLimit def - readBufferSize = Server.TLS.settingsReadBufferSize def + readBufferLowerLimit = Server.TLS.settingsReadBufferLowerLimit Server.TLS.defaultSettings + readBufferSize = Server.TLS.settingsReadBufferSize Server.TLS.defaultSettings -- | Create config to be used with @http2-tls@ (with TLS) -- -- This is adapted from @allocConfigForServer@ in -- @http2-tls:Network.HTTP2.TLS.Config@. withConfigForSecure :: - Time.Manager + TimeManager -> Server.TLS.IOBackend -> (Server.Config -> IO a) -> IO a @@ -94,9 +76,9 @@ -- | Internal generalization withConfig :: - Time.Manager + TimeManager -> (Strict.ByteString -> IO ()) - -> Recv + -> Recv.Recv -> SockAddr -> SockAddr -> (Server.Config -> IO a) @@ -104,15 +86,14 @@ withConfig mgr send recv mysa peersa k = bracket (mallocBytes writeBufferSize) free $ \buf -> do recvN <- Recv.makeRecvN mempty recv - k Server.Config { - confWriteBuffer = buf - , confBufferSize = writeBufferSize - , confSendAll = send - , confReadN = recvN - , confPositionReadMaker = Server.defaultPositionReadMaker - , confTimeoutManager = mgr - , confMySockAddr = mysa - , confPeerSockAddr = peersa + k Server.defaultConfig{ + Server.confWriteBuffer = buf + , Server.confBufferSize = writeBufferSize + , Server.confSendAll = send + , Server.confReadN = recvN + , Server.confTimeoutManager = mgr + , Server.confMySockAddr = mysa + , Server.confPeerSockAddr = peersa } where -- This is the default value for @settingsSendBufferSize@ in @http2-tls@ @@ -197,26 +178,3 @@ Nothing -> Server.rstRateLimit Server.defaultSettings Just limit -> limit } - -{------------------------------------------------------------------------------- - Timeouts --------------------------------------------------------------------------------} - --- | Allocate time manager (without any actual timeouts) --- --- The @http2@ ecosystem relies on a time manager for timeouts; we don't use --- those timeouts (see disableTimeout), but must still provide a time manager --- for insecure connections. For secure connections the time manager is --- allocated in 'Network.Run.Timeout.runTCPServerWithSocket' from @network-run@. --- In that package it allocates a single manager for the entire server (it --- allocates the manager before calling accept), so we should do the same in the --- insecure case for better consistency between the two setups; this also avoids --- the possibility of leaking managers. -withTimeManager :: (Time.Manager -> IO a) -> IO a -withTimeManager = TimeManager.withManager (disableTimeout * 1_000_000) - --- | Disable timeouts in http2/http2-tls --- --- A value of 0 (or lower) disables timeouts as of @time-manager-0.2.2@. -disableTimeout :: Int -disableTimeout = 0 diff --git a/src/Network/GRPC/Util/HTTP2/Stream.hs b/src/Network/GRPC/Util/HTTP2/Stream.hs deleted file mode 100644 --- a/src/Network/GRPC/Util/HTTP2/Stream.hs +++ /dev/null @@ -1,207 +0,0 @@ -module Network.GRPC.Util.HTTP2.Stream ( - -- * Streams - OutputStream -- opaque - , writeChunk - , writeChunkFinal - , flush - , InputStream -- opaque - , getChunk - , getTrailers - -- * Server API - , serverOutputStream - , serverInputStream - -- ** Client API - , clientInputStream - , clientOutputStream - -- * Exceptions - , ClientDisconnected(..) - , ServerDisconnected(..) - , wrapStreamExceptionsWith - ) where - -import Control.Exception -import Data.Binary.Builder (Builder) -import Data.ByteString qualified as Strict (ByteString) -import GHC.Stack -import Network.HTTP.Types qualified as HTTP -import Network.HTTP2.Client qualified as Client -import Network.HTTP2.Server qualified as Server -import Network.HTTP2.Server (OutBodyIface(..)) - -import Network.GRPC.Util.HTTP2 (fromHeaderTable) - -{------------------------------------------------------------------------------- - Streams --------------------------------------------------------------------------------} - -data OutputStream = OutputStream { - -- | Write a chunk to the stream - _writeChunk :: HasCallStack => Builder -> IO () - - -- | Write the final chunk to the stream - , _writeChunkFinal :: HasCallStack => Builder -> IO () - - -- | Flush the stream (send frames to the peer) - , _flush :: HasCallStack => IO () - } - -data InputStream = InputStream { - _getChunk :: HasCallStack => IO (Strict.ByteString, Bool) - , _getTrailers :: HasCallStack => IO [HTTP.Header] - } - -{------------------------------------------------------------------------------- - Wrappers to get the proper CallStack --------------------------------------------------------------------------------} - -writeChunk :: HasCallStack => OutputStream -> Builder -> IO () -writeChunk = _writeChunk - -writeChunkFinal :: HasCallStack => OutputStream -> Builder -> IO () -writeChunkFinal = _writeChunkFinal - -flush :: HasCallStack => OutputStream -> IO () -flush = _flush - -getChunk :: HasCallStack => InputStream -> IO (Strict.ByteString, Bool) -getChunk = _getChunk - -getTrailers :: HasCallStack => InputStream -> IO [HTTP.Header] -getTrailers = _getTrailers - -{------------------------------------------------------------------------------- - Server API --------------------------------------------------------------------------------} - -serverInputStream :: Server.Request -> IO InputStream -serverInputStream req = do - return InputStream { - _getChunk = - wrapStreamExceptionsWith ClientDisconnected $ - Server.getRequestBodyChunk' req - , _getTrailers = - wrapStreamExceptionsWith ClientDisconnected $ - maybe [] fromHeaderTable <$> Server.getRequestTrailers req - } - --- | Create output stream --- --- == Note on the use of Trailers-Only in non-error cases --- --- If the stream is closed without writing anything, the situation is similar to --- the gRPC @Trailers-Only@ case, except that we have already sent the initial --- set of headers. In this case, http2 will (reasonably enough) create an empty --- DATA frame, and then another HEADERS frame for the trailers. This is conform --- the gRPC specification, which mandates: --- --- > Most responses are expected to have both headers and trailers but --- > Trailers-Only is permitted for calls that produce an immediate error. --- --- If we compare this to the official Python example @RouteGuide@ server, --- however, we see that the @Trailers-Only@ case is sometimes also used in --- non-error cases. An example is @RouteGuide.listFeatures@: when there /are/ no --- features in the specified rectangle, the server will send no messages back to --- the client. The example Python server will use the gRPC Trailers-Only case --- here (and so we must be able to deal with that in our client implementation). --- --- We do provide this functionality, but only through a specific API (see --- 'sendTrailersOnly'); when that API is used, we do not make use of this --- 'OutputStream' abstraction (indeed, we do not stream at all). In streaming --- cases (the default) we do not make use of @Trailers-Only@. -serverOutputStream :: OutBodyIface -> IO OutputStream -serverOutputStream iface = do - -- Make sure that http2 does not wait for the first message before sending - -- the response headers. This is important: the client might want the - -- initial response metadata before the first message. - -- - -- This does require some justification; if any of the reasons below is - -- no longer true, we might need to reconsider: - -- - -- o The extra cost of this flush is that we might need an additional TCP - -- packet; no big deal. - -- o We only create the 'OutputStream' once the user actually initiates the - -- response, at which point the headers are fixed. - -- o We do not use an 'OutputStream' at all when we are in the Trailers-Only - -- case (see discussion above). - - let outputStream = OutputStream { - _writeChunk = \c -> - wrapStreamExceptionsWith ClientDisconnected $ - outBodyPush iface c - , _writeChunkFinal = \c -> - wrapStreamExceptionsWith ClientDisconnected $ - outBodyPushFinal iface c - , _flush = - wrapStreamExceptionsWith ClientDisconnected $ - outBodyFlush iface - } - - flush outputStream - return outputStream - -{------------------------------------------------------------------------------- - Client API --------------------------------------------------------------------------------} - -clientInputStream :: Client.Response -> IO InputStream -clientInputStream resp = do - return InputStream { - _getChunk = - wrapStreamExceptionsWith ServerDisconnected $ - Client.getResponseBodyChunk' resp - , _getTrailers = - wrapStreamExceptionsWith ServerDisconnected $ - maybe [] fromHeaderTable <$> Client.getResponseTrailers resp - } - --- | Construct a client 'OutputStream' --- --- We do not wrap the members of the 'OutputStream' with --- 'wrapStreamExceptionsWith', since we do this around the entire --- 'sendMessageLoop'. See the comment for @outboundThread@ in --- 'Network.GRPC.Util.Session.Client.setupRequestChannel'. -clientOutputStream :: OutBodyIface -> IO OutputStream -clientOutputStream iface = - return OutputStream { - _writeChunk = \c -> - outBodyPush iface c - , _writeChunkFinal = \c -> - outBodyPushFinal iface c - , _flush = - outBodyFlush iface - } - -{------------------------------------------------------------------------------- - Exceptions --------------------------------------------------------------------------------} - --- | Client disconnected unexpectedly --- --- /If/ you choose to catch this exception, you are advised to match against --- the type, rather than against the constructor, and then use the record --- accessors to get access to the fields. Future versions of @grapesy@ may --- record more information. -data ClientDisconnected = ClientDisconnected { - clientDisconnectedException :: SomeException - , clientDisconnectedCallStack :: CallStack - } - deriving stock (Show) - deriving anyclass (Exception) - --- | Server disconnected unexpectedly --- --- See comments for 'ClientDisconnected' on how to catch this exception. -data ServerDisconnected = ServerDisconnected { - serverDisconnectedException :: SomeException - , serverDisconnectedCallstack :: CallStack - } - deriving stock (Show) - deriving anyclass (Exception) - -wrapStreamExceptionsWith :: - (HasCallStack, Exception e) - => (SomeException -> CallStack -> e) - -> IO a -> IO a -wrapStreamExceptionsWith f action = - action `catch` \err -> - throwIO $ f err callStack diff --git a/src/Network/GRPC/Util/HeaderTable.hs b/src/Network/GRPC/Util/HeaderTable.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Util/HeaderTable.hs @@ -0,0 +1,17 @@ +module Network.GRPC.Util.HeaderTable ( + -- * General auxiliary + fromHeaderTable, +) where + +import Network.GRPC.Util.Imports + +import Network.HTTP.Types qualified as HTTP +import Network.HTTP.Semantics qualified as HTTP.Semantics + +{------------------------------------------------------------------------------- + General auxiliary +-------------------------------------------------------------------------------} + + +fromHeaderTable :: HTTP.Semantics.TokenHeaderTable -> [HTTP.Header] +fromHeaderTable = map (first HTTP.Semantics.tokenKey) . fst diff --git a/src/Network/GRPC/Util/Imports.hs b/src/Network/GRPC/Util/Imports.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Util/Imports.hs @@ -0,0 +1,36 @@ +module Network.GRPC.Util.Imports ( + module X, + module Network.GRPC.Spec, + module Network.GRPC.Spec.Serialization, +) where + +import Control.Concurrent.Async as X (Async, cancelWith, wait, withAsync) +import Control.DeepSeq as X (NFData, force) +import Control.Exception as X (evaluate) +import Control.Exception as X (Exception (toException, fromException, displayException), bracket, catch) +import Control.Monad as X (void, when, unless, forM_) +import Control.Monad.Catch as X (ExitCase(..)) +import Control.Monad.IO.Class as X (MonadIO(liftIO)) +import Data.Bifoldable as X (Bifoldable (bifoldMap)) +import Data.Bifunctor as X (Bifunctor (bimap, first, second)) +import Data.Bitraversable as X (Bitraversable (bitraverse)) +import Data.Default as X (Default(def)) +import Data.Foldable as X (asum, toList) +import Data.Function as X ((&)) +import Data.HashMap.Strict as X (HashMap) +import Data.Kind as X (Type) +import Data.List.NonEmpty as X (NonEmpty (..)) +import Data.Maybe as X (fromMaybe) +import Data.Proxy as X (Proxy (..)) +import Data.Semigroup as X (Semigroup (..)) +import Data.String as X (IsString (..)) +import Data.Text as X (Text) +import Data.Typeable as X (Typeable) +import Data.Void as X (Void, absurd) +import GHC.Generics as X (Generic) +import GHC.Stack as X (HasCallStack, CallStack, callStack) +import GHC.TypeLits as X (Symbol) + +-- from grpc-spec +import Network.GRPC.Spec +import Network.GRPC.Spec.Serialization diff --git a/src/Network/GRPC/Util/RedundantConstraint.hs b/src/Network/GRPC/Util/RedundantConstraint.hs --- a/src/Network/GRPC/Util/RedundantConstraint.hs +++ b/src/Network/GRPC/Util/RedundantConstraint.hs diff --git a/src/Network/GRPC/Util/ServerStream.hs b/src/Network/GRPC/Util/ServerStream.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Util/ServerStream.hs @@ -0,0 +1,83 @@ +module Network.GRPC.Util.ServerStream ( + -- * Server API + serverOutputStream, + serverInputStream, +) where + +import Network.HTTP.Semantics (OutBodyIface) +import Network.HTTP.Semantics qualified as HTTP +import Network.HTTP.Semantics.Server qualified as Server + +import Network.GRPC.Util.HeaderTable (fromHeaderTable) +import Network.GRPC.Util.Imports +import Network.GRPC.Util.Stream + +{------------------------------------------------------------------------------- + Server API +-------------------------------------------------------------------------------} + +serverInputStream :: Server.Request -> IO InputStream +serverInputStream req = do + return InputStream { + _getChunk = + wrapClientDisconnected $ + Server.getRequestBodyChunk' req + , _getTrailers = + wrapClientDisconnected $ + maybe [] fromHeaderTable <$> Server.getRequestTrailers req + } + +-- | Create output stream +-- +-- == Note on the use of Trailers-Only in non-error cases +-- +-- If the stream is closed without writing anything, the situation is similar to +-- the gRPC @Trailers-Only@ case, except that we have already sent the initial +-- set of headers. In this case, http2 will (reasonably enough) create an empty +-- DATA frame, and then another HEADERS frame for the trailers. This is conform +-- the gRPC specification, which mandates: +-- +-- > Most responses are expected to have both headers and trailers but +-- > Trailers-Only is permitted for calls that produce an immediate error. +-- +-- If we compare this to the official Python example @RouteGuide@ server, +-- however, we see that the @Trailers-Only@ case is sometimes also used in +-- non-error cases. An example is @RouteGuide.listFeatures@: when there /are/ no +-- features in the specified rectangle, the server will send no messages back to +-- the client. The example Python server will use the gRPC Trailers-Only case +-- here (and so we must be able to deal with that in our client implementation). +-- +-- We do provide this functionality, but only through a specific API (see +-- 'sendTrailersOnly'); when that API is used, we do not make use of this +-- 'OutputStream' abstraction (indeed, we do not stream at all). In streaming +-- cases (the default) we do not make use of @Trailers-Only@. +serverOutputStream :: HasCallStack => OutBodyIface -> IO OutputStream +serverOutputStream iface = do + -- Make sure that http2 does not wait for the first message before sending + -- the response headers. This is important: the client might want the + -- initial response metadata before the first message. + -- + -- This does require some justification; if any of the reasons below is + -- no longer true, we might need to reconsider: + -- + -- o The extra cost of this flush is that we might need an additional TCP + -- packet; no big deal. + -- o We only create the 'OutputStream' once the user actually initiates the + -- response, at which point the headers are fixed. + -- o We do not use an 'OutputStream' at all when we are in the Trailers-Only + -- case (see discussion above). + + let outputStream = OutputStream { + _writeChunk = \c -> + wrapClientDisconnected $ + HTTP.outBodyPush iface c + , _writeChunkFinal = \c -> + wrapClientDisconnected $ + HTTP.outBodyPushFinal iface c + , _flush = + wrapClientDisconnected $ + HTTP.outBodyFlush iface + } + + flush outputStream + return outputStream diff --git a/src/Network/GRPC/Util/Session.hs b/src/Network/GRPC/Util/Session.hs deleted file mode 100644 --- a/src/Network/GRPC/Util/Session.hs +++ /dev/null @@ -1,57 +0,0 @@ --- | Session interface --- --- A \"session\" is a series of messages exchanged by two nodes in a network; --- we might be a client and our peer might be a server, or we might be a --- server and our peer might be a client. Here we provide a abstraction which --- --- * takes care of concurrency issues --- * is typed, with different types for inbound and outbound headers, messages --- and trailers --- * works the same way whether we are a client or a server. --- --- Intended for qualified import. --- --- > import Network.GRPC.Util.Session qualified as Session -module Network.GRPC.Util.Session ( - -- * Session API - DataFlow(..) - , FlowStart(..) - , IsSession(..) - , InitiateSession(..) - , NoTrailers(..) - -- ** Raw request/response info - , RequestInfo(..) - , ResponseInfo(..) - -- ** Exceptions - , PeerException(..) - -- * Channel - , Channel(..) - -- ** Working with an open channel - , getInboundHeaders - , send - , recvBoth - , recvEither - , RecvFinal(..) - , RecvAfterFinal(..) - , SendAfterFinal(..) - -- ** Closing - , waitForOutbound - , close - , ChannelDiscarded(..) - , ChannelAborted(..) - -- ** Half-closing - , AllowHalfClosed(..) - -- ** Construction - -- *** Client - , ConnectionToServer(..) - , CancelRequest - , setupRequestChannel - -- *** Server - , ConnectionToClient(..) - , setupResponseChannel - ) where - -import Network.GRPC.Util.Session.API -import Network.GRPC.Util.Session.Channel -import Network.GRPC.Util.Session.Client -import Network.GRPC.Util.Session.Server diff --git a/src/Network/GRPC/Util/Session/API.hs b/src/Network/GRPC/Util/Session/API.hs --- a/src/Network/GRPC/Util/Session/API.hs +++ b/src/Network/GRPC/Util/Session/API.hs @@ -11,14 +11,12 @@ , PeerException(..) ) where -import Control.Exception +import Network.GRPC.Util.Imports + import Data.ByteString.Builder (Builder) import Data.ByteString.Lazy qualified as Lazy (ByteString) -import Data.Kind import Network.HTTP.Types qualified as HTTP - --- Doesn't really matter if we import this from .Client or .Server -import Network.HTTP2.Client qualified as HTTP2 (Path) +import Network.HTTP.Semantics qualified as HTTP.Semantics (Path) import Network.GRPC.Spec.Util.Parser (Parser) @@ -28,7 +26,7 @@ data RequestInfo = RequestInfo { requestMethod :: HTTP.Method - , requestPath :: HTTP2.Path + , requestPath :: HTTP.Semantics.Path , requestHeaders :: [HTTP.Header] } deriving (Show) diff --git a/src/Network/GRPC/Util/Session/Channel.hs b/src/Network/GRPC/Util/Session/Channel.hs --- a/src/Network/GRPC/Util/Session/Channel.hs +++ b/src/Network/GRPC/Util/Session/Channel.hs @@ -7,7 +7,6 @@ Channel(..) , initChannel -- ** Flow state - , FlowState(..) , RegularFlowState(..) , initFlowStateRegular -- * Working with an open channel @@ -23,39 +22,33 @@ , close , ChannelDiscarded(..) , ChannelAborted(..) - -- * Support for half-closing - , InboundResult - , AllowHalfClosed(..) - , linkOutboundToInbound -- * Constructing channels , sendMessageLoop , recvMessageLoop , outboundTrailersMaker ) where -import Control.Concurrent.STM -import Control.DeepSeq (NFData, force) -import Control.Exception -import Control.Monad -import Control.Monad.Catch (ExitCase(..)) -import Data.Bifunctor + +import Network.GRPC.Util.Imports + +import Control.Concurrent.STM (STM, TVar, TMVar) +import Control.Concurrent.STM qualified as STM import Data.ByteString.Builder (Builder) import Data.ByteString.Lazy qualified as BS.Lazy -import GHC.Stack --- Doesn't really matter if we import from .Client or .Server -import Network.HTTP2.Client qualified as HTTP2 ( +import Network.HTTP.Semantics qualified as HTTP.Semantics ( TrailersMaker , NextTrailersMaker(..) ) +import Network.GRPC.Common.Exception import Network.GRPC.Common.StreamElem (StreamElem(..)) import Network.GRPC.Common.StreamElem qualified as StreamElem import Network.GRPC.Spec.Util.Parser (Parser) import Network.GRPC.Spec.Util.Parser qualified as Parser -import Network.GRPC.Util.HTTP2.Stream import Network.GRPC.Util.RedundantConstraint import Network.GRPC.Util.Session.API +import Network.GRPC.Util.Stream import Network.GRPC.Util.Thread {------------------------------------------------------------------------------- @@ -86,17 +79,17 @@ -- Each channel is constructed for a /single/ session (request/response). data Channel sess = Channel { -- | Thread state of the thread receiving messages from the peer - channelInbound :: TVar (ThreadState (FlowState (Inbound sess))) + channelInbound :: TVar (FlowThreadState (Inbound sess)) -- | Thread state of the thread sending messages to the peer - , channelOutbound :: TVar (ThreadState (FlowState (Outbound sess))) + , channelOutbound :: TVar (FlowThreadState (Outbound sess)) -- | Have we sent the final message? -- -- The sole purpose of this 'TVar' is catching user mistakes: if there is -- another 'send' after the final message, we can throw an exception, -- rather than the message simply being lost or blockng indefinitely. - , channelSentFinal :: TVar (Maybe CallStack) + , channelSentFinal :: TVar (Maybe Backtraces) -- | Have we received the final message? -- @@ -106,20 +99,34 @@ , channelRecvFinal :: TVar (RecvFinal (Inbound sess)) } +-- | Thread that deals with inbound or outbound flow +type FlowThreadState flow = + ThreadState + (RegularFlowState flow) + (Trailers flow) + (NoMessages flow) + +-- | Interface to 'FlowThreadState' +type FlowThreadIface flow = + ThreadIface + (RegularFlowState flow) + (NoMessages flow) + +-- | Has the client code received the final message from the peer yet? +-- +-- NOTE: \"delivered\" here means: put the final message that we received from +-- the peer into the hands of the client code. data RecvFinal flow = - -- | We have not yet delivered the final message to the client + -- | We have not yet delivered the final message to the client code RecvNotFinal -- | We delivered the final message, but not yet the trailers | RecvWithoutTrailers (Trailers flow) -- | We delivered the final message and the trailers - | RecvFinal CallStack + | RecvFinal Backtraces --- | Data flow state -data FlowState flow = - FlowStateRegular (RegularFlowState flow) - | FlowStateNoMessages (NoMessages flow) +deriving instance DataFlow flow => Show (RecvFinal flow) -- | Regular (streaming) flow state data RegularFlowState flow = RegularFlowState { @@ -132,7 +139,7 @@ -- -- On the server side, the inbound headers are recorded when the request -- comes in, and the outbound headers are specified - -- ('setResponseMetadata') before the response is initiated + -- ('setResponseInitialMetadata') before the response is initiated -- ('initiateResponse'/'sendTrailersOnly'). flowHeaders :: Headers flow @@ -173,6 +180,13 @@ -- available by 'recvMessageLoop'. -- -- /Their/ sole purpose is to catch user errors, not capture data flow. + -- + -- == Relation to 'ThreadState' + -- + -- Although the threads write their final result (that is, the trailers) + -- to the 'ThreadState', we cannot use that in the trailers maker, because + -- the trailers are constructed /within/ the thread: that is, before it + -- terminates. , flowTerminated :: TMVar (Trailers flow) } @@ -187,12 +201,17 @@ Initialization -------------------------------------------------------------------------------} -initChannel :: HasCallStack => IO (Channel sess) -initChannel = do - channelInbound <- newThreadState - channelOutbound <- newThreadState - channelSentFinal <- newTVarIO Nothing - channelRecvFinal <- newTVarIO RecvNotFinal +initChannel :: + String + -- ^ Role (server or client) + -- + -- This is used for debugging, to label the inbound and outbound thread. + -> IO (Channel sess) +initChannel role = do + channelInbound <- newThreadState (role ++ "/inbound") + channelOutbound <- newThreadState (role ++ "/outbound") + channelSentFinal <- STM.newTVarIO Nothing + channelRecvFinal <- STM.newTVarIO RecvNotFinal return Channel{ channelInbound , channelOutbound @@ -202,8 +221,8 @@ initFlowStateRegular :: Headers flow -> IO (RegularFlowState flow) initFlowStateRegular flowHeaders = do - flowMsg <- newEmptyTMVarIO - flowTerminated <- newEmptyTMVarIO + flowMsg <- STM.newEmptyTMVarIO + flowTerminated <- STM.newEmptyTMVarIO return RegularFlowState { flowHeaders , flowMsg @@ -223,11 +242,10 @@ getInboundHeaders Channel{channelInbound} = withThreadInterface channelInbound (return . aux) where - aux :: forall flow. - FlowState flow - -> Either (NoMessages flow) (Headers flow) - aux (FlowStateRegular regular) = Right $ flowHeaders regular - aux (FlowStateNoMessages trailers) = Left trailers + aux :: FlowThreadIface flow -> Either (NoMessages flow) (Headers flow) + aux = \case + IfaceAvailable regular -> Right $ flowHeaders regular + IfaceTrivial trailers -> Left trailers -- | Send a message to the node's peer -- @@ -241,33 +259,34 @@ -> IO () send Channel{channelOutbound, channelSentFinal} = \msg -> do msg' <- evaluate $ force <$> msg - withThreadInterface channelOutbound $ aux msg' + backtrace <- collectBacktraces + withThreadInterface channelOutbound $ aux backtrace msg' where aux :: - StreamElem (Trailers (Outbound sess)) (Message (Outbound sess)) - -> FlowState (Outbound sess) + Backtraces + -> StreamElem (Trailers (Outbound sess)) (Message (Outbound sess)) + -> FlowThreadIface (Outbound sess) -> STM () - aux msg st = do + aux backtrace msg iface = do -- By checking that we haven't sent the final message yet, we know that -- this call to 'putMVar' will not block indefinitely: the thread that -- sends messages to the peer will get to it eventually (unless it dies, -- in which case the thread status will change and the call to -- 'getThreadInterface' will be retried). - sentFinal <- readTVar channelSentFinal + sentFinal <- STM.readTVar channelSentFinal case sentFinal of - Just cs -> throwSTM $ SendAfterFinal cs + Just cs -> STM.throwSTM $ SendAfterFinal cs Nothing -> return () - case st of - FlowStateRegular regular -> do + case iface of + IfaceAvailable regular -> do StreamElem.whenDefinitelyFinal msg $ \_trailers -> - writeTVar channelSentFinal $ Just callStack - - putTMVar (flowMsg regular) msg - FlowStateNoMessages _ -> + STM.writeTVar channelSentFinal $ Just backtrace + STM.putTMVar (flowMsg regular) msg + IfaceTrivial _trailers -> -- For outgoing messages, the caller decides to use Trailers-Only, -- so if they then subsequently call 'send', we throw an exception. -- This is different for /inbound/ messages; see 'recv', below. - throwSTM $ SendButTrailersOnly + STM.throwSTM $ SendButTrailersOnly -- | Receive a message from the node's peer -- @@ -276,7 +295,7 @@ -- and the trailers together. It is a bug to call 'recvBoth' again after this; -- doing so will result in a 'RecvAfterFinal' exception. recvBoth :: forall sess. - HasCallStack + (HasCallStack, IsSession sess) => Channel sess -> IO ( Either (NoMessages (Inbound sess)) @@ -296,7 +315,7 @@ -- 'recvEither'. Call 'recvEither' again /after/ receiving the trailers is a -- bug; doing so will result in a 'RecvAfterFinal' exception. recvEither :: - HasCallStack + (HasCallStack, IsSession sess) => Channel sess -> IO ( Either (NoMessages (Inbound sess)) @@ -310,7 +329,7 @@ -- | Internal generalization of 'recvBoth' and 'recvEither' recv' :: forall sess b. - HasCallStack + (HasCallStack, IsSession sess) => (Message (Inbound sess) -> b) -- ^ Message without trailers -> (Trailers (Inbound sess) -> b) -- ^ Trailers without (final) message -> ( (Message (Inbound sess), Trailers (Inbound sess)) @@ -325,24 +344,28 @@ recv' messageWithoutTrailers trailersWithoutMessage messageWithTrailers - Channel{channelInbound, channelRecvFinal} = - withThreadInterface channelInbound aux + Channel{channelInbound, channelRecvFinal} = do + backtrace <- collectBacktraces + withThreadInterface channelInbound $ aux backtrace where + _ = addConstraint @(IsSession sess) + aux :: - FlowState (Inbound sess) + Backtraces + -> FlowThreadIface (Inbound sess) -> STM (Either (NoMessages (Inbound sess)) b) - aux st = do + aux backtrace iface = do -- By checking that we haven't received the final message yet, we know -- that this call to 'takeTMVar' will not block indefinitely: the thread -- that receives messages from the peer will get to it eventually -- (unless it dies, in which case the thread status will change and the -- call to 'getThreadInterface' will be retried). - readFinal <- readTVar channelRecvFinal + readFinal <- STM.readTVar channelRecvFinal case readFinal of RecvNotFinal -> - case st of - FlowStateRegular regular -> Right <$> do - streamElem <- takeTMVar (flowMsg regular) + case iface of + IfaceAvailable regular -> Right <$> do + streamElem <- STM.takeTMVar (flowMsg regular) -- We update 'channelRecvFinal' in the same tx as the read, to -- atomically change "there is a value" to "all values read". case streamElem of @@ -350,29 +373,29 @@ return $ messageWithoutTrailers msg FinalElem msg trailers -> do let (b, mTrailers) = messageWithTrailers (msg, trailers) - writeTVar channelRecvFinal $ - maybe (RecvFinal callStack) RecvWithoutTrailers mTrailers + STM.writeTVar channelRecvFinal $ + maybe (RecvFinal backtrace) RecvWithoutTrailers mTrailers return $ b NoMoreElems trailers -> do - writeTVar channelRecvFinal $ RecvFinal callStack + STM.writeTVar channelRecvFinal $ RecvFinal backtrace return $ trailersWithoutMessage trailers - FlowStateNoMessages trailers -> do - writeTVar channelRecvFinal $ RecvFinal callStack + IfaceTrivial trailers -> do + STM.writeTVar channelRecvFinal $ RecvFinal backtrace return $ Left trailers RecvWithoutTrailers trailers -> do - writeTVar channelRecvFinal $ RecvFinal callStack + STM.writeTVar channelRecvFinal $ RecvFinal backtrace return $ Right $ trailersWithoutMessage trailers RecvFinal cs -> - throwSTM $ RecvAfterFinal cs + STM.throwSTM $ RecvAfterFinal cs -- | Thrown by 'send' -- --- The 'CallStack' is the callstack of the final call to 'send'. --- -- See 'send' for additional discussion. data SendAfterFinal = -- | Call to 'send' after the final message was sent - SendAfterFinal CallStack + -- + -- We record the backtrace of final call to 'send'. + SendAfterFinal Backtraces -- | Call to 'send', but we are in the Trailers-Only case | SendButTrailersOnly @@ -381,12 +404,13 @@ -- | Thrown by 'recv' -- --- The 'CallStack' is the callstack of the final call to 'recv'. -- -- See 'recv' for additional discussion. data RecvAfterFinal = -- | Call to 'recv' after the final message was already received - RecvAfterFinal CallStack + -- + -- We record the backtrace of final call to 'recv'. + RecvAfterFinal Backtraces deriving stock (Show) deriving anyclass (Exception) @@ -397,64 +421,51 @@ -- | Wait for the outbound thread to terminate -- -- See 'close' for discussion. -waitForOutbound :: Channel sess -> IO () -waitForOutbound Channel{channelOutbound} = atomically $ - waitForNormalThreadTermination channelOutbound +waitForOutbound :: HasCallStack => Channel sess -> IO () +waitForOutbound Channel{channelOutbound} = + void $ waitForNormalThreadTermination channelOutbound -- | Close the channel -- -- Before a channel can be closed, you should 'send' the final outbound message -- and then 'waitForOutbound' until all outbound messages have been processed. --- Not doing so is considered a bug (it is not possible to do this implicitly, --- because the final call to 'send' involves a choice of trailers, and calling --- 'waitForOutbound' /without/ a final close to 'send' will result in deadlock). --- Typically code will also process all /incoming/ messages, but doing so is of --- course not mandatory. --- --- Calling 'close' will kill the outbound thread ('sendMessageLoop'), /if/ it is --- still running. If the thread was terminated with an exception, this could --- mean one of two things: +-- It is not possible to do this implicitly, because the final call to 'send' +-- involves a choice of trailers, and calling 'waitForOutbound' /without/ a +-- final close to 'send' will result in deadlock. Typically code will also +-- process all /incoming/ messages, but doing so is of course not mandatory. -- --- 1. The connection to the peer was lost --- 2. Proper procedure for outbound messages was not followed (see above) +-- If the outbound thread is still running, 'waitForOutbound' was +-- not called, and the outbound thread will be terminated with an exception: -- --- In the case of (2) this is bug in the caller, and so 'close' will return an --- exception. In the case of (1), however, very likely an exception will --- /already/ have been thrown when a communication attempt was made, and 'close' --- will return 'Nothing'. This matches the design philosophy in @grapesy@ that --- exceptions are thrown \"lazily\" rather than \"strictly\". +-- * If the channel is closed /because of/ an exception, we use that exception +-- (or 'ChannelAborted' in the case of 'ExitCaseAbort') +-- * Otherwise, the caller terminated normally and yet did not call +-- 'waitForOutbound'. This is a bug in the caller, which we record as a +-- 'ChannelDiscarded' exception on the channel. close :: HasCallStack => Channel sess -> ExitCase a -- ^ The reason why the channel is being closed - -> IO (Maybe SomeException) + -> IO () close Channel{channelOutbound} reason = do + backtrace <- collectBacktraces + let channelClosed :: ExactException + channelClosed = WrapExactException $ + case reason of + ExitCaseSuccess _ -> toException $ ChannelDiscarded backtrace + ExitCaseAbort -> toException $ ChannelAborted backtrace + ExitCaseException e -> e + -- We leave the inbound thread running. Although the channel is closed, -- there might still be unprocessed messages in the queue. The inbound -- thread will terminate once it reaches the end of the queue. - outbound <- cancelThread channelOutbound channelClosed - case outbound of - AlreadyTerminated _ -> - return $ Nothing - AlreadyAborted _err -> - -- Connection to the peer was lost prior to closing - return $ Nothing - Cancelled -> - -- Proper procedure for outbound messages was not followed - return $ Just channelClosed - where - channelClosed :: SomeException - channelClosed = - case reason of - ExitCaseSuccess _ -> toException $ ChannelDiscarded callStack - ExitCaseAbort -> toException $ ChannelAborted callStack - ExitCaseException e -> e + cancelThread channelOutbound channelClosed -- | Channel was closed because it was discarded -- -- This typically corresponds to leaving the scope of 'runHandler' or -- 'withRPC' (without throwing an exception). -data ChannelDiscarded = ChannelDiscarded CallStack +data ChannelDiscarded = ChannelDiscarded Backtraces deriving stock (Show) deriving anyclass (Exception) @@ -462,63 +473,11 @@ -- -- This will only be used in monad stacks that have error mechanisms other -- than exceptions. -data ChannelAborted = ChannelAborted CallStack +data ChannelAborted = ChannelAborted Backtraces deriving stock (Show) deriving anyclass (Exception) {------------------------------------------------------------------------------- - Support for half-closing --------------------------------------------------------------------------------} - -type InboundResult sess = - Either (NoMessages (Inbound sess)) - (Trailers (Inbound sess)) - --- | Should we allow for a half-clsoed connection state? --- --- In HTTP2, streams are bidirectional and can be half-closed in either --- direction. This is however not true for all applications /of/ HTTP2. For --- example, in gRPC the stream can be half-closed from the client to the server --- (indicating that the client will not send any more messages), but not from --- the server to the client: when the server half-closes their connection, it --- sends the gRPC trailers and this terminates the call. -data AllowHalfClosed sess = - ContinueWhenInboundClosed - | TerminateWhenInboundClosed (InboundResult sess -> SomeException) - --- | Link outbound thread to the inbound thread --- --- This should be wrapped around the body of the inbound thread. It ensures that --- when the inbound thread throws an exception, the outbound thread dies also. --- This improves predictability of exceptions: the inbound thread spends most of --- its time blocked on messages from the peer, and will therefore notice when --- the connection is lost. This is not true for the outbound thread, which --- spends most of its time blocked waiting for messages to send to the peer. -linkOutboundToInbound :: forall sess. - IsSession sess - => AllowHalfClosed sess - -> Channel sess - -> IO (InboundResult sess) - -> IO () -linkOutboundToInbound allowHalfClosed channel inbound = do - mResult <- try inbound - - -- Implementation note: After cancelThread returns, 'channelOutbound' has - -- been updated, and considered dead, even if perhaps the thread is still - -- cleaning up. - - case (mResult, allowHalfClosed) of - (Right _result, ContinueWhenInboundClosed) -> - return () - (Right result, TerminateWhenInboundClosed f) -> - void $ cancelThread (channelOutbound channel) (f result) - (Left (exception :: SomeException), _) -> do - void $ cancelThread (channelOutbound channel) exception - throwIO exception - where - _ = addConstraint @(IsSession sess) - -{------------------------------------------------------------------------------- Constructing channels Both 'sendMessageLoop' and 'recvMessageLoop' will be run in newly forked @@ -531,43 +490,118 @@ -------------------------------------------------------------------------------} -- | Send all messages to the node's peer +-- +-- == Invariant: eventual progress +-- +-- The outbound thread, the thread running `sendMessageLoop`, communicates by +-- reading a shared 'TMVar'. When a write to this 'TMVar' is blocked (in another +-- thread), eventually one of the following two things will happen: +-- +-- * The outbound thread empties the 'TMVar' +-- * The outbound thread dies (itself observable; +-- see 'Network.GRPC.Util.Thread.withThreadInterface'). +-- +-- This invariant will cease to be true after the final message ('FinalElem' or +-- 'NoMoreElems') is consumed: the thread will not read from the 'TMVar' after +-- that point. +-- +-- == Exceptions +-- +-- When a write /fails/ (say, connection lost) we'd like to be able to +-- communicate this back to the caller: the outbound thread dies, which is +-- observable (see above). It is important to note that the /absence/ of such an +-- exception (a quote-unquote \"successful\" write) is no guarantee of anything; +-- for example, it may be that the connection is lost after the message was +-- successfully enqueued in some OS buffer but before it was put on the wire; or +-- indeed somewhere along the way across the network to the destination. +-- +-- However, the outbound thread spends most of its time blocked waiting for +-- messages to send to the network peer, and may not notice when the connection +-- is lost. It therefore /monitors/ the inbound thread, which spends most of its +-- time blocked on waiting for messages /from/ the peer and so will notice more +-- or less immediately. +-- +-- We need an important \"atomicity\" property however: once the outbound thread +-- has sent the trailers, we /expect/ the client to disconnect. We therefore +-- mark ourselves as done prior to sending the trailers, to avoid a race +-- condition where +-- +-- 1. the outbound thread sends the final chunk +-- 2. the client receives the trailers and disconnects +-- 3. before the outbound thread gets the chance to terminate (the only thing +-- left to do), it is killed (perhaps due to a monitor notification, or due +-- to @http2@ sending an async exception to a server handler) +-- +-- Such a race condition would result in timing-sensitive, non-deterministic +-- exceptions. By marking ourselves done, /we cannot be killed anymore/, hence +-- preventing the problem. +-- +-- Note that if a client disconnects /before/ receiving the final chunk, this +-- constitutes a violation of the protocol, and so it would be correct for the +-- outbound thread to report abnormal termination. +-- +-- == Failure on the final message +-- +-- Conceptually, we'd want something like +-- +-- > do .. +-- > writeChunkFinal .. +-- > -- .. prevent async exceptions here .. +-- +-- but of course that is impossible to do /literally/; anything we do /after/ +-- the call to 'writeChunkFinal' still leaves a gap in between 'writeChunkFinal' +-- and the next instruction. However, we cannot mask async exceptions /before/ +-- the call to 'writeChunkFinal' either, because 'writeChunkFinal' itself may +-- block, and if it does, we do want to be interruptible while we wait. +-- +-- By declaring ourselves done /before/ sending the final chunk (see previous +-- section) we side-step the problem, at the cost of being unable to report if +-- that final send fails. However, this is a small price to pay: +-- +-- * As discussed above, the absence of a reported failure of a send is /anyway/ +-- no guarantee of success +-- * Reporting failed sends is primarily useful for code that is repeatedly +-- sending messages, and so if one message fails to send there is no point in +-- sending the next. But for the final message there /cannot be/ a next +-- message: this must anyway be the final write. sendMessageLoop :: forall sess. IsSession sess => sess -> RegularFlowState (Outbound sess) -> OutputStream + -> (Trailers (Outbound sess) -> IO ()) -> IO () -sendMessageLoop sess st stream = do +sendMessageLoop sess st stream markDone = do trailers <- loop - atomically $ putTMVar (flowTerminated st) trailers + atomically $ STM.putTMVar (flowTerminated st) trailers where build :: (Message (Outbound sess) -> Builder) build = buildMsg sess (flowHeaders st) loop :: IO (Trailers (Outbound sess)) loop = do - msg <- atomically $ takeTMVar (flowMsg st) + msg <- atomically $ STM.takeTMVar (flowMsg st) case msg of StreamElem x -> do writeChunk stream $ build x flush stream loop FinalElem x trailers -> do + markDone trailers writeChunkFinal stream $ build x return trailers NoMoreElems trailers -> do - -- It is crucial to still 'writeChunkFinal' here to guarantee that - -- cancellation is a no-op. Without it, cancellation may result in a - -- @RST_STREAM@ frame may being sent to the peer. - -- - -- This does not necessarily write a DATA frame, since http2 avoids - -- writing empty data frames unless they are marked @END_OF_STREAM@. + markDone trailers + -- Send empty chunk marked \"final\" to let our peer know that we + -- have sent our last message. Note that this does not /necessarily/ + -- write a DATA frame, since http2 avoids writing empty data frames + -- unless they are marked @END_OF_STREAM@. writeChunkFinal stream $ mempty return trailers -- | Receive all messages sent by the node's peer recvMessageLoop :: forall sess. - IsSession sess + (IsSession sess, HasCallStack) => sess -> RegularFlowState (Inbound sess) -> InputStream @@ -587,23 +621,23 @@ return trailers Nothing -> do trailers <- processTrailers - atomically $ putTMVar (flowMsg st) $ NoMoreElems trailers + atomically $ STM.putTMVar (flowMsg st) $ NoMoreElems trailers return trailers processOne :: Message (Inbound sess) -> IO () processOne msg = do - atomically $ putTMVar (flowMsg st) $ StreamElem msg + atomically $ STM.putTMVar (flowMsg st) $ StreamElem msg processFinal :: Message (Inbound sess) -> IO (Trailers (Inbound sess)) processFinal msg = do trailers <- processTrailers - atomically $ putTMVar (flowMsg st) $ FinalElem msg trailers + atomically $ STM.putTMVar (flowMsg st) $ FinalElem msg trailers return trailers processTrailers :: IO (Trailers (Inbound sess)) processTrailers = do trailers <- parseInboundTrailers sess =<< getTrailers stream - atomically $ putTMVar (flowTerminated st) $ trailers + atomically $ STM.putTMVar (flowTerminated st) $ trailers return trailers throwParseErrors :: Parser.ProcessResult String b -> IO (Maybe b) @@ -621,17 +655,17 @@ => sess -> Channel sess -> RegularFlowState (Outbound sess) - -> HTTP2.TrailersMaker + -> HTTP.Semantics.TrailersMaker outboundTrailersMaker sess Channel{channelOutbound} regular = go where - go :: HTTP2.TrailersMaker - go (Just _) = return $ HTTP2.NextTrailersMaker go + go :: HTTP.Semantics.TrailersMaker + go (Just _) = return $ HTTP.Semantics.NextTrailersMaker go go Nothing = do mFlowState <- atomically $ unlessAbnormallyTerminated channelOutbound $ - readTMVar (flowTerminated regular) + STM.readTMVar (flowTerminated regular) case mFlowState of Right trailers -> - return $ HTTP2.Trailers $ buildOutboundTrailers sess trailers + return $ HTTP.Semantics.Trailers $ buildOutboundTrailers sess trailers Left _exception -> - return $ HTTP2.Trailers [] + return $ HTTP.Semantics.Trailers [] diff --git a/src/Network/GRPC/Util/Session/Client.hs b/src/Network/GRPC/Util/Session/Client.hs --- a/src/Network/GRPC/Util/Session/Client.hs +++ b/src/Network/GRPC/Util/Session/Client.hs @@ -6,23 +6,24 @@ , setupRequestChannel ) where -import Control.Concurrent -import Control.Concurrent.STM -import Control.Monad -import Control.Monad.Catch +import Network.GRPC.Util.Imports + +import Control.Concurrent.STM qualified as STM import Data.ByteString qualified as BS.Strict import Data.ByteString qualified as Strict (ByteString) import Data.ByteString.Lazy qualified as BS.Lazy import Data.ByteString.Lazy qualified as Lazy (ByteString) -import Data.Proxy +import Network.HTTP.Semantics qualified as HTTP +import Network.HTTP.Semantics.Client qualified as Client import Network.HTTP.Types qualified as HTTP -import Network.HTTP2.Client qualified as Client -import Network.GRPC.Util.HTTP2 (fromHeaderTable) -import Network.GRPC.Util.HTTP2.Stream +import Network.GRPC.Common.Exception +import Network.GRPC.Util.ClientStream +import Network.GRPC.Util.HeaderTable (fromHeaderTable) import Network.GRPC.Util.RedundantConstraint (addConstraint) import Network.GRPC.Util.Session.API import Network.GRPC.Util.Session.Channel +import Network.GRPC.Util.Stream import Network.GRPC.Util.Thread {------------------------------------------------------------------------------- @@ -86,32 +87,37 @@ -- | There is no interesting information in the trailers noTrailers :: Proxy sess -> Trailers (Outbound sess) -type CancelRequest = Maybe SomeException -> IO () +type CancelRequest = Maybe ExactException -> IO () +type InboundResult sess = + Either (NoMessages (Inbound sess)) + (Trailers (Inbound sess)) + -- | Setup request channel -- -- This initiates a new request. -- setupRequestChannel :: forall sess. - (InitiateSession sess, NoTrailers sess) + (HasCallStack, InitiateSession sess, NoTrailers sess) => sess -> ConnectionToServer - -> (InboundResult sess -> SomeException) + -> (InboundResult sess -> ExactException) -- ^ We assume that when the server closes their outbound connection to us, -- the entire conversation is over (i.e., the server cannot "half-close"). -> FlowStart (Outbound sess) -> IO (Channel sess, CancelRequest) -setupRequestChannel sess - ConnectionToServer{sendRequest} - terminateCall - outboundStart - = do - channel <- initChannel +setupRequestChannel sess conn terminateCall outboundStart = do + channel <- initChannel "client" + monitorInbound terminateCall channel let requestInfo = buildRequestInfo sess outboundStart - cancelRequestVar <- newEmptyMVar + cancelRequestVar <- STM.newEmptyTMVarIO let cancelRequest :: CancelRequest - cancelRequest e = join . (fmap ($ e)) $ readMVar cancelRequestVar + cancelRequest e = do + -- If the outbound thread died, cancelRequestVar might never be set + cancel <- withThreadInterface (channelOutbound channel) $ \_ -> + STM.readTMVar cancelRequestVar + cancel e case outboundStart of FlowStartRegular headers -> do @@ -124,21 +130,18 @@ $ outboundThread channel cancelRequestVar regular forkRequest channel req FlowStartNoMessages trailers -> do - let state :: FlowState (Outbound sess) - state = FlowStateNoMessages trailers - - req :: Client.Request + let req :: Client.Request req = Client.requestNoBody (requestMethod requestInfo) (requestPath requestInfo) (requestHeaders requestInfo) - -- Can't cancel non-streaming request - putMVar cancelRequestVar $ \_ -> return () - atomically $ - modifyTVar (channelOutbound channel) $ \oldState -> + atomically $ do + -- Can't cancel non-streaming request + STM.putTMVar cancelRequestVar $ \_ -> return () + STM.modifyTVar (channelOutbound channel) $ \oldState -> case oldState of ThreadNotStarted debugId -> - ThreadDone debugId state + ThreadTrivial debugId trailers _otherwise -> error "setupRequestChannel: expected thread state" forkRequest channel req @@ -149,63 +152,103 @@ forkRequest :: Channel sess -> Client.Request -> IO () forkRequest channel req = - forkThread "grapesy:clientInbound" (channelInbound channel) $ \unmask markReady _debugId -> unmask $ - linkOutboundToInbound (TerminateWhenInboundClosed terminateCall) channel $ - sendRequest req $ \resp -> do - responseStatus <- - case Client.responseStatus resp of - Just x -> return x - Nothing -> throwM PeerMissingPseudoHeaderStatus + forkThread "grapesy:clientInbound" (channelInbound channel) $ \unmask ctxt -> unmask $ + sendRequest conn req $ \resp -> do + responseStatus <- + case Client.responseStatus resp of + Just x -> return x + Nothing -> throwIO PeerMissingPseudoHeaderStatus - -- Read the entire response body in case of a non-OK response - responseBody :: Maybe Lazy.ByteString <- - if HTTP.statusIsSuccessful responseStatus then - return Nothing - else - Just <$> readResponseBody resp + -- Read the entire response body in case of a non-OK response + responseBody :: Maybe Lazy.ByteString <- + if HTTP.statusIsSuccessful responseStatus then + return Nothing + else + Just <$> readResponseBody resp - let responseHeaders = - fromHeaderTable $ Client.responseHeaders resp - responseInfo = ResponseInfo { - responseHeaders - , responseStatus - , responseBody - } + let responseHeaders = + fromHeaderTable $ Client.responseHeaders resp + responseInfo = ResponseInfo { + responseHeaders + , responseStatus + , responseBody + } - flowStart <- parseResponse sess responseInfo - case flowStart of - FlowStartRegular headers -> do - state <- initFlowStateRegular headers - stream <- clientInputStream resp - markReady $ FlowStateRegular state - Right <$> recvMessageLoop sess state stream - FlowStartNoMessages trailers -> do - markReady $ FlowStateNoMessages trailers - return $ Left trailers + flowStart <- parseResponse sess responseInfo + case flowStart of + FlowStartRegular headers -> do + regular <- initFlowStateRegular headers + stream <- clientInputStream resp + threadMainBody ctxt regular $ \markDone -> + markDone =<< recvMessageLoop sess regular stream + FlowStartNoMessages trailers -> do + threadTrivial ctxt trailers outboundThread :: Channel sess - -> MVar CancelRequest + -> STM.TMVar CancelRequest -> RegularFlowState (Outbound sess) - -> Client.OutBodyIface + -> HTTP.OutBodyIface -> IO () outboundThread channel cancelRequestVar regular iface = - threadBody "grapesy:clientOutbound" (channelOutbound channel) $ \markReady _debugId -> do - markReady $ FlowStateRegular regular - putMVar cancelRequestVar (Client.outBodyCancel iface) - stream <- clientOutputStream iface - -- Unlike the client inbound thread, or the inbound/outbound threads - -- of the server, http2 knows about this particular thread and may - -- raise an exception on it when the server dies. This results in a - -- race condition between that exception and the exception we get from - -- attempting to read the next message. No matter who wins that race, - -- we need to mark that as 'ServerDisconnected'. - -- - -- We don't have this top-level exception handler in other places - -- because we don't want to mark /our own/ exceptions as - -- 'ServerDisconnected' or 'ClientDisconnected'. - wrapStreamExceptionsWith ServerDisconnected $ - Client.outBodyUnmask iface $ sendMessageLoop sess regular stream + threadBody "grapesy:clientOutbound" (channelOutbound channel) $ \ctxt -> do + threadMainBody ctxt regular $ \markDone -> do + atomically $ STM.putTMVar cancelRequestVar cancelRequest + stream <- clientOutputStream iface + -- Unlike the client inbound thread, or the inbound/outbound threads + -- of the server, http2 knows about this particular thread and may + -- raise an exception on it when the server dies. This results in a + -- race condition between that exception and the exception we get from + -- attempting to read the next message. No matter who wins that race, + -- we need to mark that as 'ServerDisconnected'. + -- + -- We don't have this top-level exception handler in other places + -- because we don't want to mark /our own/ exceptions as + -- 'ServerDisconnected' or 'ClientDisconnected'. + wrapServerDisconnected $ + HTTP.outBodyUnmask iface $ + sendMessageLoop sess regular stream markDone + where + cancelRequest :: CancelRequest + cancelRequest = HTTP.outBodyCancel iface . fmap unwrapExactException + +-- | Make outbound thread monitor the input thread +-- +-- The outbound thread is started by http2 when the request is successfully +-- initiated from the inbound thread. This means that monitoring must be setup +-- /outside of/ the outbound thread, because if not the monitor might never be +-- setup, and an attempt to interact with the outbound thread might block +-- indefinitely because it never makes it past its 'ThreadNotStarted' not +-- started state, even though the inbound thread has died. +-- +-- In HTTP2, streams are bidirectional and can be half-closed in either +-- direction. However, in gRPC the stream can be half-closed from the client to +-- the server (indicating that the client will not send any more messages), but +-- not from the server to the client: when the server half-closes their +-- connection, it sends the gRPC trailers and this terminates the call. +monitorInbound :: forall sess. + (InboundResult sess -> ExactException) + -> Channel sess -> IO () +monitorInbound terminateCall channel = do + _monitorRef <- + threadMonitor + (channelOutbound channel) + (channelInbound channel) + monitorPred + return () + where + monitorPred :: + Either + ThreadException + ( Either + (NoMessages (Inbound sess)) + (Trailers (Inbound sess)) + ) + -> Maybe ExactException + monitorPred = \case + Left e -> Just $ threadException e + Right trailers -> Just $ terminateCall trailers + {------------------------------------------------------------------------------- Auxiliary http2 diff --git a/src/Network/GRPC/Util/Session/Server.hs b/src/Network/GRPC/Util/Session/Server.hs --- a/src/Network/GRPC/Util/Session/Server.hs +++ b/src/Network/GRPC/Util/Session/Server.hs @@ -4,11 +4,17 @@ , setupResponseChannel ) where -import Network.HTTP2.Server qualified as Server +import Control.Concurrent +import Control.Exception +import Network.HTTP.Semantics qualified as HTTP +import Network.HTTP.Semantics.Server qualified as Server -import Network.GRPC.Util.HTTP2.Stream +import Network.GRPC.Common.Exception +import Network.GRPC.Util.Imports +import Network.GRPC.Util.ServerStream import Network.GRPC.Util.Session.API import Network.GRPC.Util.Session.Channel +import Network.GRPC.Util.Stream import Network.GRPC.Util.Thread {------------------------------------------------------------------------------- @@ -22,6 +28,60 @@ } {------------------------------------------------------------------------------- + Internal auxiliary: constructing responses +-------------------------------------------------------------------------------} + +respondStreamingWithResult :: forall a. + HasCallStack + => ConnectionToClient + -> Server.TrailersMaker + -> ResponseInfo + -> (OutputStream -> IO a) + -> IO a +respondStreamingWithResult conn trailers responseInfo body = do + resultVar :: MVar (Either ExactException a) <- newEmptyMVar + let resp :: Server.Response + resp = flip Server.setResponseTrailersMaker trailers + . Server.responseStreamingIface + (responseStatus responseInfo) + (responseHeaders responseInfo) + $ auxThreadBody resultVar + + respond conn resp + + -- Any exception thrown here is thrown in the context of a 'Thread'. + either throwExact return =<< takeMVar resultVar + where + -- This will be running in an auxiliary thread, spawned by http2. Any + -- exceptions that are thrown by that thread will remain uncaught, and + -- will trigger the top-level uncaught exception handler. We therefore + -- catch all of these and store them in 'resultVar', which the main + -- grapesy outbound thread is waiting on. + -- + -- When the connection is closed, this thread will be cleaned up by + -- the ThreadManager in http2. + auxThreadBody :: + MVar (Either ExactException a) + -> HTTP.OutBodyIface + -> IO () + auxThreadBody resultVar iface = do + result <- try $ do + -- It is important we create the output stream inside the body of the + -- exception handler, since that too can fail. + ostrm <- serverOutputStream iface + body ostrm + putMVar resultVar result + +respondNoBody :: ConnectionToClient -> ResponseInfo -> IO () +respondNoBody conn responseInfo = + respond conn resp + where + resp :: Server.Response + resp = Server.responseNoBody + (responseStatus responseInfo) + (responseHeaders responseInfo) + +{------------------------------------------------------------------------------- Initiate response -------------------------------------------------------------------------------} @@ -33,7 +93,7 @@ -- * We assume that the client is allowed to close their outbound stream to us. -- * 'setupResponseChannel' will not throw any exceptions. setupResponseChannel :: forall sess. - IsSession sess + (HasCallStack, IsSession sess) => sess -> ConnectionToClient -> FlowStart (Inbound sess) @@ -52,59 +112,67 @@ inboundStart startOutbound = do - channel <- initChannel + channel <- initChannel "server" + monitorInbound channel - forkThread "grapesy:serverInbound" (channelInbound channel) $ - \unmask markReady _debugId -> unmask $ - linkOutboundToInbound ContinueWhenInboundClosed channel $ do - case inboundStart of - FlowStartRegular headers -> do - regular <- initFlowStateRegular headers - stream <- serverInputStream (request conn) - markReady $ FlowStateRegular regular - Right <$> recvMessageLoop sess regular stream - FlowStartNoMessages trailers -> do - -- The client sent a request with an empty body - markReady $ FlowStateNoMessages trailers - return $ Left trailers - -- Thread terminates immediately + forkThread "grapesy:serverInbound" (channelInbound channel) $ \unmask ctxt -> unmask $ + case inboundStart of + FlowStartRegular headers -> do + regular <- initFlowStateRegular headers + stream <- serverInputStream (request conn) + threadMainBody ctxt regular $ \markDone -> + markDone =<< recvMessageLoop sess regular stream + FlowStartNoMessages trailers -> + -- The client sent a request with an empty body + threadTrivial ctxt trailers - forkThread "grapesy:serverOutbound" (channelOutbound channel) $ - \unmask markReady _debugId -> unmask $ do - (outboundStart, responseInfo) <- startOutbound - case outboundStart of - FlowStartRegular headers -> do - regular <- initFlowStateRegular headers - markReady $ FlowStateRegular regular - let resp :: Server.Response - resp = setResponseTrailers sess channel regular - $ Server.responseStreamingIface - (responseStatus responseInfo) - (responseHeaders responseInfo) - $ \iface -> do - stream <- serverOutputStream iface - sendMessageLoop sess regular stream - respond conn resp - FlowStartNoMessages trailers -> do - markReady $ FlowStateNoMessages trailers - let resp :: Server.Response - resp = Server.responseNoBody - (responseStatus responseInfo) - (responseHeaders responseInfo) - respond conn $ resp + forkThread "grapesy:serverOutbound" (channelOutbound channel) $ \unmask ctxt -> unmask $ do + (outboundStart, responseInfo) <- startOutbound + case outboundStart of + FlowStartRegular headers -> do + regular <- initFlowStateRegular headers + threadMainBody ctxt regular $ \markDone -> do + respondStreamingWithResult + conn + (outboundTrailersMaker sess channel regular) + responseInfo $ \stream -> + sendMessageLoop sess regular stream markDone + FlowStartNoMessages trailers -> do + respondNoBody conn responseInfo + threadTrivial ctxt trailers return channel -{------------------------------------------------------------------------------- - Auxiliary http2 --------------------------------------------------------------------------------} - -setResponseTrailers :: - IsSession sess - => sess - -> Channel sess - -> RegularFlowState (Outbound sess) - -> Server.Response -> Server.Response -setResponseTrailers sess channel regular resp = - Server.setResponseTrailersMaker resp $ - outboundTrailersMaker sess channel regular +-- | Make outbound thread monitor the input thread +-- +-- Monitoring here is a bit subtle: http2 will spawn an auxiliary thread, which +-- will be the one that will actually run the 'sendMessageLoop'. Meanwhile, our +-- \"outbound thread\" will simply be waiting for that auxiliary thread to +-- terminate; if the monitor fires, is it /this/ thread that receives it, not +-- the auxiliary http2 thread. +monitorInbound :: forall sess. Channel sess -> IO () +monitorInbound channel = do + _monitorRef <- + threadMonitor + (channelOutbound channel) + (channelInbound channel) + monitorPred + return () + where + -- Unlike on the client-side, if the input thread terminates normally, the + -- server can continue to run normally (the stream can be half-closed from + -- the client). We only only terminate if the inbound thread threw an + -- exception, indicating that the client disconnected abruptly. + -- + -- See also 'Network.GRPC.Util.Session.Client.setupRequestChannel'. + monitorPred :: + Either + ThreadException + ( Either + (NoMessages (Inbound sess)) + (Trailers (Inbound sess)) + ) + -> Maybe ExactException + monitorPred = \case + Left e -> Just $ threadException e + Right _trailers -> Nothing diff --git a/src/Network/GRPC/Util/Stream.hs b/src/Network/GRPC/Util/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Util/Stream.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE CPP #-} + +module Network.GRPC.Util.Stream ( + -- * Streams + OutputStream(..) + , writeChunk + , writeChunkFinal + , flush + , InputStream(..) + , getChunk + , getTrailers + -- * Exceptions + , ClientDisconnected(..) + , ServerDisconnected(..) + , wrapServerDisconnected + , wrapClientDisconnected + ) where + +import Data.Binary.Builder (Builder) +import Data.ByteString qualified as Strict (ByteString) +import Network.HTTP.Types qualified as HTTP + +import Network.GRPC.Common.Exception +import Network.GRPC.Util.Imports + +{------------------------------------------------------------------------------- + Streams +-------------------------------------------------------------------------------} + +data OutputStream = OutputStream { + -- | Write a chunk to the stream + _writeChunk :: HasCallStack => Builder -> IO () + + -- | Write the final chunk to the stream + , _writeChunkFinal :: HasCallStack => Builder -> IO () + + -- | Flush the stream (send frames to the peer) + , _flush :: HasCallStack => IO () + } + +data InputStream = InputStream { + _getChunk :: HasCallStack => IO (Strict.ByteString, Bool) + , _getTrailers :: HasCallStack => IO [HTTP.Header] + } + +{------------------------------------------------------------------------------- + Wrappers to get the proper CallStack +-------------------------------------------------------------------------------} + +writeChunk :: HasCallStack => OutputStream -> Builder -> IO () +writeChunk = _writeChunk + +writeChunkFinal :: HasCallStack => OutputStream -> Builder -> IO () +writeChunkFinal = _writeChunkFinal + +flush :: HasCallStack => OutputStream -> IO () +flush = _flush + +getChunk :: HasCallStack => InputStream -> IO (Strict.ByteString, Bool) +getChunk = _getChunk + +getTrailers :: HasCallStack => InputStream -> IO [HTTP.Header] +getTrailers = _getTrailers + +{------------------------------------------------------------------------------- + Internal auxiliary +-------------------------------------------------------------------------------} + +wrapClientDisconnected :: HasCallStack => IO a -> IO a +wrapClientDisconnected = catchAndWrap $ \err -> ClientDisconnected err Nothing + +wrapServerDisconnected :: HasCallStack => IO a -> IO a +wrapServerDisconnected = catchAndWrap $ \err -> ServerDisconnected err Nothing diff --git a/src/Network/GRPC/Util/Thread.hs b/src/Network/GRPC/Util/Thread.hs --- a/src/Network/GRPC/Util/Thread.hs +++ b/src/Network/GRPC/Util/Thread.hs @@ -1,9 +1,13 @@ +{-# LANGUAGE CPP #-} + -- | Monitored threads -- -- Intended for unqualified import. module Network.GRPC.Util.Thread ( ThreadState(..) + , ThreadException(..) -- * Creating threads + , ThreadContext(..) , ThreadBody , newThreadState , forkThread @@ -12,27 +16,37 @@ , DebugThreadId -- opaque , threadDebugId -- * Access thread state - , CancelResult(..) , cancelThread , ThreadState_(..) , getThreadState_ , unlessAbnormallyTerminated + , ThreadIface(..) , withThreadInterface , waitForNormalThreadTermination , waitForNormalOrAbnormalThreadTermination + -- * Monitoring + , MonitorRef -- opaque + , MonitorAnnotation(..) + , threadMonitor + , demonitor ) where +import Network.GRPC.Util.Imports + import Control.Concurrent -import Control.Concurrent.STM -import Control.Exception -import Control.Monad -import Data.Void (Void, absurd) -import Foreign (newStablePtr, freeStablePtr) -import GHC.Stack +import Control.Concurrent.STM (STM, TVar) +import Control.Concurrent.STM qualified as STM +import Control.Exception qualified as E +import Foreign qualified import System.IO.Unsafe (unsafePerformIO) +import Network.GRPC.Common.Exception import Network.GRPC.Util.GHC +#if MIN_VERSION_base(4,20,0) +import Control.Exception.Annotation +#endif + {------------------------------------------------------------------------------- Debug thread IDs -------------------------------------------------------------------------------} @@ -42,8 +56,8 @@ -- Unlike 'ThreadId', these do not correspond to a /running/ thread necessarily, -- but just enable us to distinguish one thread from another. data DebugThreadId = DebugThreadId { - debugThreadId :: Word - , debugThreadCreatedAt :: CallStack + debugThreadId :: Word + , debugThreadLabel :: String } deriving stock (Show) @@ -51,28 +65,63 @@ {-# NOINLINE nextDebugThreadId #-} nextDebugThreadId = unsafePerformIO $ newMVar 0 -newDebugThreadId :: HasCallStack => IO DebugThreadId -newDebugThreadId = +newDebugThreadId :: String -> IO DebugThreadId +newDebugThreadId label = do modifyMVar nextDebugThreadId $ \x -> do let !nextId = succ x return ( nextId - , DebugThreadId x (popIrrelevant callStack) + , DebugThreadId x label ) - where - -- Pop off the call to 'newDebugThreadId' + +{------------------------------------------------------------------------------- + Exceptions +-------------------------------------------------------------------------------} + +-- | Exception that killed a thread +data ThreadException = ThreadException{ + threadException :: ExactException + , threadExceptionAnnotation :: ThreadExceptionAnnotation + } + deriving stock (Show) + +data ThreadExceptionAnnotation = + -- | Thread body itself threw an exception + ThreadThrewException + + -- | Thread was cancelled -- - -- We leave the call to 'newThreadState' on the stack because it is useful - -- to know where that was called /from/. - popIrrelevant :: CallStack -> CallStack - popIrrelevant = popCallStack + -- We record the backtrace of the cancellation + | ThreadCancelled Backtraces + deriving stock (Show) +data ThreadInterfaceUnavailable = + -- | Attempt to access the thread interface after the thread died + -- + -- We record the backtrace of the attempt to access the thread interface, + -- which will be different from the backtrace of the exception that + -- killed the thread + ThreadInterfaceUnavailable Backtraces + deriving stock (Show) + +#if MIN_VERSION_base(4,20,0) +instance ExceptionAnnotation ThreadExceptionAnnotation +instance ExceptionAnnotation ThreadInterfaceUnavailable +#endif + +throwThreadException :: (MonadIO m, HasCallStack) => ThreadException -> m a +throwThreadException e = liftIO $ do + backtraces <- collectBacktraces + annotateIO (threadExceptionAnnotation e) $ + annotateIO (ThreadInterfaceUnavailable backtraces) $ + throwExact (threadException e) + {------------------------------------------------------------------------------- State -------------------------------------------------------------------------------} -- | State of a thread with public interface of type @a@ -data ThreadState a = +data ThreadState a r r' = -- | The thread has not yet started -- -- If the thread is cancelled before it is started, then the exception will @@ -89,6 +138,9 @@ ThreadNotStarted DebugThreadId -- | The externally visible thread interface is still being initialized + -- + -- This period ends once the thread body calls 'threadMainBody' or + -- 'threadTrivial'. | ThreadInitializing DebugThreadId ThreadId -- | Thread is ready @@ -98,126 +150,230 @@ -- -- This still carries the thread interface: we may need it to query the -- thread's final status, for example. - | ThreadDone DebugThreadId a + | ThreadDone DebugThreadId a r + -- | Trivial thread + -- + -- See 'threadTrivial' for discussion. + | ThreadTrivial DebugThreadId r' + -- | Thread terminated with an exception - | ThreadException DebugThreadId SomeException - deriving stock (Show, Functor) + | ThreadDied DebugThreadId ThreadException + deriving stock (Show) -threadDebugId :: ThreadState a -> DebugThreadId +-- | For debugging: reduce to skeleton +showableState :: ThreadState a r r' -> ThreadState () () () +showableState = \case + ThreadNotStarted did -> ThreadNotStarted did + ThreadInitializing did tid -> ThreadInitializing did tid + ThreadRunning did tid _ -> ThreadRunning did tid () + ThreadDone did _ _ -> ThreadDone did () () + ThreadTrivial did _ -> ThreadTrivial did () + ThreadDied did e -> ThreadDied did e + +threadDebugId :: ThreadState a r r' -> DebugThreadId threadDebugId (ThreadNotStarted debugId ) = debugId threadDebugId (ThreadInitializing debugId _ ) = debugId threadDebugId (ThreadRunning debugId _ _) = debugId -threadDebugId (ThreadDone debugId _) = debugId -threadDebugId (ThreadException debugId _) = debugId +threadDebugId (ThreadDone debugId _ _) = debugId +threadDebugId (ThreadTrivial debugId _ ) = debugId +threadDebugId (ThreadDied debugId _) = debugId {------------------------------------------------------------------------------- Creating threads -------------------------------------------------------------------------------} -type ThreadBody a = - (forall x. IO x -> IO x) -- ^ Unmask exceptions - -> (a -> IO ()) -- ^ Mark thread ready - -> DebugThreadId -- ^ Unique identifier for this thread - -> IO () +-- | Thread context +-- +-- The thread body /must/ call either 'threadMainBody' or 'threadTrivial' when +-- it is ready: +-- +-- > threadBody = +-- > .. initial setup .. +-- > case foo of +-- > .. -> .. threadMainBody .. +-- > .. -> .. treadTrivial .. +-- +-- Any attempt to interact with the thread will block until it marks itself +-- ready through 'threadMainBody' or 'threadTrivial' (or it dies). +data ThreadContext a r r' = ThreadContext{ + -- | Mark thread ready, providing the main thread body + -- + -- The thread body is given a callback that it can use to declare itself + -- done. Once declared done, any further exceptions that happen in the + -- thread will not be recorded in the thread state anymore. + threadMainBody :: a -> ((r -> IO ()) -> IO ()) -> IO () -newThreadState :: HasCallStack => IO (TVar (ThreadState a)) -newThreadState = do - debugId <- newDebugThreadId - newTVarIO $ ThreadNotStarted debugId + -- | Terminate the thread immediately + -- + -- We refer to this as a \"trivial\" thread: it's a thread that provides + -- a result without having to do further work. This is a slightly odd + -- abstraction, but useful: we may start a thread using @http2@ to + -- receive messages, but as soon as we receive the headers realize that + -- no further work needs to be done. We treat this separately, to allow + -- this case to have a diferent result type. + , threadTrivial :: r' -> IO () + -- | Unique identifier for this thread + , threadId :: DebugThreadId + } + +type ThreadBody a r r' = + (forall x. IO x -> IO x) + -- ^ Unmask exceptions + -- + -- If using 'forkThread', the thread is started with exceptions masked + -> ThreadContext a r r' + -- ^ Thread context + -- + -- This allows the thread body to inspect and manipulate its own context. + -> IO () + +newThreadState :: String -> IO (TVar (ThreadState a r r')) +newThreadState label = do + debugId <- newDebugThreadId label + STM.newTVarIO $ ThreadNotStarted debugId + forkThread :: HasCallStack - => ThreadLabel -> TVar (ThreadState a) -> ThreadBody a -> IO () + => ThreadLabel -> TVar (ThreadState a r r') -> ThreadBody a r r' -> IO () forkThread label state body = - void $ mask_ $ forkIOWithUnmask $ \unmask -> + void $ E.mask_ $ forkIOWithUnmask $ \unmask -> threadBody label state $ body unmask -- | Wrap the thread body -- -- This should be wrapped around the body of the thread, and should be called --- with exceptions masked. +-- with exceptions masked; the thread body itself should unmask when appropriate +-- (by using the 'ThreadContext'). -- -- This is intended for integration with existing libraries (such as @http2@), -- which might do the forking under the hood. -- -- If the 'ThreadState' is anything other than 'ThreadNotStarted' on entry, -- this function terminates immediately. -threadBody :: forall a. +threadBody :: forall a r r'. HasCallStack => ThreadLabel - -> TVar (ThreadState a) - -> ((a -> IO ()) -> DebugThreadId -> IO ()) + -> TVar (ThreadState a r r') + -> (ThreadContext a r r' -> IO ()) -> IO () threadBody label state body = do labelThisThread label threadId <- myThreadId - initState <- readTVarIO state + initState <- STM.readTVarIO state -- See discussion of 'ThreadNotStarted' -- It's critical that async exceptions are masked at this point. case initState of ThreadNotStarted debugId -> do - atomically $ writeTVar state $ ThreadInitializing debugId threadId - ThreadException _ exception -> + atomically $ STM.writeTVar state $ ThreadInitializing debugId threadId + ThreadDied _ ThreadException{threadException} -> -- We don't change the thread status here: 'cancelThread' offers the -- guarantee that the thread status /will/ be in aborted or done state -- on return. This means that /externally/ the thread will be -- considered done, even if perhaps the thread must still execute some -- actions before it can actually terminate. - void . forkIO $ throwTo threadId exception + void . forkIO $ throwTo threadId threadException _otherwise -> do - unexpected "initState" initState + unexpected initState - let markReady :: a -> STM () - markReady a = do - modifyTVar state $ \oldState -> - case oldState of - ThreadInitializing debugId _ -> - ThreadRunning debugId threadId a - ThreadException _ _ -> - oldState -- leave alone (see discussion above) - _otherwise -> - unexpected "markReady" oldState + -- 'markRunning' is invoked when the thread body calls 'threadMainBody' + let markRunning :: a -> IO () + markRunning a = atomically $ do + oldState <- STM.readTVar state + case oldState of + ThreadInitializing debugId _ -> do + STM.writeTVar state $ ThreadRunning debugId threadId a + ThreadDied{} -> + -- leave alone (see discussion above) + return () + _otherwise -> + unexpected oldState - markDone :: Either SomeException () -> STM () - markDone mDone = do - modifyTVar state $ \oldState -> - case (oldState, mDone) of - (ThreadRunning debugId _ iface, Right ()) -> - ThreadDone debugId iface - (ThreadException{}, _) -> - oldState -- record /first/ exception - (_, Left e) -> - ThreadException (threadDebugId oldState) e - _otherwise -> - unexpected "markDone" oldState + -- 'markDone' is invoked /by/ the thread body, to mark itself done + let markDone :: r -> IO () + markDone r = atomically $ do + oldState <- STM.readTVar state + case oldState of + ThreadRunning debugId _ a -> + STM.writeTVar state $ ThreadDone debugId a r + ThreadDied{} -> + -- Thread got cancelled before it could mark itself done. + return () + _otherwise -> + unexpected oldState - res <- try $ body (atomically . markReady) (threadDebugId initState) - atomically $ markDone res + -- 'markTrivial' is invoked when the thread body calls 'threadTrivial' + let markTrivial :: r' -> IO () + markTrivial r' = atomically $ do + oldState <- STM.readTVar state + case oldState of + ThreadInitializing debugId _ -> + STM.writeTVar state $ ThreadTrivial debugId r' + ThreadDied{} -> + -- Bit of a weird case: trivial thread, but cancelled; + -- we record it as cancelled. + return () + _otherwise -> + unexpected oldState + + -- 'markResult' is invoked on the result of the thread body. + let markResult :: Either ExactException () -> IO () + markResult (Right ()) = atomically $ do + -- Thread completed normally; thread state is already updated, + -- /provided/ the thread body called 'markDone'. If it didn't, + -- that's a bug in the thread body. + oldState <- STM.readTVar state + case oldState of + ThreadRunning{} -> + unexpected oldState + _otherwise -> + return () + markResult (Left e) = atomically $ do + oldState <- STM.readTVar state + case oldState of + ThreadDone{} -> + -- Thread died /after/ it marked itself done. Such an exception + -- is invisible; see 'threadMainBody'. + return () + ThreadDied{} -> + -- If the state is /already/ 'ThreadDied', that means the thread + -- was cancelled. The actual exception that we catch may be the + -- same exception, or (depending on when the thread unmasked + -- exceptions), it may be a different one. Either way, we keep + -- the exception passed to 'cancelThread' as the reason. + return () + ThreadTrivial{} -> + -- Cannot happen; trivial threads don't run anything + unexpected oldState + ThreadNotStarted{} -> + -- Can't happen + unexpected oldState + ThreadInitializing debugId _ -> + -- Thread died before it could decide between 'threadMainBody' or + -- 'threadTrivial' + STM.writeTVar state $ + ThreadDied debugId (ThreadException e ThreadThrewException) + ThreadRunning debugId _ _ -> + -- Thread died before it could declare itself done + STM.writeTVar state $ + ThreadDied debugId (ThreadException e ThreadThrewException) + + res <- tryExact $ body ThreadContext{ + threadMainBody = \a k -> markRunning a >> k markDone + , threadTrivial = markTrivial + , threadId = threadDebugId initState + } + markResult res where - unexpected :: String -> ThreadState a -> x - unexpected msg st = error $ concat [ - msg - , ": unexpected " - , show (const () <$> st) - ] + unexpected :: HasCallStack => ThreadState a r r' -> x + unexpected st = error $ "unexpected " <> show (showableState st) {------------------------------------------------------------------------------- Stopping -------------------------------------------------------------------------------} --- | Result of cancelling a thread -data CancelResult a = - -- | The thread terminated normally before we could cancel it - AlreadyTerminated a - - -- | The thread terminated with an exception before we could cancel it - | AlreadyAborted SomeException - - -- | We killed the thread with the specified exception - | Cancelled - -- | Kill thread if it is running -- -- * If the thread is in `ThreadNotStarted` state, we merely change the state to @@ -233,50 +389,66 @@ -- -- In all cases, the caller is guaranteed that the thread state has been updated -- even if perhaps the thread is still shutting down. -cancelThread :: forall a. - TVar (ThreadState a) - -> SomeException - -> IO (CancelResult a) +cancelThread :: forall a r r'. + HasCallStack + => TVar (ThreadState a r r') + -> ExactException + -> IO () cancelThread state e = do - (result, mTid) <- atomically aux + backtrace <- collectBacktraces + + let cancelled :: ThreadException + cancelled = ThreadException{ + threadException = e + , threadExceptionAnnotation = ThreadCancelled backtrace + } + + mTid <- atomically $ aux cancelled forM_ mTid $ flip throwTo e - return result where - aux :: STM (CancelResult a, Maybe ThreadId) - aux = do - st <- readTVar state + aux :: ThreadException -> STM (Maybe ThreadId) + aux cancelled = do + st <- STM.readTVar state case st of ThreadNotStarted debugId -> do - writeTVar state $ ThreadException debugId e - return (Cancelled, Nothing) + STM.writeTVar state $ ThreadDied debugId cancelled + return Nothing ThreadInitializing debugId threadId -> do - writeTVar state $ ThreadException debugId e - return (Cancelled, Just threadId) + STM.writeTVar state $ ThreadDied debugId cancelled + return $ Just threadId ThreadRunning debugId threadId _ -> do - writeTVar state $ ThreadException debugId e - return (Cancelled, Just threadId) - ThreadException _debugId e' -> - return (AlreadyAborted e', Nothing) - ThreadDone _debugId a -> - return (AlreadyTerminated a, Nothing) + STM.writeTVar state $ ThreadDied debugId cancelled + return $ Just threadId + -- already died + ThreadDied{} -> return Nothing + ThreadDone{} -> return Nothing + ThreadTrivial{} -> return Nothing + {------------------------------------------------------------------------------- Interacting with the thread -------------------------------------------------------------------------------} +data ThreadIface a r' = + -- | The thread interface is available + -- + -- We do /not/ distinguish between 'ThreadDone' and 'ThreadRunning' here, as + -- doing so is inherently racy (we might return that the client is still + -- running, and then it terminates before the calling code can do anything with + -- that information). + IfaceAvailable a + + -- | Thread was trivial (terminated immediately) + | IfaceTrivial r' + -- | Get the thread's interface -- --- The behaviour of this 'getThreadInterface' depends on the thread state; it +-- The behaviour of 'withThreadInterface' depends on the thread state; it -- -- * blocks if the thread in case of 'ThreadNotStarted' or 'ThreadInitializing' -- * throws 'ThreadInterfaceUnavailable' in case of 'ThreadException'. -- * returns the thread interface otherwise -- --- We do /not/ distinguish between 'ThreadDone' and 'ThreadRunning' here, as --- doing so is inherently racy (we might return that the client is still --- running, and then it terminates before the calling code can do anything with --- that information). --- -- NOTE: This turns off deadlock detection for the duration of the transaction. -- It should therefore only be used for transactions that can never be blocked -- indefinitely. @@ -287,85 +459,170 @@ -- those exception and treat them as network failures. If a @grapesy@ function -- ever throws a "blocked indefinitely" exception, this should be reported as a -- bug in @grapesy@. -withThreadInterface :: forall a b. - TVar (ThreadState a) - -> (a -> STM b) +withThreadInterface :: forall a b r r'. + HasCallStack + => TVar (ThreadState a r r') + -> (ThreadIface a r' -> STM b) -> IO b -withThreadInterface state k = - withoutDeadlockDetection . atomically $ - k =<< getThreadInterface +withThreadInterface state k = do + mb :: Either ThreadException b <- withoutDeadlockDetection $ atomically $ do + ma <- getThreadInterface + either (return . Left) (fmap Right . k) ma + either throwThreadException return mb where - getThreadInterface :: STM a + getThreadInterface :: STM (Either ThreadException (ThreadIface a r')) getThreadInterface = do - st <- readTVar state + st <- STM.readTVar state case st of - ThreadNotStarted _ -> retry - ThreadInitializing _ _ -> retry - ThreadRunning _ _ a -> return a - ThreadDone _ a -> return a - ThreadException _ e -> throwSTM e + ThreadNotStarted _ -> STM.retry + ThreadInitializing _ _ -> STM.retry + ThreadDied _ e -> return $ Left e + ThreadRunning _ _ a -> return $ Right $ IfaceAvailable a + ThreadDone _ a _ -> return $ Right $ IfaceAvailable a + ThreadTrivial _ r' -> return $ Right $ IfaceTrivial r' -- | Wait for the thread to terminate normally -- -- If the thread terminated with an exception, this rethrows that exception. -waitForNormalThreadTermination :: TVar (ThreadState a) -> STM () -waitForNormalThreadTermination state = - waitUntilInitialized state >>= \case - ThreadNotYetRunning_ v -> absurd v - ThreadRunning_ -> retry - ThreadDone_ -> return () - ThreadException_ e -> throwSTM e +waitForNormalThreadTermination :: + HasCallStack + => TVar (ThreadState a r r') -> IO (Either r' r) +waitForNormalThreadTermination state = do + mErr <- atomically $ waitForNormalOrAbnormalThreadTermination state + either throwThreadException return mErr -- | Wait for the thread to terminate normally or abnormally waitForNormalOrAbnormalThreadTermination :: - TVar (ThreadState a) - -> STM (Maybe SomeException) + TVar (ThreadState a r r') + -> STM (Either ThreadException (Either r' r)) waitForNormalOrAbnormalThreadTermination state = waitUntilInitialized state >>= \case ThreadNotYetRunning_ v -> absurd v - ThreadRunning_ -> retry - ThreadDone_ -> return $ Nothing - ThreadException_ e -> return $ Just e + ThreadRunning_ -> STM.retry + ThreadDone_ r -> return $ Right (Right r) + ThreadTrivial_ r' -> return $ Right (Left r') + ThreadException_ e -> return $ Left e -- | Run the specified transaction, unless the thread terminated with an -- exception unlessAbnormallyTerminated :: - TVar (ThreadState a) + TVar (ThreadState a r r') -> STM b - -> STM (Either SomeException b) + -> STM (Either ThreadException b) unlessAbnormallyTerminated state f = waitUntilInitialized state >>= \case ThreadNotYetRunning_ v -> absurd v ThreadRunning_ -> Right <$> f - ThreadDone_ -> Right <$> f + ThreadDone_ _ -> Right <$> f + ThreadTrivial_ _ -> Right <$> f ThreadException_ e -> return $ Left e waitUntilInitialized :: - TVar (ThreadState a) - -> STM (ThreadState_ Void) -waitUntilInitialized state = getThreadState_ state retry + TVar (ThreadState a r r') + -> STM (ThreadState_ Void r r') +waitUntilInitialized state = getThreadState_ state STM.retry -- | An abstraction of 'ThreadState' without the public interface type. -data ThreadState_ notRunning = +data ThreadState_ notRunning r r' = ThreadNotYetRunning_ notRunning | ThreadRunning_ - | ThreadDone_ - | ThreadException_ SomeException + | ThreadDone_ r + | ThreadTrivial_ r' + | ThreadException_ ThreadException getThreadState_ :: - TVar (ThreadState a) + TVar (ThreadState a r r') -> STM notRunning - -> STM (ThreadState_ notRunning) + -> STM (ThreadState_ notRunning r r') getThreadState_ state onNotRunning = do - st <- readTVar state + st <- STM.readTVar state case st of ThreadNotStarted _ -> ThreadNotYetRunning_ <$> onNotRunning ThreadInitializing _ _ -> ThreadNotYetRunning_ <$> onNotRunning ThreadRunning _ _ _ -> return $ ThreadRunning_ - ThreadDone _ _ -> return $ ThreadDone_ - ThreadException _ e -> return $ ThreadException_ e + ThreadDone _ _ r -> return $ ThreadDone_ r + ThreadTrivial _ r' -> return $ ThreadTrivial_ r' + ThreadDied _ e -> return $ ThreadException_ e {------------------------------------------------------------------------------- + Monitoring +-------------------------------------------------------------------------------} + +newtype MonitorRef = MonitorRef ThreadId + deriving stock (Show, Eq) + deriving ToExceptionDoc via LinesToExceptionDoc MonitorRef + +-- | Annotation added to exceptions that were thrown by 'threadMonitor'. +data MonitorAnnotation = MonitorAnnotation{ + -- | Backtrace to where the monitor was first established + monitorAnnotationContext :: Backtraces + + -- | The ID of the monitor + -- + -- Although the 'MonitorRef' is opaque, it /does/ have an 'Eq' instance, + -- so this can occassionally be useful to relate an exception back to + -- a specific monitor instance. + , monitorAnnotationRef :: MonitorRef + } + deriving stock (Show, Generic) + deriving anyclass (ToExceptionDoc) + +#if MIN_VERSION_base(4,20,0) +instance ExceptionAnnotation MonitorAnnotation where + displayExceptionAnnotation = renderDoc . toExceptionDoc defaultFormatCtx +#endif + +-- | Monitor another thread +-- +-- Inspired by monitoring in Erlang +-- . +-- +-- Just like in Erlang, if the target thread has already died when we start +-- monitoring, the monitor exception (if any) is thrown immediately (we inherit +-- this behaviour from 'waitForNormalOrAbnormalThreadTermination'). +threadMonitor :: + (HasCallStack, Exception e) + => TVar (ThreadState a1 r1 r'1) + -- ^ Thread doing the monitoring + -- + -- This is the thread that wants to receive the exception when the other + -- thread terminates. + -> TVar (ThreadState a2 r2 r'2) + -- ^ The thread to monitor + -> (Either ThreadException (Either r'2 r2) -> Maybe e) + -- ^ Given the termination result of the target, should we throw an + -- exception to the monitoring thread? + -- + -- If 'Just', the exception is given a 'MonitorAnnotation'. + -> IO MonitorRef +threadMonitor us them p = do + -- Backtrace to where the monitor was established + backtrace <- collectBacktraces + MonitorRef <$> forkIO (aux backtrace) + where + aux :: Backtraces -> IO () + aux backtrace = do + -- The 'MonitorRef' is the ID of the thread that /actually/ doing the + -- monitoring: that is, us. + ref <- MonitorRef <$> myThreadId + res <- atomically $ waitForNormalOrAbnormalThreadTermination them + forM_ (p res) $ \e -> do + let ann :: MonitorAnnotation + ann = MonitorAnnotation{ + monitorAnnotationContext = backtrace + , monitorAnnotationRef = ref + } + let e' :: E.SomeException + e' = addExceptionContext ann (toException e) + cancelThread us (WrapExactException e') + +-- | Remove monitor +-- +-- The caller is guaranteed that on return the monitor will no longer fire. +demonitor :: MonitorRef -> IO () +demonitor (MonitorRef ref) = killThread ref + +{------------------------------------------------------------------------------- Internal auxiliary -------------------------------------------------------------------------------} @@ -375,4 +632,4 @@ withoutDeadlockDetection :: IO a -> IO a withoutDeadlockDetection k = do threadId <- myThreadId - bracket (newStablePtr threadId) freeStablePtr $ \_ -> k + bracket (Foreign.newStablePtr threadId) Foreign.freeStablePtr $ \_ -> k diff --git a/src/Network/GRPC/Util/TimeManager.hs b/src/Network/GRPC/Util/TimeManager.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Util/TimeManager.hs @@ -0,0 +1,33 @@ +module Network.GRPC.Util.TimeManager ( + -- * Timeouts + TimeManager, + withTimeManager, + disableTimeout, +) where + +import System.TimeManager qualified as TimeManager + +{------------------------------------------------------------------------------- + Timeouts +-------------------------------------------------------------------------------} + +type TimeManager = TimeManager.Manager + +-- | Allocate time manager (without any actual timeouts) +-- +-- The @http2@ ecosystem relies on a time manager for timeouts; we don't use +-- those timeouts (see disableTimeout), but must still provide a time manager +-- for insecure connections. For secure connections the time manager is +-- allocated in 'Network.Run.Timeout.runTCPServerWithSocket' from @network-run@. +-- In that package it allocates a single manager for the entire server (it +-- allocates the manager before calling accept), so we should do the same in the +-- insecure case for better consistency between the two setups; this also avoids +-- the possibility of leaking managers. +withTimeManager :: (TimeManager -> IO a) -> IO a +withTimeManager = TimeManager.withManager (disableTimeout * 1_000_000) + +-- | Disable timeouts in http2/http2-tls +-- +-- A value of 0 (or lower) disables timeouts as of @time-manager-0.2.2@. +disableTimeout :: Int +disableTimeout = 0 diff --git a/src/Network/GRPC/Util/Version.hs b/src/Network/GRPC/Util/Version.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Util/Version.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE CPP #-} +module Network.GRPC.Util.Version (version) where + +-- | Version of this package +version :: String +version = CURRENT_PACKAGE_VERSION diff --git a/test-disconnect/Main.hs b/test-disconnect/Main.hs new file mode 100644 --- /dev/null +++ b/test-disconnect/Main.hs @@ -0,0 +1,279 @@ +module Main (main) where + +import Control.Concurrent +import Control.Exception (fromException) +import Control.Exception qualified as Exception +import Control.Monad +import Data.Proxy +import Network.Socket +import System.IO +import Test.HUnit + +import Network.GRPC.Common +import Network.GRPC.Client qualified as Client +import Network.GRPC.Server qualified as Server + +import Network.GRPC.Server.Run qualified as Grapesy + +import Test.Disconnect.Echo.Client +import Test.Disconnect.Echo.RPC +import Test.Disconnect.Echo.Server +import Test.Disconnect.Util.Client +import Test.Disconnect.Util.Process +import Test.Disconnect.Util.Server + +{------------------------------------------------------------------------------- + Test disconnects + + The goal of this test suite is to test what happens when a client or a server + abruptly disconnects: does their peer notice that they disappeared? To model + network failure, we run the node which will disconnect in a separate process, + and then unceremoniously kill that process (without even giving the Haskell + RTS a chance to shutdown cleanly). + + We use 'forkProcess' to start auxiliary processes, which does not seem to play + nice with the @tasty@ framework; I am not sure why. I suspect something to do + with threads, but I don't understand the exact reason. Tests would sometimes + mysteriously hang depending on whether or not a timeout was interested just + before the test would /begin/. We therefore do not use @tasty@ here. + + When a server disconnects, we expect: + + 1. All current calls fail with 'Client.ServerDisconnected' + 2. Future calls (after reconnection) succeed + + When a client disconnects, we expect: + + 1. The handlers dealing with that client (i.e. on that connection) should fail + with 'Server.ClientDisconnected' + 2. Future calls (after reconnection) succeed +-------------------------------------------------------------------------------} + +main :: IO () +main = do + hSetBuffering stdout NoBuffering + + runTest "clientDisconnect" test_clientDisconnect + runTest "serverDisconnect" test_serverDisconnect + where + runTest :: String -> Assertion -> IO () + runTest label testCase = do + putStr $ label ++ ".. " + testCase + putStrLn "OK" + + +{------------------------------------------------------------------------------- + Test /client/ disconnect +-------------------------------------------------------------------------------} + +-- | Two separate clients make many concurrent calls, one of them disconnects. +test_clientDisconnect :: Assertion +test_clientDisconnect = do + -- + -- Create the server + -- + + (handler1, handlerResults1) <- monitoredHandler $ handleEcho (Proxy @Echo1) + (handler2, handlerResults2) <- monitoredHandler $ handleEcho (Proxy @Echo2) + server <- Server.mkGrpcServer def [handler1, handler2] + Grapesy.forkServer def serverConfig server $ \runningServer -> do + serverAddr <- mkServerAddress <$> Grapesy.getServerPort runningServer + + -- + -- Create client + -- + + -- Start a client in a separate process + -- + -- We will kill this process one each call has connected to the server + -- + -- NOTES: + -- + -- * 'forkProcess' will not copy any threads into the child process, + -- the server runs only here. + -- * The child process will kill itself, so we don't have to keep track + -- of it here. + let numCalls1 = 10 + clientChildProcess <- forkChildProcess $ do + Client.withConnection def serverAddr $ \conn -> do + clientThreads <- replicateM numCalls1 $ + fork_echoOnceThenWait conn (Proxy @Echo1) + -- Wait until we are sure that all clients have started their RPC, + -- then kill the process. This avoids race conditions and guarantees + -- that the server will see @numCalls@ clients disconnecting. + mapM_ waitClientConnected clientThreads + killThisProcess + + -- Start second client (which will not be killed) + let numCalls2 = 20 + numSteps = 5 + childResults <- Client.withConnection def serverAddr $ \conn -> do + rpc1 <- replicateM numCalls2 $ fork_countFrom conn (Proxy @Echo1) numSteps + rpc2 <- replicateM numCalls2 $ fork_countFrom conn (Proxy @Echo2) numSteps + mapM waitClientResult (rpc1 ++ rpc2) + + -- + -- Check results + -- + + void $ waitForChildProcess clientChildProcess + + (normalTerminations1, clientDisconnected1, unexpectedExceptions1) <- + getHandlerResults maxWait handlerResults1 (numCalls1 + numCalls2) + (normalTerminations2, clientDisconnected2, unexpectedExceptions2) <- + getHandlerResults maxWait handlerResults2 numCalls2 + + -- All calls by clients in /this/ process (not the ones we killed) should + -- have finished normally + assertBool ("Unexpected childResults: " ++ show childResults) $ + flip all childResults $ \case + Right 15 -> True + _otherwise -> False + + -- The handler for Echo1 should see @numCalls1@ client disconnects and + -- @numCalls@ regular terminations; the handler for Echo2 should only see + -- regular terminations. + assertEqual "clientDisconnected1" numCalls1 $ clientDisconnected1 + assertEqual "clientDisconnected2" 0 $ clientDisconnected2 + assertEqual "normalTerminations1" numCalls2 $ normalTerminations1 + assertEqual "normalTerminations2" numCalls2 $ normalTerminations2 + + -- No handler should have thrown any unexpected exceptions + assertBool ("unexpectedExceptions1: " ++ show unexpectedExceptions1) $ + null unexpectedExceptions1 + assertBool ("unexpectedExceptions2: " ++ show unexpectedExceptions2) $ + null unexpectedExceptions2 + where + serverConfig :: Grapesy.ServerConfig + serverConfig = Grapesy.ServerConfig { + serverInsecure = Just $ Grapesy.InsecureConfig { + insecureHost = Just "127.0.0.1" + , insecurePort = 0 + } + , serverSecure = Nothing + } + + mkServerAddress :: PortNumber -> Client.Server + mkServerAddress port = Client.ServerInsecure Client.Address { + addressHost = "127.0.0.1" + , addressPort = port + , addressAuthority = Nothing + } + +{------------------------------------------------------------------------------- + Test /server/ disconnect +-------------------------------------------------------------------------------} + +test_serverDisconnect :: Assertion +test_serverDisconnect = withIPC (Proxy @PortNumber) $ \ipc-> do + -- Create the server in a separate process + -- (We start and kill the server multiple times) + let serverMain :: IO () + serverMain = do + (handler, _results) <- monitoredHandler $ handleEcho (Proxy @Echo1) + server <- Server.mkGrpcServer def [handler] + Grapesy.forkServer def serverConfig server $ \runningServer -> do + serverPort <- Grapesy.getServerPort runningServer + ipcWrite ipc serverPort + Grapesy.waitServer runningServer + + serverProcessVar <- newEmptyMVar + let startServer :: IO Client.Server + startServer = do + serverProcess <- forkChildProcess $ serverMain + serverPort <- ipcRead ipc + putMVar serverProcessVar serverProcess + return $ mkServerAddress serverPort + + killServer :: IO () + killServer = do + serverProcess <- takeMVar serverProcessVar + killChildProcess serverProcess + + flip Exception.finally killServer $ do + initServerAddr <- startServer + + -- When we kill the server, the client will notice the disconnect. + -- We construct a reconnect policy which reboots the server. + let reconnectPolicy :: Client.ReconnectPolicy + reconnectPolicy = Client.ReconnectPolicy $ do + serverAddr <- startServer + return $ Client.DoReconnect Client.Reconnect { + Client.reconnectTo = Client.ReconnectToNew serverAddr + , Client.nextPolicy = reconnectPolicy + , Client.onReconnect = def + } + + connParams :: Client.ConnParams + connParams = def { Client.connReconnectPolicy = reconnectPolicy } + + Client.withConnection connParams initServerAddr $ \conn -> do + -- Make some calls, then kill the server + do let numCalls = 10 + clientThreads <- replicateM numCalls $ + fork_echoOnceThenWait conn (Proxy @Echo1) + + -- All clients should be able to connect just fine + connected <- mapM waitClientConnected clientThreads + assertBool ("unexpected " ++ show connected) $ + flip all connected $ \case + Right () -> True + _otherwise -> False + + -- Once all clients have started their RPC, kill the server + killServer + + -- All calls should now have failed + results <- mapM waitClientResult clientThreads + assertBool ("unexpected results: " ++ show results) $ + flip all results $ \case + -- We cannot always distinguish clearly between getting + -- disconnected and the server closing the connection without + -- sending the trailers. + Left e + | Just Client.ServerDisconnected{} <- fromException e + -> True + + | Just e'@GrpcException{} <- fromException e + , grpcError e' == GrpcUnknown + -> True + + _otherwise + -> False + + -- New calls should succeed (after reconnection) + -- (No need to open a new connection, this happens transparently) + do let numCalls = 10 + let numSteps = 5 + clientThreads <- replicateM numCalls $ + fork_countFrom conn (Proxy @Echo1) numSteps + + results <- mapM waitClientResult clientThreads + assertBool ("unexpected results: " ++ show results) $ + flip all results $ \case + Right 15 -> True + _otherwise -> False + where + serverConfig :: Grapesy.ServerConfig + serverConfig = Grapesy.ServerConfig { + serverInsecure = Just $ Grapesy.InsecureConfig { + insecureHost = Just "127.0.0.1" + , insecurePort = 0 + } + , serverSecure = Nothing + } + + mkServerAddress :: PortNumber -> Client.Server + mkServerAddress port = Client.ServerInsecure Client.Address { + addressHost = "127.0.0.1" + , addressPort = port + , addressAuthority = Nothing + } + +{------------------------------------------------------------------------------- + Config +-------------------------------------------------------------------------------} + +maxWait :: Int +maxWait = 2_000_000 diff --git a/test-disconnect/Test/Disconnect/Echo/Client.hs b/test-disconnect/Test/Disconnect/Echo/Client.hs new file mode 100644 --- /dev/null +++ b/test-disconnect/Test/Disconnect/Echo/Client.hs @@ -0,0 +1,59 @@ +module Test.Disconnect.Echo.Client ( + fork_echoOnceThenWait + , fork_countFrom + ) where + +import Control.Monad +import Data.Proxy +import Data.Word +import GHC.TypeLits + +import Network.GRPC.Client qualified as Client +import Network.GRPC.Client.Binary qualified as Client.Binary +import Network.GRPC.Common + +import Test.Disconnect.Echo.RPC +import Test.Disconnect.Util.Client + +{------------------------------------------------------------------------------- + Test clients +-------------------------------------------------------------------------------} + +-- | Echo once, then wait indefinitely for a server response that never comes +fork_echoOnceThenWait :: forall (rpc :: Symbol). + KnownSymbol rpc + => Client.Connection + -> Proxy (Echo rpc) + -> IO (ClientThread ()) +fork_echoOnceThenWait conn _rpc = + forkClientThread $ \markConnected _markResult -> do + Client.withRPC conn def (Proxy @(Echo rpc)) $ \call -> do + -- One round-trip + Client.Binary.sendNextInput @Word64 call 0 + _resp <- Client.Binary.recvNextOutput @Word64 call + markConnected + + -- The next call to 'recvNextOutput' will never return + void $ Client.Binary.recvNextOutput @Word64 call + +-- | Count down from the specified number, and sum all server responses +fork_countFrom :: forall (rpc :: Symbol). + KnownSymbol rpc + => Client.Connection + -> Proxy (Echo rpc) + -> Word64 + -> IO (ClientThread Word64) +fork_countFrom conn _rpc target = + forkClientThread $ \markConnected markResult -> do + Client.withRPC conn def (Proxy @(Echo rpc)) $ \call -> do + let loop :: Word64 -> Word64 -> IO () + loop !acc 0 = do + Client.sendEndOfInput call + NoMetadata <- Client.recvTrailers call + markResult acc + loop !acc n = do + Client.Binary.sendNextInput @Word64 call n + resp <- Client.Binary.recvNextOutput @Word64 call + markConnected + loop (acc + resp) (n - 1) + loop 0 target diff --git a/test-disconnect/Test/Disconnect/Echo/RPC.hs b/test-disconnect/Test/Disconnect/Echo/RPC.hs new file mode 100644 --- /dev/null +++ b/test-disconnect/Test/Disconnect/Echo/RPC.hs @@ -0,0 +1,13 @@ +module Test.Disconnect.Echo.RPC ( + Echo + , Echo1 + , Echo2 + ) where + +import Proto.API.Trivial + +type Echo rpc = Trivial' rpc + +type Echo1 = Echo "rpc1" +type Echo2 = Echo "rpc2" + diff --git a/test-disconnect/Test/Disconnect/Echo/Server.hs b/test-disconnect/Test/Disconnect/Echo/Server.hs new file mode 100644 --- /dev/null +++ b/test-disconnect/Test/Disconnect/Echo/Server.hs @@ -0,0 +1,26 @@ +module Test.Disconnect.Echo.Server ( + handleEcho + ) where + +import Data.Proxy +import Data.Word + +import Network.GRPC.Common +import Network.GRPC.Server qualified as Server +import Network.GRPC.Server.Binary qualified as Server.Binary + +import Test.Disconnect.Echo.RPC + +-- | Echos any input +handleEcho :: Proxy (Echo rpc) -> Server.Call (Echo rpc) -> IO () +handleEcho _ call = + loop + where + loop :: IO () + loop = do + inp <- Server.Binary.recvInput @Word64 call + case inp of + StreamElem n -> Server.Binary.sendNextOutput call n >> loop + FinalElem n _ -> Server.Binary.sendFinalOutput call (n, NoMetadata) + NoMoreElems _ -> Server.sendTrailers call NoMetadata + diff --git a/test-disconnect/Test/Disconnect/Util/Client.hs b/test-disconnect/Test/Disconnect/Util/Client.hs new file mode 100644 --- /dev/null +++ b/test-disconnect/Test/Disconnect/Util/Client.hs @@ -0,0 +1,63 @@ +module Test.Disconnect.Util.Client ( + ClientThread(..) + , forkClientThread + ) where + +import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception +import Control.Monad + +{------------------------------------------------------------------------------- + General infrastructure +-------------------------------------------------------------------------------} + +data ClientThread a = ClientThread{ + -- | Wait for the client to have established a connection to the server + waitClientConnected :: IO (Either SomeException ()) + + -- | Wait for the client to terminate and get its result + , waitClientResult :: IO (Either SomeException a) + + -- | Kill the thread + , killClientThread :: IO () + } + +forkClientThread :: forall a. + ( IO () -- ^ Mark client connected (no-op if called again) + -> (a -> IO ()) -- ^ Mark client result + -> IO () + ) + -> IO (ClientThread a) +forkClientThread k = do + clientConnected <- newEmptyTMVarIO + clientResult <- newEmptyTMVarIO + let recordException :: SomeException -> IO () + recordException e = atomically $ do + -- It's possible (indeed, likely) the exception happened after + -- we set up a connection + void $ tryPutTMVar clientConnected $ Left e + + -- It should normally not happen that an exception is raised /after/ + -- the client is done. If it /does/ happen, we want to know about + -- it, so we override the existing value, if any. + void $ tryTakeTMVar clientResult + putTMVar clientResult $ Left e + + markConnected :: IO () + markConnected = atomically $ + void $ tryPutTMVar clientConnected $ Right () + + markResult :: a -> IO () + markResult result = atomically $ + putTMVar clientResult $ Right result + + clientThreadId <- forkIO $ + handle recordException $ + k markConnected markResult + + return $ ClientThread{ + waitClientConnected = atomically $ readTMVar clientConnected + , waitClientResult = atomically $ readTMVar clientResult + , killClientThread = killThread clientThreadId + } diff --git a/test-disconnect/Test/Disconnect/Util/Exception.hs b/test-disconnect/Test/Disconnect/Util/Exception.hs new file mode 100644 --- /dev/null +++ b/test-disconnect/Test/Disconnect/Util/Exception.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE CPP #-} + +module Test.Disconnect.Util.Exception ( + testFormatCtx + , uncaughtExceptionHandler + ) where + +import Control.Concurrent +import Control.Exception +import Data.Function ((&)) +import Data.Maybe (fromMaybe) +import System.IO + +#if MIN_VERSION_base(4,18,0) +import GHC.Conc.Sync (threadLabel) +#endif + +import Network.HTTP2.Client qualified as HTTP2 + +import Network.GRPC.Common.Exception + +{------------------------------------------------------------------------------- + Exception rendering +-------------------------------------------------------------------------------} + +testFormatCtx :: FormatCtx +testFormatCtx = grapesyFormatCtx + & insertFormatCtx http2 + where + http2 :: FormatCtx -> HTTP2.HTTP2Error -> Doc + http2 ctx = \case + HTTP2.BadThingHappen se -> + withHeader "BadThingHappen" $ toExceptionDoc ctx se + other -> + fromLines $ displayException other + +{------------------------------------------------------------------------------- + Uncaught exception handler +-------------------------------------------------------------------------------} + +uncaughtExceptionHandler :: SomeException -> IO () +uncaughtExceptionHandler e = do + tid <- myThreadId + mLabel :: Maybe String <- +#if MIN_VERSION_base(4,18,0) + threadLabel tid +#else + return $ Just "unknown label" +#endif + hPutStrLn stderr $ concat [ + "Uncaught exception in " + , show tid + , " (" + , fromMaybe "unlabelled" mLabel + , "): " + , renderAnyException testFormatCtx e + ] diff --git a/test-disconnect/Test/Disconnect/Util/Process.hs b/test-disconnect/Test/Disconnect/Util/Process.hs new file mode 100644 --- /dev/null +++ b/test-disconnect/Test/Disconnect/Util/Process.hs @@ -0,0 +1,93 @@ +module Test.Disconnect.Util.Process ( + -- * Process lifecycle + ChildProcess(..) + , forkChildProcess + , killThisProcess + -- * Simple IPC + , IPC(..) + , withIPC + ) where + +import Control.Concurrent +import Control.Exception +import Control.Monad +import Data.Proxy +import System.Exit +import System.IO +import System.IO.Temp +import System.Posix + +{------------------------------------------------------------------------------- + Process lifecycle +-------------------------------------------------------------------------------} + +data ChildProcess = ChildProcess{ + waitForChildProcess :: IO (Maybe ProcessStatus) + , killChildProcess :: IO () + } + +-- | Fork child process +forkChildProcess :: IO () -> IO ChildProcess +forkChildProcess k = do + child <- forkProcess k + return $ ChildProcess{ + waitForChildProcess = getProcessStatus True False child + , killChildProcess = signalProcess sigKILL child + } + +-- | Unclean process termination +-- +-- We need to use this to properly simulate the execution environment crashing +-- in an unrecoverable way. In particular, we don't want to give the program a +-- chance to do any of its normal exception handling/cleanup behavior. +killThisProcess :: IO () +killThisProcess = exitImmediately $ ExitFailure 1 + +{------------------------------------------------------------------------------- + Simple IPC +-------------------------------------------------------------------------------} + +data IPC a = IPC{ + ipcWrite :: a -> IO () + , ipcRead :: IO a + } + +-- | Setup interprocess communicaton +-- +-- We use a temporary file as a very rudimentary means of inter-process +-- communication so the server (which runs in a separate process) can make the +-- client aware of the port it is assigned by the OS. +withIPC :: forall a r. (Show a, Read a) => Proxy a -> (IPC a -> IO r) -> IO r +withIPC _ k = + withTemporaryFile $ \ipcFile -> do + let ipcWrite :: a -> IO () + ipcWrite x = writeFile ipcFile (show x) + + ipcRead :: IO a + ipcRead = do + threadDelay 10_000 + ma <- withFile ipcFile ReadWriteMode $ \h -> do + sz <- hFileSize h + if sz == 0 then + return Nothing + else do + contents <- replicateM (fromIntegral sz) $ hGetChar h + value <- evaluate $ read contents + -- Clear the contents, so we can send the next value + hSetFileSize h 0 + return $ Just value + + -- If necessary, retry (outside the scope of 'withFile') + maybe ipcRead return ma + + k IPC{ipcWrite, ipcRead} + +{------------------------------------------------------------------------------- + Internal auxiliary +-------------------------------------------------------------------------------} + +withTemporaryFile :: (FilePath -> IO a) -> IO a +withTemporaryFile k = + withSystemTempFile "grapesy-test-disconnect.txt" $ \fp h -> do + hClose h + k fp diff --git a/test-disconnect/Test/Disconnect/Util/Server.hs b/test-disconnect/Test/Disconnect/Util/Server.hs new file mode 100644 --- /dev/null +++ b/test-disconnect/Test/Disconnect/Util/Server.hs @@ -0,0 +1,114 @@ +module Test.Disconnect.Util.Server ( + -- * Monitoring server handlers + HandlerResults(..) + , monitoredHandler + , getHandlerResults + ) where + +import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception qualified as Exception +import Control.Monad +import GHC.Exception + +import Network.GRPC.Common +import Network.GRPC.Server qualified as Server + +{------------------------------------------------------------------------------- + Monitoring server handlers +-------------------------------------------------------------------------------} + +data HandlerResults = HandlerResults{ + -- | Number of normal terminations + handlerNormalTerminations :: TVar Int + + -- | Number of terminations due to 'ClientDisconnected' exceptions + , handlerClientDisconnected :: TVar Int + + -- | Terminations due to unexpected exceptions + , handlerUnexpectedExceptions :: TVar [SomeException] + } + +-- | Construct 'TVar' that records the result of each handler invocation +monitoredHandler :: forall rpc. + ( SupportsServerRpc rpc + , StaticMetadata (ResponseTrailingMetadata rpc) + , Default (ResponseInitialMetadata rpc) + ) + => (Server.Call rpc -> IO ()) + -> IO (Server.SomeRpcHandler IO, HandlerResults) +monitoredHandler handler = do + handlerNormalTerminations <- newTVarIO 0 + handlerClientDisconnected <- newTVarIO 0 + handlerUnexpectedExceptions <- newTVarIO [] + + let handlerFailed :: SomeException -> IO () + handlerFailed e = atomically $ + case fromException e of + Just Server.ClientDisconnected{} -> + modifyTVar handlerClientDisconnected (+ 1) + _otherwise -> + modifyTVar handlerUnexpectedExceptions (e :) + + handlerTerminated :: IO () + handlerTerminated = atomically $ + modifyTVar handlerNormalTerminations (+ 1) + + return ( + Server.someRpcHandler $ Server.mkRpcHandler @rpc $ \call -> + Exception.handle handlerFailed $ do + handler call + handlerTerminated + + , HandlerResults{ + handlerNormalTerminations + , handlerClientDisconnected + , handlerUnexpectedExceptions + } + ) + +-- | Get handler results +getHandlerResults :: + Int -- ^ Timeout + -> HandlerResults -- ^ Monitored handler + -> Int + -- ^ Number of expected results + -- + -- Blocks when not all results are available yet (/client/ termination does + -- not guarantee that /server/ results are available, the handler might not + -- yet have got a chance to say that it is done). + -> IO (Int, Int, [SomeException]) +getHandlerResults maxWait handlerResults expectedNumResults = do + timeoutVar <- newTVarIO False + void $ forkIO $ do + threadDelay maxWait + atomically $ writeTVar timeoutVar True + atomically $ do + normalTerminations <- readTVar handlerNormalTerminations + clientDisconnected <- readTVar handlerClientDisconnected + unexpectedExceptions <- readTVar handlerUnexpectedExceptions + timeout <- readTVar timeoutVar + + let results = ( + normalTerminations + , clientDisconnected + , unexpectedExceptions + ) + numResults = sum [ + normalTerminations + , clientDisconnected + , length unexpectedExceptions + ] + + if numResults == expectedNumResults then + return results + else if timeout then + throwSTM $ userError $ "getHandlerResults timeout: " ++ show results + else + retry + where + HandlerResults{ + handlerNormalTerminations + , handlerClientDisconnected + , handlerUnexpectedExceptions + } = handlerResults diff --git a/test-grapesy/Main.hs b/test-grapesy/Main.hs --- a/test-grapesy/Main.hs +++ b/test-grapesy/Main.hs @@ -1,27 +1,21 @@ -{-# LANGUAGE CPP #-} - module Main (main) where -import Control.Concurrent -import Control.Exception -import Data.Maybe (fromMaybe) import GHC.Conc (setUncaughtExceptionHandler) -import System.IO import Test.Tasty -#if MIN_VERSION_base(4,18,0) -import GHC.Conc.Sync (threadLabel) -#endif +import Test.Util.Exception +import Test.Common.Exception qualified as Exception import Test.Prop.Dialogue qualified as Dialogue import Test.Regression.Issue102 qualified as Issue102 import Test.Regression.Issue238 qualified as Issue238 import Test.Sanity.Any qualified as Any import Test.Sanity.BrokenDeployments qualified as BrokenDeployments +import Test.Sanity.Cancellation qualified as Cancellation 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.Metadata qualified as Metadata import Test.Sanity.NoIsLabel qualified as NoIsLabel import Test.Sanity.Reclamation qualified as Reclamation import Test.Sanity.StreamingType.CustomFormat qualified as StreamingType.CustomFormat @@ -33,8 +27,7 @@ defaultMain $ testGroup "grapesy" [ testGroup "Sanity" [ - Disconnect.tests - , EndOfStream.tests + EndOfStream.tests , testGroup "StreamingType" [ StreamingType.NonStreaming.tests , StreamingType.CustomFormat.tests @@ -45,6 +38,8 @@ , Reclamation.tests , BrokenDeployments.tests , NoIsLabel.tests + , Metadata.tests + , Cancellation.tests ] , testGroup "Regression" [ Issue102.tests @@ -53,22 +48,7 @@ , testGroup "Prop" [ Dialogue.tests ] - ] - -uncaughtExceptionHandler :: SomeException -> IO () -uncaughtExceptionHandler e = do - tid <- myThreadId - mLabel :: Maybe String <- -#if MIN_VERSION_base(4,18,0) - threadLabel tid -#else - return $ Just "unknown label" -#endif - hPutStrLn stderr $ concat [ - "Uncaught exception in " - , show tid - , " (" - , fromMaybe "unlabelled" mLabel - , "): " - , displayException e + , testGroup "Common" [ + Exception.tests + ] ] diff --git a/test-grapesy/Test/Common/Exception.hs b/test-grapesy/Test/Common/Exception.hs new file mode 100644 --- /dev/null +++ b/test-grapesy/Test/Common/Exception.hs @@ -0,0 +1,22 @@ +module Test.Common.Exception (tests) where + +import Control.Exception (SomeException (..)) +import Test.Tasty +import Test.Tasty.QuickCheck +import System.ThreadManager qualified as ThreadManager +import Data.TreeDiff.QuickCheck (ediffEq) + +import Network.GRPC.Common.Exception + +tests :: TestTree +tests = testGroup "Test.Common.Exception" + [ testProperty "thread-manager-1" $ do + let expected = unlines + [ "KilledByThreadManager" + , " IOException" + , " user error (foo)" + ] + + let exc = ThreadManager.KilledByThreadManager $ Just $ SomeException $ userError "foo" + ediffEq expected (renderAnyException grapesyFormatCtx exc) + ] diff --git a/test-grapesy/Test/Driver/ClientServer.hs b/test-grapesy/Test/Driver/ClientServer.hs --- a/test-grapesy/Test/Driver/ClientServer.hs +++ b/test-grapesy/Test/Driver/ClientServer.hs @@ -26,31 +26,36 @@ -- * Constructing clients , TestClient , simpleTestClient + -- * Test failures + , FirstTestFailure(..) ) where import Control.Concurrent import Control.Concurrent.Async -import Control.Concurrent.STM -import Control.Exception (throwIO) +import Control.Concurrent.STM (STM, TVar, TMVar) +import Control.Concurrent.STM qualified as STM import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class import Data.ProtoLens.Labels () import Data.Text qualified as Text +import GHC.Generics (Generic) +import Network.HTTP2.Client qualified as HTTP2 import Network.HTTP2.Server qualified as HTTP2.Server import Network.Socket (PortNumber) import Network.TLS +import System.ThreadManager qualified as ThreadManager import Test.QuickCheck.Monadic qualified as QuickCheck import Test.Tasty.QuickCheck qualified as QuickCheck import Network.GRPC.Client qualified as Client import Network.GRPC.Common import Network.GRPC.Common.Compression qualified as Compr +import Network.GRPC.Common.Exception import Network.GRPC.Server qualified as Server import Network.GRPC.Server.Run qualified as Server -import Test.Util.Exception -import Paths_grapesy +import Paths_ (getDataFileName) {------------------------------------------------------------------------------- Top-level @@ -97,10 +102,10 @@ , serverContentType :: ContentTypeOverride -- | Is this exception expected on the client? - , isExpectedClientException :: SomeException -> Bool + , isExpectedClientException :: ExactException -> Bool -- | Is this exception expected on the server? - , isExpectedServerException :: SomeException -> Bool + , isExpectedServerException :: ExactException -> Bool } data ContentTypeOverride = @@ -171,26 +176,54 @@ we don't see these exceptions server-side. -------------------------------------------------------------------------------} -isDeliberateException :: SomeException -> Bool -isDeliberateException e = - case fromException e of - Just DeliberateException{} -> True - _otherwise -> False +-- | Deliberate exceptions thrown in tests (do not constitute test failures) +-- +-- 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 DeliberateException = + -- | Deliberate exception thrown in the server + DeliberateServerException ExceptionId -isClientDisconnected :: SomeException -> Bool -isClientDisconnected e = + -- | Deliberate exception thrown in the client + | DeliberateClientException ExceptionId + deriving stock (Show, Eq) + deriving anyclass (Exception) + +-- | We distinguish exceptions from each other simply by a number +type ExceptionId = Int + +isDeliberateException :: ExactException -> Bool +isDeliberateException (WrapExactException e) = case fromException e of - Just Server.ClientDisconnected{} -> True + Just (_e' :: DeliberateException) -> True _otherwise -> False -isInvalidRequestHeaders :: SomeException -> Bool -isInvalidRequestHeaders e = +-- | Client disconnect +-- +-- TODO +-- When a client disconnects http2 informs us in a number of different ways; +-- which exception we get depends on which one happens to get to us first. +isClientDisconnected :: ExactException -> Bool +isClientDisconnected (WrapExactException e) + | Just Server.ClientDisconnected{} <- fromException e + = True + + | Just (ThreadManager.KilledByThreadManager (Just e')) <- fromException e + , Just HTTP2.ConnectionIsClosed <- fromException e' + = True + + | otherwise + = False + +isInvalidRequestHeaders :: ExactException -> Bool +isInvalidRequestHeaders (WrapExactException e) = case fromException e of Just Server.CallSetupInvalidRequestHeaders{} -> True _otherwise -> False -isGrpc415 :: SomeException -> Bool -isGrpc415 e = +isGrpc415 :: ExactException -> Bool +isGrpc415 (WrapExactException e) = case fromException e of Just err' | Just msg <- grpcErrorMessage err' -> and [ grpcError err' == GrpcUnknown @@ -202,8 +235,8 @@ -- -- We respond with 400 Bad Request, which gets turned into GrpcInternal -- by 'classifyServerResponse'. -isGrpc400 :: SomeException -> Bool -isGrpc400 e = +isGrpc400 :: ExactException -> Bool +isGrpc400 (WrapExactException e) = case fromException e of Just err' | Just msg <- grpcErrorMessage err' -> and [ grpcError err' == GrpcInternal @@ -211,32 +244,32 @@ ] _otherwise -> False -isGrpcCancelled :: SomeException -> Bool -isGrpcCancelled e = +isGrpcCancelled :: ExactException -> Bool +isGrpcCancelled (WrapExactException e) = case fromException e of Just err' -> grpcError err' == GrpcCancelled _otherwise -> False -isHandshakeFailed :: SomeException -> Bool -isHandshakeFailed e = +isHandshakeFailed :: ExactException -> Bool +isHandshakeFailed (WrapExactException e) = case fromException e of Just HandshakeFailed{} -> True _otherwise -> False -isServerUnsupportedCompression :: SomeException -> Bool -isServerUnsupportedCompression e = +isServerUnsupportedCompression :: ExactException -> Bool +isServerUnsupportedCompression (WrapExactException e) = case fromException e of Just Server.CallSetupUnsupportedCompression{} -> True _otherwise -> False -isClientUnsupportedCompression :: SomeException -> Bool -isClientUnsupportedCompression e = +isClientUnsupportedCompression :: ExactException -> Bool +isClientUnsupportedCompression (WrapExactException e) = case fromException e of Just Client.CallSetupUnsupportedCompression{} -> True _otherwise -> False -isHandlerTerminated :: SomeException -> Bool -isHandlerTerminated e = +isHandlerTerminated :: ExactException -> Bool +isHandlerTerminated (WrapExactException e) = case fromException e of Just Server.HandlerTerminated{} -> True _otherwise -> False @@ -280,11 +313,22 @@ -- the one exception cannot be the /cause/ for the other exception (if it was, -- then one must happen /before/ the other). data FirstTestFailure = - FirstFailureInClient SomeException - | FirstFailureInServer SomeException - deriving stock (Show) - deriving anyclass (Exception) + FirstFailureInClient ExactException + | FirstFailureInServer ExactException + deriving stock (Show, Generic) + deriving anyclass (ToExceptionDoc) +instance Exception FirstTestFailure where +#if MIN_VERSION_base(4,20,0) + -- The backtrace to the 'FirstTestFailure' /itself/ is merely distracting + -- (we're interested only in the backtrace of the actual test failure) + backtraceDesired _ = False +#endif + +firstFailureInClient, firstFailureInServer :: ExactException -> FirstTestFailure +firstFailureInClient = FirstFailureInClient +firstFailureInServer = FirstFailureInServer + data TestFailure = TestFailure deriving stock (Show) deriving anyclass (Exception) @@ -294,7 +338,7 @@ -- Does nothing if an earlier test failure has already been marked. markTestFailure :: TMVar FirstTestFailure -> FirstTestFailure -> IO () markTestFailure firstTestFailure err = - void $ atomically $ tryPutTMVar firstTestFailure err + void $ atomically $ STM.tryPutTMVar firstTestFailure err {------------------------------------------------------------------------------- Server handler lock @@ -310,12 +354,12 @@ newtype ServerHandlerLock = ServerHandlerLock (TVar Int) newServerHandlerLock :: IO ServerHandlerLock -newServerHandlerLock = ServerHandlerLock <$> newTVarIO 0 +newServerHandlerLock = ServerHandlerLock <$> STM.newTVarIO 0 waitForHandlerTermination :: ServerHandlerLock -> STM () waitForHandlerTermination (ServerHandlerLock lock) = do - activeHandlers <- readTVar lock - when (activeHandlers > 0) retry + activeHandlers <- STM.readTVar lock + when (activeHandlers > 0) STM.retry topLevelWithHandlerLock :: ClientServerConfig @@ -336,19 +380,19 @@ -> IO () handler' req respond = do markActive - result <- try $ handler unmask req respond + result <- tryExact $ handler unmask req respond case result of Right () -> return () Left err | isExpectedServerException cfg err -> return () Left err -> - markTestFailure firstTestFailure (FirstFailureInServer err) + markTestFailure firstTestFailure (firstFailureInServer err) markDone markActive, markDone :: IO () - markActive = atomically $ modifyTVar lock (\n -> n + 1) - markDone = atomically $ modifyTVar lock (\n -> n - 1) + markActive = atomically $ STM.modifyTVar lock (\n -> n + 1) + markDone = atomically $ STM.modifyTVar lock (\n -> n - 1) {------------------------------------------------------------------------------- Server @@ -362,8 +406,8 @@ -> (Server.RunningServer -> IO a) -> IO a withTestServer cfg firstTestFailure handlerLock serverHandlers k = do - pubCert <- getDataFileName "grpc-demo.pem" - privKey <- getDataFileName "grpc-demo.key" + pubCert <- getDataFileName "grapesy" "grpc-demo.pem" + privKey <- getDataFileName "grapesy" "grpc-demo.key" let serverConfig :: Server.ServerConfig serverConfig = @@ -450,7 +494,7 @@ -> TestClient -> IO () runTestClient cfg firstTestFailure pathOrPort clientRun = do - pubCert <- getDataFileName "grpc-demo.pem" + pubCert <- getDataFileName "grapesy" "grpc-demo.pem" let clientParams :: Client.ConnParams clientParams = Client.ConnParams { @@ -533,14 +577,14 @@ delimitTestScope :: IO () -> IO () delimitTestScope test = do - result :: Either SomeException () <- try test + result <- tryExact test case result of Right () -> return () Left err | isExpectedClientException cfg err -> return () Left err -> do - markTestFailure firstTestFailure (FirstFailureInClient err) + markTestFailure firstTestFailure (firstFailureInClient err) throwIO TestFailure clientRun clientParams clientServer delimitTestScope @@ -558,7 +602,7 @@ runTestClientServer :: ClientServerTest -> IO () runTestClientServer (ClientServerTest cfg clientRun handlers) = do -- Setup client and server - firstTestFailure <- newEmptyTMVarIO + firstTestFailure <- STM.newEmptyTMVarIO serverHandlerLock <- newServerHandlerLock let server :: (Server.RunningServer -> IO a) -> IO a @@ -580,19 +624,19 @@ -- (the 'orElse' is only relevant if a /handler/ throws an exception) atomically $ (void $ waitCatchSTM clientThread) - `orElse` + `STM.orElse` (void failure) -- Wait for handlers to terminate (or test failure) -- (Note that the server /itself/ normally never terminates) atomically $ (waitForHandlerTermination serverHandlerLock) - `orElse` + `STM.orElse` (void failure) atomically $ do - (failure >>= throwSTM) - `orElse` + (failure >>= STM.throwSTM) + `STM.orElse` return () -- | Wait for test failure (retries/blocks if tests have not yet failed) @@ -608,24 +652,24 @@ -> TMVar FirstTestFailure -- ^ First test failure -> STM FirstTestFailure waitForFailure server client firstTestFailure = - (readTMVar firstTestFailure) - `orElse` + (STM.readTMVar firstTestFailure) + `STM.orElse` (Server.waitServerSTM server >>= serverAux) - `orElse` - (waitCatchSTM client >>= clientAux) + `STM.orElse` + (waitCatchExact client >>= clientAux) where serverAux :: - ( Either SomeException () - , Either SomeException () + ( Either ExactException () + , Either ExactException () ) -> STM FirstTestFailure - serverAux (Left e, _) = return (FirstFailureInServer e) - serverAux (_, Left e) = return (FirstFailureInServer e) - serverAux _otherwise = throwSTM $ UnexpectedServerTermination + serverAux (Left e, _) = return (firstFailureInServer e) + serverAux (_, Left e) = return (firstFailureInServer e) + serverAux _otherwise = STM.throwSTM $ UnexpectedServerTermination - clientAux :: Either SomeException () -> STM FirstTestFailure - clientAux (Left e) = return (FirstFailureInClient e) - clientAux _otherwise = retry + clientAux :: Either ExactException () -> STM FirstTestFailure + clientAux (Left e) = return (firstFailureInClient e) + clientAux _otherwise = STM.retry -- | We don't expect the server to shutdown until we kill it data UnexpectedServerTermination = UnexpectedServerTermination diff --git a/test-grapesy/Test/Driver/Dialogue/Definition.hs b/test-grapesy/Test/Driver/Dialogue/Definition.hs --- a/test-grapesy/Test/Driver/Dialogue/Definition.hs +++ b/test-grapesy/Test/Driver/Dialogue/Definition.hs @@ -11,25 +11,21 @@ -- * Bird's-eye view , GlobalSteps(..) , LocalSteps(..) - -- * Exceptions - -- ** User exceptions - , SomeClientException(..) - , SomeServerException(..) - , ExceptionId -- * Utility , hasEarlyTermination ) where +import Control.Monad.Catch (MonadThrow) import Control.Monad.State (StateT, execStateT, modify) import Data.Bifunctor import Data.ByteString qualified as Strict (ByteString) +import GHC.Show (appPrec1, showCommaSpace) import Network.GRPC.Common +import Network.GRPC.Common.Exception +import Test.Driver.ClientServer (DeliberateException) import Test.Driver.Dialogue.TestClock qualified as TestClock -import Test.Util.Exception -import Control.Monad.Catch -import GHC.Show (appPrec1, showCommaSpace) {------------------------------------------------------------------------------- Single RPC @@ -40,10 +36,10 @@ | ServerAction ServerAction deriving stock (Show, Eq) -type ClientAction = Action (TestMetadata, RPC) NoMetadata SomeClientException -type ServerAction = Action TestMetadata TestMetadata SomeServerException +type ClientAction = Action (TestMetadata, RPC) NoMetadata +type ServerAction = Action TestMetadata TestMetadata -data Action a b e = +data Action a b = -- | Initiate request and response -- -- When the client initiates a request, they can specify a timeout, initial @@ -59,7 +55,7 @@ | Send (StreamElem b Int) -- | Early termination (cleanly or with an exception) - | Terminate (Maybe e) + | Terminate (Maybe DeliberateException) deriving stock (Show, Eq) data RPC = RPC1 | RPC2 | RPC3 @@ -153,6 +149,7 @@ getGlobalSteps :: [LocalSteps] } deriving stock (Show) + deriving ToExceptionDoc via LinesToExceptionDoc GlobalSteps {------------------------------------------------------------------------------- Utility @@ -171,4 +168,3 @@ isEarlyTermination (ClientAction (Terminate _)) = (True, False) isEarlyTermination (ServerAction (Terminate _)) = (False, True) isEarlyTermination _ = (False, False) - diff --git a/test-grapesy/Test/Driver/Dialogue/Execution.hs b/test-grapesy/Test/Driver/Dialogue/Execution.hs --- a/test-grapesy/Test/Driver/Dialogue/Execution.hs +++ b/test-grapesy/Test/Driver/Dialogue/Execution.hs @@ -8,8 +8,10 @@ import Control.Concurrent import Control.Concurrent.Async +import Control.Exception (Exception(..)) import Control.Monad -import Control.Monad.Catch +import Control.Monad.Catch (MonadThrow) +import Control.Monad.Catch qualified as E import Control.Monad.State import Data.List (sortBy) import Data.Ord (comparing) @@ -23,6 +25,7 @@ import Network.GRPC.Client.Binary qualified as Client.Binary import Network.GRPC.Common import Network.GRPC.Common.Binary +import Network.GRPC.Common.Exception import Network.GRPC.Server qualified as Server import Network.GRPC.Server.Binary qualified as Server.Binary @@ -166,7 +169,7 @@ case step of ClientAction action -> do within timeoutClock step $ TestClock.waitForTick clock tick - continue <- clientAct tick action `finally` TestClock.advance clock + continue <- clientAct tick action `E.finally` TestClock.advance clock when continue $ go steps ServerAction action -> do TestClock.giveGreenLight clock tick @@ -177,7 +180,9 @@ -- -- Returns 'True' if we should continue executing more actions, or -- exit (thereby closing the RPC call) - clientAct :: TestClock.Tick -> ClientAction -> StateT PeerHealth IO Bool + clientAct :: + HasCallStack + => TestClock.Tick -> ClientAction -> StateT PeerHealth IO Bool clientAct tick action = case action of Initiate _ -> @@ -196,10 +201,12 @@ PeerAlive -> within timeoutGreenLight action $ TestClock.waitForGreenLight clock tick case mException of - Just ex -> throwM $ DeliberateException ex + Just ex -> throwM ex Nothing -> return False - reactToServer :: TestClock.Tick -> ServerAction -> StateT PeerHealth IO () + reactToServer :: + HasCallStack + => TestClock.Tick -> ServerAction -> StateT PeerHealth IO () reactToServer tick action = case action of Initiate expectedMetadata -> liftIO $ do @@ -216,16 +223,15 @@ reactToServer tick $ Send (StreamElem a) reactToServer tick $ Send (NoMoreElems b) Send expectedElem -> do - mOut <- try $ within timeoutReceive action $ + mOut <- E.try $ within timeoutReceive action $ Client.Binary.recvOutput call expect (tick, action) (isExpectedElem expectedElem) mOut Terminate mErr -> do - mOut <- try $ within timeoutReceive action $ + mOut <- E.try $ within timeoutReceive action $ Client.Binary.recvOutput call - let mErr' = DeliberateException <$> mErr - expectation = isGrpcException mErr' + let expectation = isGrpcException mErr expect (tick, action) expectation mOut - modify $ ifPeerAlive $ PeerTerminated mErr' + modify $ ifPeerAlive $ PeerTerminated mErr -- Wait for the server disconnect to become visible -- @@ -235,7 +241,7 @@ -- consistency, however, we simply wait until sending fails. -- -- See 'waitForClientDisconnect' for additional discussion. - waitForServerDisconnect :: IO () + waitForServerDisconnect :: HasCallStack => IO () waitForServerDisconnect = within timeoutFailure () $ loop where @@ -243,7 +249,7 @@ -- We only do this when we know the client has terminated, so the -- /type/ of the message we send here as a probe does not matter. loop = do - mFailed <- try $ Client.Binary.sendNextInput call () + mFailed <- E.try $ Client.Binary.sendNextInput call () case mFailed of Left (_ :: GrpcException) -> return () @@ -355,7 +361,8 @@ -------------------------------------------------------------------------------} serverLocal :: - TestClock + HasCallStack + => TestClock -> Server.Call (TestProtocol meth) -> LocalSteps -> IO () serverLocal clock call = \(LocalSteps steps) -> do @@ -367,7 +374,7 @@ case step of ServerAction action -> do within timeoutClock step $ TestClock.waitForTick clock tick - continue <- serverAct tick action `finally` TestClock.advance clock + continue <- serverAct tick action `E.finally` TestClock.advance clock when continue $ go steps ClientAction action -> do TestClock.giveGreenLight clock tick @@ -378,7 +385,9 @@ -- -- Returns 'True' if we should continue executing the other actions, or -- terminate (thereby terminating the handler) - serverAct :: TestClock.Tick -> ServerAction -> StateT PeerHealth IO Bool + serverAct :: + HasCallStack + => TestClock.Tick -> ServerAction -> StateT PeerHealth IO Bool serverAct tick action = case action of Initiate metadata -> liftIO $ do @@ -398,23 +407,25 @@ PeerAlive -> within timeoutGreenLight action $ TestClock.waitForGreenLight clock tick case mException of - Just ex -> throwM $ DeliberateException ex + Just ex -> throwM ex Nothing -> return False - reactToClient :: TestClock.Tick -> ClientAction -> StateT PeerHealth IO () + reactToClient :: + HasCallStack + => TestClock.Tick -> ClientAction -> StateT PeerHealth IO () reactToClient tick action = case action of Initiate _ -> error "serverLocal: unexpected ClientInitiateRequest" Send expectedElem -> do - mInp <- liftIO $ try $ within timeoutReceive action $ + mInp <- liftIO $ E.try $ within timeoutReceive action $ Server.Binary.recvInput call expect (tick, action) (isExpectedElem expectedElem) mInp Terminate mErr -> do - mInp <- liftIO $ try $ within timeoutReceive action $ + mInp <- liftIO $ E.try $ within timeoutReceive action $ Server.Binary.recvInput call expect (tick, action) isExpectedDisconnect mInp - modify $ ifPeerAlive $ PeerTerminated $ DeliberateException <$> mErr + modify $ ifPeerAlive $ PeerTerminated mErr -- Wait for the client disconnect to become visible -- @@ -423,7 +434,7 @@ -- 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. - waitForClientDisconnect :: IO () + waitForClientDisconnect :: HasCallStack => IO () waitForClientDisconnect = within timeoutFailure () $ loop where @@ -431,7 +442,7 @@ -- We only do this when we know the client has terminated, so the -- /type/ of the message we send here as a probe does not matter. loop = do - mFailed <- try $ Server.Binary.sendNextOutput call () + mFailed <- E.try $ Server.Binary.sendNextOutput call () case mFailed of Left (_ :: Server.ClientDisconnected) -> return () @@ -449,13 +460,16 @@ isExpectedDisconnect :: Either Server.ClientDisconnected (StreamElem NoMetadata Int) -> Bool - isExpectedDisconnect (Left (Server.ClientDisconnected e _)) + isExpectedDisconnect (Left (Server.ClientDisconnected (WrapExactException e) _)) | Just HTTP2.Client.ConnectionIsClosed <- fromException e = True + | Just HTTP2.Client.StreamResetIsReceived{} <- fromException e + = True | otherwise = False isExpectedDisconnect _ = False +-- | Server RPC handler serverGlobal :: HasCallStack => TestClock @@ -496,7 +510,9 @@ data ConnUsage = SharedConn | ConnPerRPC -execGlobalSteps :: ConnUsage -> GlobalSteps -> IO ClientServerTest +execGlobalSteps :: + HasCallStack + => ConnUsage -> GlobalSteps -> IO ClientServerTest execGlobalSteps connUsage steps = do globalStepsVar <- newMVar (order steps) clock <- TestClock.new diff --git a/test-grapesy/Test/Driver/Dialogue/Generation.hs b/test-grapesy/Test/Driver/Dialogue/Generation.hs --- a/test-grapesy/Test/Driver/Dialogue/Generation.hs +++ b/test-grapesy/Test/Driver/Dialogue/Generation.hs @@ -19,6 +19,7 @@ import Network.GRPC.Common +import Test.Driver.ClientServer (DeliberateException(..)) import Test.Driver.Dialogue.Definition import Test.Driver.Dialogue.TestClock qualified as TestClock @@ -80,8 +81,8 @@ genException :: Gen LocalStep genException = oneof [ - ClientAction . Terminate . Just . SomeClientException <$> choose (0, 5) - , ServerAction . Terminate . Just . SomeServerException <$> choose (0, 5) + ClientAction . Terminate . Just . DeliberateClientException <$> choose (0, 5) + , ServerAction . Terminate . Just . DeliberateServerException <$> choose (0, 5) , pure $ ClientAction . Terminate $ Nothing , pure $ ServerAction . Terminate $ Nothing ] @@ -411,14 +412,19 @@ map (ClientAction . Send) $ shrinkElem (const []) x ServerAction (Send x) -> map (ServerAction . Send) $ shrinkElem shrinkMetadata x - ClientAction (Terminate (Just (SomeClientException n))) -> - map (ClientAction . Terminate . Just . SomeClientException) (shrink n) - ServerAction (Terminate (Just (SomeServerException n))) -> - map (ServerAction . Terminate . Just . SomeServerException) (shrink n) + ClientAction (Terminate (Just e)) -> + map (ClientAction . Terminate . Just) (shrinkDeliberateException e) + ServerAction (Terminate (Just e)) -> + map (ServerAction . Terminate . Just) (shrinkDeliberateException e) ClientAction (Terminate Nothing) -> [] ServerAction (Terminate Nothing) -> [] + +shrinkDeliberateException :: DeliberateException -> [DeliberateException] +shrinkDeliberateException = \case + DeliberateServerException n -> map DeliberateServerException $ shrink n + DeliberateClientException n -> map DeliberateClientException $ shrink n shrinkRPC :: RPC -> [RPC] shrinkRPC RPC1 = [] diff --git a/test-grapesy/Test/Driver/Dialogue/TestClock.hs b/test-grapesy/Test/Driver/Dialogue/TestClock.hs --- a/test-grapesy/Test/Driver/Dialogue/TestClock.hs +++ b/test-grapesy/Test/Driver/Dialogue/TestClock.hs @@ -15,7 +15,8 @@ import Prelude hiding (id) -import Control.Concurrent.STM +import Control.Concurrent.STM (TVar) +import Control.Concurrent.STM qualified as STM import Control.Exception import Control.Monad import Control.Monad.IO.Class @@ -29,6 +30,8 @@ import GHC.Stack import Test.QuickCheck (Gen, choose) +import Network.GRPC.Common.Exception + {------------------------------------------------------------------------------- Definition -------------------------------------------------------------------------------} @@ -90,7 +93,7 @@ -- | Start the clock new :: IO TestClock -new = TestClock <$> newTVarIO initState +new = TestClock <$> STM.newTVarIO initState where initState :: State initState = State { @@ -116,10 +119,10 @@ -- If the clock has already gone past the specified time, throws 'TimePassed'. waitForTick :: MonadIO m => TestClock -> Tick -> m () waitForTick (TestClock clock) t = liftIO . atomically $ do - State{stateNow} <- readTVar clock - if | stateNow < t -> retry + State{stateNow} <- STM.readTVar clock + if | stateNow < t -> STM.retry | stateNow == t -> return () - | otherwise -> throwSTM $ TimePassed { + | otherwise -> STM.throwSTM $ TimePassed { timePassedNow = stateNow , timePassedWanted = t , timePassedAt = callStack @@ -131,7 +134,7 @@ -- at any given time. advance :: MonadIO m => TestClock -> m () advance (TestClock clock) = liftIO . atomically $ do - modifyTVar clock $ \st@State{stateNow} -> + STM.modifyTVar clock $ \st@State{stateNow} -> st{stateNow = succ stateNow} {------------------------------------------------------------------------------- @@ -143,15 +146,15 @@ -- See 'TestClock' for discussion. waitForGreenLight :: MonadIO m => TestClock -> Tick -> m () waitForGreenLight (TestClock clock) t = liftIO . atomically $ do - State{stateGreen} <- readTVar clock - unless (t `Set.member` stateGreen) retry + State{stateGreen} <- STM.readTVar clock + unless (t `Set.member` stateGreen) STM.retry -- | Give green light -- -- See 'TestClock' for discussion. giveGreenLight :: MonadIO m => TestClock -> Tick -> m () giveGreenLight (TestClock clock) t = liftIO . atomically $ do - modifyTVar clock $ \st@State{stateGreen} -> + STM.modifyTVar clock $ \st@State{stateGreen} -> st{stateGreen = Set.insert t stateGreen} {------------------------------------------------------------------------------- diff --git a/test-grapesy/Test/Prop/Dialogue.hs b/test-grapesy/Test/Prop/Dialogue.hs --- a/test-grapesy/Test/Prop/Dialogue.hs +++ b/test-grapesy/Test/Prop/Dialogue.hs @@ -1,13 +1,19 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -module Test.Prop.Dialogue (tests) where +module Test.Prop.Dialogue ( + tests + , RegressionTestFailed(..) + ) where import Control.Exception +import GHC.Generics (Generic) import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck import Network.GRPC.Common +import Network.GRPC.Common.Exception import Test.Driver.ClientServer import Test.Driver.Dialogue @@ -91,21 +97,31 @@ globalSteps :: GlobalSteps globalSteps = dialogueGlobalSteps dialogue -regression :: ConnUsage -> Dialogue -> IO () +regression :: HasCallStack => ConnUsage -> Dialogue -> IO () regression connUsage dialogue = - handle (throwIO . RegressionTestFailed globalSteps) $ + catchAndWrap failure $ testClientServer =<< execGlobalSteps connUsage globalSteps where globalSteps :: GlobalSteps globalSteps = dialogueGlobalSteps dialogue + failure :: ExactException -> RegressionTestFailed + failure = RegressionTestFailed globalSteps + data RegressionTestFailed = RegressionTestFailed { regressionGlobalSteps :: GlobalSteps - , regressionException :: SomeException + , regressionException :: ExactException } - deriving stock (Show) - deriving anyclass (Exception) + deriving stock (Show, Generic) + deriving anyclass (ToExceptionDoc) +instance Exception RegressionTestFailed where +#if MIN_VERSION_base(4,20,0) + -- The backtrace to where we report that the regression failed only distracts; + -- we're interested in the backtrace of the exception itself. + backtraceDesired _ = False +#endif + {------------------------------------------------------------------------------- Regression tests @@ -199,14 +215,14 @@ exception1 :: Dialogue exception1 = NormalizedDialogue [ (0, ClientAction $ Initiate (def, RPC1)) - , (0, ServerAction $ Terminate (Just $ SomeServerException 0)) + , (0, ServerAction $ Terminate (Just $ DeliberateServerException 0)) ] -- | Client-side exception exception2 :: Dialogue exception2 = NormalizedDialogue [ (0, ClientAction $ Initiate (def, RPC1)) - , (0, ClientAction $ Terminate (Just (SomeClientException 0))) + , (0, ClientAction $ Terminate (Just (DeliberateClientException 0))) , (0, ServerAction $ Send (NoMoreElems def)) ] @@ -233,7 +249,7 @@ earlyTermination03 = NormalizedDialogue [ (1, ClientAction $ Initiate (def, RPC1 )) , (0, ClientAction $ Initiate (def, RPC1)) - , (1, ClientAction $ Terminate (Just (SomeClientException 0))) + , (1, ClientAction $ Terminate (Just (DeliberateClientException 0))) , (0, ClientAction $ Send (NoMoreElems NoMetadata)) , (1, ServerAction $ Send (NoMoreElems def)) , (0, ServerAction $ Send (NoMoreElems def)) @@ -246,7 +262,7 @@ (0, ClientAction $ Initiate (def, RPC1)) , (0, ServerAction $ Initiate def) , (1, ClientAction $ Initiate (def, RPC1 )) - , (1, ClientAction $ Terminate (Just (SomeClientException 0))) + , (1, ClientAction $ Terminate (Just (DeliberateClientException 0))) , (1, ServerAction $ Send (NoMoreElems def)) , (0, ClientAction $ Send (NoMoreElems NoMetadata)) , (0, ServerAction $ Send (NoMoreElems def)) @@ -276,7 +292,7 @@ earlyTermination06 = NormalizedDialogue [ (0, ClientAction $ Initiate (def, RPC1)) , (0, ClientAction $ Send (StreamElem 0)) - , (0, ClientAction $ Terminate (Just (SomeClientException 0))) + , (0, ClientAction $ Terminate (Just (DeliberateClientException 0))) , (0, ServerAction $ Send (NoMoreElems def)) ] @@ -285,7 +301,7 @@ earlyTermination07 = NormalizedDialogue [ (0, ClientAction $ Initiate (def, RPC1)) , (0, ServerAction $ Initiate def) - , (0, ServerAction $ Terminate (Just (SomeServerException 0))) + , (0, ServerAction $ Terminate (Just (DeliberateServerException 0))) ] -- | Server-side early termination, Trailers-Only case @@ -296,7 +312,7 @@ earlyTermination08 :: Dialogue earlyTermination08 = NormalizedDialogue [ (0, ClientAction $ Initiate (def, RPC1)) - , (0, ServerAction $ Terminate (Just (SomeServerException 0))) + , (0, ServerAction $ Terminate (Just (DeliberateServerException 0))) ] -- | Like 'earlyTermination07', but now without an exception @@ -312,7 +328,7 @@ earlyTermination10 = NormalizedDialogue [ (0, ClientAction $ Initiate (def, RPC1)) , (0, ServerAction $ Initiate def) - , (0, ClientAction $ Terminate (Just (SomeClientException 0))) + , (0, ClientAction $ Terminate (Just (DeliberateClientException 0))) , (0, ServerAction $ Send (NoMoreElems def)) ] @@ -321,7 +337,7 @@ earlyTermination11 = NormalizedDialogue [ (0, ClientAction $ Initiate (def, RPC1)) , (0, ServerAction $ Initiate def) - , (0, ClientAction $ Terminate (Just (SomeClientException 0))) + , (0, ClientAction $ Terminate (Just (DeliberateClientException 0))) , (0, ServerAction $ Send (StreamElem 0)) , (0, ServerAction $ Send (NoMoreElems def)) ] @@ -354,7 +370,7 @@ , (1, ClientAction $ Initiate (def, RPC1)) , (1, ServerAction $ Send (NoMoreElems def)) , (0, ServerAction $ Send (StreamElem 3)) - , (0, ServerAction $ Terminate (Just (SomeServerException 0))) + , (0, ServerAction $ Terminate (Just (DeliberateServerException 0))) ] -- | Both the server /and/ the client terminate early @@ -365,7 +381,7 @@ earlyTermination14 = NormalizedDialogue [ (0, ClientAction $ Initiate (def, RPC1)) , (0, ClientAction $ Terminate Nothing) - , (0, ServerAction $ Terminate (Just (SomeServerException 0))) + , (0, ServerAction $ Terminate (Just (DeliberateServerException 0))) ] unilateralTermination1 :: Dialogue @@ -435,7 +451,7 @@ allowHalfClosed3 :: Dialogue allowHalfClosed3 = NormalizedDialogue [ (0, ClientAction $ Initiate (def,RPC1)) - , (0, ClientAction $ Terminate (Just (SomeClientException 0))) + , (0, ClientAction $ Terminate (Just (DeliberateClientException 0))) , (0, ServerAction $ Initiate def) , (0, ServerAction $ Send (NoMoreElems def)) ] diff --git a/test-grapesy/Test/Regression/Issue102.hs b/test-grapesy/Test/Regression/Issue102.hs --- a/test-grapesy/Test/Regression/Issue102.hs +++ b/test-grapesy/Test/Regression/Issue102.hs @@ -35,7 +35,6 @@ import Proto.API.Trivial import Test.Driver.ClientServer -import Test.Util.Exception tests :: TestTree tests = testGroup "Issue102" [ @@ -61,7 +60,7 @@ replicate 99 predicate ++ [ \n -> (n > 10) - && throw (DeliberateException $ SomeClientException 1) + && throw (DeliberateClientException 1) ] results <- @@ -106,9 +105,8 @@ -- Only one of the calls failed, and we got the appropriate -- exception case lefts results of - [GrpcException GrpcUnknown (Just msg) Nothing []] -> do - assertBool "" $ "DeliberateException" `Text.isInfixOf` msg - assertBool "" $ "SomeServerException 1" `Text.isInfixOf` msg + [GrpcException GrpcUnknown (Just msg) Nothing []] -> + assertBool "" $ "DeliberateServerException" `Text.isInfixOf` msg _ -> assertFailure "" @@ -124,8 +122,7 @@ handlerCount <- atomicModifyIORef' handlerCounter (\n -> (n + 1, n)) when (handlerCount == 25) $ - throwIO $ - DeliberateException $ SomeServerException 1 + throwIO $ DeliberateServerException 1 incUntilFinal call ] } @@ -142,7 +139,7 @@ _mResult <- try @DeliberateException $ Client.withRPC conn def (Proxy @Trivial) $ \_call -> - throwIO (DeliberateException $ SomeServerException 0) + throwIO (DeliberateServerException 0) result <- Client.withRPC conn def (Proxy @Trivial) $ \call -> do Binary.sendFinalInput @Word8 call 0 diff --git a/test-grapesy/Test/Sanity/Any.hs b/test-grapesy/Test/Sanity/Any.hs --- a/test-grapesy/Test/Sanity/Any.hs +++ b/test-grapesy/Test/Sanity/Any.hs @@ -10,6 +10,7 @@ import Network.GRPC.Client (rpc) import Network.GRPC.Client.StreamType.IO qualified as Client import Network.GRPC.Common +import Network.GRPC.Common.Exception import Network.GRPC.Common.Protobuf import Network.GRPC.Common.Protobuf.Any (Any) import Network.GRPC.Common.Protobuf.Any qualified as Any @@ -69,7 +70,7 @@ testStatus :: Assertion testStatus = testClientServer $ ClientServerTest { config = def { - isExpectedServerException = \e -> + isExpectedServerException = \(WrapExactException e) -> case fromException e of Just err' -> grpcError err' == GrpcNotFound _otherwise -> False diff --git a/test-grapesy/Test/Sanity/BrokenDeployments.hs b/test-grapesy/Test/Sanity/BrokenDeployments.hs --- a/test-grapesy/Test/Sanity/BrokenDeployments.hs +++ b/test-grapesy/Test/Sanity/BrokenDeployments.hs @@ -7,6 +7,7 @@ import Control.Concurrent import Control.Exception +import Control.Monad import Data.ByteString.Char8 qualified as BS.Strict.Char8 import Data.ByteString.UTF8 qualified as BS.Strict.UTF8 import Data.IORef @@ -74,7 +75,7 @@ -- We don't test all codes here; we'd just end up duplicating the logic in -- 'classifyServerResponse'. We just check one representative value. test_statusNon200 :: Assertion -test_statusNon200 = respondWith response $ \addr -> do +test_statusNon200 = respondWith (\_reqBody -> response) $ \addr -> do mResp :: Either GrpcException (Proto PongMessage) <- try $ Client.withConnection connParams (Client.ServerInsecure addr) $ \conn -> Client.withRPC conn def (Proxy @Ping) $ \call -> do @@ -93,7 +94,7 @@ -- | Ensure that we include the response body for errors, if any test_statusNon200Body :: Assertion -test_statusNon200Body = respondWith response $ \addr -> do +test_statusNon200Body = respondWith (\_reqBody -> response) $ \addr -> do mResp :: Either GrpcException (Proto PongMessage) <- try $ Client.withConnection connParams (Client.ServerInsecure addr) $ \conn -> Client.withRPC conn def (Proxy @Ping) $ \call -> do @@ -122,7 +123,7 @@ -------------------------------------------------------------------------------} test_invalidContentType :: Response -> Assertion -test_invalidContentType response = respondWith response $ \addr -> do +test_invalidContentType response = respondWith (\_reqBody -> response) $ \addr -> do mResp <- try $ Client.withConnection connParams (Client.ServerInsecure addr) $ \conn -> Client.withRPC conn def (Proxy @Ping) $ \call -> do @@ -166,7 +167,7 @@ -------------------------------------------------------------------------------} test_omitStatus :: Assertion -test_omitStatus = respondWith response $ \addr -> do +test_omitStatus = respondWith (\_reqBody -> response) $ \addr -> do mResp :: Either GrpcException (StreamElem NoMetadata (Proto PongMessage)) <- try $ Client.withConnection connParams (Client.ServerInsecure addr) $ \conn -> @@ -189,7 +190,7 @@ } test_omitStatusMessage :: Assertion -test_omitStatusMessage = respondWith response $ \addr -> do +test_omitStatusMessage = respondWith (\_reqBody -> response) $ \addr -> do mResp :: Either GrpcException (StreamElem NoMetadata (Proto PongMessage)) <- try $ Client.withConnection connParams (Client.ServerInsecure addr) $ \conn -> @@ -210,7 +211,7 @@ } test_omitAllTrailers :: Assertion -test_omitAllTrailers = respondWith response $ \addr -> do +test_omitAllTrailers = respondWith (\_reqBody -> response) $ \addr -> do mResp :: Either GrpcException (StreamElem NoMetadata (Proto PongMessage)) <- try $ Client.withConnection connParams (Client.ServerInsecure addr) $ \conn -> @@ -240,7 +241,7 @@ -------------------------------------------------------------------------------} test_invalidStatusMessage :: Assertion -test_invalidStatusMessage = respondWith response $ \addr -> do +test_invalidStatusMessage = respondWith (\_reqBody -> response) $ \addr -> do mResp :: StreamElem Client.ProperTrailers' (InboundMeta, Proto PongMessage) <- @@ -270,14 +271,16 @@ someInvalidMessage = "This is invalid: %X" test_invalidRequestMetadata :: Assertion -test_invalidRequestMetadata = respondWith response $ \addr -> do +test_invalidRequestMetadata = respondWith (\_reqBody -> response) $ \addr -> do mResp :: Either (Client.TrailersOnly' HandledSynthesized) (Client.ResponseHeaders' HandledSynthesized) <- Client.withConnection connParams' (Client.ServerInsecure addr) $ \conn -> Client.withRPC conn def (Proxy @Ping) $ \call -> do Client.sendEndOfInput call - Client.recvInitialResponse call + initialResponse <- Client.recvInitialResponse call + void $ Client.waitForTrailers call + return initialResponse case mResp of Right headers | Left invalid <- Client.responseUnrecognized headers @@ -305,7 +308,7 @@ someInvalidMetadata = "This is invalid: 你好" test_invalidTrailerMetadata :: Assertion -test_invalidTrailerMetadata = respondWith response $ \addr -> do +test_invalidTrailerMetadata = respondWith (\_reqBody -> response) $ \addr -> do mResp :: StreamElem Client.ProperTrailers' (InboundMeta, Proto PongMessage) <- @@ -364,7 +367,7 @@ Client.nonStreaming conn (Client.rpc @Ping) (defMessage & #id .~ 1) case mResp1 of Left err | Just msg <- grpcErrorMessage err -> - assertBool "" $ Text.pack "uhoh" `Text.isInfixOf` msg + assertBool "" $ Text.pack "DeliberateServerException" `Text.isInfixOf` msg _otherwise -> assertFailure "Unexpected response" @@ -384,7 +387,7 @@ handler st req = do isFirst <- atomicModifyIORef st $ \i -> (succ i, i == 0) if isFirst - then return $ throw $ DeliberateException (userError "uhoh") + then return $ throw $ DeliberateServerException 0 else return $ defMessage & #id .~ req ^. #id {------------------------------------------------------------------------------- @@ -398,7 +401,7 @@ -- -- See also . test_serverIgnoresTimeout :: Assertion -test_serverIgnoresTimeout = respondWithIO response $ \addr -> do +test_serverIgnoresTimeout = respondWithIO (\_reqBody -> response) $ \addr -> do mResp :: Either GrpcException (StreamElem NoMetadata (Proto PongMessage)) <- try $ Client.withConnection connParams (Client.ServerInsecure addr) $ \conn -> diff --git a/test-grapesy/Test/Sanity/Cancellation.hs b/test-grapesy/Test/Sanity/Cancellation.hs new file mode 100644 --- /dev/null +++ b/test-grapesy/Test/Sanity/Cancellation.hs @@ -0,0 +1,184 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +{-# LANGUAGE OverloadedStrings #-} + +-- | Client cancellation (RST_STREAM) +-- +-- Four very similar tests: in each, a client initiates a request and exchanges a message +-- with a server handler. The server handler then starts messages to the client +-- indefinitely, until it is cancelled. Variations along two different axes: +-- +-- * The message from the client is marked as final or not; if final, that +-- leaves the client in half-closed state. +-- * The client terminates the scope from withRPC normally or with an exception; +-- this affects whether we send a RST_STREAM with CANCEL or INTERNAL_ERROR. +-- +-- We also verify that the server handler is eventually cancelled; that is, that +-- is does not block indefinitely when it tries to send a message that a client +-- is not listening for anymore. +-- +-- See also +-- +-- * +-- * HTTP2 PR +module Test.Sanity.Cancellation (tests) where + +import Control.Concurrent +import Control.Exception qualified as E +import Control.Monad +import Data.ByteString.Lazy qualified as Lazy (ByteString) +import Network.HTTP2.Client qualified as HTTP +import Test.Tasty +import Test.Tasty.HUnit + +import Network.GRPC.Client qualified as Client +import Network.GRPC.Common +import Network.GRPC.Common.Binary +import Network.GRPC.Common.Exception +import Network.GRPC.Server qualified as Server + +import Test.Driver.ClientServer + +tests :: TestTree +tests = testGroup "Test.Sanity.Cancellation" [ + testGroup "noException" [ + testCase "beforeHalfClosed" $ + testReset + Client.sendNextInput + (return ()) + , testCase "afterHalfClosed" $ + testReset + Client.sendFinalInput + (return ()) + ] + , testGroup "withException" [ + testCase "beforeHalfClosed" $ + testReset + Client.sendNextInput + (throwIO $ DeliberateClientException 1) + , testCase "afterHalfClosed" $ + testReset + Client.sendFinalInput + (throwIO $ DeliberateClientException 1) + ] + ] + +{------------------------------------------------------------------------------- + Test client +-------------------------------------------------------------------------------} + +testReset :: + (Client.Call EchoUntilCancelled -> Lazy.ByteString -> IO ()) + -- ^ How should we send the input? + -- ('sendNextInput', 'sendFinalInput') + -> IO () + -- ^ How should the client exit the scope of 'withRPC'? + -- (@return ()@, @throwIO@) + -> Assertion +testReset sendInput leaveScope = do + resultVar <- newEmptyMVar + testClientServer ClientServerTest{ + config = def + , server = [Server.someRpcHandler $ handleEchoUntilCancelled resultVar] + , client = simpleTestClient $ \conn -> do + checkClientException $ do + Client.withRPC conn def (Proxy @EchoUntilCancelled) $ \call -> do + sendInput call "ABCDE" + resp <- Client.recvOutput call + assertEqual "" (StreamElem "ABCDE") $ resp + leaveScope + + handlerResult <- readMVar resultVar + case handlerResult of + Left e | checkServerException e -> return () + _otherwise -> assertFailure $ "Unexpected " ++ show handlerResult + } + +{------------------------------------------------------------------------------- + Server handler +-------------------------------------------------------------------------------} + +type EchoUntilCancelled = RawRpc "Test" "EchoUntilCancelled" + +type instance RequestMetadata EchoUntilCancelled = NoMetadata +type instance ResponseInitialMetadata EchoUntilCancelled = NoMetadata +type instance ResponseTrailingMetadata EchoUntilCancelled = NoMetadata + +-- | Server handler +-- +-- The handler expects a single message of type 'Text', which may or may not +-- be marked final; it then starts echoing back that message indefinitely until +-- it is cancelled. +handleEchoUntilCancelled :: + MVar (Either ExactException ()) + -- ^ The server's own result is reported back to the client out-of-band, + -- so that we can check it as part of the test ('checkServerException'). + -- + -- NOTE: The regular 'isExpectedServerException' is less useful here, + -- because if the test simply terminates without the client waiting for the + -- server, the server handler might simply see the entire connection + -- disappear and reported a different exception. + -> Server.RpcHandler IO EchoUntilCancelled +handleEchoUntilCancelled resultVar = Server.mkRpcHandler $ \call -> do + let echoUntilCancelled :: Lazy.ByteString -> IO () + echoUntilCancelled msg = forever $ do + Server.sendOutput call $ StreamElem msg + threadDelay 10_000 + + handlerBody :: IO () + handlerBody = do + inp <- Server.recvInput call + case inp of + StreamElem msg -> echoUntilCancelled msg + FinalElem msg NoMetadata -> echoUntilCancelled msg + NoMoreElems NoMetadata -> assertFailure "Unexpected NoMoreElems" + + putMVar resultVar =<< E.try handlerBody + +{------------------------------------------------------------------------------- + Expected exceptions +-------------------------------------------------------------------------------} + +-- | Check client-side exception +-- +-- We expected 'GrpcCancelled' unless the client threw an exception itself. +checkClientException :: IO () -> IO () +checkClientException client = do + clientResult :: Either ExactException () <- E.try client + case clientResult of + Right () -> + assertFailure "Expected client exception" + Left e | Just e' + <- E.fromException (unwrapExactException e) + , grpcError e' == GrpcCancelled -> + return () + Left e | Just DeliberateClientException{} + <- E.fromException (unwrapExactException e) -> + return () + _otherwise -> + assertFailure $ "Unexpected " ++ show clientResult + +-- | Check server-side exception +-- +-- The exact nature of the exception on whether inside of @http2@ the RST_STREAM +-- frame is handled. +-- +-- TODO +-- It might be better if we made the presence of RST_STREAM explicitly visible +-- in the @grapesy@-side exception. +checkServerException :: ExactException -> Bool +checkServerException e + | Just ClientDisconnected{clientDisconnectedException} + <- E.fromException (unwrapExactException e) + , Just HTTP.StreamResetIsReceived{} + <- E.fromException (unwrapExactException clientDisconnectedException) + = True + + | Just ClientDisconnected{clientDisconnectedException} + <- E.fromException (unwrapExactException e) + , Just HTTP.StreamRemoteReset{} + <- E.fromException (unwrapExactException clientDisconnectedException) + = True + + | otherwise + = False diff --git a/test-grapesy/Test/Sanity/Compression.hs b/test-grapesy/Test/Sanity/Compression.hs --- a/test-grapesy/Test/Sanity/Compression.hs +++ b/test-grapesy/Test/Sanity/Compression.hs @@ -46,6 +46,7 @@ Client.withRPC conn def (Proxy @SayHello) $ \call -> do Client.sendFinalInput call req mResp <- StreamElem.value <$> Client.recvOutputWithMeta call + void $ Client.waitForTrailers call case mResp of Nothing -> assertFailure "Expected response" Just (meta, resp) -> do @@ -83,7 +84,13 @@ isJust (inboundCompressedSize meta) assertEqual "" compressibleName $ resp ^. #message + + + -- Make sure to wait for the trailers, so that the handler doesn't + -- see an unexpected @ClientDisconnected@ exception Client.sendEndOfInput call + NoMetadata <- Client.recvTrailers call + return () } where req :: Proto HelloRequest diff --git a/test-grapesy/Test/Sanity/Disconnect.hs b/test-grapesy/Test/Sanity/Disconnect.hs deleted file mode 100644 --- a/test-grapesy/Test/Sanity/Disconnect.hs +++ /dev/null @@ -1,427 +0,0 @@ -{-# OPTIONS_GHC -Wno-orphans #-} - --- | Handling of client or server disconnections occurring with ongoing RPCs on --- a shared connection. --- --- When a server disconnects, we expect: --- --- 1. All current calls fail with 'Client.ServerDisconnected' --- 2. Future calls (after reconnection) succeed --- --- When a client disconnects, we expect: --- --- 1. The handlers dealing with that client (i.e. on that connection) should --- fail with 'Server.ClientDisconnected' --- 2. Future calls (after reconnection) succeed -module Test.Sanity.Disconnect (tests) where - -import Control.Concurrent -import Control.Concurrent.Async -import Control.Concurrent.STM -import Control.Exception -import Control.Monad -import Data.ByteString.Lazy qualified as Lazy (ByteString) -import Data.IORef -import Data.Word -import Foreign.C.Types (CInt(..)) -import Network.Socket -import System.Posix -import Test.Tasty -import Test.Tasty.HUnit -import Text.Read hiding (step) - -import Network.GRPC.Client qualified as Client -import Network.GRPC.Client.Binary qualified as Binary -import Network.GRPC.Common -import Network.GRPC.Server qualified as Server -import Network.GRPC.Server.Binary qualified as Binary -import Network.GRPC.Server.Run - -import Proto.API.Trivial - -import Test.Util - -{------------------------------------------------------------------------------- - Top-level --------------------------------------------------------------------------------} - -tests :: TestTree -tests = testGroup "Test.Sanity.Disconnect" [ - testCase "client" test_clientDisconnect - , testCase "server" test_serverDisconnect - ] - -{------------------------------------------------------------------------------- - Disconnecting clients --------------------------------------------------------------------------------} - --- | Two separate clients make many concurrent calls, one of them disconnects. -test_clientDisconnect :: Assertion -test_clientDisconnect = do - -- Create the server - disconnectCounter1 <- newIORef 0 - disconnectCounter2 <- newIORef 0 - server <- - Server.mkGrpcServer def [ - Server.someRpcHandler $ - Server.mkRpcHandler @RPC1 $ echoHandler (Just disconnectCounter1) - , Server.someRpcHandler $ - Server.mkRpcHandler @RPC2 $ echoHandler (Just disconnectCounter2) - ] - - -- Start server - let serverConfig = ServerConfig { - serverInsecure = Just $ InsecureConfig { - insecureHost = Just "127.0.0.1" - , insecurePort = 0 - } - , serverSecure = Nothing - } - portSignal <- newEmptyMVar - void $ forkIO $ forkServer def serverConfig server $ \runningServer -> do - putMVar portSignal =<< getServerPort runningServer - waitServer runningServer - - -- Wait for the server to signal its port - serverPort <- readMVar portSignal - let serverAddress = - Client.ServerInsecure Client.Address { - addressHost = "127.0.0.1" - , addressPort = serverPort - , addressAuthority = Nothing - } - - - -- Start a client in a separate process - let numCalls = 10 - dyingChild <- forkProcess $ - Client.withConnection def serverAddress $ \conn -> do - inLockstep conn (Proxy @RPC1) numCalls NeverTerminate $ \results _getFinal -> do - -- Wait until we are sure that all clients have started their RPC, - -- then kill the process. This avoids race conditions and guarantees - -- that the server will see @numCalls@ clients disconnecting. - _ <- waitForHistoryOfMinLen results 1 - c_exit 1 - - -- Start two more clients; these will not disconnect - let numSteps = 5 - (result1, result2) <- concurrently - ( Client.withConnection def serverAddress $ \conn -> do - inLockstep conn (Proxy @RPC1) numCalls (TerminateAfter numSteps) $ \_results getFinal -> - getFinal - ) - ( Client.withConnection def serverAddress $ \conn -> do - inLockstep conn (Proxy @RPC2) numCalls (TerminateAfter numSteps) $ \_results getFinal -> - getFinal - ) - - -- Wait for the forked process to terminate - _status <- getProcessStatus True False dyingChild - - -- All calls by clients in /this/ process (not the ones we killed) should - -- have finished normally - let expectedResult = [ - replicate numCalls (StepOk i) - | i <- reverse [1 .. numSteps] - ] - assertEqual "" expectedResult result1 - assertEqual "" expectedResult result2 - - -- We should also see only @numCalls@ client disconnects for the first - -- handler and none for the second - clientDisconnects1 <- readIORef disconnectCounter1 - clientDisconnects2 <- readIORef disconnectCounter2 - assertEqual "" numCalls clientDisconnects1 - assertEqual "" 0 clientDisconnects2 - --- We need to use this to properly simulate the execution environment crashing --- in an unrecoverable way. In particular, we don't want to give the program a --- chance to do any of its normal exception handling/cleanup behavior. -foreign import ccall unsafe "exit" c_exit :: CInt -> IO () - -{------------------------------------------------------------------------------- - Disconnecting servers --------------------------------------------------------------------------------} - --- | Client makes many concurrent calls, server disconnects -test_serverDisconnect :: Assertion -test_serverDisconnect = withTemporaryFile $ \ipcFile -> do - -- We use a temporary file as a very rudimentary means of inter-process - -- communication so the server (which runs in a separate process) can make - -- the client aware of the port it is assigned by the OS. - let ipcWrite :: PortNumber -> IO () - ipcWrite port = do - writeFile ipcFile (show port) - - ipcRead :: IO PortNumber - ipcRead = do - fmap (readMaybe @PortNumber) (readFile ipcFile) >>= \case - Nothing -> do - ipcRead - Just p -> do - writeFile ipcFile "" - return p - - -- Create the server - server <- - Server.mkGrpcServer def [ - Server.someRpcHandler $ - Server.mkRpcHandler @RPC1 $ echoHandler Nothing - ] - - let serverConfig = ServerConfig { - serverInsecure = Just $ InsecureConfig { - insecureHost = Just "127.0.0.1" - , insecurePort = 0 - } - , serverSecure = Nothing - } - - -- Starts the server in a new process. Gives back an action that kills - -- the created server process. - startServer :: IO (IO ()) - startServer = do - serverPid <- - forkProcess $ - forkServer def serverConfig server $ \runningServer -> do - ipcWrite =<< getServerPort runningServer - waitServer runningServer - return $ signalProcess sigKILL serverPid - - -- Start server, get the initial port - killServer <- startServer - port1 <- ipcRead - signalRestart <- newEmptyMVar - let serverAddress port = - Client.ServerInsecure Client.Address { - addressHost = "127.0.0.1" - , addressPort = port - , addressAuthority = Nothing - } - - reconnectPolicy :: Client.ReconnectPolicy - reconnectPolicy = go 0 - where - go :: Int -> Client.ReconnectPolicy - go n - | n == 5 - = Client.ReconnectPolicy $ do - killRestarted <- startServer - port2 <- ipcRead - putMVar signalRestart killRestarted - return $ Client.DoReconnect Client.Reconnect { - Client.nextPolicy = - Client.ReconnectPolicy $ - pure $ Client.DoReconnect Client.Reconnect { - Client.reconnectTo = - Client.ReconnectToNew $ serverAddress port2 - , Client.nextPolicy = - Client.ReconnectPolicy $ pure Client.DontReconnect - , Client.onReconnect = Nothing - } - , Client.reconnectTo = Client.ReconnectToOriginal - , Client.onReconnect = def - } - | otherwise - = Client.ReconnectPolicy $ do - threadDelay 10000 - return $ - Client.DoReconnect Client.Reconnect { - reconnectTo = Client.ReconnectToOriginal - , onReconnect = def - , nextPolicy = go (n + 1) - } - - connParams :: Client.ConnParams - connParams = def { Client.connReconnectPolicy = reconnectPolicy } - - Client.withConnection connParams (serverAddress port1) $ \conn -> do - let numCalls = 10 - results <- - inLockstep conn (Proxy @RPC1) numCalls NeverTerminate $ \results getFinal -> do - -- Once all clients have started their RPC, kill the server - _ <- waitForHistoryOfMinLen results 1 - killServer - getFinal - - -- All calls should have failed (but we don't know in which step) - assertEqual "" numCalls $ length $ filter stepFailed (concat results) - - -- New calls should succeed (after reconnection) - killRestarted <- takeMVar signalRestart - result <- - inLockstep conn (Proxy @RPC1) numCalls (TerminateAfter 1) $ \_results getFinal -> - getFinal - - let expectedResult = [replicate numCalls $ StepOk 1] - assertEqual "" expectedResult result - - -- Do not leave the server process hanging around - killRestarted - -{------------------------------------------------------------------------------- - Auxiliary: echo handler --------------------------------------------------------------------------------} - --- | Echos any input -echoHandler :: - TrivialRpc rpc - => Maybe (IORef Int) - -> Server.Call rpc -> IO () -echoHandler disconnectCounter call = - trackDisconnects disconnectCounter $ loop - where - loop :: IO () - loop = do - inp <- Binary.recvInput @Word64 call - case inp of - StreamElem n -> Binary.sendNextOutput @Word64 call n >> loop - FinalElem n _ -> Binary.sendFinalOutput @Word64 call (n, NoMetadata) - NoMoreElems _ -> Server.sendTrailers call NoMetadata - - trackDisconnects :: Maybe (IORef Int) -> IO () -> IO () - trackDisconnects Nothing = id - trackDisconnects (Just counter) = - handle $ \(_e :: Server.ClientDisconnected) -> - atomicModifyIORef' counter $ \n -> (n + 1, ()) - -{------------------------------------------------------------------------------- - Bunch of clients all executing in lockstep --------------------------------------------------------------------------------} - -data NumSteps = TerminateAfter Int | NeverTerminate - -data Results = Results { - -- | Results for the current step - resultsCurr :: TVar [StepResult] - - -- | Number of the current step - , resultsStep :: Int - - -- | Previous results (in reverse order) - , resultsHist :: [[StepResult]] - } - -data StepResult = StepOk Int | StepFailed SomeException - deriving stock (Show) - -stepFailed :: StepResult -> Bool -stepFailed StepOk{} = False -stepFailed StepFailed{} = True - -instance Eq StepResult where - StepOk i == StepOk i' = i == i' - StepFailed _ == StepFailed _ = True -- the exception is merely for debugging - StepOk _ == StepFailed _ = False - StepFailed _ == StepOk _ = False - -initResults :: IO (TVar Results) -initResults = do - resultsCurr <- newTVarIO [] - newTVarIO Results{ - resultsCurr - , resultsStep = 1 - , resultsHist = [] - } - --- | Keep collecting results (never terminates) -collectResults :: Int -> TVar Results -> IO a -collectResults numClients results = - forever $ - atomically $ do - Results{resultsCurr, resultsStep, resultsHist} <- readTVar results - current <- readTVar resultsCurr - if length current < numClients - then retry - else do - current' <- newTVar [] - writeTVar results Results{ - resultsCurr = current' - , resultsStep = succ resultsStep - , resultsHist = current : resultsHist - } - --- | Get the 'TVar' for the specified step, blocking until that step is reached --- --- This is executed by each client on each step. As a result, we can assume that --- the required step can never be /before/ the current step (because all clients --- must deliver their result for the current step before the step advances). -waitForStep :: TVar Results -> Int -> IO (TVar [StepResult]) -waitForStep results step = atomically $ do - Results{resultsCurr, resultsStep} <- readTVar results - if resultsStep < step - then retry - else return resultsCurr - --- | Wait until a history of at least the specified length is ready -waitForHistoryOfMinLen :: TVar Results -> Int -> IO [[StepResult]] -waitForHistoryOfMinLen results numSteps = atomically $ do - Results{resultsHist} <- readTVar results - if length resultsHist < numSteps - then retry - else return resultsHist - -inLockstep :: forall rpc a. - TrivialRpc rpc - => Client.Connection -- ^ Server to connect to - -> Proxy rpc -- ^ Method to call - -> Int -- ^ Number of clients - -> NumSteps -- ^ How many steps each client should take - -> (TVar Results -> IO [[StepResult]] -> IO a) - -- ^ Monitor the results - -- - -- This is also passed a function to get the /final/ results, after all - -- clients have terminated. If some clients never terminate, this function - -- will block indefinitely. - -> IO a -inLockstep conn rpc numClients numSteps monitor = do - results <- initResults - withAsync (collectResults numClients results) $ \_ -> - withAsync (runClients results) $ \clients -> - monitor results (wait clients) - where - runClients :: TVar Results -> IO [[StepResult]] - runClients results = do - replicateConcurrently_ numClients $ - Client.withRPC conn def rpc (client results) - resultsHist <$> readTVarIO results - - client :: TVar Results -> Client.Call rpc -> IO () - client results call = loop 1 - where - loop :: Int -> IO () - loop n = do - current <- waitForStep results n - handle (recordException current) $ - case numSteps of - TerminateAfter n' | n == n' -> do - Binary.sendFinalInput call n - (resp, NoMetadata) <- Binary.recvFinalOutput call - atomically $ modifyTVar current (StepOk resp:) - _otherwise -> do - Binary.sendNextInput call n - resp <- Binary.recvNextOutput call - atomically $ modifyTVar current (StepOk resp:) - loop (succ n) - - recordException :: TVar [StepResult] -> SomeException -> IO () - recordException current e = - atomically $ modifyTVar current (StepFailed e:) - -{------------------------------------------------------------------------------- - Auxiliary: trivial RPCs - - We want two distinct handler so we have two trivial RPCs. --------------------------------------------------------------------------------} - -type TrivialRpc rpc = ( - SupportsClientRpc rpc - , Input rpc ~ Lazy.ByteString - , Output rpc ~ Lazy.ByteString - , RequestMetadata rpc ~ NoMetadata - , ResponseInitialMetadata rpc ~ NoMetadata - , ResponseTrailingMetadata rpc ~ NoMetadata - ) - -type RPC1 = Trivial' "rpc1" -type RPC2 = Trivial' "rpc2" diff --git a/test-grapesy/Test/Sanity/Interop.hs b/test-grapesy/Test/Sanity/Interop.hs --- a/test-grapesy/Test/Sanity/Interop.hs +++ b/test-grapesy/Test/Sanity/Interop.hs @@ -111,6 +111,7 @@ Client.withRPC conn def (Proxy @EmptyCall) $ \call -> do Client.sendFinalInput call defMessage streamElem <- Client.recvOutputWithMeta call + void $ Client.waitForTrailers call case StreamElem.value streamElem of Nothing -> fail "Expected answer" Just (meta, _x) -> verifyMeta meta @@ -153,6 +154,7 @@ ] output1 <- Client.recvOutputWithMeta call output2 <- Client.recvOutputWithMeta call + void $ Client.waitForTrailers call verifyOutputs (StreamElem.value output1, StreamElem.value output2) , server = [ Server.someRpcHandler $ diff --git a/test-grapesy/Test/Sanity/Metadata.hs b/test-grapesy/Test/Sanity/Metadata.hs new file mode 100644 --- /dev/null +++ b/test-grapesy/Test/Sanity/Metadata.hs @@ -0,0 +1,121 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +module Test.Sanity.Metadata (tests) where + +import Control.Monad +import Data.Binary (Binary) +import Data.ByteString qualified as BSS +import Data.ByteString qualified as Strict (ByteString) +import Data.String +import GHC.Generics (Generic) +import Test.Driver.ClientServer +import Test.Tasty +import Test.Tasty.HUnit +import Text.Printf + +import Network.GRPC.Client qualified as Client +import Network.GRPC.Client.Binary qualified as Client.Binary +import Network.GRPC.Common +import Network.GRPC.Common.Binary +import Network.GRPC.Server qualified as Server +import Network.GRPC.Server.Binary qualified as Server.Binary +import Network.GRPC.Spec.Serialization qualified as Spec + +tests :: TestTree +tests = testGroup "Test.Sanity.Metadata" [ + testCase "summarizeAndEcho" $ test_summarizeAndEcho 10 + ] + +{------------------------------------------------------------------------------- + Trailers +-------------------------------------------------------------------------------} + +-- | Sanity check: test that the server can receive client metadata and can +-- echo it as trailing metadata. We also verify that the server can /announce/ +-- that trailing metadata before it sends it. +test_summarizeAndEcho :: Int -> Assertion +test_summarizeAndEcho n = testClientServer $ ClientServerTest { + config = def{serverPort = Right 50051} + , server = [Server.someRpcHandler execInstr] + , client = simpleTestClient $ \conn -> do + Client.withRPC conn callParams (Proxy @ExecInstr) $ \call -> do + Client.Binary.sendFinalInput call SummarizeAndEcho + + -- Check that trailers announced + initResponse <- Client.recvInitialResponse call + case initResponse of + Left trailersOnly -> + assertFailure $ "Unexpected trailers-only " ++ show trailersOnly + Right x -> + case Client.responseTrailerNames x of + Left err -> + assertFailure $ show err + Right Nothing -> + assertFailure "Trailer not present" + Right (Just names) -> + forM_ metadata $ \md -> + assertBool ("Missing " ++ show md) $ flip elem names $ + Spec.buildHeaderName (customMetadataName md) + + -- Check summary and trailing metadata + (summary, trailers) <- Client.Binary.recvFinalOutput call + assertEqual "" (summarize metadata) $ summary + assertEqual "" metadata $ trailers + + } + where + metadata :: [CustomMetadata] + metadata = [ + CustomMetadata + (fromString $ "md-" ++ printf "%02d" i) -- for sorting purposes + (fromString $ show i) + | i <- [1 .. n] + ] + + callParams :: Client.CallParams ExecInstr + callParams = def{Client.callRequestMetadata = metadata} + +{------------------------------------------------------------------------------- + Server handler +-------------------------------------------------------------------------------} + +type ExecInstr = RawRpc "TestMetadata" "ExecInstr" + +type instance RequestMetadata ExecInstr = [CustomMetadata] +type instance ResponseInitialMetadata ExecInstr = [CustomMetadata] +type instance ResponseTrailingMetadata ExecInstr = [CustomMetadata] + +data Instruction = + -- | Summary the request metadata, and echo it as trailing metadata + SummarizeAndEcho + deriving stock (Generic) + deriving anyclass (Binary) + +execInstr :: Server.RpcHandler IO ExecInstr +execInstr = Server.mkRpcHandlerNoDefMetadata $ \call -> do + requestMetadata <- Server.getRequestMetadata call + instr <- Server.Binary.recvFinalInput call + case instr of + SummarizeAndEcho -> do + -- We need to explicitly set the trailers, because they vary from one + -- request to the next (that is, they aren't static) + Server.setResponseInitialMetadataAndTrailers call [] . Just $ + map customMetadataName requestMetadata + Server.Binary.sendFinalOutput @Summary call ( + summarize requestMetadata + , requestMetadata + ) + +{------------------------------------------------------------------------------- + Internal auxiliary +-------------------------------------------------------------------------------} + +type Summary = [(Strict.ByteString, Int)] + +summarize :: [CustomMetadata] -> Summary +summarize = map aux + where + aux :: CustomMetadata -> (Strict.ByteString, Int) + aux md = ( + getHeaderName $ customMetadataName md + , BSS.length $ customMetadataValue md + ) diff --git a/test-grapesy/Test/Sanity/NoIsLabel.hs b/test-grapesy/Test/Sanity/NoIsLabel.hs --- a/test-grapesy/Test/Sanity/NoIsLabel.hs +++ b/test-grapesy/Test/Sanity/NoIsLabel.hs @@ -1,8 +1,23 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedLabels #-} + {-# OPTIONS_GHC -Wno-orphans #-} module Test.Sanity.NoIsLabel (tests) where +#if !defined(TEST_NO_ISLABEL) + +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = testGroup "Test.Sanity.NoIsLabel" [ + testCaseInfo "Data.ProtoLens.Labels not in scope" $ + return "Skipped (requires proto-lens-protobuf-types >= 0.7.2.3)" + ] + +#else + import Data.Proxy import Data.String import GHC.OverloadedLabels @@ -38,3 +53,4 @@ f :: Int -> String f = #hi +#endif diff --git a/test-grapesy/Test/Sanity/Reclamation.hs b/test-grapesy/Test/Sanity/Reclamation.hs --- a/test-grapesy/Test/Sanity/Reclamation.hs +++ b/test-grapesy/Test/Sanity/Reclamation.hs @@ -28,7 +28,7 @@ -- | Handler that throws immediately brokenHandler :: Server.Call Ping -> IO () -brokenHandler _call = throwIO $ DeliberateException $ userError "Broken handler" +brokenHandler _call = throwIO $ DeliberateServerException 1 serverException1 :: Assertion serverException1 = testClientServer $ ClientServerTest { @@ -52,11 +52,13 @@ 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 + resp <- try $ do + -- The only difference between 'serverException1' is this call + -- to 'sendFinalInput'. We will probably get the exception when + -- we try to /receive/ a message from the server, but we + -- sometimes already get it when we /send/. + Client.sendFinalInput call defMessage + Client.recvFinalOutput call case resp of Left GrpcException{} -> return () Right _ -> assertFailure "Unexpected response" diff --git a/test-grapesy/Test/Sanity/StreamingType/NonStreaming.hs b/test-grapesy/Test/Sanity/StreamingType/NonStreaming.hs --- a/test-grapesy/Test/Sanity/StreamingType/NonStreaming.hs +++ b/test-grapesy/Test/Sanity/StreamingType/NonStreaming.hs @@ -126,6 +126,8 @@ test_increment def { isExpectedClientException = isClientUnsupportedCompression + , isExpectedServerException = + isClientDisconnected , clientCompr = Compr.none , serverCompr = diff --git a/test-grapesy/Test/Util.hs b/test-grapesy/Test/Util.hs --- a/test-grapesy/Test/Util.hs +++ b/test-grapesy/Test/Util.hs @@ -4,9 +4,6 @@ -- * Timeouts Timeout(..) , within - - -- * Files - , withTemporaryFile ) where import Control.Concurrent @@ -14,8 +11,6 @@ import Control.Monad.Catch import Control.Monad.IO.Class import GHC.Stack -import System.IO -import System.IO.Temp {------------------------------------------------------------------------------- Timeouts @@ -49,7 +44,3 @@ fmap fst $ generalBracket startTimer stopTimer $ \_ -> io - -withTemporaryFile :: (FilePath -> IO a) -> IO a -withTemporaryFile k = - withSystemTempFile "grapesy-test-suite.txt" (\fp h -> hClose h >> k fp) diff --git a/test-grapesy/Test/Util/Exception.hs b/test-grapesy/Test/Util/Exception.hs --- a/test-grapesy/Test/Util/Exception.hs +++ b/test-grapesy/Test/Util/Exception.hs @@ -1,36 +1,64 @@ --- | Utility exception types for the tests -module Test.Util.Exception - ( -- * User exceptions - SomeServerException(..) - , SomeClientException(..) +{-# LANGUAGE CPP #-} - -- * Deliberate exceptions - , DeliberateException(..) - , ExceptionId +-- | Exception utilities +module Test.Util.Exception ( + testFormatCtx + , uncaughtExceptionHandler ) where +import Control.Concurrent import Control.Exception +import Data.Function ((&)) +import Data.Maybe (fromMaybe) +import Data.Proxy +import System.IO -{------------------------------------------------------------------------------- - User exceptions +import Network.HTTP2.Client qualified as HTTP2 - 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). --------------------------------------------------------------------------------} +#if MIN_VERSION_base(4,18,0) +import GHC.Conc.Sync (threadLabel) +#endif -data SomeServerException = SomeServerException ExceptionId - deriving stock (Show, Eq) - deriving anyclass (Exception) +import Network.GRPC.Common.Exception -data SomeClientException = SomeClientException ExceptionId - deriving stock (Show, Eq) - deriving anyclass (Exception) +import Test.Driver.ClientServer (FirstTestFailure) +import Test.Prop.Dialogue (RegressionTestFailed) --- | 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 +{------------------------------------------------------------------------------- + Exception rendering +-------------------------------------------------------------------------------} --- | We distinguish exceptions from each other simply by a number -type ExceptionId = Int +testFormatCtx :: FormatCtx +testFormatCtx = grapesyFormatCtx + & insertFormatCtx http2 + & insertFormatCtx_ (Proxy @FirstTestFailure) + & insertFormatCtx_ (Proxy @RegressionTestFailed) + where + http2 :: FormatCtx -> HTTP2.HTTP2Error -> Doc + http2 ctx = \case + HTTP2.BadThingHappen se -> + withHeader "BadThingHappen" $ toExceptionDoc ctx se + other -> + fromLines (displayException other) + +{------------------------------------------------------------------------------- + Uncaught exception handler +-------------------------------------------------------------------------------} + +uncaughtExceptionHandler :: SomeException -> IO () +uncaughtExceptionHandler e = do + tid <- myThreadId + mLabel :: Maybe String <- +#if MIN_VERSION_base(4,18,0) + threadLabel tid +#else + return $ Just "unknown label" +#endif + hPutStrLn stderr $ concat [ + "Uncaught exception in " + , show tid + , " (" + , fromMaybe "unlabelled" mLabel + , "): " + , renderAnyException testFormatCtx e + ] diff --git a/test-grapesy/Test/Util/RawTestServer.hs b/test-grapesy/Test/Util/RawTestServer.hs --- a/test-grapesy/Test/Util/RawTestServer.hs +++ b/test-grapesy/Test/Util/RawTestServer.hs @@ -13,6 +13,8 @@ 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.Lazy qualified as BS.Lazy +import Data.ByteString.Lazy qualified as Lazy (ByteString) import Data.ByteString.UTF8 qualified as BS.Strict.UTF8 import Data.String (fromString) import Network.HTTP2.Server qualified as HTTP2 @@ -50,14 +52,31 @@ } k addr --- | Server that responds with the given 'Response', independent of the request -respondWith :: Response -> (Client.Address -> IO a) -> IO a -respondWith resp = respondWithIO (return resp) +-- | Pure version of 'respondWithiO' +respondWith :: + (Lazy.ByteString -> Response) + -> (Client.Address -> IO a) + -> IO a +respondWith resp = respondWithIO (return . resp) --- | Version of 'respondWith' that constructs the response -respondWithIO :: IO Response -> (Client.Address -> IO a) -> IO a -respondWithIO mkResponse = withTestServer $ \_req _aux respond -> do - response <- mkResponse +-- | Construct a response given the complete request body +-- +-- NOTE: This does not work for streaming clients! +respondWithIO :: + (Lazy.ByteString -> IO Response) + -> (Client.Address -> IO a) + -> IO a +respondWithIO mkResponse = withTestServer $ \req _aux respond -> do + let getRequestBody :: [Strict.ByteString] -> IO Lazy.ByteString + getRequestBody acc = do + (chunk, isFinal) <- HTTP2.getRequestBodyChunk' req + let acc' = chunk : acc + if isFinal + then return $ BS.Lazy.fromChunks (reverse acc') + else getRequestBody acc' + + requestBody <- getRequestBody [] + response <- mkResponse requestBody respond (toHTTP2Response response) [] data Response = Response { @@ -66,6 +85,7 @@ , responseBody :: Strict.ByteString , responseTrailers :: [HTTP.Header] } + deriving stock (Show) instance Default Response where def = Response { diff --git a/test-record-dot/Test/OverloadedRecordUpdate.hs b/test-record-dot/Test/OverloadedRecordUpdate.hs --- a/test-record-dot/Test/OverloadedRecordUpdate.hs +++ b/test-record-dot/Test/OverloadedRecordUpdate.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedRecordUpdate #-} @@ -7,7 +9,6 @@ module Test.OverloadedRecordUpdate (tests) where import Prelude -import GHC.Records.Compat import Network.GRPC.Common.Protobuf @@ -15,6 +16,18 @@ import Test.Tasty.HUnit import Proto.Spec + +#if MIN_VERSION_base(4,22,0) +import GHC.Records.Compat (getField) +import GHC.Records.Compat qualified as Compat + +-- See +setField :: forall fld a r. Compat.HasField fld r a => a -> r -> r +setField a r = Compat.setField @fld @r @a r a +#else +import GHC.Records.Compat (getField, setField) +#endif + tests :: TestTree tests = testGroup "Test.OverloadedRecordUpdate" [ diff --git a/test-stress/Main.hs b/test-stress/Main.hs --- a/test-stress/Main.hs +++ b/test-stress/Main.hs @@ -6,6 +6,8 @@ import GHC.Conc (setUncaughtExceptionHandler) import System.IO.Temp (writeSystemTempFile) import Text.Show.Pretty (dumpStr) +import System.Environment (lookupEnv) +import System.Exit (exitSuccess) #if defined(PROFILING) && MIN_VERSION_base(4,20,0) import Control.Exception.Backtrace @@ -26,6 +28,12 @@ main :: IO () main = do + lookupEnv "GITHUB_ACTIONS" >>= \case + Just "true" -> do + putStrLn "Not running stress tests on GitHub Actions" + exitSuccess + _ -> return () + #if defined(PROFILING) && MIN_VERSION_base(4,20,0) setBacktraceMechanismState CostCentreBacktrace True #endif diff --git a/test-stress/Test/Stress/Cmdline.hs b/test-stress/Test/Stress/Cmdline.hs --- a/test-stress/Test/Stress/Cmdline.hs +++ b/test-stress/Test/Stress/Cmdline.hs @@ -37,7 +37,7 @@ import Network.GRPC.Common.Compression qualified as Compr import Network.GRPC.Server.Run -import Paths_grapesy +import Paths_ (getDataFileName) {------------------------------------------------------------------------------- Definitions @@ -160,8 +160,8 @@ getCmdline :: IO Cmdline getCmdline = do - defaultPub <- getDataFileName "grpc-demo.pem" - defaultPriv <- getDataFileName "grpc-demo.key" + defaultPub <- getDataFileName "grapesy" "grpc-demo.pem" + defaultPriv <- getDataFileName "grapesy" "grpc-demo.key" let info :: Opt.ParserInfo Cmdline info = Opt.info