grapesy 1.1.1 → 1.2.0
raw patch · 103 files changed
+4922/−2527 lines, 103 filesdep +HUnitdep +http-semanticsdep +tree-diffdep ~QuickCheckdep ~aesondep ~base
Dependencies added: HUnit, http-semantics, tree-diff
Dependency ranges changed: QuickCheck, aeson, base, binary, containers, filepath, ghc-events, grpc-spec, http2, http2-tls, network, network-run, optparse-applicative, proto-lens-protobuf-types, stm, time-manager
Files
- CHANGELOG.md +20/−0
- data/grpc-demo.key +26/−26
- data/grpc-demo.pem +17/−17
- grapesy.cabal +153/−70
- interop/Interop/Client.hs +5/−4
- interop/Interop/Client/TestCase/EmptyUnary.hs +4/−1
- interop/Interop/Client/TestCase/ServerCompressedUnary.hs +4/−0
- interop/Interop/Cmdline.hs +4/−4
- interop/Interop/Server.hs +4/−3
- interop/Interop/Server/Common.hs +0/−1
- interop/Interop/Util/Exceptions.hs +42/−2
- interop/Interop/Util/NonInterleaved.hs +46/−0
- interop/Main.hs +2/−3
- kvstore/KVStore/Server.hs +3/−3
- paths/Paths_.hs +24/−0
- src/Network/GRPC/Client.hs +3/−1
- src/Network/GRPC/Client/Binary.hs +6/−5
- src/Network/GRPC/Client/Call.hs +152/−115
- src/Network/GRPC/Client/Connection.hs +19/−405
- src/Network/GRPC/Client/Meta.hs +0/−0
- src/Network/GRPC/Client/Run.hs +430/−0
- src/Network/GRPC/Client/Session.hs +5/−7
- src/Network/GRPC/Client/StreamType.hs +5/−7
- src/Network/GRPC/Client/StreamType/Conduit.hs +5/−6
- src/Network/GRPC/Client/StreamType/IO.hs +3/−5
- src/Network/GRPC/Client/StreamType/IO/Binary.hs +5/−6
- src/Network/GRPC/Common.hs +6/−45
- src/Network/GRPC/Common/Binary.hs +0/−3
- src/Network/GRPC/Common/Compression.hs +2/−5
- src/Network/GRPC/Common/Exception.hs +116/−0
- src/Network/GRPC/Common/Headers.hs +3/−4
- src/Network/GRPC/Common/Protobuf.hs +6/−10
- src/Network/GRPC/Common/Protobuf/Any.hs +2/−3
- src/Network/GRPC/Common/ProtocolException.hs +47/−0
- src/Network/GRPC/Common/StreamElem.hs +6/−5
- src/Network/GRPC/Server.hs +4/−3
- src/Network/GRPC/Server/Binary.hs +4/−3
- src/Network/GRPC/Server/Call.hs +188/−119
- src/Network/GRPC/Server/Context.hs +14/−15
- src/Network/GRPC/Server/Handler.hs +92/−49
- src/Network/GRPC/Server/HandlerMap.hs +1/−2
- src/Network/GRPC/Server/Protobuf.hs +1/−4
- src/Network/GRPC/Server/RequestHandler.hs +23/−26
- src/Network/GRPC/Server/RequestHandler/API.hs +4/−4
- src/Network/GRPC/Server/Run.hs +51/−49
- src/Network/GRPC/Server/Session.hs +4/−8
- src/Network/GRPC/Server/StreamType.hs +7/−5
- src/Network/GRPC/Server/StreamType/Binary.hs +3/−5
- src/Network/GRPC/Util/ClientStream.hs +45/−0
- src/Network/GRPC/Util/Exception/Doc.hs +65/−0
- src/Network/GRPC/Util/Exception/Exact.hs +106/−0
- src/Network/GRPC/Util/Exception/FormatCtx.hs +82/−0
- src/Network/GRPC/Util/Exception/Shims.hs +206/−0
- src/Network/GRPC/Util/Exception/ToExceptionDoc.hs +280/−0
- src/Network/GRPC/Util/GHC.hs +5/−4
- src/Network/GRPC/Util/HTTP2.hs +22/−64
- src/Network/GRPC/Util/HTTP2/Stream.hs +0/−207
- src/Network/GRPC/Util/HeaderTable.hs +17/−0
- src/Network/GRPC/Util/Imports.hs +36/−0
- src/Network/GRPC/Util/RedundantConstraint.hs +0/−0
- src/Network/GRPC/Util/ServerStream.hs +83/−0
- src/Network/GRPC/Util/Session.hs +0/−57
- src/Network/GRPC/Util/Session/API.hs +4/−6
- src/Network/GRPC/Util/Session/Channel.hs +219/−185
- src/Network/GRPC/Util/Session/Client.hs +119/−76
- src/Network/GRPC/Util/Session/Server.hs +122/−54
- src/Network/GRPC/Util/Stream.hs +73/−0
- src/Network/GRPC/Util/Thread.hs +408/−151
- src/Network/GRPC/Util/TimeManager.hs +33/−0
- src/Network/GRPC/Util/Version.hs +6/−0
- test-disconnect/Main.hs +279/−0
- test-disconnect/Test/Disconnect/Echo/Client.hs +59/−0
- test-disconnect/Test/Disconnect/Echo/RPC.hs +13/−0
- test-disconnect/Test/Disconnect/Echo/Server.hs +26/−0
- test-disconnect/Test/Disconnect/Util/Client.hs +63/−0
- test-disconnect/Test/Disconnect/Util/Exception.hs +57/−0
- test-disconnect/Test/Disconnect/Util/Process.hs +93/−0
- test-disconnect/Test/Disconnect/Util/Server.hs +114/−0
- test-grapesy/Main.hs +10/−30
- test-grapesy/Test/Common/Exception.hs +22/−0
- test-grapesy/Test/Driver/ClientServer.hs +108/−64
- test-grapesy/Test/Driver/Dialogue/Definition.hs +9/−13
- test-grapesy/Test/Driver/Dialogue/Execution.hs +40/−24
- test-grapesy/Test/Driver/Dialogue/Generation.hs +12/−6
- test-grapesy/Test/Driver/Dialogue/TestClock.hs +12/−9
- test-grapesy/Test/Prop/Dialogue.hs +34/−18
- test-grapesy/Test/Regression/Issue102.hs +5/−8
- test-grapesy/Test/Sanity/Any.hs +2/−1
- test-grapesy/Test/Sanity/BrokenDeployments.hs +16/−13
- test-grapesy/Test/Sanity/Cancellation.hs +184/−0
- test-grapesy/Test/Sanity/Compression.hs +7/−0
- test-grapesy/Test/Sanity/Disconnect.hs +0/−427
- test-grapesy/Test/Sanity/Interop.hs +2/−0
- test-grapesy/Test/Sanity/Metadata.hs +121/−0
- test-grapesy/Test/Sanity/NoIsLabel.hs +16/−0
- test-grapesy/Test/Sanity/Reclamation.hs +8/−6
- test-grapesy/Test/Sanity/StreamingType/NonStreaming.hs +2/−0
- test-grapesy/Test/Util.hs +0/−9
- test-grapesy/Test/Util/Exception.hs +54/−26
- test-grapesy/Test/Util/RawTestServer.hs +27/−7
- test-record-dot/Test/OverloadedRecordUpdate.hs +14/−1
- test-stress/Main.hs +8/−0
- test-stress/Test/Stress/Cmdline.hs +3/−3
CHANGELOG.md view
@@ -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`
data/grpc-demo.key view
@@ -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-----
data/grpc-demo.pem view
@@ -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-----
grapesy.cabal view
@@ -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 <https://github.com/well-typed/grapesy/pull/283>.+ , 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
interop/Interop/Client.hs view
@@ -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
interop/Interop/Client/TestCase/EmptyUnary.hs view
@@ -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 @@ -- | <https://github.com/grpc/grpc/blob/master/doc/interop-test-descriptions.md#empty_unary> 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
interop/Interop/Client/TestCase/ServerCompressedUnary.hs view
@@ -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
interop/Interop/Cmdline.hs view
@@ -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"
interop/Interop/Server.hs view
@@ -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"
interop/Interop/Server/Common.hs view
@@ -7,7 +7,6 @@ , checkInboundCompression ) where -import Control.Exception import Data.ProtoLens.Labels () import Network.GRPC.Common
interop/Interop/Util/Exceptions.hs view
@@ -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+ ]
+ interop/Interop/Util/NonInterleaved.hs view
@@ -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
interop/Main.hs view
@@ -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
kvstore/KVStore/Server.hs view
@@ -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 {
+ paths/Paths_.hs view
@@ -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 `<pkgname>_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 `<pkgname>.cabal`+ Nothing -> return "."
src/Network/GRPC/Client.hs view
@@ -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 {-------------------------------------------------------------------------------
src/Network/GRPC/Client/Binary.hs view
@@ -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) {-------------------------------------------------------------------------------
src/Network/GRPC/Client/Call.hs view
@@ -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 <https://github.com/grpc/grpc/blob/master/doc/interop-test-descriptions.md#cancel_after_begin> -- o <https://github.com/grpc/grpc/blob/master/doc/interop-test-descriptions.md#cancel_after_first_response> 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 --
src/Network/GRPC/Client/Connection.hs view
@@ -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
src/Network/GRPC/Client/Meta.hs view
+ src/Network/GRPC/Client/Run.hs view
@@ -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
src/Network/GRPC/Client/Session.hs view
@@ -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
src/Network/GRPC/Client/StreamType.hs view
@@ -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)
src/Network/GRPC/Client/StreamType/Conduit.hs view
@@ -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)
src/Network/GRPC/Client/StreamType/IO.hs view
@@ -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
src/Network/GRPC/Client/StreamType/IO/Binary.hs view
@@ -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
src/Network/GRPC/Common.hs view
@@ -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
src/Network/GRPC/Common/Binary.hs view
@@ -43,6 +43,3 @@ deriving stock (Show) deriving anyclass (Exception) ---
src/Network/GRPC/Common/Compression.hs view
@@ -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
+ src/Network/GRPC/Common/Exception.hs view
@@ -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.+ <https://github.com/well-typed/grapesy/issues/339>+-------------------------------------------------------------------------------}++-- | 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)
src/Network/GRPC/Common/Headers.hs view
@@ -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
src/Network/GRPC/Common/Protobuf.hs view
@@ -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
src/Network/GRPC/Common/Protobuf/Any.hs view
@@ -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
+ src/Network/GRPC/Common/ProtocolException.hs view
@@ -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
src/Network/GRPC/Common/StreamElem.hs view
@@ -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
src/Network/GRPC/Server.hs view
@@ -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 $
src/Network/GRPC/Server/Binary.hs view
@@ -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
src/Network/GRPC/Server/Call.hs view
@@ -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)
src/Network/GRPC/Server/Context.hs view
@@ -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 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0330-exception-backtraces.rst>.-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+ ]
src/Network/GRPC/Server/Handler.hs view
@@ -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+ -- <https://github.com/simonmar/async/issues/14>.+ --+ -- See also blog post “When "blocked indefinitely" is not indefinite”+ -- <https://well-typed.com/blog/2024/01/when-blocked-indefinitely-is-not-indefinite/>.+ tryAgain :: forall x. IO x -> IO x+ tryAgain f = f `catch` \E.BlockedIndefinitelyOnSTM -> f
src/Network/GRPC/Server/HandlerMap.hs view
@@ -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 {-------------------------------------------------------------------------------
src/Network/GRPC/Server/Protobuf.hs view
@@ -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
src/Network/GRPC/Server/RequestHandler.hs view
@@ -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: <https://github.com/well-typed/grapesy/issues/131> -- 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{
src/Network/GRPC/Server/RequestHandler/API.hs view
@@ -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
src/Network/GRPC/Server/Run.hs view
@@ -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
src/Network/GRPC/Server/Session.hs view
@@ -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
src/Network/GRPC/Server/StreamType.hs view
@@ -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)
src/Network/GRPC/Server/StreamType/Binary.hs view
@@ -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
+ src/Network/GRPC/Util/ClientStream.hs view
@@ -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+ }
+ src/Network/GRPC/Util/Exception/Doc.hs view
@@ -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
+ src/Network/GRPC/Util/Exception/Exact.hs view
@@ -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)
+ src/Network/GRPC/Util/Exception/FormatCtx.hs view
@@ -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'
+ src/Network/GRPC/Util/Exception/Shims.hs view
@@ -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
+ src/Network/GRPC/Util/Exception/ToExceptionDoc.hs view
@@ -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",+-- <https://well-typed.com/blog/2026/05/lay-annotation-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)
src/Network/GRPC/Util/GHC.hs view
@@ -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
src/Network/GRPC/Util/HTTP2.hs view
@@ -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
− src/Network/GRPC/Util/HTTP2/Stream.hs
@@ -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
+ src/Network/GRPC/Util/HeaderTable.hs view
@@ -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
+ src/Network/GRPC/Util/Imports.hs view
@@ -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
src/Network/GRPC/Util/RedundantConstraint.hs view
+ src/Network/GRPC/Util/ServerStream.hs view
@@ -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
− src/Network/GRPC/Util/Session.hs
@@ -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
src/Network/GRPC/Util/Session/API.hs view
@@ -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)
src/Network/GRPC/Util/Session/Channel.hs view
@@ -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 []
src/Network/GRPC/Util/Session/Client.hs view
@@ -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
src/Network/GRPC/Util/Session/Server.hs view
@@ -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
+ src/Network/GRPC/Util/Stream.hs view
@@ -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
src/Network/GRPC/Util/Thread.hs view
@@ -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+-- <https://www.erlang.org/docs/23/reference_manual/processes.html#monitors>.+--+-- 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
+ src/Network/GRPC/Util/TimeManager.hs view
@@ -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
+ src/Network/GRPC/Util/Version.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE CPP #-} +module Network.GRPC.Util.Version (version) where++-- | Version of this package+version :: String+version = CURRENT_PACKAGE_VERSION
+ test-disconnect/Main.hs view
@@ -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
+ test-disconnect/Test/Disconnect/Echo/Client.hs view
@@ -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
+ test-disconnect/Test/Disconnect/Echo/RPC.hs view
@@ -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"+
+ test-disconnect/Test/Disconnect/Echo/Server.hs view
@@ -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+
+ test-disconnect/Test/Disconnect/Util/Client.hs view
@@ -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+ }
+ test-disconnect/Test/Disconnect/Util/Exception.hs view
@@ -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+ ]
+ test-disconnect/Test/Disconnect/Util/Process.hs view
@@ -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
+ test-disconnect/Test/Disconnect/Util/Server.hs view
@@ -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
test-grapesy/Main.hs view
@@ -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+ ] ]
+ test-grapesy/Test/Common/Exception.hs view
@@ -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)+ ]
test-grapesy/Test/Driver/ClientServer.hs view
@@ -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 <https://github.com/well-typed/grapesy/issues/339>+-- 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
test-grapesy/Test/Driver/Dialogue/Definition.hs view
@@ -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)-
test-grapesy/Test/Driver/Dialogue/Execution.hs view
@@ -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
test-grapesy/Test/Driver/Dialogue/Generation.hs view
@@ -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 = []
test-grapesy/Test/Driver/Dialogue/TestClock.hs view
@@ -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} {-------------------------------------------------------------------------------
test-grapesy/Test/Prop/Dialogue.hs view
@@ -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)) ]
test-grapesy/Test/Regression/Issue102.hs view
@@ -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
test-grapesy/Test/Sanity/Any.hs view
@@ -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
test-grapesy/Test/Sanity/BrokenDeployments.hs view
@@ -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 <https://github.com/well-typed/grapesy/issues/221>. 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 ->
+ test-grapesy/Test/Sanity/Cancellation.hs view
@@ -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+--+-- * <https://github.com/well-typed/grapesy/issues/349>+-- * 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 <https://github.com/well-typed/grapesy/issues/339>+-- 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
test-grapesy/Test/Sanity/Compression.hs view
@@ -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
− test-grapesy/Test/Sanity/Disconnect.hs
@@ -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"
test-grapesy/Test/Sanity/Interop.hs view
@@ -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 $
+ test-grapesy/Test/Sanity/Metadata.hs view
@@ -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+ )
test-grapesy/Test/Sanity/NoIsLabel.hs view
@@ -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
test-grapesy/Test/Sanity/Reclamation.hs view
@@ -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"
test-grapesy/Test/Sanity/StreamingType/NonStreaming.hs view
@@ -126,6 +126,8 @@ test_increment def { isExpectedClientException = isClientUnsupportedCompression+ , isExpectedServerException =+ isClientDisconnected , clientCompr = Compr.none , serverCompr =
test-grapesy/Test/Util.hs view
@@ -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)
test-grapesy/Test/Util/Exception.hs view
@@ -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+ ]
test-grapesy/Test/Util/RawTestServer.hs view
@@ -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 {
test-record-dot/Test/OverloadedRecordUpdate.hs view
@@ -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 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0583-hasfield-redesign.rst>+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" [
test-stress/Main.hs view
@@ -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
test-stress/Test/Stress/Cmdline.hs view
@@ -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