grpc-spec (empty) → 1.0.0
raw patch · 49 files changed
+9039/−0 lines, 49 filesdep +QuickCheckdep +aesondep +base
Dependencies added: QuickCheck, aeson, base, base16-bytestring, base64-bytestring, binary, bytestring, case-insensitive, containers, data-default, deepseq, exceptions, grpc-spec, hashable, http-types, lens, mtl, network, prettyprinter, prettyprinter-ansi-terminal, proto-lens, proto-lens-protobuf-types, proto-lens-runtime, quickcheck-instances, record-hasfield, snappy-c, tasty, tasty-quickcheck, text, tree-diff, utf8-string, vector, zlib
Files
- CHANGELOG.md +5/−0
- LICENSE +31/−0
- grpc-spec.cabal +208/−0
- proto/Proto/OrcaLoadReport.hs +1171/−0
- proto/Proto/Status.hs +392/−0
- src/Network/GRPC/Spec.hs +195/−0
- src/Network/GRPC/Spec/Call.hs +57/−0
- src/Network/GRPC/Spec/Compression.hs +171/−0
- src/Network/GRPC/Spec/CustomMetadata/Map.hs +101/−0
- src/Network/GRPC/Spec/CustomMetadata/NoMetadata.hs +28/−0
- src/Network/GRPC/Spec/CustomMetadata/Raw.hs +250/−0
- src/Network/GRPC/Spec/CustomMetadata/Typed.hs +133/−0
- src/Network/GRPC/Spec/Headers/Common.hs +86/−0
- src/Network/GRPC/Spec/Headers/Invalid.hs +266/−0
- src/Network/GRPC/Spec/Headers/PseudoHeaders.hs +130/−0
- src/Network/GRPC/Spec/Headers/Request.hs +150/−0
- src/Network/GRPC/Spec/Headers/Response.hs +359/−0
- src/Network/GRPC/Spec/MessageMeta.hs +45/−0
- src/Network/GRPC/Spec/OrcaLoadReport.hs +5/−0
- src/Network/GRPC/Spec/PercentEncoding.hs +145/−0
- src/Network/GRPC/Spec/RPC.hs +152/−0
- src/Network/GRPC/Spec/RPC/JSON.hs +216/−0
- src/Network/GRPC/Spec/RPC/Protobuf.hs +281/−0
- src/Network/GRPC/Spec/RPC/Raw.hs +64/−0
- src/Network/GRPC/Spec/RPC/StreamType.hs +200/−0
- src/Network/GRPC/Spec/Serialization.hs +67/−0
- src/Network/GRPC/Spec/Serialization/Base64.hs +82/−0
- src/Network/GRPC/Spec/Serialization/CustomMetadata.hs +136/−0
- src/Network/GRPC/Spec/Serialization/Headers/Common.hs +205/−0
- src/Network/GRPC/Spec/Serialization/Headers/PseudoHeaders.hs +66/−0
- src/Network/GRPC/Spec/Serialization/Headers/Request.hs +306/−0
- src/Network/GRPC/Spec/Serialization/Headers/Response.hs +621/−0
- src/Network/GRPC/Spec/Serialization/LengthPrefixed.hs +179/−0
- src/Network/GRPC/Spec/Serialization/Status.hs +15/−0
- src/Network/GRPC/Spec/Serialization/Timeout.hs +76/−0
- src/Network/GRPC/Spec/Serialization/TraceContext.hs +130/−0
- src/Network/GRPC/Spec/Status.hs +297/−0
- src/Network/GRPC/Spec/Timeout.hs +94/−0
- src/Network/GRPC/Spec/TraceContext.hs +129/−0
- src/Network/GRPC/Spec/Util/ByteString.hs +31/−0
- src/Network/GRPC/Spec/Util/HKD.hs +205/−0
- src/Network/GRPC/Spec/Util/Parser.hs +251/−0
- src/Network/GRPC/Spec/Util/Protobuf.hs +59/−0
- test-grpc-spec/Main.hs +44/−0
- test-grpc-spec/Test/Prop/IncrementalParsing.hs +222/−0
- test-grpc-spec/Test/Prop/Serialization.hs +703/−0
- test-grpc-spec/Test/Util/Awkward.hs +154/−0
- test-grpc-spec/Test/Util/Orphans.hs +42/−0
- test-grpc-spec/Test/Util/Protobuf.hs +84/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for grpc-spec++## 1.0.0 -- 2025-01-22++* First released version.
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2023-2025, Well-Typed LLP and Anduril Industries Inc.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Well-Typed LLP, the name of Anduril+ Industries Inc., nor the names of other contributors may be+ used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ grpc-spec.cabal view
@@ -0,0 +1,208 @@+cabal-version: 3.0+name: grpc-spec+version: 1.0.0+synopsis: Implementation of the pure part of the gRPC spec+description: This is an implementation of the pure part of the core gRPC+ spec at <https://github.com/grpc/grpc/blob/master/doc/PROTOCOL-HTTP2.md>.+ This is by no means a full gRPC implementation, but can be+ used as the basis for one; see @grapesy@ for a full+ implementation.+license: BSD-3-Clause+license-file: LICENSE+author: Edsko de Vries+maintainer: edsko@well-typed.com+category: Network+build-type: Simple+extra-doc-files: CHANGELOG.md+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++source-repository head+ type: git+ location: https://github.com/well-typed/grapesy++common lang+ ghc-options:+ -Wall+ -Wredundant-constraints+ -Wno-unticked-promoted-constructors+ -Wprepositive-qualified-module+ -Widentities+ -Wmissing-export-lists+ build-depends:+ base >= 4.14 && < 4.22+ default-language:+ Haskell2010+ default-extensions:+ ConstraintKinds+ DataKinds+ DeriveAnyClass+ DeriveGeneric+ DeriveTraversable+ DerivingStrategies+ DerivingVia+ DisambiguateRecordFields+ EmptyCase+ FlexibleContexts+ FlexibleInstances+ GADTs+ GeneralizedNewtypeDeriving+ ImportQualifiedPost+ KindSignatures+ LambdaCase+ MultiParamTypeClasses+ NamedFieldPuns+ NumericUnderscores+ PatternSynonyms+ PolyKinds+ RankNTypes+ ScopedTypeVariables+ StandaloneDeriving+ TupleSections+ TypeApplications+ TypeFamilies+ TypeOperators+ UndecidableInstances++ if impl(ghc >= 9.0)+ ghc-options:+ -- This was introduced in 8.10, but it does not work reliably until 9.0.+ -- In 8.10 you might get spurious warnings when using re-exported modules+ -- (e.g. in proto-lens-runtime).+ -Wunused-packages++ if flag(snappy)+ cpp-options: -DSNAPPY++library+ import: lang+ hs-source-dirs: src, proto++ exposed-modules:+ Network.GRPC.Spec+ Network.GRPC.Spec.Serialization+ Network.GRPC.Spec.Util.HKD+ Network.GRPC.Spec.Util.Parser+ other-modules:+ Network.GRPC.Spec.Call+ Network.GRPC.Spec.Compression+ Network.GRPC.Spec.CustomMetadata.Map+ Network.GRPC.Spec.CustomMetadata.NoMetadata+ Network.GRPC.Spec.CustomMetadata.Raw+ Network.GRPC.Spec.CustomMetadata.Typed+ Network.GRPC.Spec.Headers.Common+ Network.GRPC.Spec.Headers.Invalid+ Network.GRPC.Spec.Headers.PseudoHeaders+ Network.GRPC.Spec.Headers.Request+ Network.GRPC.Spec.Headers.Response+ Network.GRPC.Spec.MessageMeta+ Network.GRPC.Spec.OrcaLoadReport+ Network.GRPC.Spec.PercentEncoding+ Network.GRPC.Spec.RPC+ Network.GRPC.Spec.RPC.JSON+ Network.GRPC.Spec.RPC.Protobuf+ Network.GRPC.Spec.RPC.Raw+ Network.GRPC.Spec.RPC.StreamType+ Network.GRPC.Spec.Serialization.Base64+ Network.GRPC.Spec.Serialization.CustomMetadata+ Network.GRPC.Spec.Serialization.Headers.Common+ Network.GRPC.Spec.Serialization.Headers.PseudoHeaders+ Network.GRPC.Spec.Serialization.Headers.Request+ Network.GRPC.Spec.Serialization.Headers.Response+ Network.GRPC.Spec.Serialization.LengthPrefixed+ Network.GRPC.Spec.Serialization.Status+ Network.GRPC.Spec.Serialization.Timeout+ Network.GRPC.Spec.Serialization.TraceContext+ Network.GRPC.Spec.Status+ Network.GRPC.Spec.Timeout+ Network.GRPC.Spec.TraceContext+ Network.GRPC.Spec.Util.ByteString+ Network.GRPC.Spec.Util.Protobuf++ Proto.OrcaLoadReport+ Proto.Status+ build-depends:+ , aeson >= 1.5 && < 2.3+ , base16-bytestring >= 1.0 && < 1.1+ , base64-bytestring >= 1.2 && < 1.3+ , binary >= 0.8 && < 0.9+ , bytestring >= 0.10.12 && < 0.13+ , case-insensitive >= 1.2 && < 1.3+ , containers >= 0.6 && < 0.8+ , data-default >= 0.7 && < 0.9+ , deepseq >= 1.4 && < 1.6+ , exceptions >= 0.10 && < 0.11+ , hashable >= 1.3 && < 1.6+ , 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+ , proto-lens-protobuf-types >= 0.7 && < 0.8+ , proto-lens-runtime >= 0.7 && < 0.8+ , record-hasfield >= 1.0 && < 1.1+ , text >= 1.2 && < 2.2+ , utf8-string >= 1.0 && < 1.1+ , vector >= 0.13 && < 0.14+ , zlib >= 0.6 && < 0.8++ -- Snappy can be a bit tricky to install on some systems, so we make it an+ -- optional dependency. Snappy support can be explicitly disabled by clearing+ -- the @snappy@ flag manually+ --+ -- > package grpc-spec+ -- > flags: -snappy+ --+ -- or by setting an unsatisfiable constraint on @snappy-c@+ --+ -- > constraints: snappy-c<0+ --+ -- It can be explicitly /enabled/ by setting the @snappy@ flag manually.+ if flag(snappy)+ build-depends:+ , snappy-c >= 0.1 && < 0.2++test-suite test-grpc-spec+ import: lang+ type: exitcode-stdio-1.0+ hs-source-dirs: test-grpc-spec+ main-is: Main.hs+ build-depends: grpc-spec++ other-modules:+ Test.Prop.IncrementalParsing+ Test.Prop.Serialization+ Test.Util.Awkward+ Test.Util.Orphans+ Test.Util.Protobuf++ build-depends:+ -- Inherited dependencies+ , base64-bytestring+ , bytestring+ , case-insensitive+ , containers+ , http-types+ , lens+ , mtl+ , proto-lens+ , text++ build-depends:+ -- Additional dependencies+ , prettyprinter >= 1.7 && < 1.8+ , prettyprinter-ansi-terminal >= 1.1 && < 1.2+ , QuickCheck >= 2.14 && < 2.16+ , quickcheck-instances >= 0.3 && < 0.4+ , tasty >= 1.4 && < 1.6+ , tasty-quickcheck >= 0.10 && < 0.12+ , tree-diff >= 0.3 && < 0.4++Flag snappy+ description: Enable snappy compression capabilities+ default: True+ manual: False
+ proto/Proto/OrcaLoadReport.hs view
@@ -0,0 +1,1171 @@+{-# OPTIONS_GHC -Wno-prepositive-qualified-module -Wno-identities #-}+{- This file was auto-generated from orca_load_report.proto by the proto-lens-protoc program. -}+{-# LANGUAGE ScopedTypeVariables, DataKinds, TypeFamilies, UndecidableInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, PatternSynonyms, MagicHash, NoImplicitPrelude, DataKinds, BangPatterns, TypeApplications, OverloadedStrings, DerivingStrategies#-}+{-# OPTIONS_GHC -Wno-unused-imports#-}+{-# OPTIONS_GHC -Wno-duplicate-exports#-}+{-# OPTIONS_GHC -Wno-dodgy-exports#-}+module Proto.OrcaLoadReport (+ OrcaLoadReport(), OrcaLoadReport'NamedMetricsEntry(),+ OrcaLoadReport'RequestCostEntry(),+ OrcaLoadReport'UtilizationEntry()+ ) where+import qualified Data.ProtoLens.Runtime.Control.DeepSeq as Control.DeepSeq+import qualified Data.ProtoLens.Runtime.Data.ProtoLens.Prism as Data.ProtoLens.Prism+import qualified Data.ProtoLens.Runtime.Prelude as Prelude+import qualified Data.ProtoLens.Runtime.Data.Int as Data.Int+import qualified Data.ProtoLens.Runtime.Data.Monoid as Data.Monoid+import qualified Data.ProtoLens.Runtime.Data.Word as Data.Word+import qualified Data.ProtoLens.Runtime.Data.ProtoLens as Data.ProtoLens+import qualified Data.ProtoLens.Runtime.Data.ProtoLens.Encoding.Bytes as Data.ProtoLens.Encoding.Bytes+import qualified Data.ProtoLens.Runtime.Data.ProtoLens.Encoding.Growing as Data.ProtoLens.Encoding.Growing+import qualified Data.ProtoLens.Runtime.Data.ProtoLens.Encoding.Parser.Unsafe as Data.ProtoLens.Encoding.Parser.Unsafe+import qualified Data.ProtoLens.Runtime.Data.ProtoLens.Encoding.Wire as Data.ProtoLens.Encoding.Wire+import qualified Data.ProtoLens.Runtime.Data.ProtoLens.Field as Data.ProtoLens.Field+import qualified Data.ProtoLens.Runtime.Data.ProtoLens.Message.Enum as Data.ProtoLens.Message.Enum+import qualified Data.ProtoLens.Runtime.Data.ProtoLens.Service.Types as Data.ProtoLens.Service.Types+import qualified Data.ProtoLens.Runtime.Lens.Family2 as Lens.Family2+import qualified Data.ProtoLens.Runtime.Lens.Family2.Unchecked as Lens.Family2.Unchecked+import qualified Data.ProtoLens.Runtime.Data.Text as Data.Text+import qualified Data.ProtoLens.Runtime.Data.Map as Data.Map+import qualified Data.ProtoLens.Runtime.Data.ByteString as Data.ByteString+import qualified Data.ProtoLens.Runtime.Data.ByteString.Char8 as Data.ByteString.Char8+import qualified Data.ProtoLens.Runtime.Data.Text.Encoding as Data.Text.Encoding+import qualified Data.ProtoLens.Runtime.Data.Vector as Data.Vector+import qualified Data.ProtoLens.Runtime.Data.Vector.Generic as Data.Vector.Generic+import qualified Data.ProtoLens.Runtime.Data.Vector.Unboxed as Data.Vector.Unboxed+import qualified Data.ProtoLens.Runtime.Text.Read as Text.Read+{- | Fields :+ + * 'Proto.OrcaLoadReport_Fields.cpuUtilization' @:: Lens' OrcaLoadReport Prelude.Double@+ * 'Proto.OrcaLoadReport_Fields.memUtilization' @:: Lens' OrcaLoadReport Prelude.Double@+ * 'Proto.OrcaLoadReport_Fields.rps' @:: Lens' OrcaLoadReport Data.Word.Word64@+ * 'Proto.OrcaLoadReport_Fields.requestCost' @:: Lens' OrcaLoadReport (Data.Map.Map Data.Text.Text Prelude.Double)@+ * 'Proto.OrcaLoadReport_Fields.utilization' @:: Lens' OrcaLoadReport (Data.Map.Map Data.Text.Text Prelude.Double)@+ * 'Proto.OrcaLoadReport_Fields.rpsFractional' @:: Lens' OrcaLoadReport Prelude.Double@+ * 'Proto.OrcaLoadReport_Fields.eps' @:: Lens' OrcaLoadReport Prelude.Double@+ * 'Proto.OrcaLoadReport_Fields.namedMetrics' @:: Lens' OrcaLoadReport (Data.Map.Map Data.Text.Text Prelude.Double)@+ * 'Proto.OrcaLoadReport_Fields.applicationUtilization' @:: Lens' OrcaLoadReport Prelude.Double@ -}+data OrcaLoadReport+ = OrcaLoadReport'_constructor {_OrcaLoadReport'cpuUtilization :: !Prelude.Double,+ _OrcaLoadReport'memUtilization :: !Prelude.Double,+ _OrcaLoadReport'rps :: !Data.Word.Word64,+ _OrcaLoadReport'requestCost :: !(Data.Map.Map Data.Text.Text Prelude.Double),+ _OrcaLoadReport'utilization :: !(Data.Map.Map Data.Text.Text Prelude.Double),+ _OrcaLoadReport'rpsFractional :: !Prelude.Double,+ _OrcaLoadReport'eps :: !Prelude.Double,+ _OrcaLoadReport'namedMetrics :: !(Data.Map.Map Data.Text.Text Prelude.Double),+ _OrcaLoadReport'applicationUtilization :: !Prelude.Double,+ _OrcaLoadReport'_unknownFields :: !Data.ProtoLens.FieldSet}+ deriving stock (Prelude.Eq, Prelude.Ord)+instance Prelude.Show OrcaLoadReport where+ showsPrec _ __x __s+ = Prelude.showChar+ '{'+ (Prelude.showString+ (Data.ProtoLens.showMessageShort __x) (Prelude.showChar '}' __s))+instance Data.ProtoLens.Field.HasField OrcaLoadReport "cpuUtilization" Prelude.Double where+ fieldOf _+ = (Prelude..)+ (Lens.Family2.Unchecked.lens+ _OrcaLoadReport'cpuUtilization+ (\ x__ y__ -> x__ {_OrcaLoadReport'cpuUtilization = y__}))+ Prelude.id+instance Data.ProtoLens.Field.HasField OrcaLoadReport "memUtilization" Prelude.Double where+ fieldOf _+ = (Prelude..)+ (Lens.Family2.Unchecked.lens+ _OrcaLoadReport'memUtilization+ (\ x__ y__ -> x__ {_OrcaLoadReport'memUtilization = y__}))+ Prelude.id+instance Data.ProtoLens.Field.HasField OrcaLoadReport "rps" Data.Word.Word64 where+ fieldOf _+ = (Prelude..)+ (Lens.Family2.Unchecked.lens+ _OrcaLoadReport'rps (\ x__ y__ -> x__ {_OrcaLoadReport'rps = y__}))+ Prelude.id+instance Data.ProtoLens.Field.HasField OrcaLoadReport "requestCost" (Data.Map.Map Data.Text.Text Prelude.Double) where+ fieldOf _+ = (Prelude..)+ (Lens.Family2.Unchecked.lens+ _OrcaLoadReport'requestCost+ (\ x__ y__ -> x__ {_OrcaLoadReport'requestCost = y__}))+ Prelude.id+instance Data.ProtoLens.Field.HasField OrcaLoadReport "utilization" (Data.Map.Map Data.Text.Text Prelude.Double) where+ fieldOf _+ = (Prelude..)+ (Lens.Family2.Unchecked.lens+ _OrcaLoadReport'utilization+ (\ x__ y__ -> x__ {_OrcaLoadReport'utilization = y__}))+ Prelude.id+instance Data.ProtoLens.Field.HasField OrcaLoadReport "rpsFractional" Prelude.Double where+ fieldOf _+ = (Prelude..)+ (Lens.Family2.Unchecked.lens+ _OrcaLoadReport'rpsFractional+ (\ x__ y__ -> x__ {_OrcaLoadReport'rpsFractional = y__}))+ Prelude.id+instance Data.ProtoLens.Field.HasField OrcaLoadReport "eps" Prelude.Double where+ fieldOf _+ = (Prelude..)+ (Lens.Family2.Unchecked.lens+ _OrcaLoadReport'eps (\ x__ y__ -> x__ {_OrcaLoadReport'eps = y__}))+ Prelude.id+instance Data.ProtoLens.Field.HasField OrcaLoadReport "namedMetrics" (Data.Map.Map Data.Text.Text Prelude.Double) where+ fieldOf _+ = (Prelude..)+ (Lens.Family2.Unchecked.lens+ _OrcaLoadReport'namedMetrics+ (\ x__ y__ -> x__ {_OrcaLoadReport'namedMetrics = y__}))+ Prelude.id+instance Data.ProtoLens.Field.HasField OrcaLoadReport "applicationUtilization" Prelude.Double where+ fieldOf _+ = (Prelude..)+ (Lens.Family2.Unchecked.lens+ _OrcaLoadReport'applicationUtilization+ (\ x__ y__ -> x__ {_OrcaLoadReport'applicationUtilization = y__}))+ Prelude.id+instance Data.ProtoLens.Message OrcaLoadReport where+ messageName _ = Data.Text.pack "xds.data.orca.v3.OrcaLoadReport"+ packedMessageDescriptor _+ = "\n\+ \\SOOrcaLoadReport\DC2'\n\+ \\SIcpu_utilization\CAN\SOH \SOH(\SOHR\SOcpuUtilization\DC2'\n\+ \\SImem_utilization\CAN\STX \SOH(\SOHR\SOmemUtilization\DC2\DC4\n\+ \\ETXrps\CAN\ETX \SOH(\EOTR\ETXrpsB\STX\CAN\SOH\DC2T\n\+ \\frequest_cost\CAN\EOT \ETX(\v21.xds.data.orca.v3.OrcaLoadReport.RequestCostEntryR\vrequestCost\DC2S\n\+ \\vutilization\CAN\ENQ \ETX(\v21.xds.data.orca.v3.OrcaLoadReport.UtilizationEntryR\vutilization\DC2%\n\+ \\SOrps_fractional\CAN\ACK \SOH(\SOHR\rrpsFractional\DC2\DLE\n\+ \\ETXeps\CAN\a \SOH(\SOHR\ETXeps\DC2W\n\+ \\rnamed_metrics\CAN\b \ETX(\v22.xds.data.orca.v3.OrcaLoadReport.NamedMetricsEntryR\fnamedMetrics\DC27\n\+ \\ETBapplication_utilization\CAN\t \SOH(\SOHR\SYNapplicationUtilization\SUB>\n\+ \\DLERequestCostEntry\DC2\DLE\n\+ \\ETXkey\CAN\SOH \SOH(\tR\ETXkey\DC2\DC4\n\+ \\ENQvalue\CAN\STX \SOH(\SOHR\ENQvalue:\STX8\SOH\SUB>\n\+ \\DLEUtilizationEntry\DC2\DLE\n\+ \\ETXkey\CAN\SOH \SOH(\tR\ETXkey\DC2\DC4\n\+ \\ENQvalue\CAN\STX \SOH(\SOHR\ENQvalue:\STX8\SOH\SUB?\n\+ \\DC1NamedMetricsEntry\DC2\DLE\n\+ \\ETXkey\CAN\SOH \SOH(\tR\ETXkey\DC2\DC4\n\+ \\ENQvalue\CAN\STX \SOH(\SOHR\ENQvalue:\STX8\SOH"+ packedFileDescriptor _ = packedFileDescriptor+ fieldsByTag+ = let+ cpuUtilization__field_descriptor+ = Data.ProtoLens.FieldDescriptor+ "cpu_utilization"+ (Data.ProtoLens.ScalarField Data.ProtoLens.DoubleField ::+ Data.ProtoLens.FieldTypeDescriptor Prelude.Double)+ (Data.ProtoLens.PlainField+ Data.ProtoLens.Optional+ (Data.ProtoLens.Field.field @"cpuUtilization")) ::+ Data.ProtoLens.FieldDescriptor OrcaLoadReport+ memUtilization__field_descriptor+ = Data.ProtoLens.FieldDescriptor+ "mem_utilization"+ (Data.ProtoLens.ScalarField Data.ProtoLens.DoubleField ::+ Data.ProtoLens.FieldTypeDescriptor Prelude.Double)+ (Data.ProtoLens.PlainField+ Data.ProtoLens.Optional+ (Data.ProtoLens.Field.field @"memUtilization")) ::+ Data.ProtoLens.FieldDescriptor OrcaLoadReport+ rps__field_descriptor+ = Data.ProtoLens.FieldDescriptor+ "rps"+ (Data.ProtoLens.ScalarField Data.ProtoLens.UInt64Field ::+ Data.ProtoLens.FieldTypeDescriptor Data.Word.Word64)+ (Data.ProtoLens.PlainField+ Data.ProtoLens.Optional (Data.ProtoLens.Field.field @"rps")) ::+ Data.ProtoLens.FieldDescriptor OrcaLoadReport+ requestCost__field_descriptor+ = Data.ProtoLens.FieldDescriptor+ "request_cost"+ (Data.ProtoLens.MessageField Data.ProtoLens.MessageType ::+ Data.ProtoLens.FieldTypeDescriptor OrcaLoadReport'RequestCostEntry)+ (Data.ProtoLens.MapField+ (Data.ProtoLens.Field.field @"key")+ (Data.ProtoLens.Field.field @"value")+ (Data.ProtoLens.Field.field @"requestCost")) ::+ Data.ProtoLens.FieldDescriptor OrcaLoadReport+ utilization__field_descriptor+ = Data.ProtoLens.FieldDescriptor+ "utilization"+ (Data.ProtoLens.MessageField Data.ProtoLens.MessageType ::+ Data.ProtoLens.FieldTypeDescriptor OrcaLoadReport'UtilizationEntry)+ (Data.ProtoLens.MapField+ (Data.ProtoLens.Field.field @"key")+ (Data.ProtoLens.Field.field @"value")+ (Data.ProtoLens.Field.field @"utilization")) ::+ Data.ProtoLens.FieldDescriptor OrcaLoadReport+ rpsFractional__field_descriptor+ = Data.ProtoLens.FieldDescriptor+ "rps_fractional"+ (Data.ProtoLens.ScalarField Data.ProtoLens.DoubleField ::+ Data.ProtoLens.FieldTypeDescriptor Prelude.Double)+ (Data.ProtoLens.PlainField+ Data.ProtoLens.Optional+ (Data.ProtoLens.Field.field @"rpsFractional")) ::+ Data.ProtoLens.FieldDescriptor OrcaLoadReport+ eps__field_descriptor+ = Data.ProtoLens.FieldDescriptor+ "eps"+ (Data.ProtoLens.ScalarField Data.ProtoLens.DoubleField ::+ Data.ProtoLens.FieldTypeDescriptor Prelude.Double)+ (Data.ProtoLens.PlainField+ Data.ProtoLens.Optional (Data.ProtoLens.Field.field @"eps")) ::+ Data.ProtoLens.FieldDescriptor OrcaLoadReport+ namedMetrics__field_descriptor+ = Data.ProtoLens.FieldDescriptor+ "named_metrics"+ (Data.ProtoLens.MessageField Data.ProtoLens.MessageType ::+ Data.ProtoLens.FieldTypeDescriptor OrcaLoadReport'NamedMetricsEntry)+ (Data.ProtoLens.MapField+ (Data.ProtoLens.Field.field @"key")+ (Data.ProtoLens.Field.field @"value")+ (Data.ProtoLens.Field.field @"namedMetrics")) ::+ Data.ProtoLens.FieldDescriptor OrcaLoadReport+ applicationUtilization__field_descriptor+ = Data.ProtoLens.FieldDescriptor+ "application_utilization"+ (Data.ProtoLens.ScalarField Data.ProtoLens.DoubleField ::+ Data.ProtoLens.FieldTypeDescriptor Prelude.Double)+ (Data.ProtoLens.PlainField+ Data.ProtoLens.Optional+ (Data.ProtoLens.Field.field @"applicationUtilization")) ::+ Data.ProtoLens.FieldDescriptor OrcaLoadReport+ in+ Data.Map.fromList+ [(Data.ProtoLens.Tag 1, cpuUtilization__field_descriptor),+ (Data.ProtoLens.Tag 2, memUtilization__field_descriptor),+ (Data.ProtoLens.Tag 3, rps__field_descriptor),+ (Data.ProtoLens.Tag 4, requestCost__field_descriptor),+ (Data.ProtoLens.Tag 5, utilization__field_descriptor),+ (Data.ProtoLens.Tag 6, rpsFractional__field_descriptor),+ (Data.ProtoLens.Tag 7, eps__field_descriptor),+ (Data.ProtoLens.Tag 8, namedMetrics__field_descriptor),+ (Data.ProtoLens.Tag 9, applicationUtilization__field_descriptor)]+ unknownFields+ = Lens.Family2.Unchecked.lens+ _OrcaLoadReport'_unknownFields+ (\ x__ y__ -> x__ {_OrcaLoadReport'_unknownFields = y__})+ defMessage+ = OrcaLoadReport'_constructor+ {_OrcaLoadReport'cpuUtilization = Data.ProtoLens.fieldDefault,+ _OrcaLoadReport'memUtilization = Data.ProtoLens.fieldDefault,+ _OrcaLoadReport'rps = Data.ProtoLens.fieldDefault,+ _OrcaLoadReport'requestCost = Data.Map.empty,+ _OrcaLoadReport'utilization = Data.Map.empty,+ _OrcaLoadReport'rpsFractional = Data.ProtoLens.fieldDefault,+ _OrcaLoadReport'eps = Data.ProtoLens.fieldDefault,+ _OrcaLoadReport'namedMetrics = Data.Map.empty,+ _OrcaLoadReport'applicationUtilization = Data.ProtoLens.fieldDefault,+ _OrcaLoadReport'_unknownFields = []}+ parseMessage+ = let+ loop ::+ OrcaLoadReport+ -> Data.ProtoLens.Encoding.Bytes.Parser OrcaLoadReport+ loop x+ = do end <- Data.ProtoLens.Encoding.Bytes.atEnd+ if end then+ do (let missing = []+ in+ if Prelude.null missing then+ Prelude.return ()+ else+ Prelude.fail+ ((Prelude.++)+ "Missing required fields: "+ (Prelude.show (missing :: [Prelude.String]))))+ Prelude.return+ (Lens.Family2.over+ Data.ProtoLens.unknownFields (\ !t -> Prelude.reverse t) x)+ else+ do tag <- Data.ProtoLens.Encoding.Bytes.getVarInt+ case tag of+ 9 -> do y <- (Data.ProtoLens.Encoding.Bytes.<?>)+ (Prelude.fmap+ Data.ProtoLens.Encoding.Bytes.wordToDouble+ Data.ProtoLens.Encoding.Bytes.getFixed64)+ "cpu_utilization"+ loop+ (Lens.Family2.set+ (Data.ProtoLens.Field.field @"cpuUtilization") y x)+ 17+ -> do y <- (Data.ProtoLens.Encoding.Bytes.<?>)+ (Prelude.fmap+ Data.ProtoLens.Encoding.Bytes.wordToDouble+ Data.ProtoLens.Encoding.Bytes.getFixed64)+ "mem_utilization"+ loop+ (Lens.Family2.set+ (Data.ProtoLens.Field.field @"memUtilization") y x)+ 24+ -> do y <- (Data.ProtoLens.Encoding.Bytes.<?>)+ Data.ProtoLens.Encoding.Bytes.getVarInt "rps"+ loop (Lens.Family2.set (Data.ProtoLens.Field.field @"rps") y x)+ 34+ -> do !(entry :: OrcaLoadReport'RequestCostEntry) <- (Data.ProtoLens.Encoding.Bytes.<?>)+ (do len <- Data.ProtoLens.Encoding.Bytes.getVarInt+ Data.ProtoLens.Encoding.Bytes.isolate+ (Prelude.fromIntegral+ len)+ Data.ProtoLens.parseMessage)+ "request_cost"+ (let+ key = Lens.Family2.view (Data.ProtoLens.Field.field @"key") entry+ value+ = Lens.Family2.view (Data.ProtoLens.Field.field @"value") entry+ in+ loop+ (Lens.Family2.over+ (Data.ProtoLens.Field.field @"requestCost")+ (\ !t -> Data.Map.insert key value t) x))+ 42+ -> do !(entry :: OrcaLoadReport'UtilizationEntry) <- (Data.ProtoLens.Encoding.Bytes.<?>)+ (do len <- Data.ProtoLens.Encoding.Bytes.getVarInt+ Data.ProtoLens.Encoding.Bytes.isolate+ (Prelude.fromIntegral+ len)+ Data.ProtoLens.parseMessage)+ "utilization"+ (let+ key = Lens.Family2.view (Data.ProtoLens.Field.field @"key") entry+ value+ = Lens.Family2.view (Data.ProtoLens.Field.field @"value") entry+ in+ loop+ (Lens.Family2.over+ (Data.ProtoLens.Field.field @"utilization")+ (\ !t -> Data.Map.insert key value t) x))+ 49+ -> do y <- (Data.ProtoLens.Encoding.Bytes.<?>)+ (Prelude.fmap+ Data.ProtoLens.Encoding.Bytes.wordToDouble+ Data.ProtoLens.Encoding.Bytes.getFixed64)+ "rps_fractional"+ loop+ (Lens.Family2.set+ (Data.ProtoLens.Field.field @"rpsFractional") y x)+ 57+ -> do y <- (Data.ProtoLens.Encoding.Bytes.<?>)+ (Prelude.fmap+ Data.ProtoLens.Encoding.Bytes.wordToDouble+ Data.ProtoLens.Encoding.Bytes.getFixed64)+ "eps"+ loop (Lens.Family2.set (Data.ProtoLens.Field.field @"eps") y x)+ 66+ -> do !(entry :: OrcaLoadReport'NamedMetricsEntry) <- (Data.ProtoLens.Encoding.Bytes.<?>)+ (do len <- Data.ProtoLens.Encoding.Bytes.getVarInt+ Data.ProtoLens.Encoding.Bytes.isolate+ (Prelude.fromIntegral+ len)+ Data.ProtoLens.parseMessage)+ "named_metrics"+ (let+ key = Lens.Family2.view (Data.ProtoLens.Field.field @"key") entry+ value+ = Lens.Family2.view (Data.ProtoLens.Field.field @"value") entry+ in+ loop+ (Lens.Family2.over+ (Data.ProtoLens.Field.field @"namedMetrics")+ (\ !t -> Data.Map.insert key value t) x))+ 73+ -> do y <- (Data.ProtoLens.Encoding.Bytes.<?>)+ (Prelude.fmap+ Data.ProtoLens.Encoding.Bytes.wordToDouble+ Data.ProtoLens.Encoding.Bytes.getFixed64)+ "application_utilization"+ loop+ (Lens.Family2.set+ (Data.ProtoLens.Field.field @"applicationUtilization") y x)+ wire+ -> do !y <- Data.ProtoLens.Encoding.Wire.parseTaggedValueFromWire+ wire+ loop+ (Lens.Family2.over+ Data.ProtoLens.unknownFields (\ !t -> (:) y t) x)+ in+ (Data.ProtoLens.Encoding.Bytes.<?>)+ (do loop Data.ProtoLens.defMessage) "OrcaLoadReport"+ buildMessage+ = \ _x+ -> (Data.Monoid.<>)+ (let+ _v+ = Lens.Family2.view+ (Data.ProtoLens.Field.field @"cpuUtilization") _x+ in+ if (Prelude.==) _v Data.ProtoLens.fieldDefault then+ Data.Monoid.mempty+ else+ (Data.Monoid.<>)+ (Data.ProtoLens.Encoding.Bytes.putVarInt 9)+ ((Prelude..)+ Data.ProtoLens.Encoding.Bytes.putFixed64+ Data.ProtoLens.Encoding.Bytes.doubleToWord _v))+ ((Data.Monoid.<>)+ (let+ _v+ = Lens.Family2.view+ (Data.ProtoLens.Field.field @"memUtilization") _x+ in+ if (Prelude.==) _v Data.ProtoLens.fieldDefault then+ Data.Monoid.mempty+ else+ (Data.Monoid.<>)+ (Data.ProtoLens.Encoding.Bytes.putVarInt 17)+ ((Prelude..)+ Data.ProtoLens.Encoding.Bytes.putFixed64+ Data.ProtoLens.Encoding.Bytes.doubleToWord _v))+ ((Data.Monoid.<>)+ (let _v = Lens.Family2.view (Data.ProtoLens.Field.field @"rps") _x+ in+ if (Prelude.==) _v Data.ProtoLens.fieldDefault then+ Data.Monoid.mempty+ else+ (Data.Monoid.<>)+ (Data.ProtoLens.Encoding.Bytes.putVarInt 24)+ (Data.ProtoLens.Encoding.Bytes.putVarInt _v))+ ((Data.Monoid.<>)+ (Data.Monoid.mconcat+ (Prelude.map+ (\ _v+ -> (Data.Monoid.<>)+ (Data.ProtoLens.Encoding.Bytes.putVarInt 34)+ ((Prelude..)+ (\ bs+ -> (Data.Monoid.<>)+ (Data.ProtoLens.Encoding.Bytes.putVarInt+ (Prelude.fromIntegral+ (Data.ByteString.length bs)))+ (Data.ProtoLens.Encoding.Bytes.putBytes bs))+ Data.ProtoLens.encodeMessage+ (Lens.Family2.set+ (Data.ProtoLens.Field.field @"key") (Prelude.fst _v)+ (Lens.Family2.set+ (Data.ProtoLens.Field.field @"value") (Prelude.snd _v)+ (Data.ProtoLens.defMessage ::+ OrcaLoadReport'RequestCostEntry)))))+ (Data.Map.toList+ (Lens.Family2.view+ (Data.ProtoLens.Field.field @"requestCost") _x))))+ ((Data.Monoid.<>)+ (Data.Monoid.mconcat+ (Prelude.map+ (\ _v+ -> (Data.Monoid.<>)+ (Data.ProtoLens.Encoding.Bytes.putVarInt 42)+ ((Prelude..)+ (\ bs+ -> (Data.Monoid.<>)+ (Data.ProtoLens.Encoding.Bytes.putVarInt+ (Prelude.fromIntegral+ (Data.ByteString.length bs)))+ (Data.ProtoLens.Encoding.Bytes.putBytes bs))+ Data.ProtoLens.encodeMessage+ (Lens.Family2.set+ (Data.ProtoLens.Field.field @"key") (Prelude.fst _v)+ (Lens.Family2.set+ (Data.ProtoLens.Field.field @"value")+ (Prelude.snd _v)+ (Data.ProtoLens.defMessage ::+ OrcaLoadReport'UtilizationEntry)))))+ (Data.Map.toList+ (Lens.Family2.view+ (Data.ProtoLens.Field.field @"utilization") _x))))+ ((Data.Monoid.<>)+ (let+ _v+ = Lens.Family2.view+ (Data.ProtoLens.Field.field @"rpsFractional") _x+ in+ if (Prelude.==) _v Data.ProtoLens.fieldDefault then+ Data.Monoid.mempty+ else+ (Data.Monoid.<>)+ (Data.ProtoLens.Encoding.Bytes.putVarInt 49)+ ((Prelude..)+ Data.ProtoLens.Encoding.Bytes.putFixed64+ Data.ProtoLens.Encoding.Bytes.doubleToWord _v))+ ((Data.Monoid.<>)+ (let _v = Lens.Family2.view (Data.ProtoLens.Field.field @"eps") _x+ in+ if (Prelude.==) _v Data.ProtoLens.fieldDefault then+ Data.Monoid.mempty+ else+ (Data.Monoid.<>)+ (Data.ProtoLens.Encoding.Bytes.putVarInt 57)+ ((Prelude..)+ Data.ProtoLens.Encoding.Bytes.putFixed64+ Data.ProtoLens.Encoding.Bytes.doubleToWord _v))+ ((Data.Monoid.<>)+ (Data.Monoid.mconcat+ (Prelude.map+ (\ _v+ -> (Data.Monoid.<>)+ (Data.ProtoLens.Encoding.Bytes.putVarInt 66)+ ((Prelude..)+ (\ bs+ -> (Data.Monoid.<>)+ (Data.ProtoLens.Encoding.Bytes.putVarInt+ (Prelude.fromIntegral+ (Data.ByteString.length bs)))+ (Data.ProtoLens.Encoding.Bytes.putBytes+ bs))+ Data.ProtoLens.encodeMessage+ (Lens.Family2.set+ (Data.ProtoLens.Field.field @"key")+ (Prelude.fst _v)+ (Lens.Family2.set+ (Data.ProtoLens.Field.field @"value")+ (Prelude.snd _v)+ (Data.ProtoLens.defMessage ::+ OrcaLoadReport'NamedMetricsEntry)))))+ (Data.Map.toList+ (Lens.Family2.view+ (Data.ProtoLens.Field.field @"namedMetrics") _x))))+ ((Data.Monoid.<>)+ (let+ _v+ = Lens.Family2.view+ (Data.ProtoLens.Field.field @"applicationUtilization")+ _x+ in+ if (Prelude.==) _v Data.ProtoLens.fieldDefault then+ Data.Monoid.mempty+ else+ (Data.Monoid.<>)+ (Data.ProtoLens.Encoding.Bytes.putVarInt 73)+ ((Prelude..)+ Data.ProtoLens.Encoding.Bytes.putFixed64+ Data.ProtoLens.Encoding.Bytes.doubleToWord _v))+ (Data.ProtoLens.Encoding.Wire.buildFieldSet+ (Lens.Family2.view Data.ProtoLens.unknownFields _x))))))))))+instance Control.DeepSeq.NFData OrcaLoadReport where+ rnf+ = \ x__+ -> Control.DeepSeq.deepseq+ (_OrcaLoadReport'_unknownFields x__)+ (Control.DeepSeq.deepseq+ (_OrcaLoadReport'cpuUtilization x__)+ (Control.DeepSeq.deepseq+ (_OrcaLoadReport'memUtilization x__)+ (Control.DeepSeq.deepseq+ (_OrcaLoadReport'rps x__)+ (Control.DeepSeq.deepseq+ (_OrcaLoadReport'requestCost x__)+ (Control.DeepSeq.deepseq+ (_OrcaLoadReport'utilization x__)+ (Control.DeepSeq.deepseq+ (_OrcaLoadReport'rpsFractional x__)+ (Control.DeepSeq.deepseq+ (_OrcaLoadReport'eps x__)+ (Control.DeepSeq.deepseq+ (_OrcaLoadReport'namedMetrics x__)+ (Control.DeepSeq.deepseq+ (_OrcaLoadReport'applicationUtilization x__) ())))))))))+{- | Fields :+ + * 'Proto.OrcaLoadReport_Fields.key' @:: Lens' OrcaLoadReport'NamedMetricsEntry Data.Text.Text@+ * 'Proto.OrcaLoadReport_Fields.value' @:: Lens' OrcaLoadReport'NamedMetricsEntry Prelude.Double@ -}+data OrcaLoadReport'NamedMetricsEntry+ = OrcaLoadReport'NamedMetricsEntry'_constructor {_OrcaLoadReport'NamedMetricsEntry'key :: !Data.Text.Text,+ _OrcaLoadReport'NamedMetricsEntry'value :: !Prelude.Double,+ _OrcaLoadReport'NamedMetricsEntry'_unknownFields :: !Data.ProtoLens.FieldSet}+ deriving stock (Prelude.Eq, Prelude.Ord)+instance Prelude.Show OrcaLoadReport'NamedMetricsEntry where+ showsPrec _ __x __s+ = Prelude.showChar+ '{'+ (Prelude.showString+ (Data.ProtoLens.showMessageShort __x) (Prelude.showChar '}' __s))+instance Data.ProtoLens.Field.HasField OrcaLoadReport'NamedMetricsEntry "key" Data.Text.Text where+ fieldOf _+ = (Prelude..)+ (Lens.Family2.Unchecked.lens+ _OrcaLoadReport'NamedMetricsEntry'key+ (\ x__ y__ -> x__ {_OrcaLoadReport'NamedMetricsEntry'key = y__}))+ Prelude.id+instance Data.ProtoLens.Field.HasField OrcaLoadReport'NamedMetricsEntry "value" Prelude.Double where+ fieldOf _+ = (Prelude..)+ (Lens.Family2.Unchecked.lens+ _OrcaLoadReport'NamedMetricsEntry'value+ (\ x__ y__ -> x__ {_OrcaLoadReport'NamedMetricsEntry'value = y__}))+ Prelude.id+instance Data.ProtoLens.Message OrcaLoadReport'NamedMetricsEntry where+ messageName _+ = Data.Text.pack+ "xds.data.orca.v3.OrcaLoadReport.NamedMetricsEntry"+ packedMessageDescriptor _+ = "\n\+ \\DC1NamedMetricsEntry\DC2\DLE\n\+ \\ETXkey\CAN\SOH \SOH(\tR\ETXkey\DC2\DC4\n\+ \\ENQvalue\CAN\STX \SOH(\SOHR\ENQvalue:\STX8\SOH"+ packedFileDescriptor _ = packedFileDescriptor+ fieldsByTag+ = let+ key__field_descriptor+ = Data.ProtoLens.FieldDescriptor+ "key"+ (Data.ProtoLens.ScalarField Data.ProtoLens.StringField ::+ Data.ProtoLens.FieldTypeDescriptor Data.Text.Text)+ (Data.ProtoLens.PlainField+ Data.ProtoLens.Optional (Data.ProtoLens.Field.field @"key")) ::+ Data.ProtoLens.FieldDescriptor OrcaLoadReport'NamedMetricsEntry+ value__field_descriptor+ = Data.ProtoLens.FieldDescriptor+ "value"+ (Data.ProtoLens.ScalarField Data.ProtoLens.DoubleField ::+ Data.ProtoLens.FieldTypeDescriptor Prelude.Double)+ (Data.ProtoLens.PlainField+ Data.ProtoLens.Optional (Data.ProtoLens.Field.field @"value")) ::+ Data.ProtoLens.FieldDescriptor OrcaLoadReport'NamedMetricsEntry+ in+ Data.Map.fromList+ [(Data.ProtoLens.Tag 1, key__field_descriptor),+ (Data.ProtoLens.Tag 2, value__field_descriptor)]+ unknownFields+ = Lens.Family2.Unchecked.lens+ _OrcaLoadReport'NamedMetricsEntry'_unknownFields+ (\ x__ y__+ -> x__ {_OrcaLoadReport'NamedMetricsEntry'_unknownFields = y__})+ defMessage+ = OrcaLoadReport'NamedMetricsEntry'_constructor+ {_OrcaLoadReport'NamedMetricsEntry'key = Data.ProtoLens.fieldDefault,+ _OrcaLoadReport'NamedMetricsEntry'value = Data.ProtoLens.fieldDefault,+ _OrcaLoadReport'NamedMetricsEntry'_unknownFields = []}+ parseMessage+ = let+ loop ::+ OrcaLoadReport'NamedMetricsEntry+ -> Data.ProtoLens.Encoding.Bytes.Parser OrcaLoadReport'NamedMetricsEntry+ loop x+ = do end <- Data.ProtoLens.Encoding.Bytes.atEnd+ if end then+ do (let missing = []+ in+ if Prelude.null missing then+ Prelude.return ()+ else+ Prelude.fail+ ((Prelude.++)+ "Missing required fields: "+ (Prelude.show (missing :: [Prelude.String]))))+ Prelude.return+ (Lens.Family2.over+ Data.ProtoLens.unknownFields (\ !t -> Prelude.reverse t) x)+ else+ do tag <- Data.ProtoLens.Encoding.Bytes.getVarInt+ case tag of+ 10+ -> do y <- (Data.ProtoLens.Encoding.Bytes.<?>)+ (do len <- Data.ProtoLens.Encoding.Bytes.getVarInt+ Data.ProtoLens.Encoding.Bytes.getText+ (Prelude.fromIntegral len))+ "key"+ loop (Lens.Family2.set (Data.ProtoLens.Field.field @"key") y x)+ 17+ -> do y <- (Data.ProtoLens.Encoding.Bytes.<?>)+ (Prelude.fmap+ Data.ProtoLens.Encoding.Bytes.wordToDouble+ Data.ProtoLens.Encoding.Bytes.getFixed64)+ "value"+ loop (Lens.Family2.set (Data.ProtoLens.Field.field @"value") y x)+ wire+ -> do !y <- Data.ProtoLens.Encoding.Wire.parseTaggedValueFromWire+ wire+ loop+ (Lens.Family2.over+ Data.ProtoLens.unknownFields (\ !t -> (:) y t) x)+ in+ (Data.ProtoLens.Encoding.Bytes.<?>)+ (do loop Data.ProtoLens.defMessage) "NamedMetricsEntry"+ buildMessage+ = \ _x+ -> (Data.Monoid.<>)+ (let _v = Lens.Family2.view (Data.ProtoLens.Field.field @"key") _x+ in+ if (Prelude.==) _v Data.ProtoLens.fieldDefault then+ Data.Monoid.mempty+ else+ (Data.Monoid.<>)+ (Data.ProtoLens.Encoding.Bytes.putVarInt 10)+ ((Prelude..)+ (\ bs+ -> (Data.Monoid.<>)+ (Data.ProtoLens.Encoding.Bytes.putVarInt+ (Prelude.fromIntegral (Data.ByteString.length bs)))+ (Data.ProtoLens.Encoding.Bytes.putBytes bs))+ Data.Text.Encoding.encodeUtf8 _v))+ ((Data.Monoid.<>)+ (let+ _v = Lens.Family2.view (Data.ProtoLens.Field.field @"value") _x+ in+ if (Prelude.==) _v Data.ProtoLens.fieldDefault then+ Data.Monoid.mempty+ else+ (Data.Monoid.<>)+ (Data.ProtoLens.Encoding.Bytes.putVarInt 17)+ ((Prelude..)+ Data.ProtoLens.Encoding.Bytes.putFixed64+ Data.ProtoLens.Encoding.Bytes.doubleToWord _v))+ (Data.ProtoLens.Encoding.Wire.buildFieldSet+ (Lens.Family2.view Data.ProtoLens.unknownFields _x)))+instance Control.DeepSeq.NFData OrcaLoadReport'NamedMetricsEntry where+ rnf+ = \ x__+ -> Control.DeepSeq.deepseq+ (_OrcaLoadReport'NamedMetricsEntry'_unknownFields x__)+ (Control.DeepSeq.deepseq+ (_OrcaLoadReport'NamedMetricsEntry'key x__)+ (Control.DeepSeq.deepseq+ (_OrcaLoadReport'NamedMetricsEntry'value x__) ()))+{- | Fields :+ + * 'Proto.OrcaLoadReport_Fields.key' @:: Lens' OrcaLoadReport'RequestCostEntry Data.Text.Text@+ * 'Proto.OrcaLoadReport_Fields.value' @:: Lens' OrcaLoadReport'RequestCostEntry Prelude.Double@ -}+data OrcaLoadReport'RequestCostEntry+ = OrcaLoadReport'RequestCostEntry'_constructor {_OrcaLoadReport'RequestCostEntry'key :: !Data.Text.Text,+ _OrcaLoadReport'RequestCostEntry'value :: !Prelude.Double,+ _OrcaLoadReport'RequestCostEntry'_unknownFields :: !Data.ProtoLens.FieldSet}+ deriving stock (Prelude.Eq, Prelude.Ord)+instance Prelude.Show OrcaLoadReport'RequestCostEntry where+ showsPrec _ __x __s+ = Prelude.showChar+ '{'+ (Prelude.showString+ (Data.ProtoLens.showMessageShort __x) (Prelude.showChar '}' __s))+instance Data.ProtoLens.Field.HasField OrcaLoadReport'RequestCostEntry "key" Data.Text.Text where+ fieldOf _+ = (Prelude..)+ (Lens.Family2.Unchecked.lens+ _OrcaLoadReport'RequestCostEntry'key+ (\ x__ y__ -> x__ {_OrcaLoadReport'RequestCostEntry'key = y__}))+ Prelude.id+instance Data.ProtoLens.Field.HasField OrcaLoadReport'RequestCostEntry "value" Prelude.Double where+ fieldOf _+ = (Prelude..)+ (Lens.Family2.Unchecked.lens+ _OrcaLoadReport'RequestCostEntry'value+ (\ x__ y__ -> x__ {_OrcaLoadReport'RequestCostEntry'value = y__}))+ Prelude.id+instance Data.ProtoLens.Message OrcaLoadReport'RequestCostEntry where+ messageName _+ = Data.Text.pack "xds.data.orca.v3.OrcaLoadReport.RequestCostEntry"+ packedMessageDescriptor _+ = "\n\+ \\DLERequestCostEntry\DC2\DLE\n\+ \\ETXkey\CAN\SOH \SOH(\tR\ETXkey\DC2\DC4\n\+ \\ENQvalue\CAN\STX \SOH(\SOHR\ENQvalue:\STX8\SOH"+ packedFileDescriptor _ = packedFileDescriptor+ fieldsByTag+ = let+ key__field_descriptor+ = Data.ProtoLens.FieldDescriptor+ "key"+ (Data.ProtoLens.ScalarField Data.ProtoLens.StringField ::+ Data.ProtoLens.FieldTypeDescriptor Data.Text.Text)+ (Data.ProtoLens.PlainField+ Data.ProtoLens.Optional (Data.ProtoLens.Field.field @"key")) ::+ Data.ProtoLens.FieldDescriptor OrcaLoadReport'RequestCostEntry+ value__field_descriptor+ = Data.ProtoLens.FieldDescriptor+ "value"+ (Data.ProtoLens.ScalarField Data.ProtoLens.DoubleField ::+ Data.ProtoLens.FieldTypeDescriptor Prelude.Double)+ (Data.ProtoLens.PlainField+ Data.ProtoLens.Optional (Data.ProtoLens.Field.field @"value")) ::+ Data.ProtoLens.FieldDescriptor OrcaLoadReport'RequestCostEntry+ in+ Data.Map.fromList+ [(Data.ProtoLens.Tag 1, key__field_descriptor),+ (Data.ProtoLens.Tag 2, value__field_descriptor)]+ unknownFields+ = Lens.Family2.Unchecked.lens+ _OrcaLoadReport'RequestCostEntry'_unknownFields+ (\ x__ y__+ -> x__ {_OrcaLoadReport'RequestCostEntry'_unknownFields = y__})+ defMessage+ = OrcaLoadReport'RequestCostEntry'_constructor+ {_OrcaLoadReport'RequestCostEntry'key = Data.ProtoLens.fieldDefault,+ _OrcaLoadReport'RequestCostEntry'value = Data.ProtoLens.fieldDefault,+ _OrcaLoadReport'RequestCostEntry'_unknownFields = []}+ parseMessage+ = let+ loop ::+ OrcaLoadReport'RequestCostEntry+ -> Data.ProtoLens.Encoding.Bytes.Parser OrcaLoadReport'RequestCostEntry+ loop x+ = do end <- Data.ProtoLens.Encoding.Bytes.atEnd+ if end then+ do (let missing = []+ in+ if Prelude.null missing then+ Prelude.return ()+ else+ Prelude.fail+ ((Prelude.++)+ "Missing required fields: "+ (Prelude.show (missing :: [Prelude.String]))))+ Prelude.return+ (Lens.Family2.over+ Data.ProtoLens.unknownFields (\ !t -> Prelude.reverse t) x)+ else+ do tag <- Data.ProtoLens.Encoding.Bytes.getVarInt+ case tag of+ 10+ -> do y <- (Data.ProtoLens.Encoding.Bytes.<?>)+ (do len <- Data.ProtoLens.Encoding.Bytes.getVarInt+ Data.ProtoLens.Encoding.Bytes.getText+ (Prelude.fromIntegral len))+ "key"+ loop (Lens.Family2.set (Data.ProtoLens.Field.field @"key") y x)+ 17+ -> do y <- (Data.ProtoLens.Encoding.Bytes.<?>)+ (Prelude.fmap+ Data.ProtoLens.Encoding.Bytes.wordToDouble+ Data.ProtoLens.Encoding.Bytes.getFixed64)+ "value"+ loop (Lens.Family2.set (Data.ProtoLens.Field.field @"value") y x)+ wire+ -> do !y <- Data.ProtoLens.Encoding.Wire.parseTaggedValueFromWire+ wire+ loop+ (Lens.Family2.over+ Data.ProtoLens.unknownFields (\ !t -> (:) y t) x)+ in+ (Data.ProtoLens.Encoding.Bytes.<?>)+ (do loop Data.ProtoLens.defMessage) "RequestCostEntry"+ buildMessage+ = \ _x+ -> (Data.Monoid.<>)+ (let _v = Lens.Family2.view (Data.ProtoLens.Field.field @"key") _x+ in+ if (Prelude.==) _v Data.ProtoLens.fieldDefault then+ Data.Monoid.mempty+ else+ (Data.Monoid.<>)+ (Data.ProtoLens.Encoding.Bytes.putVarInt 10)+ ((Prelude..)+ (\ bs+ -> (Data.Monoid.<>)+ (Data.ProtoLens.Encoding.Bytes.putVarInt+ (Prelude.fromIntegral (Data.ByteString.length bs)))+ (Data.ProtoLens.Encoding.Bytes.putBytes bs))+ Data.Text.Encoding.encodeUtf8 _v))+ ((Data.Monoid.<>)+ (let+ _v = Lens.Family2.view (Data.ProtoLens.Field.field @"value") _x+ in+ if (Prelude.==) _v Data.ProtoLens.fieldDefault then+ Data.Monoid.mempty+ else+ (Data.Monoid.<>)+ (Data.ProtoLens.Encoding.Bytes.putVarInt 17)+ ((Prelude..)+ Data.ProtoLens.Encoding.Bytes.putFixed64+ Data.ProtoLens.Encoding.Bytes.doubleToWord _v))+ (Data.ProtoLens.Encoding.Wire.buildFieldSet+ (Lens.Family2.view Data.ProtoLens.unknownFields _x)))+instance Control.DeepSeq.NFData OrcaLoadReport'RequestCostEntry where+ rnf+ = \ x__+ -> Control.DeepSeq.deepseq+ (_OrcaLoadReport'RequestCostEntry'_unknownFields x__)+ (Control.DeepSeq.deepseq+ (_OrcaLoadReport'RequestCostEntry'key x__)+ (Control.DeepSeq.deepseq+ (_OrcaLoadReport'RequestCostEntry'value x__) ()))+{- | Fields :+ + * 'Proto.OrcaLoadReport_Fields.key' @:: Lens' OrcaLoadReport'UtilizationEntry Data.Text.Text@+ * 'Proto.OrcaLoadReport_Fields.value' @:: Lens' OrcaLoadReport'UtilizationEntry Prelude.Double@ -}+data OrcaLoadReport'UtilizationEntry+ = OrcaLoadReport'UtilizationEntry'_constructor {_OrcaLoadReport'UtilizationEntry'key :: !Data.Text.Text,+ _OrcaLoadReport'UtilizationEntry'value :: !Prelude.Double,+ _OrcaLoadReport'UtilizationEntry'_unknownFields :: !Data.ProtoLens.FieldSet}+ deriving stock (Prelude.Eq, Prelude.Ord)+instance Prelude.Show OrcaLoadReport'UtilizationEntry where+ showsPrec _ __x __s+ = Prelude.showChar+ '{'+ (Prelude.showString+ (Data.ProtoLens.showMessageShort __x) (Prelude.showChar '}' __s))+instance Data.ProtoLens.Field.HasField OrcaLoadReport'UtilizationEntry "key" Data.Text.Text where+ fieldOf _+ = (Prelude..)+ (Lens.Family2.Unchecked.lens+ _OrcaLoadReport'UtilizationEntry'key+ (\ x__ y__ -> x__ {_OrcaLoadReport'UtilizationEntry'key = y__}))+ Prelude.id+instance Data.ProtoLens.Field.HasField OrcaLoadReport'UtilizationEntry "value" Prelude.Double where+ fieldOf _+ = (Prelude..)+ (Lens.Family2.Unchecked.lens+ _OrcaLoadReport'UtilizationEntry'value+ (\ x__ y__ -> x__ {_OrcaLoadReport'UtilizationEntry'value = y__}))+ Prelude.id+instance Data.ProtoLens.Message OrcaLoadReport'UtilizationEntry where+ messageName _+ = Data.Text.pack "xds.data.orca.v3.OrcaLoadReport.UtilizationEntry"+ packedMessageDescriptor _+ = "\n\+ \\DLEUtilizationEntry\DC2\DLE\n\+ \\ETXkey\CAN\SOH \SOH(\tR\ETXkey\DC2\DC4\n\+ \\ENQvalue\CAN\STX \SOH(\SOHR\ENQvalue:\STX8\SOH"+ packedFileDescriptor _ = packedFileDescriptor+ fieldsByTag+ = let+ key__field_descriptor+ = Data.ProtoLens.FieldDescriptor+ "key"+ (Data.ProtoLens.ScalarField Data.ProtoLens.StringField ::+ Data.ProtoLens.FieldTypeDescriptor Data.Text.Text)+ (Data.ProtoLens.PlainField+ Data.ProtoLens.Optional (Data.ProtoLens.Field.field @"key")) ::+ Data.ProtoLens.FieldDescriptor OrcaLoadReport'UtilizationEntry+ value__field_descriptor+ = Data.ProtoLens.FieldDescriptor+ "value"+ (Data.ProtoLens.ScalarField Data.ProtoLens.DoubleField ::+ Data.ProtoLens.FieldTypeDescriptor Prelude.Double)+ (Data.ProtoLens.PlainField+ Data.ProtoLens.Optional (Data.ProtoLens.Field.field @"value")) ::+ Data.ProtoLens.FieldDescriptor OrcaLoadReport'UtilizationEntry+ in+ Data.Map.fromList+ [(Data.ProtoLens.Tag 1, key__field_descriptor),+ (Data.ProtoLens.Tag 2, value__field_descriptor)]+ unknownFields+ = Lens.Family2.Unchecked.lens+ _OrcaLoadReport'UtilizationEntry'_unknownFields+ (\ x__ y__+ -> x__ {_OrcaLoadReport'UtilizationEntry'_unknownFields = y__})+ defMessage+ = OrcaLoadReport'UtilizationEntry'_constructor+ {_OrcaLoadReport'UtilizationEntry'key = Data.ProtoLens.fieldDefault,+ _OrcaLoadReport'UtilizationEntry'value = Data.ProtoLens.fieldDefault,+ _OrcaLoadReport'UtilizationEntry'_unknownFields = []}+ parseMessage+ = let+ loop ::+ OrcaLoadReport'UtilizationEntry+ -> Data.ProtoLens.Encoding.Bytes.Parser OrcaLoadReport'UtilizationEntry+ loop x+ = do end <- Data.ProtoLens.Encoding.Bytes.atEnd+ if end then+ do (let missing = []+ in+ if Prelude.null missing then+ Prelude.return ()+ else+ Prelude.fail+ ((Prelude.++)+ "Missing required fields: "+ (Prelude.show (missing :: [Prelude.String]))))+ Prelude.return+ (Lens.Family2.over+ Data.ProtoLens.unknownFields (\ !t -> Prelude.reverse t) x)+ else+ do tag <- Data.ProtoLens.Encoding.Bytes.getVarInt+ case tag of+ 10+ -> do y <- (Data.ProtoLens.Encoding.Bytes.<?>)+ (do len <- Data.ProtoLens.Encoding.Bytes.getVarInt+ Data.ProtoLens.Encoding.Bytes.getText+ (Prelude.fromIntegral len))+ "key"+ loop (Lens.Family2.set (Data.ProtoLens.Field.field @"key") y x)+ 17+ -> do y <- (Data.ProtoLens.Encoding.Bytes.<?>)+ (Prelude.fmap+ Data.ProtoLens.Encoding.Bytes.wordToDouble+ Data.ProtoLens.Encoding.Bytes.getFixed64)+ "value"+ loop (Lens.Family2.set (Data.ProtoLens.Field.field @"value") y x)+ wire+ -> do !y <- Data.ProtoLens.Encoding.Wire.parseTaggedValueFromWire+ wire+ loop+ (Lens.Family2.over+ Data.ProtoLens.unknownFields (\ !t -> (:) y t) x)+ in+ (Data.ProtoLens.Encoding.Bytes.<?>)+ (do loop Data.ProtoLens.defMessage) "UtilizationEntry"+ buildMessage+ = \ _x+ -> (Data.Monoid.<>)+ (let _v = Lens.Family2.view (Data.ProtoLens.Field.field @"key") _x+ in+ if (Prelude.==) _v Data.ProtoLens.fieldDefault then+ Data.Monoid.mempty+ else+ (Data.Monoid.<>)+ (Data.ProtoLens.Encoding.Bytes.putVarInt 10)+ ((Prelude..)+ (\ bs+ -> (Data.Monoid.<>)+ (Data.ProtoLens.Encoding.Bytes.putVarInt+ (Prelude.fromIntegral (Data.ByteString.length bs)))+ (Data.ProtoLens.Encoding.Bytes.putBytes bs))+ Data.Text.Encoding.encodeUtf8 _v))+ ((Data.Monoid.<>)+ (let+ _v = Lens.Family2.view (Data.ProtoLens.Field.field @"value") _x+ in+ if (Prelude.==) _v Data.ProtoLens.fieldDefault then+ Data.Monoid.mempty+ else+ (Data.Monoid.<>)+ (Data.ProtoLens.Encoding.Bytes.putVarInt 17)+ ((Prelude..)+ Data.ProtoLens.Encoding.Bytes.putFixed64+ Data.ProtoLens.Encoding.Bytes.doubleToWord _v))+ (Data.ProtoLens.Encoding.Wire.buildFieldSet+ (Lens.Family2.view Data.ProtoLens.unknownFields _x)))+instance Control.DeepSeq.NFData OrcaLoadReport'UtilizationEntry where+ rnf+ = \ x__+ -> Control.DeepSeq.deepseq+ (_OrcaLoadReport'UtilizationEntry'_unknownFields x__)+ (Control.DeepSeq.deepseq+ (_OrcaLoadReport'UtilizationEntry'key x__)+ (Control.DeepSeq.deepseq+ (_OrcaLoadReport'UtilizationEntry'value x__) ()))+packedFileDescriptor :: Data.ByteString.ByteString+packedFileDescriptor+ = "\n\+ \\SYNorca_load_report.proto\DC2\DLExds.data.orca.v3\"\175\ENQ\n\+ \\SOOrcaLoadReport\DC2'\n\+ \\SIcpu_utilization\CAN\SOH \SOH(\SOHR\SOcpuUtilization\DC2'\n\+ \\SImem_utilization\CAN\STX \SOH(\SOHR\SOmemUtilization\DC2\DC4\n\+ \\ETXrps\CAN\ETX \SOH(\EOTR\ETXrpsB\STX\CAN\SOH\DC2T\n\+ \\frequest_cost\CAN\EOT \ETX(\v21.xds.data.orca.v3.OrcaLoadReport.RequestCostEntryR\vrequestCost\DC2S\n\+ \\vutilization\CAN\ENQ \ETX(\v21.xds.data.orca.v3.OrcaLoadReport.UtilizationEntryR\vutilization\DC2%\n\+ \\SOrps_fractional\CAN\ACK \SOH(\SOHR\rrpsFractional\DC2\DLE\n\+ \\ETXeps\CAN\a \SOH(\SOHR\ETXeps\DC2W\n\+ \\rnamed_metrics\CAN\b \ETX(\v22.xds.data.orca.v3.OrcaLoadReport.NamedMetricsEntryR\fnamedMetrics\DC27\n\+ \\ETBapplication_utilization\CAN\t \SOH(\SOHR\SYNapplicationUtilization\SUB>\n\+ \\DLERequestCostEntry\DC2\DLE\n\+ \\ETXkey\CAN\SOH \SOH(\tR\ETXkey\DC2\DC4\n\+ \\ENQvalue\CAN\STX \SOH(\SOHR\ENQvalue:\STX8\SOH\SUB>\n\+ \\DLEUtilizationEntry\DC2\DLE\n\+ \\ETXkey\CAN\SOH \SOH(\tR\ETXkey\DC2\DC4\n\+ \\ENQvalue\CAN\STX \SOH(\SOHR\ENQvalue:\STX8\SOH\SUB?\n\+ \\DC1NamedMetricsEntry\DC2\DLE\n\+ \\ETXkey\CAN\SOH \SOH(\tR\ETXkey\DC2\DC4\n\+ \\ENQvalue\CAN\STX \SOH(\SOHR\ENQvalue:\STX8\SOHJ\156\DC1\n\+ \\ACK\DC2\EOT\NUL\NUL1\SOH\n\+ \\b\n\+ \\SOH\f\DC2\ETX\NUL\NUL\DC2\n\+ \\b\n\+ \\SOH\STX\DC2\ETX\STX\NUL\EM\n\+ \\134\SOH\n\+ \\STX\EOT\NUL\DC2\EOT\a\NUL1\SOH2z See section `ORCA load report format` of the design document in\n\+ \ :ref:`https://github.com/envoyproxy/envoy/issues/6614`.\n\+ \\n\+ \\n\+ \\n\+ \\ETX\EOT\NUL\SOH\DC2\ETX\a\b\SYN\n\+ \\250\SOH\n\+ \\EOT\EOT\NUL\STX\NUL\DC2\ETX\f\STX\GS\SUB\236\SOH CPU utilization expressed as a fraction of available CPU resources. This\n\+ \ should be derived from the latest sample or measurement. The value may be\n\+ \ larger than 1.0 when the usage exceeds the reporter dependent notion of\n\+ \ soft limits.\n\+ \\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\NUL\ENQ\DC2\ETX\f\STX\b\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\NUL\SOH\DC2\ETX\f\t\CAN\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\NUL\ETX\DC2\ETX\f\ESC\FS\n\+ \\152\SOH\n\+ \\EOT\EOT\NUL\STX\SOH\DC2\ETX\DLE\STX\GS\SUB\138\SOH Memory utilization expressed as a fraction of available memory\n\+ \ resources. This should be derived from the latest sample or measurement.\n\+ \\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\SOH\ENQ\DC2\ETX\DLE\STX\b\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\SOH\SOH\DC2\ETX\DLE\t\CAN\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\SOH\ETX\DC2\ETX\DLE\ESC\FS\n\+ \\176\SOH\n\+ \\EOT\EOT\NUL\STX\STX\DC2\ETX\NAK\STX%\SUB\162\SOH Total RPS being served by an endpoint. This should cover all services that an endpoint is\n\+ \ responsible for.\n\+ \ Deprecated -- use ``rps_fractional`` field instead.\n\+ \\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\STX\ENQ\DC2\ETX\NAK\STX\b\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\STX\SOH\DC2\ETX\NAK\t\f\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\STX\ETX\DC2\ETX\NAK\SI\DLE\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\STX\b\DC2\ETX\NAK\DC1$\n\+ \\r\n\+ \\ACK\EOT\NUL\STX\STX\b\ETX\DC2\ETX\NAK\DC2#\n\+ \\142\SOH\n\+ \\EOT\EOT\NUL\STX\ETX\DC2\ETX\EM\STX'\SUB\128\SOH Application specific requests costs. Each value is an absolute cost (e.g. 3487 bytes of\n\+ \ storage) associated with the request.\n\+ \\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\ETX\ACK\DC2\ETX\EM\STX\NAK\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\ETX\SOH\DC2\ETX\EM\SYN\"\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\ETX\ETX\DC2\ETX\EM%&\n\+ \\160\SOH\n\+ \\EOT\EOT\NUL\STX\EOT\DC2\ETX\GS\STX&\SUB\146\SOH Resource utilization values. Each value is expressed as a fraction of total resources\n\+ \ available, derived from the latest sample or measurement.\n\+ \\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\EOT\ACK\DC2\ETX\GS\STX\NAK\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\EOT\SOH\DC2\ETX\GS\SYN!\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\EOT\ETX\DC2\ETX\GS$%\n\+ \z\n\+ \\EOT\EOT\NUL\STX\ENQ\DC2\ETX!\STX\FS\SUBm Total RPS being served by an endpoint. This should cover all services that an endpoint is\n\+ \ responsible for.\n\+ \\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\ENQ\ENQ\DC2\ETX!\STX\b\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\ENQ\SOH\DC2\ETX!\t\ETB\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\ENQ\ETX\DC2\ETX!\SUB\ESC\n\+ \\138\SOH\n\+ \\EOT\EOT\NUL\STX\ACK\DC2\ETX%\STX\DC1\SUB} Total EPS (errors/second) being served by an endpoint. This should cover\n\+ \ all services that an endpoint is responsible for.\n\+ \\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\ACK\ENQ\DC2\ETX%\STX\b\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\ACK\SOH\DC2\ETX%\t\f\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\ACK\ETX\DC2\ETX%\SI\DLE\n\+ \3\n\+ \\EOT\EOT\NUL\STX\a\DC2\ETX(\STX(\SUB& Application specific opaque metrics.\n\+ \\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\a\ACK\DC2\ETX(\STX\NAK\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\a\SOH\DC2\ETX(\SYN#\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\a\ETX\DC2\ETX(&'\n\+ \\148\ETX\n\+ \\EOT\EOT\NUL\STX\b\DC2\ETX0\STX%\SUB\134\ETX Application specific utilization expressed as a fraction of available\n\+ \ resources. For example, an application may report the max of CPU and memory\n\+ \ utilization for better load balancing if it is both CPU and memory bound.\n\+ \ This should be derived from the latest sample or measurement.\n\+ \ The value may be larger than 1.0 when the usage exceeds the reporter\n\+ \ dependent notion of soft limits.\n\+ \\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\b\ENQ\DC2\ETX0\STX\b\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\b\SOH\DC2\ETX0\t \n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\b\ETX\DC2\ETX0#$b\ACKproto3"
+ proto/Proto/Status.hs view
@@ -0,0 +1,392 @@+{-# OPTIONS_GHC -Wno-prepositive-qualified-module -Wno-identities #-}+{- This file was auto-generated from status.proto by the proto-lens-protoc program. -}+{-# LANGUAGE ScopedTypeVariables, DataKinds, TypeFamilies, UndecidableInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, PatternSynonyms, MagicHash, NoImplicitPrelude, DataKinds, BangPatterns, TypeApplications, OverloadedStrings, DerivingStrategies#-}+{-# OPTIONS_GHC -Wno-unused-imports#-}+{-# OPTIONS_GHC -Wno-duplicate-exports#-}+{-# OPTIONS_GHC -Wno-dodgy-exports#-}+module Proto.Status (+ Status()+ ) where+import qualified Data.ProtoLens.Runtime.Control.DeepSeq as Control.DeepSeq+import qualified Data.ProtoLens.Runtime.Data.ProtoLens.Prism as Data.ProtoLens.Prism+import qualified Data.ProtoLens.Runtime.Prelude as Prelude+import qualified Data.ProtoLens.Runtime.Data.Int as Data.Int+import qualified Data.ProtoLens.Runtime.Data.Monoid as Data.Monoid+import qualified Data.ProtoLens.Runtime.Data.Word as Data.Word+import qualified Data.ProtoLens.Runtime.Data.ProtoLens as Data.ProtoLens+import qualified Data.ProtoLens.Runtime.Data.ProtoLens.Encoding.Bytes as Data.ProtoLens.Encoding.Bytes+import qualified Data.ProtoLens.Runtime.Data.ProtoLens.Encoding.Growing as Data.ProtoLens.Encoding.Growing+import qualified Data.ProtoLens.Runtime.Data.ProtoLens.Encoding.Parser.Unsafe as Data.ProtoLens.Encoding.Parser.Unsafe+import qualified Data.ProtoLens.Runtime.Data.ProtoLens.Encoding.Wire as Data.ProtoLens.Encoding.Wire+import qualified Data.ProtoLens.Runtime.Data.ProtoLens.Field as Data.ProtoLens.Field+import qualified Data.ProtoLens.Runtime.Data.ProtoLens.Message.Enum as Data.ProtoLens.Message.Enum+import qualified Data.ProtoLens.Runtime.Data.ProtoLens.Service.Types as Data.ProtoLens.Service.Types+import qualified Data.ProtoLens.Runtime.Lens.Family2 as Lens.Family2+import qualified Data.ProtoLens.Runtime.Lens.Family2.Unchecked as Lens.Family2.Unchecked+import qualified Data.ProtoLens.Runtime.Data.Text as Data.Text+import qualified Data.ProtoLens.Runtime.Data.Map as Data.Map+import qualified Data.ProtoLens.Runtime.Data.ByteString as Data.ByteString+import qualified Data.ProtoLens.Runtime.Data.ByteString.Char8 as Data.ByteString.Char8+import qualified Data.ProtoLens.Runtime.Data.Text.Encoding as Data.Text.Encoding+import qualified Data.ProtoLens.Runtime.Data.Vector as Data.Vector+import qualified Data.ProtoLens.Runtime.Data.Vector.Generic as Data.Vector.Generic+import qualified Data.ProtoLens.Runtime.Data.Vector.Unboxed as Data.Vector.Unboxed+import qualified Data.ProtoLens.Runtime.Text.Read as Text.Read+import qualified Proto.Google.Protobuf.Any+{- | Fields :+ + * 'Proto.Status_Fields.code' @:: Lens' Status Data.Int.Int32@+ * 'Proto.Status_Fields.message' @:: Lens' Status Data.Text.Text@+ * 'Proto.Status_Fields.details' @:: Lens' Status [Proto.Google.Protobuf.Any.Any]@+ * 'Proto.Status_Fields.vec'details' @:: Lens' Status (Data.Vector.Vector Proto.Google.Protobuf.Any.Any)@ -}+data Status+ = Status'_constructor {_Status'code :: !Data.Int.Int32,+ _Status'message :: !Data.Text.Text,+ _Status'details :: !(Data.Vector.Vector Proto.Google.Protobuf.Any.Any),+ _Status'_unknownFields :: !Data.ProtoLens.FieldSet}+ deriving stock (Prelude.Eq, Prelude.Ord)+instance Prelude.Show Status where+ showsPrec _ __x __s+ = Prelude.showChar+ '{'+ (Prelude.showString+ (Data.ProtoLens.showMessageShort __x) (Prelude.showChar '}' __s))+instance Data.ProtoLens.Field.HasField Status "code" Data.Int.Int32 where+ fieldOf _+ = (Prelude..)+ (Lens.Family2.Unchecked.lens+ _Status'code (\ x__ y__ -> x__ {_Status'code = y__}))+ Prelude.id+instance Data.ProtoLens.Field.HasField Status "message" Data.Text.Text where+ fieldOf _+ = (Prelude..)+ (Lens.Family2.Unchecked.lens+ _Status'message (\ x__ y__ -> x__ {_Status'message = y__}))+ Prelude.id+instance Data.ProtoLens.Field.HasField Status "details" [Proto.Google.Protobuf.Any.Any] where+ fieldOf _+ = (Prelude..)+ (Lens.Family2.Unchecked.lens+ _Status'details (\ x__ y__ -> x__ {_Status'details = y__}))+ (Lens.Family2.Unchecked.lens+ Data.Vector.Generic.toList+ (\ _ y__ -> Data.Vector.Generic.fromList y__))+instance Data.ProtoLens.Field.HasField Status "vec'details" (Data.Vector.Vector Proto.Google.Protobuf.Any.Any) where+ fieldOf _+ = (Prelude..)+ (Lens.Family2.Unchecked.lens+ _Status'details (\ x__ y__ -> x__ {_Status'details = y__}))+ Prelude.id+instance Data.ProtoLens.Message Status where+ messageName _ = Data.Text.pack "google.rpc.Status"+ packedMessageDescriptor _+ = "\n\+ \\ACKStatus\DC2\DC2\n\+ \\EOTcode\CAN\SOH \SOH(\ENQR\EOTcode\DC2\CAN\n\+ \\amessage\CAN\STX \SOH(\tR\amessage\DC2.\n\+ \\adetails\CAN\ETX \ETX(\v2\DC4.google.protobuf.AnyR\adetails"+ packedFileDescriptor _ = packedFileDescriptor+ fieldsByTag+ = let+ code__field_descriptor+ = Data.ProtoLens.FieldDescriptor+ "code"+ (Data.ProtoLens.ScalarField Data.ProtoLens.Int32Field ::+ Data.ProtoLens.FieldTypeDescriptor Data.Int.Int32)+ (Data.ProtoLens.PlainField+ Data.ProtoLens.Optional (Data.ProtoLens.Field.field @"code")) ::+ Data.ProtoLens.FieldDescriptor Status+ message__field_descriptor+ = Data.ProtoLens.FieldDescriptor+ "message"+ (Data.ProtoLens.ScalarField Data.ProtoLens.StringField ::+ Data.ProtoLens.FieldTypeDescriptor Data.Text.Text)+ (Data.ProtoLens.PlainField+ Data.ProtoLens.Optional (Data.ProtoLens.Field.field @"message")) ::+ Data.ProtoLens.FieldDescriptor Status+ details__field_descriptor+ = Data.ProtoLens.FieldDescriptor+ "details"+ (Data.ProtoLens.MessageField Data.ProtoLens.MessageType ::+ Data.ProtoLens.FieldTypeDescriptor Proto.Google.Protobuf.Any.Any)+ (Data.ProtoLens.RepeatedField+ Data.ProtoLens.Unpacked (Data.ProtoLens.Field.field @"details")) ::+ Data.ProtoLens.FieldDescriptor Status+ in+ Data.Map.fromList+ [(Data.ProtoLens.Tag 1, code__field_descriptor),+ (Data.ProtoLens.Tag 2, message__field_descriptor),+ (Data.ProtoLens.Tag 3, details__field_descriptor)]+ unknownFields+ = Lens.Family2.Unchecked.lens+ _Status'_unknownFields+ (\ x__ y__ -> x__ {_Status'_unknownFields = y__})+ defMessage+ = Status'_constructor+ {_Status'code = Data.ProtoLens.fieldDefault,+ _Status'message = Data.ProtoLens.fieldDefault,+ _Status'details = Data.Vector.Generic.empty,+ _Status'_unknownFields = []}+ parseMessage+ = let+ loop ::+ Status+ -> Data.ProtoLens.Encoding.Growing.Growing Data.Vector.Vector Data.ProtoLens.Encoding.Growing.RealWorld Proto.Google.Protobuf.Any.Any+ -> Data.ProtoLens.Encoding.Bytes.Parser Status+ loop x mutable'details+ = do end <- Data.ProtoLens.Encoding.Bytes.atEnd+ if end then+ do frozen'details <- Data.ProtoLens.Encoding.Parser.Unsafe.unsafeLiftIO+ (Data.ProtoLens.Encoding.Growing.unsafeFreeze+ mutable'details)+ (let missing = []+ in+ if Prelude.null missing then+ Prelude.return ()+ else+ Prelude.fail+ ((Prelude.++)+ "Missing required fields: "+ (Prelude.show (missing :: [Prelude.String]))))+ Prelude.return+ (Lens.Family2.over+ Data.ProtoLens.unknownFields (\ !t -> Prelude.reverse t)+ (Lens.Family2.set+ (Data.ProtoLens.Field.field @"vec'details") frozen'details x))+ else+ do tag <- Data.ProtoLens.Encoding.Bytes.getVarInt+ case tag of+ 8 -> do y <- (Data.ProtoLens.Encoding.Bytes.<?>)+ (Prelude.fmap+ Prelude.fromIntegral+ Data.ProtoLens.Encoding.Bytes.getVarInt)+ "code"+ loop+ (Lens.Family2.set (Data.ProtoLens.Field.field @"code") y x)+ mutable'details+ 18+ -> do y <- (Data.ProtoLens.Encoding.Bytes.<?>)+ (do len <- Data.ProtoLens.Encoding.Bytes.getVarInt+ Data.ProtoLens.Encoding.Bytes.getText+ (Prelude.fromIntegral len))+ "message"+ loop+ (Lens.Family2.set (Data.ProtoLens.Field.field @"message") y x)+ mutable'details+ 26+ -> do !y <- (Data.ProtoLens.Encoding.Bytes.<?>)+ (do len <- Data.ProtoLens.Encoding.Bytes.getVarInt+ Data.ProtoLens.Encoding.Bytes.isolate+ (Prelude.fromIntegral len)+ Data.ProtoLens.parseMessage)+ "details"+ v <- Data.ProtoLens.Encoding.Parser.Unsafe.unsafeLiftIO+ (Data.ProtoLens.Encoding.Growing.append mutable'details y)+ loop x v+ wire+ -> do !y <- Data.ProtoLens.Encoding.Wire.parseTaggedValueFromWire+ wire+ loop+ (Lens.Family2.over+ Data.ProtoLens.unknownFields (\ !t -> (:) y t) x)+ mutable'details+ in+ (Data.ProtoLens.Encoding.Bytes.<?>)+ (do mutable'details <- Data.ProtoLens.Encoding.Parser.Unsafe.unsafeLiftIO+ Data.ProtoLens.Encoding.Growing.new+ loop Data.ProtoLens.defMessage mutable'details)+ "Status"+ buildMessage+ = \ _x+ -> (Data.Monoid.<>)+ (let _v = Lens.Family2.view (Data.ProtoLens.Field.field @"code") _x+ in+ if (Prelude.==) _v Data.ProtoLens.fieldDefault then+ Data.Monoid.mempty+ else+ (Data.Monoid.<>)+ (Data.ProtoLens.Encoding.Bytes.putVarInt 8)+ ((Prelude..)+ Data.ProtoLens.Encoding.Bytes.putVarInt Prelude.fromIntegral _v))+ ((Data.Monoid.<>)+ (let+ _v = Lens.Family2.view (Data.ProtoLens.Field.field @"message") _x+ in+ if (Prelude.==) _v Data.ProtoLens.fieldDefault then+ Data.Monoid.mempty+ else+ (Data.Monoid.<>)+ (Data.ProtoLens.Encoding.Bytes.putVarInt 18)+ ((Prelude..)+ (\ bs+ -> (Data.Monoid.<>)+ (Data.ProtoLens.Encoding.Bytes.putVarInt+ (Prelude.fromIntegral (Data.ByteString.length bs)))+ (Data.ProtoLens.Encoding.Bytes.putBytes bs))+ Data.Text.Encoding.encodeUtf8 _v))+ ((Data.Monoid.<>)+ (Data.ProtoLens.Encoding.Bytes.foldMapBuilder+ (\ _v+ -> (Data.Monoid.<>)+ (Data.ProtoLens.Encoding.Bytes.putVarInt 26)+ ((Prelude..)+ (\ bs+ -> (Data.Monoid.<>)+ (Data.ProtoLens.Encoding.Bytes.putVarInt+ (Prelude.fromIntegral (Data.ByteString.length bs)))+ (Data.ProtoLens.Encoding.Bytes.putBytes bs))+ Data.ProtoLens.encodeMessage _v))+ (Lens.Family2.view (Data.ProtoLens.Field.field @"vec'details") _x))+ (Data.ProtoLens.Encoding.Wire.buildFieldSet+ (Lens.Family2.view Data.ProtoLens.unknownFields _x))))+instance Control.DeepSeq.NFData Status where+ rnf+ = \ x__+ -> Control.DeepSeq.deepseq+ (_Status'_unknownFields x__)+ (Control.DeepSeq.deepseq+ (_Status'code x__)+ (Control.DeepSeq.deepseq+ (_Status'message x__)+ (Control.DeepSeq.deepseq (_Status'details x__) ())))+packedFileDescriptor :: Data.ByteString.ByteString+packedFileDescriptor+ = "\n\+ \\fstatus.proto\DC2\n\+ \google.rpc\SUB\EMgoogle/protobuf/any.proto\"f\n\+ \\ACKStatus\DC2\DC2\n\+ \\EOTcode\CAN\SOH \SOH(\ENQR\EOTcode\DC2\CAN\n\+ \\amessage\CAN\STX \SOH(\tR\amessage\DC2.\n\+ \\adetails\CAN\ETX \ETX(\v2\DC4.google.protobuf.AnyR\adetailsB^\n\+ \\SOcom.google.rpcB\vStatusProtoP\SOHZ7google.golang.org/genproto/googleapis/rpc/status;status\162\STX\ETXRPCJ\139\RS\n\+ \\ACK\DC2\EOT\SO\NUL[\SOH\n\+ \\189\EOT\n\+ \\SOH\f\DC2\ETX\SO\NUL\DC22\178\EOT Copyright 2016 Google Inc.\n\+ \\n\+ \ Licensed under the Apache License, Version 2.0 (the \"License\");\n\+ \ you may not use this file except in compliance with the License.\n\+ \ You may obtain a copy of the License at\n\+ \\n\+ \ http://www.apache.org/licenses/LICENSE-2.0\n\+ \\n\+ \ Unless required by applicable law or agreed to in writing, software\n\+ \ distributed under the License is distributed on an \"AS IS\" BASIS,\n\+ \ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.\n\+ \ See the License for the specific language governing permissions and\n\+ \ limitations under the License.\n\+ \\n\+ \\b\n\+ \\SOH\STX\DC2\ETX\DLE\NUL\DC3\n\+ \\t\n\+ \\STX\ETX\NUL\DC2\ETX\DC2\NUL#\n\+ \\b\n\+ \\SOH\b\DC2\ETX\DC4\NULN\n\+ \\t\n\+ \\STX\b\v\DC2\ETX\DC4\NULN\n\+ \\b\n\+ \\SOH\b\DC2\ETX\NAK\NUL\"\n\+ \\t\n\+ \\STX\b\n\+ \\DC2\ETX\NAK\NUL\"\n\+ \\b\n\+ \\SOH\b\DC2\ETX\SYN\NUL,\n\+ \\t\n\+ \\STX\b\b\DC2\ETX\SYN\NUL,\n\+ \\b\n\+ \\SOH\b\DC2\ETX\ETB\NUL'\n\+ \\t\n\+ \\STX\b\SOH\DC2\ETX\ETB\NUL'\n\+ \\b\n\+ \\SOH\b\DC2\ETX\CAN\NUL!\n\+ \\t\n\+ \\STX\b$\DC2\ETX\CAN\NUL!\n\+ \\214\DC3\n\+ \\STX\EOT\NUL\DC2\EOTO\NUL[\SOH\SUB\201\DC3 The `Status` type defines a logical error model that is suitable for different\n\+ \ programming environments, including REST APIs and RPC APIs. It is used by\n\+ \ [gRPC](https://github.com/grpc). The error model is designed to be:\n\+ \\n\+ \ - Simple to use and understand for most users\n\+ \ - Flexible enough to meet unexpected needs\n\+ \\n\+ \ # Overview\n\+ \\n\+ \ The `Status` message contains three pieces of data: error code, error message,\n\+ \ and error details. The error code should be an enum value of\n\+ \ [google.rpc.Code][google.rpc.Code], but it may accept additional error codes if needed. The\n\+ \ error message should be a developer-facing English message that helps\n\+ \ developers *understand* and *resolve* the error. If a localized user-facing\n\+ \ error message is needed, put the localized message in the error details or\n\+ \ localize it in the client. The optional error details may contain arbitrary\n\+ \ information about the error. There is a predefined set of error detail types\n\+ \ in the package `google.rpc` which can be used for common error conditions.\n\+ \\n\+ \ # Language mapping\n\+ \\n\+ \ The `Status` message is the logical representation of the error model, but it\n\+ \ is not necessarily the actual wire format. When the `Status` message is\n\+ \ exposed in different client libraries and different wire protocols, it can be\n\+ \ mapped differently. For example, it will likely be mapped to some exceptions\n\+ \ in Java, but more likely mapped to some error codes in C.\n\+ \\n\+ \ # Other uses\n\+ \\n\+ \ The error model and the `Status` message can be used in a variety of\n\+ \ environments, either with or without APIs, to provide a\n\+ \ consistent developer experience across different environments.\n\+ \\n\+ \ Example uses of this error model include:\n\+ \\n\+ \ - Partial errors. If a service needs to return partial errors to the client,\n\+ \ it may embed the `Status` in the normal response to indicate the partial\n\+ \ errors.\n\+ \\n\+ \ - Workflow errors. A typical workflow has multiple steps. Each step may\n\+ \ have a `Status` message for error reporting purpose.\n\+ \\n\+ \ - Batch operations. If a client uses batch request and batch response, the\n\+ \ `Status` message should be used directly inside batch response, one for\n\+ \ each error sub-response.\n\+ \\n\+ \ - Asynchronous operations. If an API call embeds asynchronous operation\n\+ \ results in its response, the status of those operations should be\n\+ \ represented directly using the `Status` message.\n\+ \\n\+ \ - Logging. If some API errors are stored in logs, the message `Status` could\n\+ \ be used directly after any stripping needed for security/privacy reasons.\n\+ \\n\+ \\n\+ \\n\+ \\ETX\EOT\NUL\SOH\DC2\ETXO\b\SO\n\+ \d\n\+ \\EOT\EOT\NUL\STX\NUL\DC2\ETXQ\STX\DC1\SUBW The status code, which should be an enum value of [google.rpc.Code][google.rpc.Code].\n\+ \\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\NUL\ENQ\DC2\ETXQ\STX\a\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\NUL\SOH\DC2\ETXQ\b\f\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\NUL\ETX\DC2\ETXQ\SI\DLE\n\+ \\235\SOH\n\+ \\EOT\EOT\NUL\STX\SOH\DC2\ETXV\STX\NAK\SUB\221\SOH A developer-facing error message, which should be in English. Any\n\+ \ user-facing error message should be localized and sent in the\n\+ \ [google.rpc.Status.details][google.rpc.Status.details] field, or localized by the client.\n\+ \\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\SOH\ENQ\DC2\ETXV\STX\b\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\SOH\SOH\DC2\ETXV\t\DLE\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\SOH\ETX\DC2\ETXV\DC3\DC4\n\+ \~\n\+ \\EOT\EOT\NUL\STX\STX\DC2\ETXZ\STX+\SUBq A list of messages that carry the error details. There will be a\n\+ \ common set of message types for APIs to use.\n\+ \\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\STX\EOT\DC2\ETXZ\STX\n\+ \\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\STX\ACK\DC2\ETXZ\v\RS\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\STX\SOH\DC2\ETXZ\US&\n\+ \\f\n\+ \\ENQ\EOT\NUL\STX\STX\ETX\DC2\ETXZ)*b\ACKproto3"
+ src/Network/GRPC/Spec.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE CPP #-}++-- | Pure implementation of the gRPC spec+--+-- Most code will not need to use this module directly.+--+-- Intended for unqualified import.+module Network.GRPC.Spec (+ -- * RPC+ IsRPC(..)+ , Input+ , Output+ , SupportsClientRpc(..)+ , SupportsServerRpc(..)+ , defaultRpcContentType+ -- ** Instances+ -- *** Protobuf+ , Protobuf+ , Proto(..)+ , getProto+ -- *** JSON+ , JsonRpc+ , JsonObject(..)+ , Required(..)+ , Optional(..)+ , DecodeFields -- opaque+ , EncodeFields -- opaque+ -- *** Raw+ , RawRpc+ -- * Streaming types+ , StreamingType(..)+ , SStreamingType(..)+ , ValidStreamingType(..)+ -- ** Link RPCs to streaming types+ , SupportsStreamingType+ , HasStreamingType(..)+ -- ** Handler type definition+ , NextElem(..)+ , Send+ , Recv+ , Positive+ , Negative(..)+ , HandlerRole(..)+ , Handler+ -- ** Handler newtype wrappers+ , ServerHandler'(..)+ , ServerHandler+ , ClientHandler'(..)+ , ClientHandler+ , hoistServerHandler+ -- * Compression+ , CompressionId(..)+ , Compression(..)+ , noCompression+ , gzip+ , allSupportedCompression+ , serializeCompressionId+ , deserializeCompressionId+ -- * Message metadata+ , OutboundMeta(..)+ , InboundMeta(..)+ -- * Requests+ , RequestHeaders_(..)+ , RequestHeaders+ , RequestHeaders'+ -- ** Parameters+ , CallParams(..)+ -- ** Pseudo-headers+ , PseudoHeaders(..)+ , ServerHeaders(..)+ , ResourceHeaders(..)+ , Path(..)+ , Address(..)+ , Scheme(..)+ , Method(..)+ , rpcPath+ -- ** Timeouts+ , Timeout(..)+ , TimeoutValue(..)+ , TimeoutUnit(..)+ , timeoutToMicro+ , isValidTimeoutValue+ -- * Responses+ -- ** Headers+ , ResponseHeaders_(..)+ , ResponseHeaders+ , ResponseHeaders'+ -- ** Trailers+ , ProperTrailers_(..)+ , ProperTrailers+ , ProperTrailers'+ , TrailersOnly_(..)+ , TrailersOnly+ , TrailersOnly'+ , Pushback(..)+ , simpleProperTrailers+ -- ** Termination+ , GrpcNormalTermination(..)+ , grpcExceptionToTrailers+ , grpcClassifyTermination+ , properTrailersToTrailersOnly+ , trailersOnlyToProperTrailers+ -- * Status+ , GrpcStatus(..)+ , GrpcError(..)+ -- ** Numerical status codes+ , fromGrpcStatus+ , fromGrpcError+ , toGrpcStatus+ , toGrpcError+ -- ** Exceptions+ , GrpcException(..)+ , throwGrpcError+ -- ** Details+ , Status+ -- * Metadata+ , CustomMetadata(CustomMetadata)+ , customMetadataName+ , customMetadataValue+ , safeCustomMetadata+ , HeaderName(BinaryHeader, AsciiHeader)+ , safeHeaderName+ , isValidAsciiValue+ , NoMetadata(..)+ , UnexpectedMetadata(..)+ -- ** Handling of duplicate metadata entries+ , CustomMetadataMap -- opaque+ , customMetadataMapFromList+ , customMetadataMapToList+ , customMetadataMapInsert+ -- ** Typed+ , RequestMetadata+ , ResponseInitialMetadata+ , ResponseTrailingMetadata+ , ResponseMetadata(..)+ -- ** Serialization+ , BuildMetadata(..)+ , ParseMetadata(..)+ , StaticMetadata(..)+ , buildMetadataIO+ -- * Invalid headers+ , InvalidHeaders(..)+ , InvalidHeader(..)+ -- ** Construction+ , invalidHeader+ , missingHeader+ , unexpectedHeader+ , invalidHeaderSynthesize+ , throwInvalidHeader+ -- ** Synthesized errors+ , HandledSynthesized+ , handledSynthesized+ , dropSynthesized+ , mapSynthesizedM+ , mapSynthesized+ , throwSynthesized+ -- ** Use+ , invalidHeaders+ , prettyInvalidHeaders+ , statusInvalidHeaders+ -- * Common infrastructure to all headers+ , ContentType(..)+ , chooseContentType+ , MessageType(..)+ , chooseMessageType+ -- * OpenTelemetry+ , TraceContext(..)+ , TraceId(..)+ , SpanId(..)+ , TraceOptions(..)+ -- * ORCA+ , OrcaLoadReport+ ) where++import Network.GRPC.Spec.Call+import Network.GRPC.Spec.Compression+import Network.GRPC.Spec.CustomMetadata.Map+import Network.GRPC.Spec.CustomMetadata.NoMetadata+import Network.GRPC.Spec.CustomMetadata.Raw+import Network.GRPC.Spec.CustomMetadata.Typed+import Network.GRPC.Spec.Headers.Common+import Network.GRPC.Spec.Headers.Invalid+import Network.GRPC.Spec.Headers.PseudoHeaders+import Network.GRPC.Spec.Headers.Request+import Network.GRPC.Spec.Headers.Response+import Network.GRPC.Spec.MessageMeta+import Network.GRPC.Spec.OrcaLoadReport+import Network.GRPC.Spec.RPC+import Network.GRPC.Spec.RPC.JSON+import Network.GRPC.Spec.RPC.Protobuf+import Network.GRPC.Spec.RPC.Raw+import Network.GRPC.Spec.RPC.StreamType+import Network.GRPC.Spec.Status+import Network.GRPC.Spec.Timeout+import Network.GRPC.Spec.TraceContext
+ src/Network/GRPC/Spec/Call.hs view
@@ -0,0 +1,57 @@+module Network.GRPC.Spec.Call (+ -- * Parameters+ CallParams -- opaque+ , callTimeout+ , callRequestMetadata+ ) where++import Data.Default+import Data.Functor.Const++import Network.GRPC.Spec.CustomMetadata.Typed+import Network.GRPC.Spec.Timeout++{-------------------------------------------------------------------------------+ Parameters++ NOTE: 'CallParams' is re-exported as is in the Client API.+-------------------------------------------------------------------------------}++-- | RPC parameters that can be chosen on a per-call basis+data CallParams rpc = CallParams {+ -- | Timeout+ --+ -- Tell the server that if the request cannot be completed within the+ -- specified amount of time, it should be aborted. If the timeout gets+ -- exceeded, a 'Network.GRPC.Common.GrpcDeadlineExceeded' exception will+ -- be raised.+ callTimeout :: Maybe Timeout++ -- | Custom metadata to be included in the request+ , callRequestMetadata :: RequestMetadata rpc++ -- | Type hack: fix the type of @rpc@+ --+ -- Without the presence of this field, something like+ --+ -- > callParams :: CallParams SomeSpecificRPC+ -- > callParams = def { callRequestMetata = .. }+ --+ -- would result in a type error about @rpc@ being ambiguous for @def@;+ -- after all, we have a type changing override here, so the choice of+ -- @rpc@ for @def@ is undetermined. The presence of 'callFixTypeOfRPC'+ -- (which is not exported) means that field overrides will never change+ -- the overall type of the parameters.+ , callFixTypeOfRPC :: Const () rpc+ }++deriving instance (Show (RequestMetadata rpc)) => Show (CallParams rpc)++-- | Default t'CallParams'+instance Default (RequestMetadata rpc) => Default (CallParams rpc) where+ def = CallParams {+ callTimeout = Nothing+ , callRequestMetadata = def+ , callFixTypeOfRPC = Const ()+ }+
+ src/Network/GRPC/Spec/Compression.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Compression+--+-- Intended for unqualified import.+module Network.GRPC.Spec.Compression (+ -- * Definition+ Compression(..)+ , noCompression+ , gzip+ , allSupportedCompression+ , compressionIsIdentity+ -- ** ID+ , CompressionId(..)+ , serializeCompressionId+ , deserializeCompressionId+ ) where++import Codec.Compression.GZip qualified as GZip+import Codec.Compression.Zlib qualified as Deflate+import Data.ByteString qualified as Strict (ByteString)+import Data.ByteString.Lazy qualified as Lazy (ByteString)+import Data.ByteString.UTF8 qualified as BS.Strict.UTF8+import Data.Int (Int64)+import Data.List.NonEmpty (NonEmpty(..))+import Data.String+import GHC.Generics (Generic)++#ifdef SNAPPY+import Codec.Compression.SnappyC.Framed qualified as Snappy+#endif++{-------------------------------------------------------------------------------+ Definition+-------------------------------------------------------------------------------}++-- | Compression scheme+data Compression = Compression {+ -- | Compression identifier+ compressionId :: CompressionId++ -- | Compress+ , compress :: Lazy.ByteString -> Lazy.ByteString++ -- | Decompress+ --+ -- TODO: <https://github.com/well-typed/grapesy/issues/57>.+ -- We need to deal with decompression failures.+ , decompress :: Lazy.ByteString -> Lazy.ByteString++ -- | Uncompressed size threshold+ --+ -- Compression is only useful for uncompressed data sizes satisfying this+ -- predicate.+ , uncompressedSizeThreshold :: Int64 -> Bool+ }++instance Show Compression where+ show Compression{compressionId} = "<Compression " ++ show compressionId ++ ">"++-- | All supported compression algorithms supported+--+-- The order of this list is important: algorithms listed earlier are preferred+-- over algorithms listed later.+allSupportedCompression :: NonEmpty Compression+allSupportedCompression =+ gzip :|+ [ deflate+#ifdef SNAPPY+ , snappy+#endif+ , noCompression+ ]++{-------------------------------------------------------------------------------+ Compression ID+-------------------------------------------------------------------------------}++-- | Compression ID+--+-- The gRPC specification defines+--+-- > Content-Coding → "identity" / "gzip" / "deflate" / "snappy" / {custom}+data CompressionId =+ Identity+ | GZip+ | Deflate+ | Snappy+ | Custom String+ deriving stock (Eq, Ord, Generic)++-- | Serialize compression ID+serializeCompressionId :: CompressionId -> Strict.ByteString+serializeCompressionId Identity = "identity"+serializeCompressionId GZip = "gzip"+serializeCompressionId Deflate = "deflate"+serializeCompressionId Snappy = "snappy"+serializeCompressionId (Custom i) = BS.Strict.UTF8.fromString i++-- | Parse compression ID+deserializeCompressionId :: Strict.ByteString -> CompressionId+deserializeCompressionId "identity" = Identity+deserializeCompressionId "gzip" = GZip+deserializeCompressionId "deflate" = Deflate+deserializeCompressionId "snappy" = Snappy+deserializeCompressionId i = Custom (BS.Strict.UTF8.toString i)++instance Show CompressionId where+ show = BS.Strict.UTF8.toString . serializeCompressionId++instance IsString CompressionId where+ fromString = deserializeCompressionId . BS.Strict.UTF8.fromString++compressionIsIdentity :: Compression -> Bool+compressionIsIdentity = (== Identity) . compressionId++{-------------------------------------------------------------------------------+ Compression algorithms+-------------------------------------------------------------------------------}++-- | Disable compression (referred to as @identity@ in the gRPC spec)+noCompression :: Compression+noCompression = Compression {+ compressionId = Identity+ , compress = id+ , decompress = id+ , uncompressedSizeThreshold = const False+ }++-- | @gzip@+gzip :: Compression+gzip = Compression {+ compressionId = GZip+ , compress = GZip.compress+ , decompress = GZip.decompress++ -- gzip only achieves a compression ratio of 8:7 for messages of at least+ -- 27 bytes.+ , uncompressedSizeThreshold = (>= 27)+ }++-- | @zlib@ (aka @deflate@) compression+--+-- Note: The gRPC spec calls this "deflate", but it is /not/ raw deflate+-- format. The expected format (at least by the python server) is just zlib+-- (which is an envelope holding the deflate data).+deflate :: Compression+deflate = Compression {+ compressionId = Deflate+ , compress = Deflate.compress+ , decompress = Deflate.decompress++ -- zlib deflate only achieves a compression ratio of 8:7 for messages of+ -- at least 13 bytes.+ , uncompressedSizeThreshold = (>= 13)+ }++#ifdef SNAPPY+-- | Snappy compression+snappy :: Compression+snappy = Compression {+ compressionId = Snappy+ , compress = Snappy.compress+ , decompress = Snappy.decompress++ -- snappy only achieves a compression ratio of 8:7 for messages of at+ -- least 28 bytes.+ , uncompressedSizeThreshold = (>= 28)+ }+#endif
+ src/Network/GRPC/Spec/CustomMetadata/Map.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Map of t'CustomMetadata', handling joining values+module Network.GRPC.Spec.CustomMetadata.Map (+ CustomMetadataMap -- opaque+ -- * Conversion+ , customMetadataMapFromList+ , customMetadataMapToList+ -- * Construction+ , customMetadataMapInsert+ ) where++import Data.ByteString qualified as Strict (ByteString)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (fromMaybe)+import GHC.Generics (Generic)++import Network.GRPC.Spec.CustomMetadata.Raw++{-------------------------------------------------------------------------------+ Definition+-------------------------------------------------------------------------------}++-- | Map from header names to values+--+-- The gRPC spec mandates+--+-- > Custom-Metadata header order is not guaranteed to be preserved except for+-- > values with duplicate header names. Duplicate header names may have their+-- > values joined with "," as the delimiter and be considered semantically+-- > equivalent.+--+-- Internally we don't allow for these duplicates, but instead join the headers+-- as mandated by the spec.+newtype CustomMetadataMap = CustomMetadataMap {+ getCustomMetadataMap :: Map HeaderName Strict.ByteString+ }+ deriving stock (Show, Eq, Generic)++{-------------------------------------------------------------------------------+ Dealing with duplicates+-------------------------------------------------------------------------------}++instance Monoid CustomMetadataMap where+ mempty = CustomMetadataMap Map.empty++instance Semigroup CustomMetadataMap where+ CustomMetadataMap x <> CustomMetadataMap y = CustomMetadataMap $+ Map.unionWith joinHeaderValue x y++{-------------------------------------------------------------------------------+ Conversion+-------------------------------------------------------------------------------}++-- | Construct t'CustomMetadataMap', joining duplicates+customMetadataMapFromList :: [CustomMetadata] -> CustomMetadataMap+customMetadataMapFromList =+ CustomMetadataMap+ . Map.fromListWith joinHeaderValue+ . map unpairCustomMetadata++-- | Flatten t'CustomMetadataMap' to a list+--+-- Precondition: the map must be valid.+customMetadataMapToList :: CustomMetadataMap -> [CustomMetadata]+customMetadataMapToList mds =+ map pairCustomMetadata+ . Map.toList+ . getCustomMetadataMap+ $ mds++{-------------------------------------------------------------------------------+ Construction+-------------------------------------------------------------------------------}++-- | Insert value into t'CustomMetadataMap'+--+-- If a header with the same name already exists, the value is appended to+-- (the end of) the existing value.+customMetadataMapInsert ::+ CustomMetadata+ -> CustomMetadataMap -> CustomMetadataMap+customMetadataMapInsert (CustomMetadata name value) (CustomMetadataMap mds) =+ CustomMetadataMap $+ Map.insertWith (flip joinHeaderValue) name value mds++{-------------------------------------------------------------------------------+ Internal auxiliary+-------------------------------------------------------------------------------}++joinHeaderValue :: Strict.ByteString -> Strict.ByteString -> Strict.ByteString+joinHeaderValue x y = x <> "," <> y++unpairCustomMetadata :: CustomMetadata -> (HeaderName, Strict.ByteString)+unpairCustomMetadata (CustomMetadata name value) = (name, value)++pairCustomMetadata :: (HeaderName, Strict.ByteString) -> CustomMetadata+pairCustomMetadata md =+ fromMaybe (error $ "invalid " ++ show md) $+ uncurry safeCustomMetadata md
+ src/Network/GRPC/Spec/CustomMetadata/NoMetadata.hs view
@@ -0,0 +1,28 @@+module Network.GRPC.Spec.CustomMetadata.NoMetadata (+ NoMetadata(..)+ ) where++import Control.Monad.Catch+import Data.Default++import Network.GRPC.Spec.CustomMetadata.Typed++-- | Indicate the absence of custom metadata+--+-- NOTE: The 'ParseMetadata' instance for 'NoMetadata' throws an exception if+-- any metadata is present (that is, metadata is /not/ silently ignored).+data NoMetadata = NoMetadata+ deriving stock (Show, Eq)++instance Default NoMetadata where+ def = NoMetadata++instance BuildMetadata NoMetadata where+ buildMetadata NoMetadata = []++instance ParseMetadata NoMetadata where+ parseMetadata [] = return NoMetadata+ parseMetadata hdrs = throwM $ UnexpectedMetadata hdrs++instance StaticMetadata NoMetadata where+ metadataHeaderNames _ = []
+ src/Network/GRPC/Spec/CustomMetadata/Raw.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Custom metadata+--+-- These are application-defined headers/trailers.+--+-- Intended for unqualified import.+module Network.GRPC.Spec.CustomMetadata.Raw (+ -- * Definition+ CustomMetadata(CustomMetadata)+ , customMetadataName+ , customMetadataValue+ , safeCustomMetadata+ , HeaderName(BinaryHeader, AsciiHeader)+ , safeHeaderName+ , isValidAsciiValue+ ) where++import Control.DeepSeq (NFData)+import Control.Monad+import Data.ByteString qualified as BS.Strict+import Data.ByteString qualified as Strict (ByteString)+import Data.List qualified as List+import Data.Maybe (fromMaybe)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.String+import Data.Word+import GHC.Generics (Generic)+import GHC.Show+import GHC.Stack++import Network.GRPC.Spec.Util.ByteString (strip, ascii)++{-------------------------------------------------------------------------------+ Definition++ > Custom-Metadata → Binary-Header / ASCII-Header+ > Binary-Header → {Header-Name "-bin" } {base64 encoded value}+ > ASCII-Header → Header-Name ASCII-Value++ Implementation note: ASCII headers and binary headers are distinguished based+ on their name (see 'HeaderName'). We do /not/ introduce a different type for+ the /values/ of such headers, because if we did, we would then need additional+ machinery to make sure that binary header names are paired with binary header+ values, and similarly for ASCII headers, with little benefit. Instead we check+ in the smart constructor for 'CustomMetadata' that the header value satisfies+ the rules for the particular type of header.+-------------------------------------------------------------------------------}++-- | Custom metadata+--+-- This is an arbitrary set of key-value pairs defined by the application layer.+--+-- Custom metadata order is not guaranteed to be preserved except for values+-- with duplicate header names. Duplicate header names may have their values+-- joined with "," as the delimiter and be considered semantically equivalent.+data CustomMetadata = UnsafeCustomMetadata {+ -- | Header name+ --+ -- The header name determines if this is an ASCII header or a binary+ -- header; see the t'CustomMetadata' pattern synonym.+ customMetadataName :: HeaderName++ -- | Header value+ , customMetadataValue :: Strict.ByteString+ }+ deriving stock (Eq, Generic)+ deriving anyclass (NFData)++-- | 'Show' instance relies on the v'CustomMetadata' pattern synonym+instance Show CustomMetadata where+ showsPrec p (UnsafeCustomMetadata name value) = showParen (p >= appPrec1) $+ showString "CustomMetadata "+ . showsPrec appPrec1 name+ . showSpace+ . showsPrec appPrec1 value++-- | Check for valid ASCII header value+--+-- > ASCII-Value → 1*( %x20-%x7E ) ; space and printable ASCII+--+-- NOTE: By rights this should verify that the header is non-empty. However,+-- empty header values do occasionally show up, and so we permit them. The main+-- reason for checking for validity at all is to ensure that we don't confuse+-- binary headers and ASCII headers.+isValidAsciiValue :: Strict.ByteString -> Bool+isValidAsciiValue bs = BS.Strict.all (\c -> 0x20 <= c && c <= 0x7E) bs++-- | Construct t'CustomMetadata'+--+-- Returns 'Nothing' if the 'HeaderName' indicates an ASCII header but the+-- value is not valid ASCII (consider using a binary header instead).+safeCustomMetadata :: HeaderName -> Strict.ByteString -> Maybe CustomMetadata+safeCustomMetadata name value =+ case name of+ UnsafeAsciiHeader _ -> do+ guard $ isValidAsciiValue value+ return $ UnsafeCustomMetadata name (strip value)+ UnsafeBinaryHeader _ ->+ -- Values of binary headers are not subject to any constraints+ return $ UnsafeCustomMetadata name value++pattern CustomMetadata ::+ HasCallStack+ => HeaderName -> Strict.ByteString -> CustomMetadata+pattern CustomMetadata name value <- UnsafeCustomMetadata name value+ where+ CustomMetadata name value =+ fromMaybe (invalid constructedForError) $+ safeCustomMetadata name value+ where+ constructedForError :: CustomMetadata+ constructedForError = UnsafeCustomMetadata name value++{-# COMPLETE CustomMetadata #-}++{-------------------------------------------------------------------------------+ Header-Name++ > Header-Name → 1*( %x30-39 / %x61-7A / "_" / "-" / ".") ; 0-9 a-z _ - .+----------------------\--------------------------------------------------------}++-- | Header name+--+-- To construct a 'HeaderName', you can either use the 'IsString' instance+--+-- > "foo" :: HeaderName -- an ASCII header+-- > "bar-bin" :: HeaderName -- a binary header+--+-- or alternatively use the 'AsciiHeader' and 'BinaryHeader' patterns+--+-- > AsciiHeader "foo"+-- > BinaryHeader "bar-bin"+--+-- The latter style is more explicit, and can catch more errors:+--+-- > AsciiHeader "foo-bin" -- exception: unexpected -bin suffix+-- > BinaryHeader "bar" -- exception: expected -bin suffix+--+-- Header names cannot be empty, and must consist of digits (@0-9@), lowercase+-- letters (@a-z@), underscore (@_@), hyphen (@-@), or period (@.@).+-- Reserved header names are disallowed.+--+-- See also 'safeHeaderName'.+data HeaderName =+ -- | Binary header+ --+ -- Binary headers will be base-64 encoded.+ --+ -- The header name must have a @-bin@ suffix (runtime libraries use this+ -- suffix to detect binary headers and properly apply base64 encoding &+ -- decoding as headers are sent and received).+ --+ -- Since this is binary data, padding considerations do not apply.+ UnsafeBinaryHeader Strict.ByteString++ -- | ASCII header+ --+ -- ASCII headers cannot be empty, and can only use characters in the range+ -- @0x20 .. 0x7E@. Note that although this range includes whitespace, any+ -- padding will be removed when constructing the value.+ --+ -- The gRPC spec is not precise about what exactly constitutes \"padding\",+ -- but the ABNF spec defines it as "space and horizontal tab"+ -- <https://www.rfc-editor.org/rfc/rfc5234#section-3.1>.+ | UnsafeAsciiHeader Strict.ByteString+ deriving stock (Eq, Ord, Generic)+ deriving anyclass (NFData)++pattern BinaryHeader :: HasCallStack => Strict.ByteString -> HeaderName+pattern BinaryHeader name <- UnsafeBinaryHeader name+ where+ BinaryHeader name =+ case safeHeaderName name of+ Just name'@UnsafeBinaryHeader{} ->+ name'+ Just UnsafeAsciiHeader{} ->+ error "binary headers must have -bin suffix"+ Nothing ->+ error $ "Invalid header name " ++ show name++pattern AsciiHeader :: HasCallStack => Strict.ByteString -> HeaderName+pattern AsciiHeader name <- UnsafeAsciiHeader name+ where+ AsciiHeader name =+ case safeHeaderName name of+ Just name'@UnsafeAsciiHeader{} ->+ name'+ Just UnsafeBinaryHeader{} ->+ error "ASCII headers cannot have -bin suffix"+ Nothing ->+ error $ "Invalid header name " ++ show name++{-# COMPLETE BinaryHeader, AsciiHeader #-}++-- | Check for header name validity+--+-- We choose between 'BinaryHeader' and 'AsciiHeader' based on the presence or+-- absence of a @-bin suffix.+safeHeaderName :: Strict.ByteString -> Maybe HeaderName+safeHeaderName bs = do+ guard $ BS.Strict.length bs >= 1+ guard $ BS.Strict.all isValidChar bs+ guard $ not $ "grpc-" `BS.Strict.isPrefixOf` bs+ guard $ not $ bs `Set.member` reservedNames+ return $ if "-bin" `BS.Strict.isSuffixOf` bs+ then UnsafeBinaryHeader bs+ else UnsafeAsciiHeader bs+ where+ isValidChar :: Word8 -> Bool+ isValidChar c = or [+ 0x30 <= c && c <= 0x39+ , 0x61 <= c && c <= 0x7A+ , c == ascii '_'+ , c == ascii '-'+ , c == ascii '.'+ ]++ -- Reserved header names that do not start with @grpc-@+ reservedNames :: Set Strict.ByteString+ reservedNames = Set.fromList [+ "user-agent"+ , "content-type"+ , "te"+ , "trailer"+ ]++instance IsString HeaderName where+ fromString str =+ fromMaybe (invalid constructedForError) $+ safeHeaderName (fromString str)+ where+ constructedForError :: HeaderName+ constructedForError =+ if "-bin" `List.isSuffixOf` str+ then UnsafeBinaryHeader $ fromString str+ else UnsafeAsciiHeader $ fromString str++-- | 'Show' instance relies on the 'IsString' instance+instance Show HeaderName where+ show (UnsafeBinaryHeader name) = show name+ show (UnsafeAsciiHeader name) = show name++{-------------------------------------------------------------------------------+ Internal auxiliary+-------------------------------------------------------------------------------}++invalid :: (Show a, HasCallStack) => a -> b+invalid x = error $ "Invalid: " ++ show x ++ " at "
+ src/Network/GRPC/Spec/CustomMetadata/Typed.hs view
@@ -0,0 +1,133 @@+module Network.GRPC.Spec.CustomMetadata.Typed (+ -- * Map RPC to metadata+ RequestMetadata+ , ResponseInitialMetadata+ , ResponseTrailingMetadata+ , ResponseMetadata(..)+ -- * Serialization+ , BuildMetadata(..)+ , StaticMetadata(..)+ , ParseMetadata(..)+ , UnexpectedMetadata(..)+ , buildMetadataIO+ ) where++import Control.DeepSeq (force)+import Control.Exception+import Control.Monad.Catch+import Data.Kind+import Data.Proxy++import Network.GRPC.Spec.CustomMetadata.Raw++{-------------------------------------------------------------------------------+ Map RPC to metadata+-------------------------------------------------------------------------------}++-- | Metadata included in the request+--+-- Often you can give a blanket metadata definition for all methods in a+-- service. For example:+--+-- > type instance RequestMetadata (Protobuf RouteGuide meth) = NoMetadata+-- > type instance ResponseInitialMetadata (Protobuf RouteGuide meth) = NoMetadata+-- > type instance ResponseTrailingMetadata (Protobuf RouteGuide meth) = NoMetadata+--+-- If you want to give specific types of metadata for specific methods but not+-- for others, it can sometimes be useful to introduce an auxiliary closed type,+-- so that you can give a catch-all case. For example:+--+-- > type instance ResponseInitialMetadata (Protobuf Greeter meth) = GreeterResponseInitialMetadata meth+-- >+-- > type family GreeterResponseInitialMetadata (meth :: Symbol) where+-- > GreeterResponseInitialMetadata "sayHelloStreamReply" = SayHelloMetadata+-- > GreeterResponseInitialMetadata meth = NoMetadata+type family RequestMetadata (rpc :: k) :: Type++-- | Metadata included in the initial response+--+-- See 'RequestMetadata' for discussion.+type family ResponseInitialMetadata (rpc :: k) :: Type++-- | Metadata included in the response trailers+--+-- See 'RequestMetadata' for discussion.+type family ResponseTrailingMetadata (rpc :: k) :: Type++-- | Response metadata+--+-- It occassionally happens that we do not know if we should expect the initial+-- metadata from the server or the trailing metadata (when the server uses+-- Trailers-Only); for example, see+-- 'Network.GRPC.Client.recvResponseInitialMetadata'.+data ResponseMetadata rpc =+ ResponseInitialMetadata (ResponseInitialMetadata rpc)+ | ResponseTrailingMetadata (ResponseTrailingMetadata rpc)++deriving stock instance+ ( Show (ResponseInitialMetadata rpc)+ , Show (ResponseTrailingMetadata rpc)+ )+ => Show (ResponseMetadata rpc)++deriving stock instance+ ( Eq (ResponseInitialMetadata rpc)+ , Eq (ResponseTrailingMetadata rpc)+ )+ => Eq (ResponseMetadata rpc)++{-------------------------------------------------------------------------------+ Serialization+-------------------------------------------------------------------------------}++-- | Serialize metadata to custom metadata headers+class BuildMetadata a where+ buildMetadata :: a -> [CustomMetadata]++-- | Wrapper around 'buildMetadata' that catches any pure exceptions+--+-- These pure exceptions can arise when invalid headers are generated (for+-- example, ASCII headers with non-ASCII values).+buildMetadataIO :: BuildMetadata a => a -> IO [CustomMetadata]+buildMetadataIO = evaluate . force . buildMetadata++-- | Metadata with statically known fields+--+-- This is required for the response trailing metadata. When the server sends+-- the /initial/ set of headers to the client, it must tell the client which+-- trailers to expect (by means of the HTTP @Trailer@ header; see+-- <https://datatracker.ietf.org/doc/html/rfc7230#section-4.4>).+--+-- Any headers constructed in 'buildMetadata' /must/ be listed here; not doing+-- so is a bug. However, the converse is not true: it is acceptable for a header+-- to be listed in 'metadataHeaderNames' but not in 'buildMetadata'. Put another+-- way: the list of "trailers to expect" included in the initial request headers+-- is allowed to be an overapproximation, but not an underapproximation.+class BuildMetadata a => StaticMetadata a where+ metadataHeaderNames :: Proxy a -> [HeaderName]++-- | Parse metadata from custom metadata headers+--+-- Some guidelines for defining instances:+--+-- * You can assume that the list of headers will not contain duplicates. The+-- gRPC spec /does/ allow for duplicate headers and specifies how to process+-- them, but this will be taken care of before 'parseMetadata' is called.+-- * However, you should assume no particular /order/.+-- * If there are unexpected headers present, you have a choice whether you want+-- to consider this a error and throw an exception, or regard the additional+-- headers as merely additional information and simply ignore them. There is+-- no single right answer here: ignoring additional metadata runs the risk of+-- not realizing that the peer is trying to tell you something important, but+-- throwing an error runs the risk of unnecessarily aborting an RPC.+class ParseMetadata a where+ parseMetadata :: MonadThrow m => [CustomMetadata] -> m a++-- | Unexpected metadata+--+-- This exception can be thrown in 'ParseMetadata' instances. See 'ParseMetadata'+-- for discussion.+data UnexpectedMetadata = UnexpectedMetadata [CustomMetadata]+ deriving stock (Show)+ deriving anyclass (Exception)+
+ src/Network/GRPC/Spec/Headers/Common.hs view
@@ -0,0 +1,86 @@+-- | Functionality shared between requests and responses+--+-- The following headers are used both in requests and in responses:+--+-- * @Content-Type@+-- * @Message-Encoding@+-- * @Message-Accept-Encoding@+-- * @Custom-Metadata@ (see "Network.GRPC.Spec.CustomMetadata")+--+-- We also define 'MessageType' here, which is currently only used for request+-- headers, but at least morally speaking seems to apply the response just the+-- same.+--+-- Intended for unqualified import.+module Network.GRPC.Spec.Headers.Common (+ -- * Content type+ ContentType(..)+ , chooseContentType+ -- * Message type+ , MessageType(..)+ , chooseMessageType+ ) where++import Data.ByteString qualified as Strict (ByteString)+import Data.Default+import Data.Proxy+import GHC.Generics (Generic)++import Network.GRPC.Spec.RPC++{-------------------------------------------------------------------------------+ ContentType+-------------------------------------------------------------------------------}++-- | Content type+data ContentType =+ -- | The default content type for this RPC+ --+ -- This is given by 'rpcContentType', and is typically+ -- @application/grpc+format@, where @format@ is @proto@, @json@, .. (see+ -- also 'defaultRpcContentType').+ ContentTypeDefault++ -- | Override the content type+ --+ -- Depending on the choice of override, this may or may not be conform spec.+ -- See <https://datatracker.ietf.org/doc/html/rfc2045#section-5> for a spec+ -- of the Content-Type header; the gRPC spec however disallows most of what+ -- is technically allowed by this RPC.+ | ContentTypeOverride Strict.ByteString+ deriving stock (Show, Eq, Generic)++instance Default ContentType where+ def = ContentTypeDefault++-- | Interpret 'ContentType'+chooseContentType :: IsRPC rpc => Proxy rpc -> ContentType -> Strict.ByteString+chooseContentType p ContentTypeDefault = rpcContentType p+chooseContentType _ (ContentTypeOverride ct) = ct++{-------------------------------------------------------------------------------+ MessageType+-------------------------------------------------------------------------------}++-- | Message type+data MessageType =+ -- | Default message type for this RPC+ --+ -- This is given by 'rpcMessageType'. For the specific case Protobuf this+ -- is the fully qualified proto message name (and we currently omit the+ -- @grpc-message-type@ header altogether for JSON).+ MessageTypeDefault++ -- | Override the message type+ | MessageTypeOverride Strict.ByteString+ deriving stock (Show, Eq, Generic)++instance Default MessageType where+ def = MessageTypeDefault++-- | Interpret 'MessageType'+chooseMessageType ::+ IsRPC rpc+ => Proxy rpc -> MessageType -> Maybe Strict.ByteString+chooseMessageType p MessageTypeDefault = rpcMessageType p+chooseMessageType _ (MessageTypeOverride mt) = Just mt
+ src/Network/GRPC/Spec/Headers/Invalid.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Dealing with invalid headers+module Network.GRPC.Spec.Headers.Invalid (+ InvalidHeaders(..)+ , InvalidHeader(..)+ -- * Construction+ , invalidHeader+ , missingHeader+ , unexpectedHeader+ , invalidHeaderSynthesize+ , throwInvalidHeader+ -- * Synthesized errors+ , HandledSynthesized+ , handledSynthesized+ , dropSynthesized+ , mapSynthesized+ , mapSynthesizedM+ , throwSynthesized+ -- * Utility+ , invalidHeaders+ , prettyInvalidHeaders+ , statusInvalidHeaders+ ) where++import Control.Monad.Except+import Data.ByteString.Builder qualified as Builder+import Data.ByteString.Builder qualified as ByteString (Builder)+import Data.ByteString.UTF8 qualified as BS.UTF8+import Data.CaseInsensitive qualified as CI+import Data.Foldable (asum)+import Data.Functor.Identity+import Data.Maybe (fromMaybe, mapMaybe)+import Network.HTTP.Types qualified as HTTP++import Network.GRPC.Spec.Status+import Network.GRPC.Spec.Util.HKD (Checked)+import Network.GRPC.Spec.Util.HKD qualified as HKD++{-------------------------------------------------------------------------------+ Definition+-------------------------------------------------------------------------------}++-- | Invalid headers+--+-- This is used for request headers, response headers, and response trailers.+newtype InvalidHeaders e = InvalidHeaders {+ getInvalidHeaders :: [InvalidHeader e]+ }+ deriving stock (Show, Eq)+ deriving newtype (Semigroup, Monoid)++-- | Invalid header+--+-- This corresponds to a single \"raw\" HTTP header. It is possible that a+-- particular field of, say, 'Network.GRPC.Spec.Headers.Request.RequestHeaders'+-- corresponds to /multiple/ t'InvalidHeader', when the value of that field is+-- determined by combining multiple HTTP headers. A special case of this is the+-- field for unrecognized headers (see+-- 'Network.GRPC.Spec.Headers.Request.requestUnrecognized',+-- 'Network.GRPC.Spec.Headers.Response.responseUnrecognized', etc.), which+-- collects /all/ unrecognized headers in one field (and has value @()@ if there+-- are none).+--+-- For some invalid headers the gRPC spec mandates a specific HTTP status;+-- if this status is not specified, then we use 400 Bad Request.+data InvalidHeader e =+ -- | We failed to parse this header+ --+ -- We record the original header and the reason parsing failed.+ InvalidHeader (Maybe HTTP.Status) HTTP.Header String++ -- | Missing header (header that should have been present but was not)+ | MissingHeader (Maybe HTTP.Status) HTTP.HeaderName++ -- | Unexpected header (header that should not have been present but was)+ | UnexpectedHeader HTTP.HeaderName++ -- | Synthesize gRPC exception+ --+ -- This will be instantiated to 'Network.GRPC.Spec.GrpcException' after+ -- parsing, and to 'HandledSynthesized' once synthesized errors have been+ -- handled. See 'HandledSynthesized' for more details.+ --+ -- We record both the actual error and the synthesized error.+ | InvalidHeaderSynthesize e (InvalidHeader HandledSynthesized)+ deriving stock (Show, Eq)++{-------------------------------------------------------------------------------+ Construction+-------------------------------------------------------------------------------}++-- | Convenience constructor around v'InvalidHeader'+invalidHeader :: Maybe HTTP.Status -> HTTP.Header -> String -> InvalidHeaders e+invalidHeader status hdr err = wrapOne $ InvalidHeader status hdr err++-- | Convenience constructor around v'MissingHeader'+missingHeader :: Maybe HTTP.Status -> HTTP.HeaderName -> InvalidHeaders e+missingHeader status name = wrapOne $ MissingHeader status name++-- | Convenience constructor around v'UnexpectedHeader'+unexpectedHeader :: HTTP.HeaderName -> InvalidHeaders e+unexpectedHeader name = wrapOne $ UnexpectedHeader name++-- | Convenience constructor around v'InvalidHeaderSynthesize'+invalidHeaderSynthesize ::+ e+ -> InvalidHeader HandledSynthesized+ -> InvalidHeaders e+invalidHeaderSynthesize e orig = wrapOne $ InvalidHeaderSynthesize e orig++-- | Convenience function for throwing an 'invalidHeader' exception.+throwInvalidHeader ::+ MonadError (InvalidHeaders e) m+ => HTTP.Header+ -> Either String a+ -> m a+throwInvalidHeader _ (Right a) = return a+throwInvalidHeader hdr (Left err) = throwError $ invalidHeader Nothing hdr err++{-------------------------------------------------------------------------------+ Synthesized errors+-------------------------------------------------------------------------------}++-- | Indicate that all synthesized errors have been handled+--+-- For some headers the gRPC spec mandates a specific gRPC error that should+-- be synthesized when the header is invalid. We use 'HandledSynthesized'+-- in types to indicate that all errors that should have been synthesized have+-- already been thrown.+--+-- For example, 'Network.GRPC.Spec.RequestHeaders'' 'HandledSynthesized'+-- indicates that these request headers may still contain errors for some+-- headers, but no errors for which the spec mandates that we synthesize a+-- specific gRPC exception.+data HandledSynthesized++instance Show HandledSynthesized where+ show = handledSynthesized++instance Eq HandledSynthesized where+ x == _ = handledSynthesized x++-- | Evidence that 'HandledSynthesized' is an empty type+handledSynthesized :: HandledSynthesized -> a+handledSynthesized x = case x of {}++-- | Drop all synthesized errors, leaving just the original+dropSynthesized :: InvalidHeaders e -> InvalidHeaders HandledSynthesized+dropSynthesized = \(InvalidHeaders es) ->+ InvalidHeaders $ map aux es+ where+ aux :: InvalidHeader e -> InvalidHeader HandledSynthesized+ aux (InvalidHeader status (name, value) err) =+ InvalidHeader status (name, value) err+ aux (MissingHeader status name) =+ MissingHeader status name+ aux (UnexpectedHeader name) =+ UnexpectedHeader name+ aux (InvalidHeaderSynthesize _ orig) =+ orig++-- | Map over the errors+mapSynthesizedM :: forall m e e'.+ Monad m+ => (e -> m e')+ -> InvalidHeaders e+ -> m (InvalidHeaders e')+mapSynthesizedM f = \(InvalidHeaders es) ->+ InvalidHeaders <$> go [] es+ where+ go :: [InvalidHeader e'] -> [InvalidHeader e] -> m [InvalidHeader e']+ go acc [] = pure $ reverse acc+ go acc (x:xs) =+ case x of+ InvalidHeader status (name, value) err ->+ go (InvalidHeader status (name, value) err : acc) xs+ MissingHeader status name ->+ go (MissingHeader status name : acc) xs+ UnexpectedHeader name ->+ go (UnexpectedHeader name : acc) xs+ InvalidHeaderSynthesize e orig -> do+ e' <- f e+ go (InvalidHeaderSynthesize e' orig : acc) xs++-- | Pure version of 'mapSynthesizedM'+mapSynthesized :: (e -> e') -> InvalidHeaders e -> InvalidHeaders e'+mapSynthesized f = runIdentity . mapSynthesizedM (Identity . f)++-- | Throw all synthesized errors+--+-- After this we are guaranteed that the synthesized errors have been handlded.+throwSynthesized ::+ (HKD.Traversable h, Monad m)+ => (forall a. GrpcException -> m a)+ -> h (Checked (InvalidHeaders GrpcException))+ -> m (h (Checked (InvalidHeaders HandledSynthesized)))+throwSynthesized throw =+ HKD.traverse $+ either+ (fmap Left . mapSynthesizedM throw)+ (fmap Right . return)++{-------------------------------------------------------------------------------+ Utility+-------------------------------------------------------------------------------}++-- | Extract all invalid headers+invalidHeaders :: InvalidHeaders e -> [HTTP.Header]+invalidHeaders = \invalid ->+ case dropSynthesized invalid of+ InvalidHeaders es -> mapMaybe aux es+ where+ aux :: InvalidHeader HandledSynthesized -> Maybe HTTP.Header+ aux (InvalidHeader _status hdr _) = Just hdr+ aux MissingHeader{} = Nothing+ aux UnexpectedHeader{} = Nothing+ aux (InvalidHeaderSynthesize e _) = handledSynthesized e++-- | Render t'InvalidHeaders'+prettyInvalidHeaders :: InvalidHeaders HandledSynthesized -> ByteString.Builder+prettyInvalidHeaders = mconcat . map go . getInvalidHeaders+ where+ go :: InvalidHeader HandledSynthesized -> ByteString.Builder+ go (InvalidHeader _status (name, value) err) = mconcat [+ "Invalid header '"+ , Builder.byteString (CI.original name)+ , "' with value '"+ , Builder.byteString value+ , "': "+ , Builder.byteString $ BS.UTF8.fromString err+ , "\n"+ ]+ go (MissingHeader _status name) = mconcat [+ "Missing header '"+ , Builder.byteString (CI.original name)+ , "'\n"+ ]+ go (UnexpectedHeader name) = mconcat [+ "Unexpected header '"+ , Builder.byteString (CI.original name)+ , "'\n"+ ]+ go (InvalidHeaderSynthesize e _orig) =+ handledSynthesized e++-- | HTTP status to report+--+-- If there are multiple headers, each of which with a mandated status, we+-- just use the first; the spec is essentially ambiguous in this case.+statusInvalidHeaders :: InvalidHeaders HandledSynthesized -> HTTP.Status+statusInvalidHeaders (InvalidHeaders hs) =+ fromMaybe HTTP.badRequest400 $ asum $ map getStatus hs+ where+ getStatus :: InvalidHeader HandledSynthesized -> Maybe HTTP.Status+ getStatus (InvalidHeader status _ _) = status+ getStatus (MissingHeader status _) = status+ getStatus (UnexpectedHeader _) = Nothing+ getStatus (InvalidHeaderSynthesize e _orig) = handledSynthesized e++{-------------------------------------------------------------------------------+ Internal auxiliary+-------------------------------------------------------------------------------}++wrapOne :: InvalidHeader e -> InvalidHeaders e+wrapOne = InvalidHeaders . (:[])
+ src/Network/GRPC/Spec/Headers/PseudoHeaders.hs view
@@ -0,0 +1,130 @@+-- | Part of the gRPC spec that maps to HTTP2 pseudo-headers+--+-- Intended for unqualified import.+module Network.GRPC.Spec.Headers.PseudoHeaders (+ -- * Definition+ ServerHeaders(..)+ , ResourceHeaders(..)+ , PseudoHeaders(..)+ -- ** Individual headers+ , Method(..)+ , Scheme(..)+ , Address(..)+ , Path(..)+ , rpcPath+ ) where++import Data.ByteString qualified as Strict (ByteString)+import Data.Hashable+import Data.Proxy+import Network.Socket (HostName, PortNumber)++import Network.GRPC.Spec.RPC++{-------------------------------------------------------------------------------+ Definition++ This is not intended to be a general definition of pseudo-headers in HTTP2,+ but rather a reflection of how these pseudo-headers are used in gRPC.+-------------------------------------------------------------------------------}++-- | Partial pseudo headers: identify the server, but not a specific resource+data ServerHeaders = ServerHeaders {+ serverScheme :: Scheme+ , serverAddress :: Address+ }+ deriving stock (Show)++-- | Request pseudo-methods+--+-- <https://datatracker.ietf.org/doc/html/rfc7540#section-8.1.2.3>+data ResourceHeaders = ResourceHeaders {+ resourceMethod :: Method+ , resourcePath :: Path+ }+ deriving stock (Show)++-- | All pseudo-headers+data PseudoHeaders = PseudoHeaders {+ serverHeaders :: ServerHeaders+ , resourceHeaders :: ResourceHeaders+ }+ deriving stock (Show)++-- | Method+--+-- The only method supported by gRPC is @POST@.+--+-- See also <https://datatracker.ietf.org/doc/html/rfc7231#section-4>.+data Method = Post+ deriving stock (Show)++-- | Scheme+--+-- See <https://datatracker.ietf.org/doc/html/rfc3986#section-3.1>.+data Scheme = Http | Https+ deriving stock (Show)++-- | Address+--+-- The address of a server to connect to. This is not standard gRPC+-- nomenclature, but follows convention such as adopted by+-- [grpcurl](https://github.com/fullstorydev/grpcurl) and+-- [grpc-client-cli](https://github.com/vadimi/grpc-client-cli), which+-- distinguish between the /address/ of a server to connect to (hostname and+-- port), and the (optional) HTTP /authority/, which is an (optional) string to+-- be included as the HTTP2+-- [:authority](https://datatracker.ietf.org/doc/html/rfc3986#section-3.2)+-- [pseudo-header](https://datatracker.ietf.org/doc/html/rfc7540#section-8.1.2.3).+data Address = Address {+ -- | Hostname+ addressHost :: HostName++ -- | TCP port+ , addressPort :: PortNumber++ -- | Authority+ --+ -- When the authority is not specified, it defaults to @addressHost@.+ --+ -- This is used both for the HTTP2 @:authority@ pseudo-header as well+ -- as for TLS SNI (if using a secure connection).+ --+ -- Although the HTTP(2) specification allows the authority to include a+ -- port number, and many servers can accept this, this will /not/ work+ -- with TLS, and it is therefore recommended not to include a port number.+ -- Note that the HTTP2 spec explicitly /disallows/ the authority to+ -- include @userinfo@@.+ , addressAuthority :: Maybe String+ }+ deriving stock (Show)++-- | Path+--+-- The gRPC spec specifies:+--+-- > Path → ":path" "/" Service-Name "/" {method name} # But see note below.+--+-- Moreover, it says:+--+-- > Path is case-sensitive. Some gRPC implementations may allow the Path format+-- > shown above to be overridden, but this functionality is strongly+-- > discouraged. gRPC does not go out of its way to break users that are using+-- > this kind of override, but we do not actively support it, and some+-- > functionality (e.g., service config support) will not work when the path is+-- > not of the form shown above.+--+-- We don't support these non-standard paths at all.+data Path = Path {+ pathService :: Strict.ByteString+ , pathMethod :: Strict.ByteString+ }+ deriving stock (Show, Eq)++instance Hashable Path where+ hashWithSalt salt Path{pathService, pathMethod} =+ hashWithSalt salt (pathService, pathMethod)++-- | Construct path+rpcPath :: IsRPC rpc => Proxy rpc -> Path+rpcPath proxy = Path (rpcServiceName proxy) (rpcMethodName proxy)
+ src/Network/GRPC/Spec/Headers/Request.hs view
@@ -0,0 +1,150 @@+-- | Construct HTTP2 requests+--+-- Intended for qualified import.+--+-- > import Network.GRPC.Spec.Request qualified as Req+module Network.GRPC.Spec.Headers.Request (+ -- * Inputs (message sent to the peer)+ RequestHeaders_(..)+ , RequestHeaders+ , RequestHeaders'+ ) where++import Data.ByteString qualified as Strict (ByteString)+import Data.List.NonEmpty (NonEmpty)+import GHC.Generics (Generic)++import Network.GRPC.Spec.Compression (CompressionId)+import Network.GRPC.Spec.CustomMetadata.Map+import Network.GRPC.Spec.Headers.Common+import Network.GRPC.Spec.Headers.Invalid+import Network.GRPC.Spec.Timeout+import Network.GRPC.Spec.TraceContext+import Network.GRPC.Spec.Util.HKD (HKD, Undecorated, Checked)+import Network.GRPC.Spec.Util.HKD qualified as HKD++{-------------------------------------------------------------------------------+ Inputs (message sent to the peer)+-------------------------------------------------------------------------------}++-- | Full set of call parameters required to construct the RPC call+--+-- This is constructed internally; it is not part of the public API.+data RequestHeaders_ f = RequestHeaders {+ -- | Timeout+ requestTimeout :: HKD f (Maybe Timeout)++ -- | Compression used for outgoing messages+ , requestCompression :: HKD f (Maybe CompressionId)++ -- | Accepted compression algorithms for incoming messages+ --+ -- @Maybe (NonEmpty ..)@ is perhaps a bit strange (why not just @[]@), but+ -- it emphasizes the specification: /if/ the header is present, it must be+ -- a non-empty list.+ , requestAcceptCompression :: HKD f (Maybe (NonEmpty CompressionId))++ -- | Optionally, override the content-type+ --+ -- Set to 'Nothing' to omit the content-type header altogether.+ --+ -- See also discussion of 'requestMessageType'.+ , requestContentType :: HKD f (Maybe ContentType)++ -- | Should we include the @Message-Type@ header?+ --+ -- Set to 'Nothing' to omit the message-type header altogether.+ --+ -- We do not need the header in order to know the message type, because+ -- the /path/ determines the service and method, and that in turn+ -- determines the message type. If it /is/ present, however, we verify+ -- that it has the valeu we expect.+ , requestMessageType :: HKD f (Maybe MessageType)++ -- | User agent+ , requestUserAgent :: HKD f (Maybe Strict.ByteString)++ -- | Should we include the @te: trailers@ header?+ --+ -- The @TE@ header is part of the HTTP specification;+ -- see also <https://datatracker.ietf.org/doc/html/rfc7230#section-4.3>.+ -- It indicates that we are willing to accept a chunked encoding for the+ -- response body, and that we expect trailers to be present after the+ -- response body.+ --+ -- To be conform to the gRPC spec, the @te@ header should be included, but+ -- we does not insist that the header is present for incoming requests.+ -- However, /if/ it is present, we /do/ verify that it has the right+ -- value; this prevents values getting lost without notice.+ , requestIncludeTE :: HKD f Bool++ -- | Trace context (for OpenTelemetry)+ , requestTraceContext :: HKD f (Maybe TraceContext)++ -- | Previous RPC attempts+ --+ -- This is part of automatic retries.+ -- See <https://github.com/grpc/proposal/blob/master/A6-client-retries.md>.+ , requestPreviousRpcAttempts :: HKD f (Maybe Int)++ -- | Custom metadata+ --+ -- Any header we do not otherwise explicitly support we attempt to parse+ -- as custom metadata. Headers for which this fails end up in+ -- 'requestUnrecognized'; reasons for this include the use of reserved+ -- header names (starting with @grpc-@), invalid binary encodings, etc.+ , requestMetadata :: CustomMetadataMap++ -- | Unrecognized headers+ , requestUnrecognized :: HKD f ()+ }+ deriving anyclass (HKD.Coerce)++-- | Request headers (without allowing for invalid headers)+--+-- NOTE: The HKD type+--+-- > RequestHeaders_ Undecorated+--+-- means that each field of type @HKD f a@ is simply of type @a@ (that is,+-- undecorated).+type RequestHeaders = RequestHeaders_ Undecorated++-- | Request headers allowing for invalid headers+--+-- NOTE: The HKD type+--+-- > RequestHeaders_ (Checked InvalidHeaders)+--+-- means that each field of type @HKD f a@ is of type+--+-- > Either InvalidHeaders a+--+-- (i.e., either valid or invalid).+--+-- See 'InvalidHeaderSynthesize' for an explanation of the @e@ parameter.+type RequestHeaders' e = RequestHeaders_ (Checked (InvalidHeaders e))++deriving stock instance Show RequestHeaders+deriving stock instance Eq RequestHeaders+deriving stock instance Generic RequestHeaders++deriving stock instance Show e => Show (RequestHeaders' e)+deriving stock instance Eq e => Eq (RequestHeaders' e)+-- We do not derive Generic for RequestHeaders', as doing so makes ghc confused+-- about the instance for RequestHeaders for some reason.++instance HKD.Traversable RequestHeaders_ where+ traverse f x =+ RequestHeaders+ <$> (f $ requestTimeout x)+ <*> (f $ requestCompression x)+ <*> (f $ requestAcceptCompression x)+ <*> (f $ requestContentType x)+ <*> (f $ requestMessageType x)+ <*> (f $ requestUserAgent x)+ <*> (f $ requestIncludeTE x)+ <*> (f $ requestTraceContext x)+ <*> (f $ requestPreviousRpcAttempts x)+ <*> (pure $ requestMetadata x)+ <*> (f $ requestUnrecognized x)
+ src/Network/GRPC/Spec/Headers/Response.hs view
@@ -0,0 +1,359 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Deal with HTTP2 responses+--+-- Intended for qualified import.+--+-- > import Network.GRPC.Spec.Response qualified as Resp+module Network.GRPC.Spec.Headers.Response (+ -- * Headers+ ResponseHeaders_(..)+ , ResponseHeaders+ , ResponseHeaders'+ , ProperTrailers_(..)+ , ProperTrailers+ , ProperTrailers'+ , TrailersOnly_(..)+ , TrailersOnly+ , TrailersOnly'+ , Pushback(..)+ , simpleProperTrailers+ , trailersOnlyToProperTrailers+ , properTrailersToTrailersOnly+ -- * Termination+ , GrpcNormalTermination(..)+ , grpcClassifyTermination+ , grpcExceptionToTrailers+ ) where++import Control.Exception+import Control.Monad.Except (throwError)+import Data.ByteString qualified as Strict (ByteString)+import Data.List.NonEmpty (NonEmpty)+import Data.Proxy+import Data.Text (Text)+import GHC.Generics (Generic)++import Network.GRPC.Spec.Compression (CompressionId)+import Network.GRPC.Spec.CustomMetadata.Map+import Network.GRPC.Spec.CustomMetadata.Raw+import Network.GRPC.Spec.Headers.Common+import Network.GRPC.Spec.Headers.Invalid+import Network.GRPC.Spec.OrcaLoadReport+import Network.GRPC.Spec.Status+import Network.GRPC.Spec.Util.HKD (HKD, Undecorated, Checked)+import Network.GRPC.Spec.Util.HKD qualified as HKD++{-------------------------------------------------------------------------------+ Outputs (messages received from the peer)+-------------------------------------------------------------------------------}++-- | Response headers+data ResponseHeaders_ f = ResponseHeaders {+ -- | Compression used for outbound messages+ responseCompression :: HKD f (Maybe CompressionId)++ -- | Compression accepted for inbound messages+ , responseAcceptCompression :: HKD f (Maybe (NonEmpty CompressionId))++ -- | Content-type+ --+ -- Set to 'Nothing' to omit the content-type header altogether.+ , responseContentType :: HKD f (Maybe ContentType)++ -- | Initial response metadata+ --+ -- The response can include additional metadata in the trailers; see+ -- 'properTrailersMetadata'.+ , responseMetadata :: CustomMetadataMap++ -- | Unrecognized headers+ , responseUnrecognized :: HKD f ()+ }+ deriving anyclass (HKD.Coerce)++-- | Response headers (without allowing for invalid headers)+--+-- See t'Network.GRPC.Spec.RequestHeaders' for an explanation of 'Undecorated'.+type ResponseHeaders = ResponseHeaders_ Undecorated++-- | Response headers allowing for invalid headers+--+-- See t'Network.GRPC.Spec.RequestHeaders'' for an explanation of 'Checked' and+-- the purpose of @e@.+type ResponseHeaders' e = ResponseHeaders_ (Checked (InvalidHeaders e))++deriving stock instance Show ResponseHeaders+deriving stock instance Eq ResponseHeaders+deriving stock instance Generic ResponseHeaders++deriving stock instance Show e => Show (ResponseHeaders_ (Checked e))+deriving stock instance Eq e => Eq (ResponseHeaders_ (Checked e))++instance HKD.Traversable ResponseHeaders_ where+ traverse f x =+ ResponseHeaders+ <$> (f $ responseCompression x)+ <*> (f $ responseAcceptCompression x)+ <*> (f $ responseContentType x)+ <*> (pure $ responseMetadata x)+ <*> (f $ responseUnrecognized x)++-- | Information sent by the peer after the final output+--+-- Response trailers are a+-- [HTTP2 concept](https://datatracker.ietf.org/doc/html/rfc7540#section-8.1.3):+-- they are HTTP headers that are sent /after/ the content body. For example,+-- imagine the server is streaming a file that it's reading from disk; it could+-- use trailers to give the client an MD5 checksum when streaming is complete.+data ProperTrailers_ f = ProperTrailers {+ -- | gPRC status+ properTrailersGrpcStatus :: HKD f GrpcStatus++ -- | Additional status message+ , properTrailersGrpcMessage :: HKD f (Maybe Text)++ -- | Status details+ --+ -- This can be used to provide additional details about the RPC error;+ -- as this is a binary field, it can be used for structured data.+ --+ -- The spec imposes some additional restrictions on this field:+ --+ -- * @Status-Details@ is allowed only if @Status@ is not OK.+ -- * When using Protobuf this contains a @google.rpc.Status@ message.+ -- * If it contains a status code (as in the case of a @google.rpc.Status@+ -- message), it MUST NOT contradict the Status header.+ --+ -- The spec additionally mandates that consumers MUST verify that third+ -- requirement; however, it is impossible to verify this unless a specific+ -- format for the status details is known.+ , properTrailersStatusDetails :: HKD f (Maybe Strict.ByteString)++ -- | Server pushback+ --+ -- This is part of automatic retries.+ -- See <https://github.com/grpc/proposal/blob/master/A6-client-retries.md>.+ , properTrailersPushback :: HKD f (Maybe Pushback)++ -- | ORCA load report+ --+ -- See <https://github.com/grpc/proposal/blob/master/A51-custom-backend-metrics.md>+ , properTrailersOrcaLoadReport :: HKD f (Maybe OrcaLoadReport)++ -- | Trailing metadata+ --+ -- See also 'responseMetadata' for the initial metadata.+ , properTrailersMetadata :: CustomMetadataMap++ -- | Unrecognized trailers+ , properTrailersUnrecognized :: HKD f ()+ }+ deriving anyclass (HKD.Coerce)++-- | Default constructor for t'ProperTrailers'+simpleProperTrailers :: forall f.+ HKD.ValidDecoration Applicative f+ => HKD f GrpcStatus+ -> HKD f (Maybe Text)+ -> HKD f (Maybe Strict.ByteString)+ -> CustomMetadataMap+ -> ProperTrailers_ f+simpleProperTrailers status msg details metadata = ProperTrailers {+ properTrailersGrpcStatus = status+ , properTrailersGrpcMessage = msg+ , properTrailersStatusDetails = details+ , properTrailersPushback = HKD.pure (Proxy @f) (Nothing :: Maybe Pushback)+ , properTrailersOrcaLoadReport = HKD.pure (Proxy @f) (Nothing :: Maybe OrcaLoadReport)+ , properTrailersMetadata = metadata+ , properTrailersUnrecognized = HKD.pure (Proxy @f) ()+ }++-- | Trailers sent after the response (without allowing for invalid trailers)+type ProperTrailers = ProperTrailers_ Undecorated++-- | Trailers sent after the response, allowing for invalid trailers+--+-- We do not parameterize this over the type of synthesized errors: unlike+-- response (or request) headers, we have no opportunity to check the trailers+-- for synthesized errors ahead of time, so having a type to signal+-- "trailers without synthesized errors" is not particularly useful.+type ProperTrailers' = ProperTrailers_ (Checked (InvalidHeaders GrpcException))++deriving stock instance Show ProperTrailers+deriving stock instance Eq ProperTrailers+deriving stock instance Generic ProperTrailers++deriving stock instance Show e => Show (ProperTrailers_ (Checked e))+deriving stock instance Eq e => Eq (ProperTrailers_ (Checked e))++instance HKD.Traversable ProperTrailers_ where+ traverse f x =+ ProperTrailers+ <$> (f $ properTrailersGrpcStatus x)+ <*> (f $ properTrailersGrpcMessage x)+ <*> (f $ properTrailersStatusDetails x)+ <*> (f $ properTrailersPushback x)+ <*> (f $ properTrailersOrcaLoadReport x)+ <*> (pure $ properTrailersMetadata x)+ <*> (f $ properTrailersUnrecognized x)++-- | Trailers sent in the gRPC Trailers-Only case+--+-- We deal with the HTTP status elsewhere.+data TrailersOnly_ f = TrailersOnly {+ -- | Content type+ --+ -- Set to 'Nothing' to omit the content-type altogether.+ trailersOnlyContentType :: HKD f (Maybe ContentType)++ -- | All regular trailers can also appear in the Trailers-Only case+ , trailersOnlyProper :: ProperTrailers_ f+ }+ deriving anyclass (HKD.Coerce)++-- | Trailers for the Trailers-Only case (without allowing for invalid trailers)+type TrailersOnly = TrailersOnly_ Undecorated++-- | Trailers for the Trailers-Only case, allowing for invalid headers+type TrailersOnly' e = TrailersOnly_ (Checked (InvalidHeaders e))++deriving stock instance Show TrailersOnly+deriving stock instance Eq TrailersOnly+deriving stock instance Generic TrailersOnly++deriving stock instance Show e => Show (TrailersOnly_ (Checked e))+deriving stock instance Eq e => Eq (TrailersOnly_ (Checked e))++instance HKD.Traversable TrailersOnly_ where+ traverse f x =+ TrailersOnly+ <$> (f $ trailersOnlyContentType x)+ <*> (HKD.traverse f $ trailersOnlyProper x)++-- | t'ProperTrailers' is a subset of t'TrailersOnly'+properTrailersToTrailersOnly ::+ (ProperTrailers_ f, HKD f (Maybe ContentType))+ -> TrailersOnly_ f+properTrailersToTrailersOnly (proper, ct) = TrailersOnly {+ trailersOnlyProper = proper+ , trailersOnlyContentType = ct+ }++-- | t'TrailersOnly' is a superset of t'ProperTrailers'+trailersOnlyToProperTrailers ::+ TrailersOnly_ f+ -> (ProperTrailers_ f, HKD f (Maybe ContentType))+trailersOnlyToProperTrailers TrailersOnly{+ trailersOnlyProper+ , trailersOnlyContentType+ } = (+ trailersOnlyProper+ , trailersOnlyContentType+ )++{-------------------------------------------------------------------------------+ Pushback+-------------------------------------------------------------------------------}++-- | Pushback+--+-- The server adds this header to push back against client retries. We do not+-- yet support automatic retries+-- (<https://github.com/well-typed/grapesy/issues/104>), but do /we/ parse this+-- header so that /if/ the server includes it, we do not throw a parser error.+--+-- See also <https://github.com/grpc/proposal/blob/master/A6-client-retries.md>+data Pushback =+ RetryAfter Word+ | DoNotRetry+ deriving (Show, Eq, Generic)++{-------------------------------------------------------------------------------+ Termination+-------------------------------------------------------------------------------}++-- | Server indicated normal termination+--+-- This is only an exception if the client tries to send any further messages.+data GrpcNormalTermination = GrpcNormalTermination {+ grpcTerminatedMetadata :: [CustomMetadata]+ }+ deriving stock (Show)+ deriving anyclass (Exception)++-- | Check if trailers correspond to an exceptional response+--+-- The gRPC spec states that+--+-- > Trailers-Only is permitted for calls that produce an immediate error+--+-- However, in practice gRPC servers can also respond with @Trailers-Only@ in+-- non-error cases, simply indicating that the server considers the+-- conversation over. To distinguish, we look at 'properTrailersGrpcStatus'.+grpcClassifyTermination ::+ ProperTrailers'+ -> Either GrpcException GrpcNormalTermination+grpcClassifyTermination =+ -- If there are any synthesized errors, those take precedence+ either Left aux . throwSynthesized throwError+ where+ aux ::+ ProperTrailers_ (Checked (InvalidHeaders HandledSynthesized))+ -> Either GrpcException GrpcNormalTermination+ aux ProperTrailers { properTrailersGrpcStatus+ , properTrailersGrpcMessage+ , properTrailersStatusDetails+ , properTrailersMetadata+ } =+ case properTrailersGrpcStatus of+ Right GrpcOk -> Right GrpcNormalTermination {+ grpcTerminatedMetadata =+ customMetadataMapToList properTrailersMetadata+ }+ Right (GrpcError err) -> Left GrpcException{+ grpcError = err+ , grpcErrorMessage =+ case (properTrailersGrpcMessage, properTrailersStatusDetails) of+ (Right msg, Right _) ->+ msg+ (Left _, Right _) ->+ Just "'grpc-message' invalid"+ (Left _, Left _) ->+ Just "'grpc-message' and 'grpc-status-details-bin' invalid"+ (Right Nothing, Left _) ->+ Just "'grpc-status-details-bin' invalid"+ (Right (Just msg), Left _) ->+ -- This is the trickiest case. We have a valid grpc-message,+ -- but grpc-status-details-bin is invalid. We cannot+ -- construct an alternative value for 'grpcErrorDetails',+ -- because we have no way of knowing which format it is+ -- expected to be. So instead we add a remark here.+ Just $ msg <> "\n'grpc-status-details-bin' invalid"+ , grpcErrorDetails =+ case properTrailersStatusDetails of+ Right details -> details+ Left _ -> Nothing -- see above+ , grpcErrorMetadata =+ customMetadataMapToList properTrailersMetadata+ }+ Left _invalidStatus -> Left GrpcException {+ grpcError = GrpcUnknown+ , grpcErrorMessage = Just "Invalid grpc-status"+ , grpcErrorDetails = Nothing+ , grpcErrorMetadata = customMetadataMapToList properTrailersMetadata+ }++-- | Translate gRPC exception to response trailers+grpcExceptionToTrailers :: GrpcException -> ProperTrailers+grpcExceptionToTrailers GrpcException{+ grpcError+ , grpcErrorMessage+ , grpcErrorDetails+ , grpcErrorMetadata+ } =+ simpleProperTrailers+ (GrpcError grpcError)+ grpcErrorMessage+ grpcErrorDetails+ (customMetadataMapFromList grpcErrorMetadata)
+ src/Network/GRPC/Spec/MessageMeta.hs view
@@ -0,0 +1,45 @@+-- | Information about messages+module Network.GRPC.Spec.MessageMeta (+ OutboundMeta(..)+ , InboundMeta(..)+ ) where++import Control.DeepSeq (NFData)+import Data.Default+import Data.Word+import GHC.Generics (Generic)++{-------------------------------------------------------------------------------+ Outbound messages+-------------------------------------------------------------------------------}++-- | Meta-information for outbound messages+data OutboundMeta = OutboundMeta {+ -- | Enable compression for this message+ --+ -- Even if enabled, compression will only be used if this results in a+ -- smaller message.+ outboundEnableCompression :: Bool+ }+ deriving stock (Show, Generic)+ deriving anyclass (NFData)++instance Default OutboundMeta where+ def = OutboundMeta {+ outboundEnableCompression = True+ }++{-------------------------------------------------------------------------------+ Inbound messages+-------------------------------------------------------------------------------}++-- | Meta-information about inbound messages+data InboundMeta = InboundMeta {+ -- | Size of the message in compressed form, /if/ it was compressed+ inboundCompressedSize :: Maybe Word32++ -- | Size of the message in uncompressed (but still serialized) form+ , inboundUncompressedSize :: Word32+ }+ deriving stock (Show)+
+ src/Network/GRPC/Spec/OrcaLoadReport.hs view
@@ -0,0 +1,5 @@+module Network.GRPC.Spec.OrcaLoadReport (+ OrcaLoadReport+ ) where++import Proto.OrcaLoadReport
+ src/Network/GRPC/Spec/PercentEncoding.hs view
@@ -0,0 +1,145 @@+-- | Percent encoding+--+-- The gRPC spec is similar, but not identical, to URI encoding.+--+-- > Percent-Encoded → 1*(Percent-Byte-Unencoded / Percent-Byte-Encoded)+-- > Percent-Byte-Unencoded → 1*( %x20-%x24 / %x26-%x7E ) ; space and VCHAR, except %+-- > Percent-Byte-Encoded → "%" 2HEXDIGIT ; 0-9 A-F+--+-- We work with strict bytestrings here, since these are ultimately intended+-- as header values.+--+-- Intended for qualified import.+--+-- > import Network.GRPC.Spec.PercentEncoding qualified as PercentEncoding+module Network.GRPC.Spec.PercentEncoding (+ encode+ , decode+ ) where++import Control.Exception+import Data.Bifunctor+import Data.Bits+import Data.ByteString qualified as BS.Strict+import Data.ByteString qualified as Strict (ByteString)+import Data.ByteString.Builder (Builder)+import Data.ByteString.Builder qualified as Builder+import Data.ByteString.Lazy qualified as BS.Lazy+import Data.Text (Text)+import Data.Text.Encoding qualified as Text+import Data.Text.Encoding.Error qualified as Text+import Data.Word++import Network.GRPC.Spec.Util.ByteString (ascii)++{-------------------------------------------------------------------------------+ Encoding+-------------------------------------------------------------------------------}++encode :: Text -> Strict.ByteString+encode =+ BS.Lazy.toStrict+ . Builder.toLazyByteString+ . foldMap encodeChar+ . BS.Strict.unpack+ . Text.encodeUtf8++encodeChar :: Word8 -> Builder+encodeChar c+ | needsEncoding c = let (hi, lo) = toBase16 c+ in mconcat [+ Builder.char7 '%'+ , Builder.word8 hi+ , Builder.word8 lo+ ]+ | otherwise = Builder.word8 c++-- | Does this character have to be encoded?+--+-- The gRPC spec unencoded characters as "space and VCHAR, except %":+--+-- > Percent-Byte-Unencoded → 1*( %x20-%x24 / %x26-%x7E )+needsEncoding :: Word8 -> Bool+needsEncoding c+ | 0x20 <= c && c <= 0x24 = False+ | 0x26 <= c && c <= 0x7E = False+ | otherwise = True++{-------------------------------------------------------------------------------+ Decoding+-------------------------------------------------------------------------------}++data DecodeException =+ -- | Hex digit outside its range @(0..9, A..F)@+ InvalidHexDigit Word8++ -- | Percent (@%@) which was not followed by two hex digits+ | MissingHexDigits++ -- | Hex-decoding was fine, but encoded string was not valid UTF8+ | InvalidUtf8 Text.UnicodeException+ deriving stock (Show)++instance Exception DecodeException where+ displayException (InvalidHexDigit w) =+ "invalid hex digit '" ++ show w ++ "'"+ displayException MissingHexDigits =+ "'%' not followed by two hex digits"+ displayException (InvalidUtf8 err) =+ displayException err++decode :: Strict.ByteString -> Either DecodeException Text+decode =+ (>>= first InvalidUtf8 . Text.decodeUtf8')+ . fmap BS.Strict.pack+ . go []+ . BS.Strict.unpack+ where+ go :: [Word8] -> [Word8] -> Either DecodeException [Word8]+ go acc (c:cs)+ | c == ascii '%' = case cs of+ hi:lo:cs' -> do+ c' <- fromBase16 (hi, lo)+ go (c':acc) cs'+ _otherwise ->+ Left $ MissingHexDigits+ | otherwise = go (c:acc) cs+ go acc [] = Right (reverse acc)++{-------------------------------------------------------------------------------+ Utilities for working with base16++ We could depend on @base16@ or @base16-bytestring@ here, but they deal with+ entire strings at a time, which doesn't quite fit our needs here and would+ result in quite a bit of overhead.+-------------------------------------------------------------------------------}++toBase16 :: Word8 -> (Word8, Word8)+toBase16 c = (toHexDigit hi, toHexDigit lo)+ where+ hi, lo :: Word8+ hi = c `shiftR` 4+ lo = c .&. 0x0F;++fromBase16 :: (Word8, Word8) -> Either DecodeException Word8+fromBase16 = \(hi, lo) -> aux <$> fromHexDigit hi <*> fromHexDigit lo+ where+ aux :: Word8 -> Word8 -> Word8+ aux hi lo = (hi `shiftL` 4) .|. lo++toHexDigit :: Word8 -> Word8+toHexDigit c+ | 0 <= c && c <= 9 = ascii '0' + c+ | 10 <= c && c <= 15 = ascii 'A' + (c - 10)+ | otherwise = error "toHexDigit: out of range"++-- | Value of a single hex digit+--+-- The gRPC spec does not actually allow for lowercase here, but we support it+-- in case we're dealing with non-conformant peers.+fromHexDigit :: Word8 -> Either DecodeException Word8+fromHexDigit c+ | ascii '0' <= c && c <= ascii '9' = Right $ c - ascii '0'+ | ascii 'A' <= c && c <= ascii 'F' = Right $ 10 + c - ascii 'A'+ | ascii 'a' <= c && c <= ascii 'f' = Right $ 10 + c - ascii 'a'+ | otherwise = Left $ InvalidHexDigit c
+ src/Network/GRPC/Spec/RPC.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.GRPC.Spec.RPC (+ IsRPC(..)+ , Input+ , Output+ , SupportsServerRpc(..)+ , SupportsClientRpc(..)+ , defaultRpcContentType+ ) where++import Control.DeepSeq (NFData)+import Data.ByteString qualified as Strict (ByteString)+import Data.ByteString.Lazy qualified as Lazy+import Data.Kind+import Data.Typeable+import GHC.Stack++import Network.GRPC.Spec.CustomMetadata.Typed++{-------------------------------------------------------------------------------+ RPC call+-------------------------------------------------------------------------------}++-- | Messages from the client to the server+type family Input (rpc :: k) :: Type++-- | Messages from the server to the client+type family Output (rpc :: k) :: Type++-- | Abstract definition of an RPC+--+-- Note on encoding: the gRPC specification does not say anything about text+-- encoding issues for paths (service names and method names) or message types.+-- The Protobuf compiler (by far the most common instantation of gRPC) does not+-- allow for non-ASCII character at all ("interpreting non ascii codepoint").+-- We therefore punt on the encoding issue here, and use bytestrings. /If/+-- applications want to use non-ASCII characters, they can choose their own+-- encoding.+class ( -- Serialization+ --+ -- We force messages to NF before enqueueing them. This ensures that+ -- if those messages contain any pure exceptions (due to a bug in a+ -- client or a server), we detect the problem when the message is+ -- enqueued, and can throw an appropriate exception.+ NFData (Input rpc)+ , NFData (Output rpc)++ -- Debug constraints+ --+ -- For debugging it is useful when we have 'Show' instances in scope.+ -- This is not that strong a requirement; after all, we must be able+ -- to serialize inputs and deserialize outputs, so they must also be+ -- 'Show'able.+ , Show (Input rpc)+ , Show (Output rpc)+ , Show (RequestMetadata rpc)+ , Show (ResponseInitialMetadata rpc)+ , Show (ResponseTrailingMetadata rpc)+ ) => IsRPC (rpc :: k) where+ -- | Content-type+ --+ -- gRPC is agnostic to the message format; the spec defines the @Content-Type@+ -- header as+ --+ -- > Content-Type →+ -- > "content-type"+ -- > "application/grpc"+ -- > [("+proto" / "+json" / {custom})]+ --+ -- 'defaultRpcContentType' can be used in the case that the format (such as+ -- @proto@) is known.+ --+ -- Note on terminology: throughout this codebase we avoid the terms "encoding"+ -- and "decoding", which can be ambiguous. Instead we use+ -- \"serialize\"\/\"deserialize\" and \"compress\"\/\"decompress\".+ rpcContentType :: Proxy rpc -> Strict.ByteString++ -- | Service name+ --+ -- For Protobuf, this is the fully qualified service name.+ rpcServiceName :: HasCallStack => Proxy rpc -> Strict.ByteString++ -- | Method name+ --+ -- For Protobuf, this is /just/ the method name (no qualifier required).+ rpcMethodName :: HasCallStack => Proxy rpc -> Strict.ByteString++ -- | Message type, if specified+ --+ -- This is used to set the (optional) @grpc-message-type@ header.+ -- For Protobuf, this is the fully qualified message type.+ rpcMessageType :: HasCallStack => Proxy rpc -> Maybe Strict.ByteString++-- | Default content type string+--+-- This is equal to @"application/grpc+format@ for some @format@ such as+-- @proto@ or @json@. See also 'rpcContentType'.+defaultRpcContentType :: Strict.ByteString -> Strict.ByteString+defaultRpcContentType format = "application/grpc+" <> format++-- | Client-side RPC+class ( IsRPC rpc++ -- Serialization+ , BuildMetadata (RequestMetadata rpc)+ , ParseMetadata (ResponseInitialMetadata rpc)+ , ParseMetadata (ResponseTrailingMetadata rpc)+ ) => SupportsClientRpc rpc where++ -- | Serialize RPC input+ --+ -- We don't ask for a builder here, but instead ask for the complete+ -- serialized form. gRPC insists that individual messages are length prefixed,+ -- so we /must/ compute the full serialization in memory before we can send+ -- anything.+ --+ -- We use the terms \"serialize\" and \"deserialize\" here, and+ -- \"compress\"/\"decompress\" for compression, rather than+ -- \"encode\"/\"decode\", which could refer to either process.+ rpcSerializeInput :: Proxy rpc -> Input rpc -> Lazy.ByteString++ -- | Deserialize RPC output+ --+ -- Discussion of 'rpcDeserializeInput' applies here, also.+ rpcDeserializeOutput ::+ Proxy rpc+ -> Lazy.ByteString+ -> Either String (Output rpc)++-- | Server-side RPC+class ( IsRPC rpc++ -- Serialization+ , ParseMetadata (RequestMetadata rpc)+ , BuildMetadata (ResponseInitialMetadata rpc)+ , StaticMetadata (ResponseTrailingMetadata rpc)+ ) => SupportsServerRpc rpc where++ -- | Deserialize RPC input+ --+ -- This function does not have to deal with compression or length prefixes,+ -- and can assume fully consume the given bytestring (if there are unconsumed+ -- bytes, this should be considered a parse failure).+ rpcDeserializeInput ::+ Proxy rpc+ -> Lazy.ByteString+ -> Either String (Input rpc)++ -- | Serialize RPC output+ rpcSerializeOutput :: Proxy rpc -> Output rpc -> Lazy.ByteString+
+ src/Network/GRPC/Spec/RPC/JSON.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.GRPC.Spec.RPC.JSON (+ JsonRpc++ -- Aeson support+ , JsonObject(..)+ , Required(..)+ , Optional(..)+ , DecodeFields -- opaque+ , EncodeFields -- opaque+ ) where++import Control.DeepSeq (NFData(..))+import Data.Aeson (ToJSON(..), FromJSON(..), (.=), (.:), (.:?))+import Data.Aeson qualified as Aeson+import Data.Aeson.Types qualified as Aeson+import Data.ByteString.Char8 qualified as BS.Char8+import Data.Kind+import Data.Proxy+import Data.String+import GHC.TypeLits++import Network.GRPC.Spec.CustomMetadata.Typed+import Network.GRPC.Spec.RPC+import Network.GRPC.Spec.RPC.StreamType++-- | gRPC using JSON as the message encoding+--+-- "JSON over gRPC" is a bit of an ambiguous phrase. It can be a very general+-- term, simply meaning using an otherwise-unspecified JSON encoding, or it can+-- refer to "Protobuf over JSON" (see+-- <https://protobuf.dev/programming-guides/proto3/#json>). In this module we+-- deal with the former, and don't deal with anything Protobuf-specific at all,+-- nor do we rely on any of the infrastructure generated by the Protobuf+-- compiler (in other words, there is no need to use @protoc@). See+-- <https://grpc.io/blog/grpc-with-json/> for a Java example of using gRPC with+-- JSON without Protobuf.+--+-- In the absence of the infrastructure provided by @protoc@, you will need to+-- manually provide 'Input' and 'Output' instances for each RPC you use.+-- For example:+--+-- > type Create = JsonRpc KeyValueService "Create"+-- > type Delete = JsonRpc KeyValueService "Delete"+-- > ..+-- >+-- > type instance Input Create = ..+-- > type instance Output Create = ..+-- > type instance Input Retrieve = ..+-- > type instance Output Retrieve = ..+-- > ..+--+-- On the client, you will need 'ToJSON' instances for inputs and 'FromJSON'+-- instances for outputs; on the server the situation is dual. You may find it+-- convenient to use t'JsonObject' (but this is certainly not required).+--+-- TODO: <https://github.com/well-typed/grapesy/issues/166>+-- We don't currently offer explicit support for "Protobuf JSON".+data JsonRpc (serv :: Symbol) (meth :: Symbol)++instance ( KnownSymbol serv+ , KnownSymbol meth++ -- Serialization+ , NFData (Input (JsonRpc serv meth))+ , NFData (Output (JsonRpc serv meth))++ -- Debugging constraints+ , Show (Input (JsonRpc serv meth))+ , Show (Output (JsonRpc serv meth))+ , Show (RequestMetadata (JsonRpc serv meth))+ , Show (ResponseInitialMetadata (JsonRpc serv meth))+ , Show (ResponseTrailingMetadata (JsonRpc serv meth))+ ) => IsRPC (JsonRpc serv meth) where+ rpcContentType _ = defaultRpcContentType "json"+ rpcServiceName _ = BS.Char8.pack $ symbolVal (Proxy @serv)+ rpcMethodName _ = BS.Char8.pack $ symbolVal (Proxy @meth)+ rpcMessageType _ = Nothing++instance ( IsRPC (JsonRpc serv meth)++ -- Serialization constraints+ , ToJSON (Input (JsonRpc serv meth))+ , FromJSON (Output (JsonRpc serv meth))++ -- Metadata constraints+ , BuildMetadata (RequestMetadata (JsonRpc serv meth))+ , ParseMetadata (ResponseInitialMetadata (JsonRpc serv meth))+ , ParseMetadata (ResponseTrailingMetadata (JsonRpc serv meth))+ ) => SupportsClientRpc (JsonRpc serv meth) where+ rpcSerializeInput _ = Aeson.encode+ rpcDeserializeOutput _ = Aeson.eitherDecode++instance ( IsRPC (JsonRpc serv meth)++ -- Serialization constraints+ , FromJSON (Input (JsonRpc serv meth))+ , ToJSON (Output (JsonRpc serv meth))++ -- Metadata constraints+ , ParseMetadata (RequestMetadata (JsonRpc serv meth))+ , BuildMetadata (ResponseInitialMetadata (JsonRpc serv meth))+ , StaticMetadata (ResponseTrailingMetadata (JsonRpc serv meth))+ ) => SupportsServerRpc (JsonRpc serv meth) where+ rpcDeserializeInput _ = Aeson.eitherDecode+ rpcSerializeOutput _ = Aeson.encode++-- | For JSON protocol we do not check communication protocols+instance ValidStreamingType styp+ => SupportsStreamingType (JsonRpc serv meth) styp++{-------------------------------------------------------------------------------+ Support for constructing JSON objects+-------------------------------------------------------------------------------}++-- | Convenient way to construct JSON values+--+-- Example:+--+-- > type instance Input Create =+-- > JsonObject '[ '("key" , Required Key)+-- > , '("value" , Required Value)+-- > ]+data JsonObject :: [(Symbol, Type)] -> Type where+ JsonObject :: JsonObject '[]+ (:*) :: forall f x fs. x -> JsonObject fs -> JsonObject ('(f, x) : fs)++instance Show (JsonObject '[]) where+ showsPrec _ JsonObject = showString "JsonObject"++instance (Show x, Show (JsonObject fs))+ => Show (JsonObject ('(f, x) : fs)) where+ showsPrec p (x :* xs) = showParen (p >= 6) $+ showsPrec 6 x+ . showString " :* "+ . showsPrec 6 xs++instance NFData (JsonObject '[]) where+ rnf JsonObject = ()++instance (NFData x, NFData (JsonObject fs))+ => NFData (JsonObject ('(f, x) : fs)) where+ rnf (x :* xs) = rnf (x, xs)++-- | Required field+newtype Required a = Required {+ getRequired :: a+ }+ deriving stock (Show)+ deriving newtype (NFData)++-- | Optional field+--+-- 'Maybe' will be represented by the /absence/ of the field in the object.+newtype Optional a = Optional {+ getOptional :: Maybe a+ }+ deriving stock (Show)+ deriving newtype (NFData)++infixr 5 :*++-- | Auxiliary class used for the 'ToJSON' instance for t'JsonObject'+--+-- It is not possible (nor necessary) to define additional instances.+class EncodeFields fs where+ encodeFields :: JsonObject fs -> [Aeson.Pair]+ encodeFields = undefined++instance EncodeFields '[] where+ encodeFields JsonObject = []++instance (KnownSymbol f, ToJSON x, EncodeFields fs)+ => EncodeFields ('(f, Required x) : fs) where+ encodeFields (Required x :* xs) =+ (fromString (symbolVal (Proxy @f)) .= x)+ : encodeFields xs++instance (KnownSymbol f, ToJSON x, EncodeFields fs)+ => EncodeFields ('(f, Optional x) : fs) where+ encodeFields (Optional Nothing :* xs) = encodeFields xs+ encodeFields (Optional (Just x) :* xs) =+ (fromString (symbolVal (Proxy @f)) .= x)+ : encodeFields xs++instance EncodeFields fs => ToJSON (JsonObject fs) where+ toJSON = Aeson.object . encodeFields++-- | Auxiliary class used for the 'FromJSON' instance for t'JsonObject'+--+-- It is not possible (nor necessary) to define additional instances.+class DecodeFields fs where+ decodeFields :: Aeson.Object -> Aeson.Parser (JsonObject fs)+ decodeFields = undefined++instance DecodeFields '[] where+ decodeFields _ = return JsonObject++instance (KnownSymbol f, FromJSON x, DecodeFields fs)+ => DecodeFields ('(f, Required x) : fs) where+ decodeFields obj = do+ fs <- decodeFields obj+ x <- obj .: fromString (symbolVal (Proxy @f))+ return (Required x :* fs)++instance (KnownSymbol f, FromJSON x, DecodeFields fs)+ => DecodeFields ('(f, Optional x) : fs) where+ decodeFields obj = do+ fs <- decodeFields obj+ x <- obj .:? fromString (symbolVal (Proxy @f))+ return (Optional x :* fs)++instance DecodeFields fs => FromJSON (JsonObject fs) where+ parseJSON = Aeson.withObject "JsonObject" $ decodeFields+
+ src/Network/GRPC/Spec/RPC/Protobuf.hs view
@@ -0,0 +1,281 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}++-- | gRPC with Protobuf+module Network.GRPC.Spec.RPC.Protobuf (+ Protobuf+ , Proto(..)+ , getProto+ ) where++import Control.DeepSeq (NFData)+import Control.Lens hiding (lens)+import Data.ByteString qualified as Strict (ByteString)+import Data.ByteString.Char8 qualified as BS.Char8+import Data.Int+import Data.Kind+import Data.Map (Map)+import Data.ProtoLens+import Data.ProtoLens.Field qualified as ProtoLens+import Data.ProtoLens.Service.Types+import Data.Proxy+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Vector qualified as Boxed (Vector)+import Data.Vector.Unboxed qualified as Unboxed (Vector)+import Data.Word+import GHC.Exts (Proxy#, proxy#)+import GHC.Records qualified as GHC+import GHC.Records.Compat qualified as GHC.Compat+import GHC.TypeLits++import Network.GRPC.Spec.CustomMetadata.Typed+import Network.GRPC.Spec.RPC+import Network.GRPC.Spec.RPC.StreamType+import Network.GRPC.Spec.Util.Protobuf qualified as Protobuf++{-------------------------------------------------------------------------------+ The spec defines the following in Appendix A, "GRPC for Protobuf":++ > Service-Name → ?( {proto package name} "." ) {service name}+ > Message-Type → {fully qualified proto message name}+ > Content-Type → "application/grpc+proto"+-------------------------------------------------------------------------------}++-- | Protobuf RPC+--+-- This exists only as a type-level marker+data Protobuf (serv :: Type) (meth :: Symbol)++type instance Input (Protobuf serv meth) = Proto (MethodInput serv meth)+type instance Output (Protobuf serv meth) = Proto (MethodOutput serv meth)++instance ( HasMethodImpl serv meth++ -- Debugging+ , Show (MethodInput serv meth)+ , Show (MethodOutput serv meth)++ -- Serialization+ , NFData (MethodInput serv meth)+ , NFData (MethodOutput serv meth)++ -- Metadata constraints+ , Show (RequestMetadata (Protobuf serv meth))+ , Show (ResponseInitialMetadata (Protobuf serv meth))+ , Show (ResponseTrailingMetadata (Protobuf serv meth))+ ) => IsRPC (Protobuf serv meth) where+ rpcContentType _ = defaultRpcContentType "proto"+ rpcServiceName _ = BS.Char8.pack $ concat [+ symbolVal $ Proxy @(ServicePackage serv)+ , "."+ , symbolVal $ Proxy @(ServiceName serv)+ ]+ rpcMethodName _ = BS.Char8.pack . symbolVal $+ Proxy @(MethodName serv meth)+ rpcMessageType _ = Just . BS.Char8.pack . Text.unpack . messageName $+ Proxy @(MethodInput serv meth)++instance ( IsRPC (Protobuf serv meth)+ , HasMethodImpl serv meth++ -- Metadata constraints+ , BuildMetadata (RequestMetadata (Protobuf serv meth))+ , ParseMetadata (ResponseInitialMetadata (Protobuf serv meth))+ , ParseMetadata (ResponseTrailingMetadata (Protobuf serv meth))+ ) => SupportsClientRpc (Protobuf serv meth) where+ rpcSerializeInput _ = Protobuf.buildLazy+ rpcDeserializeOutput _ = Protobuf.parseLazy++instance ( IsRPC (Protobuf serv meth)+ , HasMethodImpl serv meth++ -- Metadata constraints+ , ParseMetadata (RequestMetadata (Protobuf serv meth))+ , BuildMetadata (ResponseInitialMetadata (Protobuf serv meth))+ , StaticMetadata (ResponseTrailingMetadata (Protobuf serv meth))+ ) => SupportsServerRpc (Protobuf serv meth) where+ rpcDeserializeInput _ = Protobuf.parseLazy+ rpcSerializeOutput _ = Protobuf.buildLazy++instance ( styp ~ MethodStreamingType serv meth+ , ValidStreamingType styp+ )+ => SupportsStreamingType (Protobuf serv meth) styp++instance ValidStreamingType (MethodStreamingType serv meth)+ => HasStreamingType (Protobuf serv meth) where+ type RpcStreamingType (Protobuf serv meth) = MethodStreamingType serv meth++{-------------------------------------------------------------------------------+ Wrapper around Protobuf messages+-------------------------------------------------------------------------------}++-- | Wrapper around Protobuf messages and Protobuf enums+--+-- Protobuf messages and enums behave differently to normal Haskell datatypes.+-- Fields in messages always have defaults, enums can have unknown values, etc.+-- We therefore mark them at the type-level with this t'Proto' wrapper. Most of+-- the time you can work with t'Proto' values as if the wrapper is not there,+-- because @Proto msg@ inherits 'Message' and @Data.ProtoLens.Field@+-- 'ProtoLens.HasField' instances from @msg@. For example, you can create a+-- 'Proto Point' value as+--+-- > p = defMessage+-- > & #latitude .~ ..+-- > & #longitude .~ ..+--+-- and access fields /from/ such a value using+--+-- > p ^. #latitude+--+-- as per usual.+--+-- One advantage of the t'Proto' wrapper is that we can give blanket instances+-- for /all/ Protobuf messages; we use this to provide @GHC.Records@+-- 'GHC.HasField' and @GHC.Records.Compat@ 'GHC.Compat.HasField' instances.+-- This means that you can also use @OverloadedRecordDot@ to access fields+--+-- > p.latitude+--+-- or even @OverloadedRecordUpdate@ to set fields+--+-- > p{latitude = ..}+newtype Proto msg = Proto msg+ deriving stock (Show)+ deriving newtype (+ Eq+ , Ord+ , Bounded+ , Enum+ , FieldDefault+ , MessageEnum+ , NFData+ )++-- | Field accessor for t'Proto'+getProto :: Proto msg -> msg+-- Implementation note: This /must/ be defined separately from the 'Proto'+-- newtype, otherwise ghc won't let us define a 'GHC.HasField' instance.+getProto (Proto msg) = msg++instance Message msg => Message (Proto msg) where+ messageName _ = messageName (Proxy @msg)+ packedMessageDescriptor _ = packedMessageDescriptor (Proxy @msg)+ packedFileDescriptor _ = packedFileDescriptor (Proxy @msg)++ defMessage = Proto defMessage+ buildMessage = buildMessage . getProto+ parseMessage = Proto <$> parseMessage+ unknownFields = _proto . unknownFields+ fieldsByTag = protoFieldDescriptor <$> fieldsByTag++{-------------------------------------------------------------------------------+ ProtoLens.HasField instance for Proto++ We want to piggy-back on the generated HasField instance, but re-wrap nested+ messages in 'Proto' (but not primitive fields).++ See++ * <https://protobuf.dev/programming-guides/proto3/>+ * @Data.ProtoLens.Compiler.Generate.Field@ in @proto-lens-protoc@+-------------------------------------------------------------------------------}++-- | Field description+data FieldDesc = MkFieldDesc FieldLabel IsScalar++-- | Is this a scalar field or an enum/nested message?+data IsScalar = Scalar | NotScalar++-- | Field label+--+-- <https://protobuf.dev/programming-guides/proto3/#field-labels>+data FieldLabel =+ LabelImplicit+ | LabelOptional+ | LabelRepeated+ | LabelMap++type family Describe (a :: Type) :: FieldDesc where+ Describe (Maybe a) = MkFieldDesc LabelOptional (CheckIsScalar a)+ Describe [a] = MkFieldDesc LabelRepeated (CheckIsScalar a)+ Describe (Unboxed.Vector a) = MkFieldDesc LabelRepeated Scalar+ Describe (Boxed.Vector a) = MkFieldDesc LabelRepeated (CheckIsScalar a)+ Describe (Map _ a) = MkFieldDesc LabelMap (CheckIsScalar a)+ Describe a = MkFieldDesc LabelImplicit (CheckIsScalar a)++type family CheckIsScalar (a :: Type) :: IsScalar where+ CheckIsScalar Bool = Scalar+ CheckIsScalar Double = Scalar+ CheckIsScalar Float = Scalar+ CheckIsScalar Int32 = Scalar+ CheckIsScalar Int64 = Scalar+ CheckIsScalar Strict.ByteString = Scalar+ CheckIsScalar Text = Scalar+ CheckIsScalar Word32 = Scalar+ CheckIsScalar Word64 = Scalar+ CheckIsScalar _ = NotScalar++class RewrapField (desc :: FieldDesc) (x :: Type) (y :: Type) | desc x -> y where+ rewrapField :: Proxy# desc -> Lens' x y++instance RewrapField (MkFieldDesc label Scalar) a a where+ rewrapField _ = coerced++instance RewrapField (MkFieldDesc LabelImplicit NotScalar) a (Proto a) where+ rewrapField _ = coerced++instance RewrapField (MkFieldDesc LabelOptional NotScalar) (Maybe a) (Maybe (Proto a)) where+ rewrapField _ = coerced++instance RewrapField (MkFieldDesc LabelRepeated NotScalar) [a] [Proto a] where+ rewrapField _ = coerced++instance RewrapField (MkFieldDesc LabelRepeated NotScalar) (Boxed.Vector a) (Boxed.Vector (Proto a)) where+ rewrapField _ = coerced++instance RewrapField (MkFieldDesc LabelMap NotScalar) (Map k a) (Map k (Proto a)) where+ rewrapField _ = coerced++instance+ ( ProtoLens.HasField rec fldName x+ , RewrapField (Describe x) x fldType+ )+ => ProtoLens.HasField (Proto rec) fldName fldType where+ fieldOf p = _proto . ProtoLens.fieldOf p . rewrapField (proxy# @(Describe x))++instance ProtoLens.HasField (Proto rec) fldName fldType+ => GHC.HasField fldName (Proto rec) fldType where+ getField r = (+ r ^. ProtoLens.fieldOf (proxy# @fldName)+ )++instance ProtoLens.HasField (Proto rec) fldName fldType+ => GHC.Compat.HasField fldName (Proto rec) fldType where+ hasField r = (+ \a -> r & ProtoLens.fieldOf (proxy# @fldName) .~ a+ , r ^. ProtoLens.fieldOf (proxy# @fldName)+ )++{-------------------------------------------------------------------------------+ Internal auxiliary: Proto wrapper+-------------------------------------------------------------------------------}++_proto :: Iso' (Proto msg) msg+_proto = coerced++protoFieldDescriptor :: FieldDescriptor msg -> FieldDescriptor (Proto msg)+protoFieldDescriptor (FieldDescriptor name typ acc) =+ FieldDescriptor name typ (protoFieldAccessor acc)++protoFieldAccessor :: FieldAccessor msg value -> FieldAccessor (Proto msg) value+protoFieldAccessor (PlainField def lens) =+ PlainField def (coerced . lens)+protoFieldAccessor (OptionalField lens) =+ OptionalField (coerced . lens)+protoFieldAccessor (RepeatedField packing lens) =+ RepeatedField packing (coerced . lens)+protoFieldAccessor (MapField lensKey lensValue lensMap) =+ MapField lensKey lensValue (coerced . lensMap)
+ src/Network/GRPC/Spec/RPC/Raw.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.GRPC.Spec.RPC.Raw (RawRpc) where++import Data.ByteString.Char8 qualified as BS.Char8+import Data.ByteString.Lazy qualified as Lazy (ByteString)+import Data.Proxy+import GHC.TypeLits++import Network.GRPC.Spec.CustomMetadata.Typed+import Network.GRPC.Spec.RPC+import Network.GRPC.Spec.RPC.StreamType++{-------------------------------------------------------------------------------+ Raw format+-------------------------------------------------------------------------------}++-- | Custom gRPC format+--+-- Usually @gRPC@ runs over Protobuf, but it does not have to. 'RawRpc' provides+-- an alternative format, which does not use serialization/deserialization at+-- all, just using raw bytestrings for messages. This is a non-standard format+-- (which the gRPC specification explicitly permits).+data RawRpc (serv :: Symbol) (meth :: Symbol)++type instance Input (RawRpc serv meth) = Lazy.ByteString+type instance Output (RawRpc serv meth) = Lazy.ByteString++instance ( KnownSymbol serv+ , KnownSymbol meth++ -- Metadata constraints+ , Show (RequestMetadata (RawRpc serv meth))+ , Show (ResponseInitialMetadata (RawRpc serv meth))+ , Show (ResponseTrailingMetadata (RawRpc serv meth))+ ) => IsRPC (RawRpc serv meth) where+ rpcContentType _ = defaultRpcContentType "raw"+ rpcServiceName _ = BS.Char8.pack $ symbolVal (Proxy @serv)+ rpcMethodName _ = BS.Char8.pack $ symbolVal (Proxy @meth)+ rpcMessageType _ = Nothing++instance ( IsRPC (RawRpc serv meth)++ -- Metadata constraints+ , BuildMetadata (RequestMetadata (RawRpc serv meth))+ , ParseMetadata (ResponseInitialMetadata (RawRpc serv meth))+ , ParseMetadata (ResponseTrailingMetadata (RawRpc serv meth))+ ) => SupportsClientRpc (RawRpc serv meth) where+ rpcSerializeInput _ = id+ rpcDeserializeOutput _ = return++instance ( IsRPC (RawRpc serv meth)++ -- Metadata constraints+ , ParseMetadata (RequestMetadata (RawRpc serv meth))+ , BuildMetadata (ResponseInitialMetadata (RawRpc serv meth))+ , StaticMetadata (ResponseTrailingMetadata (RawRpc serv meth))+ ) => SupportsServerRpc (RawRpc serv meth) where+ rpcDeserializeInput _ = return+ rpcSerializeOutput _ = id++-- | For the raw protocol we do not check communication protocols+instance ValidStreamingType styp+ => SupportsStreamingType (RawRpc serv meth) styp
+ src/Network/GRPC/Spec/RPC/StreamType.hs view
@@ -0,0 +1,200 @@+-- | Streaming types+module Network.GRPC.Spec.RPC.StreamType (+ StreamingType(..)+ -- * Link RPCs to streaming types+ , SupportsStreamingType+ , HasStreamingType(..)+ -- * Handler type definition+ , NextElem(..)+ , Send+ , Recv+ , Positive+ , Negative(..)+ , HandlerRole(..)+ , Handler+ -- * Handler newtype wrappers+ , ServerHandler'(..)+ , ServerHandler+ , ClientHandler'(..)+ , ClientHandler+ -- * Singleton+ , SStreamingType(..)+ , ValidStreamingType(..)+ -- * Hoisting+ , hoistServerHandler+ ) where++-- Borrow protolens 'StreamingType' (but this module is not Protobuf specific)+import Data.ProtoLens.Service.Types (StreamingType(..))++import Data.Kind+import Data.Proxy++import Network.GRPC.Spec.RPC++{-------------------------------------------------------------------------------+ Link RPCs to streaming types+-------------------------------------------------------------------------------}++-- | This RPC supports the given streaming type+--+-- This is a weaker condition than 'HasStreamingType': some (non-Protobuf) RPCs+-- may support more than one streaming type.+class ValidStreamingType styp+ => SupportsStreamingType rpc (styp :: StreamingType)++-- | /The/ streaming type supported by this RPC++-- This is a stronger condition than 'SupportsStreamingType': we associate the+-- RPC with one /specific/ streaming type.+class SupportsStreamingType rpc (RpcStreamingType rpc)+ => HasStreamingType rpc where+ -- | The (single) streaming type supported by this RPC+ type RpcStreamingType rpc :: StreamingType++{-------------------------------------------------------------------------------+ Internal: preliminaries++ 'NextElem' does not allow to mark the final streaming element as final /as/ we+ send it; instead, we must use 'NoMoreElems' (which will correspond to an+ additional empty HTTP data frame); similarly, on the input side we cannot+ detect that an element is final as we receive it. This does not matter in the+ vast majority of cases; for the rare case where it does matter, user code can+ simply use the core API instead of the streaming API.++ It /is/ important that we mark the final message as final for /non-streaming/+ cases; some servers get confused when this is not the case. However, this is+ fine: in the non-streaming case we take care of on behalf of the user, and+ don't use 'NextElem' at all.+-------------------------------------------------------------------------------}++-- | Is there a next element in a stream?+data NextElem a = NoNextElem | NextElem !a+ deriving stock (Show, Eq, Functor, Foldable, Traversable)++-- | Send a value+type Send a = NextElem a -> IO ()++-- | Receive a value+--+-- 'Nothing' indicates no more values. Calling this function again after+-- receiving 'Nothing' is a bug.+type Recv a = IO (NextElem a)++-- | Positive use of @a@+type Positive m a b = a -> m b++-- | Negative use of @a@+newtype Negative m a b = Negative {+ runNegative :: forall r. (a -> m r) -> m (b, r)+ }++{-------------------------------------------------------------------------------+ Handler++ The handler definitions are carefully designed to make the duality between the+ server and the client obvious.+-------------------------------------------------------------------------------}++-- | Handler role+data HandlerRole =+ Server -- ^ Deal with an incoming request+ | Client -- ^ Initiate an outgoing request++-- | Type of a handler+type family Handler (r :: HandlerRole) (s :: StreamingType) m (rpc :: k) where+ Handler Server NonStreaming m rpc = Input rpc -> m (Output rpc)+ Handler Client NonStreaming m rpc = Input rpc -> m (Output rpc)++ Handler Server ClientStreaming m rpc = Positive m (Recv (Input rpc)) (Output rpc)+ Handler Client ClientStreaming m rpc = Negative m (Send (Input rpc)) (Output rpc)++ Handler Server ServerStreaming m rpc = Input rpc -> Positive m (Send (Output rpc)) ()+ Handler Client ServerStreaming m rpc = Input rpc -> Negative m (Recv (Output rpc)) ()++ Handler Server BiDiStreaming m rpc = Positive m (Recv (Input rpc), Send (Output rpc)) ()+ Handler Client BiDiStreaming m rpc = Negative m (Send (Input rpc), Recv (Output rpc)) ()++{-------------------------------------------------------------------------------+ Wrappers+-------------------------------------------------------------------------------}++-- | Wrapper around @Handler Server@ to avoid ambiguous types+data ServerHandler' (styp :: StreamingType) m (rpc :: k) where+ ServerHandler ::+ SupportsStreamingType rpc styp+ => Handler Server styp m rpc+ -> ServerHandler' styp m rpc++-- | Wrapper around @Handler Client@ to avoid ambiguous types+data ClientHandler' (s :: StreamingType) m (rpc :: k) where+ ClientHandler ::+ SupportsStreamingType rpc styp+ => Handler Client styp m rpc+ -> ClientHandler' styp m rpc++-- | Alias for 'ServerHandler'' with the streaming type determined by the @rpc@+type ServerHandler m rpc = ServerHandler' (RpcStreamingType rpc) m rpc++-- | Alias for 'ClientHandler'' with the streaming type determined by the @rpc@+type ClientHandler m rpc = ClientHandler' (RpcStreamingType rpc) m rpc++{-------------------------------------------------------------------------------+ Singleton+-------------------------------------------------------------------------------}++-- | Singleton for 'StreamingType'+data SStreamingType :: StreamingType -> Type where+ SNonStreaming :: SStreamingType NonStreaming+ SClientStreaming :: SStreamingType ClientStreaming+ SServerStreaming :: SStreamingType ServerStreaming+ SBiDiStreaming :: SStreamingType BiDiStreaming++-- | Valid streaming types+class ValidStreamingType (styp :: StreamingType) where+ -- | Obtain singleton+ validStreamingType :: Proxy styp -> SStreamingType styp++instance ValidStreamingType NonStreaming where validStreamingType _ = SNonStreaming+instance ValidStreamingType ClientStreaming where validStreamingType _ = SClientStreaming+instance ValidStreamingType ServerStreaming where validStreamingType _ = SServerStreaming+instance ValidStreamingType BiDiStreaming where validStreamingType _ = SBiDiStreaming++{-------------------------------------------------------------------------------+ Hoisting+-------------------------------------------------------------------------------}++class HoistServerHandler styp where+ hoistServerHandler' ::+ (forall a. m a -> n a)+ -> ServerHandler' styp m rpc+ -> ServerHandler' styp n rpc++instance HoistServerHandler NonStreaming where+ hoistServerHandler' f (ServerHandler h) = ServerHandler $ \inp ->+ f $ h inp++instance HoistServerHandler ClientStreaming where+ hoistServerHandler' f (ServerHandler h) = ServerHandler $ \recv ->+ f $ h recv++instance HoistServerHandler ServerStreaming where+ hoistServerHandler' f (ServerHandler h) = ServerHandler $ \inp send ->+ f $ h inp send++instance HoistServerHandler BiDiStreaming where+ hoistServerHandler' f (ServerHandler h) = ServerHandler $ \(recv, send) ->+ f $ h (recv, send)++-- | Hoist server handler from one monad to another+hoistServerHandler :: forall styp m n rpc.+ ValidStreamingType styp+ => (forall a. m a -> n a)+ -> ServerHandler' styp m rpc+ -> ServerHandler' styp n rpc+hoistServerHandler f =+ case validStreamingType (Proxy @styp) of+ SNonStreaming -> hoistServerHandler' f+ SClientStreaming -> hoistServerHandler' f+ SServerStreaming -> hoistServerHandler' f+ SBiDiStreaming -> hoistServerHandler' f
+ src/Network/GRPC/Spec/Serialization.hs view
@@ -0,0 +1,67 @@+-- | Serialization functions+--+-- We collect these functions in a separate module, rather than exporting them+-- from "Network.GRPC.Spec", because while the functions in "Network.GRPC.Spec"+-- /may/ be needed in some user code (albeit rarely), the serialization+-- functions from this module really should only be needed in gRPC+-- implementations such as @grapesy@.+module Network.GRPC.Spec.Serialization (+ -- * Messages+ -- ** Inputs+ buildInput+ , parseInput+ -- ** Outputs+ , buildOutput+ , parseOutput+ -- * Headers+ -- ** Pseudoheaders+ , RawResourceHeaders(..)+ , InvalidResourceHeaders(..)+ , buildResourceHeaders+ , parseResourceHeaders+ -- ** RequestHeaders+ , buildRequestHeaders+ , parseRequestHeaders+ , parseRequestHeaders'+ -- *** Timeouts+ , buildTimeout+ , parseTimeout+ -- *** OpenTelemetry+ , buildTraceContext+ , parseTraceContext+ -- ** ResponseHeaders+ , buildResponseHeaders+ , parseResponseHeaders+ , parseResponseHeaders'+ -- *** Pushback+ , buildPushback+ , parsePushback+ -- ** ProperTrailers+ , buildProperTrailers+ , parseProperTrailers+ , parseProperTrailers'+ -- ** TrailersOnly+ , buildTrailersOnly+ , parseTrailersOnly+ , parseTrailersOnly'+ -- ** Classify server response+ , classifyServerResponse+ -- ** Custom metadata+ , parseCustomMetadata+ , buildCustomMetadata+ -- *** Binary values+ , buildBinaryValue+ , parseBinaryValue+ -- *** Status (Protobuf specific)+ , buildStatus+ , parseStatus+ ) where++import Network.GRPC.Spec.Serialization.CustomMetadata+import Network.GRPC.Spec.Serialization.Headers.PseudoHeaders+import Network.GRPC.Spec.Serialization.Headers.Request+import Network.GRPC.Spec.Serialization.Headers.Response+import Network.GRPC.Spec.Serialization.LengthPrefixed+import Network.GRPC.Spec.Serialization.Status+import Network.GRPC.Spec.Serialization.Timeout+import Network.GRPC.Spec.Serialization.TraceContext
+ src/Network/GRPC/Spec/Serialization/Base64.hs view
@@ -0,0 +1,82 @@+-- | gRPC-style base64-encoding+--+-- The gRPC specification mandates standard Base64-encoding for binary headers+-- <https://datatracker.ietf.org/doc/html/rfc4648#section-4>, /but/ without+-- padding.+module Network.GRPC.Spec.Serialization.Base64 (+ encodeBase64+ , decodeBase64+ ) where++import Control.Monad+import Data.ByteString qualified as BS.Strict+import Data.ByteString qualified as Strict (ByteString)+import Data.ByteString.Base64 qualified as BS.Strict.B64+import Data.ByteString.Char8 qualified as BS.Strict.Char8++{-------------------------------------------------------------------------------+ Top-level+-------------------------------------------------------------------------------}++encodeBase64 :: Strict.ByteString -> Strict.ByteString+encodeBase64 = removePadding . BS.Strict.B64.encode++decodeBase64 :: Strict.ByteString -> Either String Strict.ByteString+decodeBase64 = BS.Strict.B64.decode <=< addPadding++{-------------------------------------------------------------------------------+ Internal: Adding and removing padding++ In Base64 encoding, every group of three bytes in the input is represented as+ 4 bytes in the output. We therefore have three possibilities:++ * The input has size @3n@. No padding bytes are added.+ * The input has size @3n + 1@. Two padding byte are added.+ * The input has size @3n + 2@. One padding byte is added.++ Standard base64 encoding (including padding) therefore /always/ has size @4m@.+-------------------------------------------------------------------------------}++removePadding :: Strict.ByteString -> Strict.ByteString+removePadding bs+ -- Empty bytestring+ --+ -- If the bytestring is not null, it must have at least 4 bytes, justifying+ -- the calls to @index@ below.+ | BS.Strict.null bs+ = bs++ -- Two padding bytes+ | BS.Strict.Char8.index bs (len - 2) == '='+ = BS.Strict.take (len - 2) bs++ -- One padding byte+ | BS.Strict.Char8.index bs (len - 1) == '='+ = BS.Strict.take (len - 1) bs++ | otherwise+ = bs+ where+ len :: Int+ len = BS.Strict.length bs++addPadding :: Strict.ByteString -> Either String Strict.ByteString+addPadding bs+ -- Three padding bytes (i.e., invalid strict)+ | len `mod` 4 == 1+ = Left $ "Invalid length of unpadded base64-encoded string " ++ show len++ -- Two padding bytes+ | len `mod` 4 == 2+ = Right $ bs <> BS.Strict.Char8.pack "=="++ -- One padding bytes+ | len `mod` 4 == 3+ = Right $ bs <> BS.Strict.Char8.pack "="++ -- No padding (this includes the empty string)+ | otherwise+ = Right bs+ where+ len :: Int+ len = BS.Strict.length bs
+ src/Network/GRPC/Spec/Serialization/CustomMetadata.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.GRPC.Spec.Serialization.CustomMetadata (+ -- * HeaderName+ buildHeaderName+ , parseHeaderName+ -- * AsciiValue+ , buildAsciiValue+ , parseAsciiValue+ -- * BinaryValue+ , buildBinaryValue+ , parseBinaryValue+ -- * CustomMetadata+ , buildCustomMetadata+ , parseCustomMetadata+ ) where++import Control.Monad+import Control.Monad.Except (MonadError(throwError))+import Data.ByteString qualified as BS.Strict+import Data.ByteString qualified as Strict (ByteString)+import Data.CaseInsensitive (CI)+import Data.CaseInsensitive qualified as CI+import Data.List (intersperse)+import Network.HTTP.Types qualified as HTTP++import Network.GRPC.Spec+import Network.GRPC.Spec.Serialization.Base64+import Network.GRPC.Spec.Util.ByteString (ascii)++{-------------------------------------------------------------------------------+ HeaderName+-------------------------------------------------------------------------------}++buildHeaderName :: HeaderName -> CI Strict.ByteString+buildHeaderName name =+ case name of+ BinaryHeader name' -> CI.mk name'+ AsciiHeader name' -> CI.mk name'++parseHeaderName :: MonadError String m => CI Strict.ByteString -> m HeaderName+parseHeaderName name =+ case safeHeaderName (CI.foldedCase name) of+ Nothing -> throwError $ "Invalid header name: " ++ show name+ Just name' -> return name'++{-------------------------------------------------------------------------------+ AsciiValue+-------------------------------------------------------------------------------}++buildAsciiValue :: Strict.ByteString -> Strict.ByteString+buildAsciiValue = id++parseAsciiValue ::+ MonadError String m+ => Strict.ByteString -> m Strict.ByteString+parseAsciiValue bs = do+ unless (isValidAsciiValue bs) $+ throwError $ "Invalid ASCII header: " ++ show bs+ return bs++{-------------------------------------------------------------------------------+ BinaryValue+-------------------------------------------------------------------------------}++-- | Serialize binary value (base-64 encoding)+buildBinaryValue :: Strict.ByteString -> Strict.ByteString+buildBinaryValue = encodeBase64++-- | Parse binary value+--+-- The presence of duplicate headers makes this a bit subtle. Let's consider an+-- example. Suppose we have two duplicate headers+--+-- > foo-bin: YWJj -- encoding of "abc"+-- > foo-bin: ZGVm -- encoding of "def"+--+-- The spec says+--+-- > Custom-Metadata header order is not guaranteed to be preserved except for+-- > values with duplicate header names. Duplicate header names may have their+-- > values joined with "," as the delimiter and be considered semantically+-- > equivalent.+--+-- We will do the decoding of both headers /prior/ to joining duplicate headers,+-- and so the value we will reconstruct for @foo-bin@ is \"abc,def\".+--+-- However, suppose we deal with a (non-compliant) peer which is unaware of+-- binary headers and has applied the joining rule /without/ decoding:+--+-- > foo-bin: YWJj,ZGVm+--+-- The spec is a bit vague about this case, saying only:+--+-- > Implementations must split Binary-Headers on "," before decoding the+-- > Base64-encoded values.+--+-- Here we assume that this case must be treated the same way as if the headers+-- /had/ been decoded prior to joining. Therefore, we split the input on commas,+-- decode each result separately, and join the results with commas again.+parseBinaryValue :: forall m.+ MonadError String m+ => Strict.ByteString -> m Strict.ByteString+parseBinaryValue bs = do+ let chunks = BS.Strict.split (ascii ',') bs+ decoded <- mapM decode chunks+ return $ mconcat $ intersperse "," decoded+ where+ decode :: Strict.ByteString -> m Strict.ByteString+ decode chunk =+ case decodeBase64 chunk of+ Left err -> throwError err+ Right val -> return val++{-------------------------------------------------------------------------------+ CustomMetadata+-------------------------------------------------------------------------------}++-- | Serialize t'CustomMetadata'+buildCustomMetadata :: CustomMetadata -> HTTP.Header+buildCustomMetadata (CustomMetadata name value) =+ case name of+ BinaryHeader _ -> (buildHeaderName name, buildBinaryValue value)+ AsciiHeader _ -> (buildHeaderName name, buildAsciiValue value)++-- | Parse t'CustomMetadata'+parseCustomMetadata ::+ MonadError (InvalidHeaders GrpcException) m+ => HTTP.Header -> m CustomMetadata+parseCustomMetadata hdr@(name, value) = throwInvalidHeader hdr $ do+ name' <- parseHeaderName name+ value' <- case name' of+ AsciiHeader _ -> parseAsciiValue value+ BinaryHeader _ -> parseBinaryValue value+ -- If parsing succeeds, that justifies the use of 'UnsafeCustomMetadata'+ return $ CustomMetadata name' value'
+ src/Network/GRPC/Spec/Serialization/Headers/Common.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.GRPC.Spec.Serialization.Headers.Common (+ -- * Content type+ buildContentType+ , parseContentType+ -- * Message type+ , buildMessageType+ , parseMessageType+ -- * Message encoding+ , buildMessageEncoding+ , buildMessageAcceptEncoding+ , parseMessageEncoding+ , parseMessageAcceptEncoding+ -- * Utilities+ , trim+ ) where++import Control.Monad+import Control.Monad.Except+import Data.ByteString qualified as BS.Strict+import Data.ByteString qualified as Strict (ByteString)+import Data.ByteString.Char8 qualified as BS.Strict.C8+import Data.Foldable (toList)+import Data.List (intersperse)+import Data.List.NonEmpty (NonEmpty(..))+import Data.Proxy+import Data.Word+import Network.HTTP.Types qualified as HTTP++import Network.GRPC.Spec+import Network.GRPC.Spec.Util.ByteString++{-------------------------------------------------------------------------------+ > Content-Type →+ > "content-type"+ > "application/grpc"+ > [("+proto" / "+json" / {custom})]+-------------------------------------------------------------------------------}++buildContentType ::+ Maybe Strict.ByteString -- ^ Content-type, if known+ -> HTTP.Header+buildContentType mContentType = (+ "content-type"+ , case mContentType of+ Nothing -> "application/grpc"+ Just ct -> ct+ )++-- | Parse @content-type@ header+--+-- The gRPC spec mandates different behaviour here for requests and responses:+-- when parsing a request (i.e., on the server), the spec requires that the+-- server responds with @415 Unsupported Media Type@. When parsing a response,+-- however (i.e., on the client), the spec mandates that we synthesize a+-- gRPC exception. We therefore take a function as parameter to construct the+-- actual error.+parseContentType :: forall m rpc.+ (MonadError (InvalidHeaders GrpcException) m, IsRPC rpc)+ => Proxy rpc+ -> (String -> InvalidHeaders GrpcException)+ -> HTTP.Header+ -> m ContentType+parseContentType proxy invalid (_name, value) = do+ if value == rpcContentType proxy then+ return ContentTypeDefault+ else do+ -- Headers must be ASCII, justifying the use of BS.Strict.C8.+ -- See <https://www.rfc-editor.org/rfc/rfc7230#section-3.2.4>.+ -- The gRPC spec does not allow for quoted strings.+ withoutPrefix <-+ case BS.Strict.C8.stripPrefix "application/grpc" value of+ Nothing -> err "Missing \"application/grpc\" prefix."+ Just remainder -> return remainder++ -- The gRPC spec does not allow for any parameters.+ when (';' `BS.Strict.C8.elem` withoutPrefix) $+ err "Unexpected parameter."++ -- Check format+ --+ -- The only @format@ we should allow is @serializationFormat proxy@.+ -- However, some non-conforming proxies use formats such as+ -- @application/grpc+octet-stream@. We therefore ignore @format@ here.+ if BS.Strict.C8.null withoutPrefix then+ -- Accept "application/grpc"+ return $ ContentTypeOverride value+ else+ case BS.Strict.C8.stripPrefix "+" withoutPrefix of+ Just _format ->+ -- Accept "application/grpc+<format>"+ return $ ContentTypeOverride value+ Nothing ->+ err "Invalid subtype."+ where+ err :: String -> m a+ err reason = throwError . invalid . concat $ [+ reason+ , " Expected \"application/grpc\" or \""+ , BS.Strict.C8.unpack $+ rpcContentType proxy+ , "\", with \""+ , "application/grpc+{other_format}"+ , "\" also accepted."+ ]++{-------------------------------------------------------------------------------+ > Message-Type → "grpc-message-type" {type name for message schema}+-------------------------------------------------------------------------------}++buildMessageType ::+ IsRPC rpc+ => Proxy rpc+ -> MessageType+ -> Maybe HTTP.Header+buildMessageType proxy messageType =+ mkHeader <$> chooseMessageType proxy messageType+ where+ mkHeader :: Strict.ByteString -> HTTP.Header+ mkHeader = ("grpc-message-type",)++-- | Parse message type+--+-- We do not need the @grpc-message-type@ header in order to know the message+-- type, because the /path/ determines the service and method, and that in turn+-- determines the message type. Therefore, if the value is not what we expect,+-- we merely record this fact ('MessageTypeOverride') but don't otherwise do+-- anything differently.+parseMessageType :: forall rpc.+ IsRPC rpc+ => Proxy rpc+ -> HTTP.Header+ -> MessageType+parseMessageType proxy (_name, given) =+ case rpcMessageType proxy of+ Nothing ->+ -- We expected no message type at all, but did get one+ MessageTypeOverride given+ Just expected ->+ if expected == given+ then MessageTypeDefault+ else MessageTypeOverride given++{-------------------------------------------------------------------------------+ > Message-Encoding → "grpc-encoding" Content-Coding+ > Content-Coding → "identity" / "gzip" / "deflate" / "snappy" / {custom}+-------------------------------------------------------------------------------}++buildMessageEncoding :: CompressionId -> HTTP.Header+buildMessageEncoding compr = (+ "grpc-encoding"+ , serializeCompressionId compr+ )++parseMessageEncoding ::+ MonadError (InvalidHeaders GrpcException) m+ => HTTP.Header+ -> m CompressionId+parseMessageEncoding (_name, value) =+ return $ deserializeCompressionId value++{-------------------------------------------------------------------------------+ > Message-Accept-Encoding →+ > "grpc-accept-encoding" Content-Coding *("," Content-Coding)+-------------------------------------------------------------------------------}++buildMessageAcceptEncoding :: NonEmpty CompressionId -> HTTP.Header+buildMessageAcceptEncoding compr = (+ "grpc-accept-encoding"+ , mconcat . intersperse "," . map serializeCompressionId $ toList compr+ )++parseMessageAcceptEncoding :: forall m.+ MonadError (InvalidHeaders GrpcException) m+ => HTTP.Header+ -> m (NonEmpty CompressionId)+parseMessageAcceptEncoding hdr@(_name, value) =+ atLeastOne+ . map (deserializeCompressionId . strip)+ . BS.Strict.splitWith (== ascii ',')+ $ value+ where+ atLeastOne :: forall a. [a] -> m (NonEmpty a)+ atLeastOne (x : xs) = return (x :| xs)+ atLeastOne [] = throwError $ invalidHeader Nothing hdr $+ "Expected at least one compresion ID"++{-------------------------------------------------------------------------------+ Utilities+-------------------------------------------------------------------------------}++-- | Trim leading or trailing whitespace+--+-- We only allow for space and tab, based on+-- <https://www.rfc-editor.org/rfc/rfc9110.html#name-whitespace>.+trim :: Strict.ByteString -> Strict.ByteString+trim = ltrim . rtrim+ where+ ltrim, rtrim :: Strict.ByteString -> Strict.ByteString+ ltrim = BS.Strict.dropWhile isSpace+ rtrim = BS.Strict.dropWhileEnd isSpace++ isSpace :: Word8 -> Bool+ isSpace x = x == 32 || x == 9
+ src/Network/GRPC/Spec/Serialization/Headers/PseudoHeaders.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.GRPC.Spec.Serialization.Headers.PseudoHeaders (+ RawResourceHeaders(..)+ , InvalidResourceHeaders(..)+ , buildResourceHeaders+ , parseResourceHeaders+ ) where++import Control.Monad.Except+import Data.ByteString qualified as BS.Strict+import Data.ByteString qualified as Strict (ByteString)++import Network.GRPC.Spec+import Network.GRPC.Spec.Util.ByteString++{-------------------------------------------------------------------------------+ Serialization+-------------------------------------------------------------------------------}++-- | Raw (serialized) form of t'ResourceHeaders'+data RawResourceHeaders = RawResourceHeaders {+ rawPath :: Strict.ByteString -- ^ Serialized 'resourcePath'+ , rawMethod :: Strict.ByteString -- ^ Serialized 'resourceMethod'+ }+ deriving (Show)++-- | Invalid resource headers+--+-- See 'parseResourceHeaders'+data InvalidResourceHeaders =+ InvalidMethod Strict.ByteString+ | InvalidPath Strict.ByteString+ deriving stock (Show)++-- | Serialize t'ResourceHeaders' (pseudo headers)+buildResourceHeaders :: ResourceHeaders -> RawResourceHeaders+buildResourceHeaders ResourceHeaders{resourcePath, resourceMethod} =+ RawResourceHeaders {+ rawMethod = case resourceMethod of Post -> "POST"+ , rawPath = mconcat [+ "/"+ , pathService resourcePath+ , "/"+ , pathMethod resourcePath+ ]+ }++-- | Parse t'ResourceHeaders' (pseudo headers)+parseResourceHeaders ::+ RawResourceHeaders+ -> Either InvalidResourceHeaders ResourceHeaders+parseResourceHeaders RawResourceHeaders{rawMethod, rawPath} = do+ resourceMethod <-+ case rawMethod of+ "POST" -> return Post+ _otherwise -> throwError $ InvalidMethod rawMethod++ resourcePath <-+ case BS.Strict.split (ascii '/') rawPath of+ ["", service, method] ->+ return $ Path service method+ _otherwise ->+ throwError $ InvalidPath rawPath++ return ResourceHeaders{resourceMethod, resourcePath}
+ src/Network/GRPC/Spec/Serialization/Headers/Request.hs view
@@ -0,0 +1,306 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.GRPC.Spec.Serialization.Headers.Request (+ buildRequestHeaders+ --+ -- Throws an error if any headers fail to parse; if this is not desired, see+ -- 'parseRequestHeaders'' instead.+ , parseRequestHeaders+ --+ -- Throws an error if any headers fail to parse; if this is not desired, see+ -- 'parseRequestHeaders'' instead.+ , parseRequestHeaders'+ ) where++import Control.Monad+import Control.Monad.Except (MonadError(throwError))+import Control.Monad.State (State, execState, modify)+import Data.Bifunctor+import Data.ByteString qualified as Strict (ByteString)+import Data.ByteString.Char8 qualified as BS.Strict.C8+import Data.Functor (($>))+import Data.List (intercalate)+import Data.Maybe (catMaybes)+import Data.Proxy+import Network.HTTP.Types qualified as HTTP+import Text.Read (readMaybe)++import Network.GRPC.Spec+import Network.GRPC.Spec.Serialization.CustomMetadata+import Network.GRPC.Spec.Serialization.Headers.Common+import Network.GRPC.Spec.Serialization.Timeout+import Network.GRPC.Spec.Serialization.TraceContext+import Network.GRPC.Spec.Util.HKD qualified as HKD++{-------------------------------------------------------------------------------+ Construction+-------------------------------------------------------------------------------}++-- | Request headers+--+-- > Request-Headers →+-- > Call-Definition+-- > *Custom-Metadata+buildRequestHeaders ::+ IsRPC rpc+ => Proxy rpc -> RequestHeaders -> [HTTP.Header]+buildRequestHeaders proxy callParams@RequestHeaders{requestMetadata} = concat [+ callDefinition proxy callParams+ , map buildCustomMetadata $ customMetadataMapToList requestMetadata+ ]++-- | Call definition+--+-- > Call-Definition →+-- > Method+-- > Scheme+-- > Path+-- > TE+-- > [Authority]+-- > [Timeout]+-- > Content-Type+-- > [Message-Type]+-- > [Message-Encoding]+-- > [Message-Accept-Encoding]+-- > [User-Agent]+--+-- However, the spec additionally mandates that+--+-- HTTP2 requires that reserved headers, ones starting with ":" appear+-- before all other headers. Additionally implementations should send+-- Timeout immediately after the reserved headers and they should send the+-- Call-Definition headers before sending Custom-Metadata.+--+-- (Relevant part of the HTTP2 spec:+-- <https://www.rfc-editor.org/rfc/rfc7540#section-8.1.2.1>.) This means+-- @TE@ should come /after/ @Authority@ (if using). However, we will not include+-- the reserved headers here /at all/, as they are automatically added by+-- @http2@.+callDefinition :: forall rpc.+ IsRPC rpc+ => Proxy rpc -> RequestHeaders -> [HTTP.Header]+callDefinition proxy = \hdrs -> catMaybes [+ hdrTimeout <$> requestTimeout hdrs+ , guard (requestIncludeTE hdrs) $> buildTe+ , buildContentType . Just . chooseContentType proxy <$>+ requestContentType hdrs+ , join $ buildMessageType proxy <$> requestMessageType hdrs+ , buildMessageEncoding <$> requestCompression hdrs+ , buildMessageAcceptEncoding <$> requestAcceptCompression hdrs+ , buildUserAgent <$> requestUserAgent hdrs+ , buildGrpcTraceBin <$> requestTraceContext hdrs+ , buildPreviousRpcAttempts <$> requestPreviousRpcAttempts hdrs+ ]+ where+ hdrTimeout :: Timeout -> HTTP.Header+ hdrTimeout t = ("grpc-timeout", buildTimeout t)++ -- > TE → "te" "trailers" # Used to detect incompatible proxies+ buildTe :: HTTP.Header+ buildTe = ("te", "trailers")++ -- > User-Agent → "user-agent" {structured user-agent string}+ --+ -- The spec says:+ --+ -- While the protocol does not require a user-agent to function it is+ -- recommended that clients provide a structured user-agent string that+ -- provides a basic description of the calling library, version & platform+ -- to facilitate issue diagnosis in heterogeneous environments. The+ -- following structure is recommended to library developers+ --+ -- > User-Agent →+ -- > "grpc-"+ -- > Language+ -- > ?("-" Variant)+ -- > "/"+ -- > Version+ -- > ?( " (" *(AdditionalProperty ";") ")" )+ buildUserAgent :: Strict.ByteString -> HTTP.Header+ buildUserAgent userAgent = (+ "user-agent"+ , userAgent+ )++ buildGrpcTraceBin :: TraceContext -> HTTP.Header+ buildGrpcTraceBin ctxt = (+ "grpc-trace-bin"+ , buildBinaryValue $ buildTraceContext ctxt+ )++ buildPreviousRpcAttempts :: Int -> HTTP.Header+ buildPreviousRpcAttempts n = (+ "grpc-previous-rpc-attempts"+ , BS.Strict.C8.pack $ show n+ )++{-------------------------------------------------------------------------------+ Parsing+-------------------------------------------------------------------------------}++-- | Parse t'RequestHeaders'+--+-- Throws an error if any headers fail to parse; if this is not desired, see+-- 'parseRequestHeaders'' instead.+parseRequestHeaders :: forall rpc m.+ (IsRPC rpc, MonadError (InvalidHeaders GrpcException) m)+ => Proxy rpc+ -> [HTTP.Header] -> m RequestHeaders+parseRequestHeaders proxy = HKD.sequenceChecked . parseRequestHeaders' proxy++-- | Parse request headers+--+-- This can report invalid headers on a per-header basis; see also+-- 'parseRequestHeaders'.+parseRequestHeaders' :: forall rpc.+ IsRPC rpc+ => Proxy rpc+ -> [HTTP.Header] -> RequestHeaders' GrpcException+parseRequestHeaders' proxy =+ flip execState uninitRequestHeaders+ . mapM_ (parseHeader . second trim)+ where+ parseHeader :: HTTP.Header -> State (RequestHeaders' GrpcException) ()+ parseHeader hdr@(name, value)+ | name == "user-agent"+ = modify $ \x -> x {+ requestUserAgent = return (Just value)+ }++ | name == "grpc-timeout"+ = modify $ \x -> x {+ requestTimeout = fmap Just $+ httpError hdr $+ parseTimeout value+ }++ | name == "grpc-encoding"+ = modify $ \x -> x {+ requestCompression = fmap Just $+ parseMessageEncoding hdr+ }++ | name == "grpc-accept-encoding"+ = modify $ \x -> x {+ requestAcceptCompression = fmap Just $+ parseMessageAcceptEncoding hdr+ }++ | name == "grpc-trace-bin"+ = modify $ \x -> x {+ requestTraceContext = fmap Just $+ httpError hdr $+ parseBinaryValue value >>= parseTraceContext+ }++ | name == "content-type"+ = modify $ \x -> x {+ requestContentType = fmap Just $+ parseContentType' proxy hdr+ }++ | name == "grpc-message-type"+ = modify $ \x -> x {+ requestMessageType = return . Just $+ parseMessageType proxy hdr+ }++ | name == "te"+ = modify $ \x -> x {+ requestIncludeTE = do+ expectHeaderValue hdr ["trailers"]+ return True+ }++ | name == "grpc-previous-rpc-attempts"+ = modify $ \x -> x {+ requestPreviousRpcAttempts = do+ httpError hdr $+ maybe+ (Left $ "grpc-previous-rpc-attempts: invalid " ++ show value)+ (Right . Just)+ (readMaybe $ BS.Strict.C8.unpack value)+ }++ | otherwise+ = modify $ \x ->+ case parseCustomMetadata hdr of+ Left invalid -> x {+ requestUnrecognized = Left $+ case requestUnrecognized x of+ Left invalid' -> invalid <> invalid'+ Right () -> invalid+ }+ Right md -> x {+ requestMetadata = customMetadataMapInsert md $ requestMetadata x+ }++ uninitRequestHeaders :: RequestHeaders' GrpcException+ uninitRequestHeaders = RequestHeaders {+ requestTimeout = return Nothing+ , requestCompression = return Nothing+ , requestAcceptCompression = return Nothing+ , requestIncludeTE = return False+ , requestUserAgent = return Nothing+ , requestTraceContext = return Nothing+ , requestPreviousRpcAttempts = return Nothing+ , requestMetadata = mempty+ , requestUnrecognized = return ()++ -- Special cases++ , requestContentType =+ throwError $ missingHeader invalidContentType "content-type"+ , requestMessageType =+ -- If the default is that this header should be absent, then /start/+ -- with 'MessageTypeDefault'; if it happens to present, parse it as+ -- an override.+ case rpcMessageType proxy of+ Nothing -> return $ Just MessageTypeDefault+ Just _ -> return $ Nothing+ }++ httpError ::+ MonadError (InvalidHeaders GrpcException) m'+ => HTTP.Header -> Either String a -> m' a+ httpError _ (Right a) = return a+ httpError hdr (Left err) = throwError $ invalidHeader Nothing hdr err++{-------------------------------------------------------------------------------+ Content type++ See 'parseContentType' for discussion.+-------------------------------------------------------------------------------}++parseContentType' ::+ IsRPC rpc+ => Proxy rpc+ -> HTTP.Header+ -> Either (InvalidHeaders GrpcException) ContentType+parseContentType' proxy hdr =+ parseContentType+ proxy+ (invalidHeader invalidContentType hdr)+ hdr++invalidContentType :: Maybe HTTP.Status+invalidContentType = Just HTTP.unsupportedMediaType415++{-------------------------------------------------------------------------------+ Internal auxiliary+-------------------------------------------------------------------------------}++expectHeaderValue ::+ MonadError (InvalidHeaders GrpcException) m+ => HTTP.Header -> [Strict.ByteString] -> m ()+expectHeaderValue hdr@(_name, actual) expected =+ unless (actual `elem` expected) $+ throwError $ invalidHeader Nothing hdr err+ where+ err :: String+ err = concat [+ "Expected "+ , intercalate " or " $+ map (\e -> "\"" ++ BS.Strict.C8.unpack e ++ "\"") expected+ , "."+ ]
+ src/Network/GRPC/Spec/Serialization/Headers/Response.hs view
@@ -0,0 +1,621 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Deal with HTTP2 responses+--+-- Intended for unqualified import.+module Network.GRPC.Spec.Serialization.Headers.Response (+ -- * ResponseHeaders+ buildResponseHeaders+ , parseResponseHeaders+ , parseResponseHeaders'+ -- * ProperTrailers+ , buildProperTrailers+ , parseProperTrailers+ , parseProperTrailers'+ -- * TrailersOnly+ , buildTrailersOnly+ , parseTrailersOnly+ , parseTrailersOnly'+ -- * Classify server response+ , classifyServerResponse+ -- * Pushback+ , buildPushback+ , parsePushback+ ) where++import Control.Monad.Except+import Control.Monad.State+import Data.Bifunctor+import Data.ByteString qualified as BS.Strict+import Data.ByteString qualified as Strict (ByteString)+import Data.ByteString.Char8 qualified as BS.Strict.C8+import Data.ByteString.Lazy qualified as BS.Lazy+import Data.ByteString.Lazy qualified as Lazy (ByteString)+import Data.CaseInsensitive qualified as CI+import Data.Maybe (isJust)+import Data.Proxy+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Network.HTTP.Types qualified as HTTP+import Text.Read (readMaybe)++#if !MIN_VERSION_text(2,0,0)+import Data.Text.Encoding.Error qualified as Text+#endif++import Network.GRPC.Spec+import Network.GRPC.Spec.PercentEncoding qualified as PercentEncoding+import Network.GRPC.Spec.Serialization.CustomMetadata+import Network.GRPC.Spec.Serialization.Headers.Common+import Network.GRPC.Spec.Util.HKD qualified as HKD+import Network.GRPC.Spec.Util.Protobuf qualified as Protobuf++{-------------------------------------------------------------------------------+ Classify server response+-------------------------------------------------------------------------------}++-- | Classify server response+--+-- gRPC servers are supposed to respond with HTTP status @200 OK@ no matter+-- whether the call was successful or not; if not successful, the information+-- about the failure should be reported using @grpc-status@ and related headers+-- (@grpc-message@, @grpc-status-details-bin@).+--+-- The gRPC spec mandates that if we get a non-200 status from a broken+-- deployment, we synthesize a gRPC exception with an appropriate status and+-- status message. The spec itself does not provide any guidance on what such an+-- appropriate status would look like, but the official gRPC repo does provide a+-- partial mapping between HTTP status codes and gRPC status codes at+-- <https://github.com/grpc/grpc/blob/master/doc/http-grpc-status-mapping.md>.+-- This is the mapping we implement here.+classifyServerResponse :: forall rpc.+ IsRPC rpc+ => Proxy rpc+ -> HTTP.Status -- ^ HTTP status+ -> [HTTP.Header] -- ^ Headers+ -> Maybe Lazy.ByteString -- ^ Response body, if known (used for errors only)+ -> Either (TrailersOnly' GrpcException) (ResponseHeaders' GrpcException)+classifyServerResponse rpc status headers mBody+ -- The "HTTP to gRPC Status Code Mapping" is explicit:+ --+ -- > (..) to be used only for clients that received a response that did not+ -- > include grpc-status. If grpc-status was provided, it must be used.+ --+ -- Therefore if @grpc-status@ is present, we ignore the HTTP status.+ | hasGrpcStatus headers+ = Left $ parseTrailersOnly' rpc headers++ | 200 <- statusCode+ = Right $ parseResponseHeaders' rpc headers++ | otherwise+ = Left $+ case statusCode of+ 400 -> synthesize GrpcInternal -- Bad request+ 401 -> synthesize GrpcUnauthenticated -- Unauthorized+ 403 -> synthesize GrpcPermissionDenied -- Forbidden+ 404 -> synthesize GrpcUnimplemented -- Not found+ 429 -> synthesize GrpcUnavailable -- Too many requests+ 502 -> synthesize GrpcUnavailable -- Bad gateway+ 503 -> synthesize GrpcUnavailable -- Service unavailable+ 504 -> synthesize GrpcUnavailable -- Gateway timeout+ _ -> synthesize GrpcUnknown+ where+ HTTP.Status{statusCode, statusMessage} = status++ -- The @grpc-status@ header not present, and HTTP status not @200 OK@.+ -- We classify the response as an error response (hence 'TrailersOnly''):+ --+ -- * We set 'properTrailersGrpcStatus' based on the HTTP status.+ -- * We leave 'properTrailersGrpcMessage' alone if @grpc-message@ present+ -- and valid, and replace it with a default message otherwise.+ --+ -- The resulting 'TrailersOnly'' cannot contain any parse errors+ -- (only @grpc-status@ is required, and only @grpc-message@ can fail).+ synthesize :: GrpcError -> TrailersOnly' GrpcException+ synthesize err = parsed {+ trailersOnlyContentType =+ -- We tried to parse the headers that were there, but there will+ -- almost certainly not be a content-type header present in the+ -- case of a non-200 HTTP status. We don't want to synthesize /that/+ -- error, so we override it.+ case trailersOnlyContentType parsed of+ Left _err -> Right Nothing+ Right mCType -> Right mCType+ , trailersOnlyProper = parsedTrailers {+ properTrailersGrpcStatus = Right $+ GrpcError err+ , properTrailersGrpcMessage = Right $+ case properTrailersGrpcMessage parsedTrailers of+ Right (Just msg) -> Just msg+ _otherwise -> Just defaultMsg+ }+ }+ where+ parsed :: TrailersOnly' GrpcException+ parsed = parseTrailersOnly' rpc headers++ parsedTrailers :: ProperTrailers'+ parsedTrailers = trailersOnlyProper parsed++ defaultMsg :: Text+ defaultMsg = mconcat [+ "Unexpected HTTP status code "+ , Text.pack (show statusCode)+ , if not (BS.Strict.null statusMessage)+ then " (" <> decodeUtf8Lenient statusMessage <> ")"+ else mempty+ , case mBody of+ Just body | not (BS.Lazy.null body) -> mconcat [+ "\nResponse body:\n"+ , decodeUtf8Lenient (BS.Lazy.toStrict body)+ ]+ _otherwise ->+ mempty+ ]++-- | Is the @grpc-status@ header set?+--+-- We use this as a proxy to determine if we are in the Trailers-Only case.+--+-- It might be tempting to use the HTTP @Content-Length@ header instead, but+-- this is doubly wrong:+--+-- * There might be servers who use the Trailers-Only case but do not set the+-- @Content-Length@ header (although such a server would not conform to the+-- HTTP spec: "An origin server SHOULD send a @Content-Length@ header field+-- when the content size is known prior to sending the complete header+-- section"; see+-- <https://www.rfc-editor.org/rfc/rfc9110.html#name-content-length>).+-- * Conversely, there might be servers or proxies who /do/ set @Content-Length@+-- header even when it's /not/ the Trailers-Only case (e.g., see+-- <https://github.com/grpc/grpc-web/issues/1101> or+-- <https://github.com/envoyproxy/envoy/issues/5554>).+--+-- We therefore check for the presence of the @grpc-status@ header instead.+hasGrpcStatus :: [HTTP.Header] -> Bool+hasGrpcStatus = isJust . lookup "grpc-status"++{-------------------------------------------------------------------------------+ > Response-Headers →+ > HTTP-Status+ > [Message-Encoding]+ > [Message-Accept-Encoding]+ > Content-Type+ > *Custom-Metadata++ We do not deal with @HTTP-Status@ here; @http2@ deals this separately.+-------------------------------------------------------------------------------}++-- | Build response headers+buildResponseHeaders :: forall rpc.+ SupportsServerRpc rpc+ => Proxy rpc -> ResponseHeaders -> [HTTP.Header]+buildResponseHeaders proxy+ ResponseHeaders{ responseCompression+ , responseAcceptCompression+ , responseMetadata+ , responseContentType+ } = concat [+ [ buildContentType $ Just (chooseContentType proxy x)+ | Just x <- [responseContentType]+ ]+ , [ buildMessageEncoding x+ | Just x <- [responseCompression]+ ]+ , [ buildMessageAcceptEncoding x+ | Just x <- [responseAcceptCompression]+ ]+ , [ buildTrailer proxy ]+ , [ buildCustomMetadata x+ | x <- customMetadataMapToList responseMetadata+ ]+ ]++-- | Parse response headers+parseResponseHeaders :: forall rpc m.+ (IsRPC rpc, MonadError (InvalidHeaders GrpcException) m)+ => Proxy rpc -> [HTTP.Header] -> m ResponseHeaders+parseResponseHeaders proxy = HKD.sequenceChecked . parseResponseHeaders' proxy++-- | Generalization of 'parseResponseHeaders' that does not throw errors+--+-- See also 'Network.GRPC.Spec.parseRequestHeaders' versus+-- ''Network.GRPC.Spec.parseRequestHeaders'' for a similar pair of functions.+parseResponseHeaders' :: forall rpc.+ IsRPC rpc+ => Proxy rpc -> [HTTP.Header] -> ResponseHeaders' GrpcException+parseResponseHeaders' proxy =+ flip execState uninitResponseHeaders+ . mapM_ (parseHeader . second trim)+ where+ -- HTTP2 header names are always lowercase, and must be ASCII.+ -- <https://datatracker.ietf.org/doc/html/rfc7540#section-8.1.2>+ parseHeader :: HTTP.Header -> State (ResponseHeaders' GrpcException) ()+ parseHeader hdr@(name, _value)+ | name == "content-type"+ = modify $ \x -> x {+ responseContentType = Just <$> parseContentType' proxy hdr+ }++ | name == "grpc-encoding"+ = modify $ \x -> x {+ responseCompression = Just <$> parseMessageEncoding hdr+ }++ | name == "grpc-accept-encoding"+ = modify $ \x -> x {+ responseAcceptCompression = Just <$> parseMessageAcceptEncoding hdr+ }++ | name == "trailer"+ = return () -- ignore the HTTP trailer header++ | otherwise+ = modify $ \x ->+ case parseCustomMetadata hdr of+ Left invalid -> x{+ responseUnrecognized = Left $ mconcat [+ invalid+ , otherInvalid $ responseUnrecognized x+ ]+ }+ Right md -> x{+ responseMetadata =+ customMetadataMapInsert md $ responseMetadata x+ }++ uninitResponseHeaders :: ResponseHeaders' GrpcException+ uninitResponseHeaders = ResponseHeaders {+ responseCompression = return Nothing+ , responseAcceptCompression = return Nothing+ , responseMetadata = mempty+ , responseUnrecognized = return ()++ -- special cases++ , responseContentType =+ throwError $+ invalidContentType+ "Missing content-type header"+ (MissingHeader Nothing "content-type")+ }++{-------------------------------------------------------------------------------+ Content type++ See 'parseContentType' for discussion.+-------------------------------------------------------------------------------}++parseContentType' ::+ IsRPC rpc+ => Proxy rpc+ -> HTTP.Header+ -> Either (InvalidHeaders GrpcException) ContentType+parseContentType' proxy hdr =+ parseContentType+ proxy+ (\err -> invalidContentType err (InvalidHeader Nothing hdr err))+ hdr++invalidContentType ::+ String+ -> InvalidHeader HandledSynthesized+ -> InvalidHeaders GrpcException+invalidContentType err = invalidHeaderSynthesize GrpcException {+ grpcError = GrpcUnknown+ , grpcErrorMessage = Just $ Text.pack err+ , grpcErrorDetails = Nothing+ , grpcErrorMetadata = []+ }++{-------------------------------------------------------------------------------+ > Trailers → Status [Status-Message] *Custom-Metadata Status →+ > "grpc-status" 1*DIGIT ; 0-9 Status-Message → "grpc-message" Percent-Encoded+ > Status-Details → "grpc-status-details-bin" {base64 encoded value}++ where++ > Status-Details is allowed only if Status is not OK. If it is set, it+ > contains additional information about the RPC error. If it contains a status+ > code field, it MUST NOT contradict the Status header. The consumer MUST+ > verify this requirement.+-------------------------------------------------------------------------------}++-- | Construct the HTTP @Trailer@ header+--+-- This lists all headers that /might/ be present in the trailers.+--+-- See+--+-- * <https://datatracker.ietf.org/doc/html/rfc7230#section-4.4>+-- * <https://www.rfc-editor.org/rfc/rfc9110#name-processing-trailer-fields>+buildTrailer :: forall rpc. SupportsServerRpc rpc => Proxy rpc -> HTTP.Header+buildTrailer _ = (+ "Trailer"+ , BS.Strict.intercalate ", " allPotentialTrailers+ )+ where+ allPotentialTrailers :: [Strict.ByteString]+ allPotentialTrailers = concat [+ reservedTrailers+ , map (CI.original . buildHeaderName) $+ metadataHeaderNames (Proxy @(ResponseTrailingMetadata rpc))+ ]++ -- These cannot be 'HeaderName' (which disallow reserved names)+ --+ -- This list must match the names used by 'buildProperTrailers'+ -- and recognized by 'parseProperTrailers'.+ reservedTrailers :: [Strict.ByteString]+ reservedTrailers = [+ "grpc-status"+ , "grpc-message"+ , "grpc-retry-pushback-ms"+ , "endpoint-load-metrics-bin"+ ]++-- | Build trailers (see 'buildTrailersOnly' for the Trailers-Only case)+buildProperTrailers :: ProperTrailers -> [HTTP.Header]+buildProperTrailers ProperTrailers{+ properTrailersGrpcStatus+ , properTrailersGrpcMessage+ , properTrailersStatusDetails+ , properTrailersMetadata+ , properTrailersPushback+ , properTrailersOrcaLoadReport+ } = concat [+ -- NOTE: If we add additional (reserved) headers here, we also need to add+ -- them to 'buildTrailer'.+ [ ( "grpc-status"+ , BS.Strict.C8.pack $ show $ fromGrpcStatus properTrailersGrpcStatus+ )+ ]+ , [ ("grpc-message", PercentEncoding.encode x)+ | Just x <- [properTrailersGrpcMessage]+ ]+ , [ ("grpc-status-details-bin", buildBinaryValue x)+ | Just x <- [properTrailersStatusDetails]+ ]+ , [ ( "grpc-retry-pushback-ms"+ , buildPushback x+ )+ | Just x <- [properTrailersPushback]+ ]+ , [ ( "endpoint-load-metrics-bin"+ , buildBinaryValue $ Protobuf.buildStrict x+ )+ | Just x <- [properTrailersOrcaLoadReport]+ ]+ , [ buildCustomMetadata x+ | x <- customMetadataMapToList properTrailersMetadata+ ]+ ]++-- | Build trailers for the Trailers-Only case+buildTrailersOnly ::+ (ContentType -> Maybe BS.Strict.C8.ByteString)+ -- ^ Interpret 'ContentType'+ --+ -- Under normal circumstances this should be @Just .@ 'chooseContentType'.+ -- In some cases, however, the content-type might not be known. For+ -- example, when a request comes in for an unknown method, the gRPC server+ -- is supposed to respond with a @Trailers-Only@ message, with an+ -- @UNIMPLEMENTED@ error code. Frustratingly, @Trailers-Only@ requires a+ -- @Content-Type@ header, /even though there is no content/. This+ -- @Content-Type@ header normally indicates the serialization format (e.g.,+ -- @application/grpc+proto@), but this format depends on the specific+ -- method, which was not found!+ --+ -- To resolve this catch-22, this function is allowed to return @Nothing@,+ -- in which case the @Content-Type@ we will use @application/grpc@, with no+ -- format specifier. Fortunately, this is allowed by the spec.+ -> TrailersOnly -> [HTTP.Header]+buildTrailersOnly f TrailersOnly{+ trailersOnlyContentType+ , trailersOnlyProper+ } = concat [+ [ buildContentType $ f x+ | Just x <- [trailersOnlyContentType]+ ]+ , buildProperTrailers trailersOnlyProper+ ]++-- | Parse response trailers+--+-- The gRPC spec defines:+--+-- > Trailers → ..+-- > Trailers-Only → HTTP-Status Content-Type Trailers+--+-- This means that Trailers-Only is a superset of the Trailers; we make use of+-- this here, and error out if we get an unexpected @Content-Type@ override.+parseProperTrailers :: forall rpc m.+ (IsRPC rpc, MonadError (InvalidHeaders GrpcException) m)+ => Proxy rpc -> [HTTP.Header] -> m ProperTrailers+parseProperTrailers proxy = HKD.sequenceChecked . parseProperTrailers' proxy++-- | Generalization of 'parseProperTrailers' that does not throw errors.+--+-- See also 'Network.GRPC.Spec.parseRequestHeaders' versus+-- ''Network.GRPC.Spec.parseRequestHeaders'' for a similar pair of functions.+-- See t'ProperTrailers'' for a discussion of why 'ProperTrailers'' is not+-- parameterized (unlike t'ResponseHeaders'' and+-- t'Network.GRPC.Spec.RequestHeaders'').+parseProperTrailers' :: forall rpc.+ IsRPC rpc+ => Proxy rpc -> [HTTP.Header] -> ProperTrailers'+parseProperTrailers' proxy hdrs =+ case trailersOnlyToProperTrailers trailersOnly of+ (properTrailers, Right Nothing) ->+ properTrailers+ (properTrailers, Right (Just _ct)) ->+ properTrailers {+ properTrailersUnrecognized = Left $ mconcat [+ unexpectedHeader "content-type"+ , otherInvalid $ properTrailersUnrecognized properTrailers+ ]+ }+ (properTrailers, Left invalid) ->+ case dropSynthesized invalid of+ -- The content-type header is "invalid" because it's missing.+ -- In our case, this actually means everything is as it should be.+ InvalidHeaders [MissingHeader{}] ->+ properTrailers+ -- The @content-type@ header is present, /and/ invalid!+ _otherwise ->+ properTrailers {+ properTrailersUnrecognized = Left $ mconcat [+ unexpectedHeader "content-type"+ , invalid+ , otherInvalid $ properTrailersUnrecognized properTrailers+ ]+ }+ where+ trailersOnly :: TrailersOnly' GrpcException+ trailersOnly = parseTrailersOnly' proxy hdrs++-- | Parse t'TrailersOnly'+parseTrailersOnly :: forall m rpc.+ (IsRPC rpc, MonadError (InvalidHeaders GrpcException) m)+ => Proxy rpc -> [HTTP.Header] -> m TrailersOnly+parseTrailersOnly proxy = HKD.sequenceChecked . parseTrailersOnly' proxy++-- | Generalization of 'parseTrailersOnly' does that not throw errors.+--+-- See also 'Network.GRPC.Spec.parseRequestHeaders' versus+-- ''Network.GRPC.Spec.parseRequestHeaders'' for a similar pair of functions.+parseTrailersOnly' :: forall rpc.+ IsRPC rpc+ => Proxy rpc -> [HTTP.Header] -> TrailersOnly' GrpcException+parseTrailersOnly' proxy =+ flip execState uninitTrailersOnly+ . mapM_ (parseHeader . second trim)+ where+ parseHeader :: HTTP.Header -> State (TrailersOnly' GrpcException) ()+ parseHeader hdr@(name, value)+ | name == "content-type"+ = modify $ \x -> x {+ trailersOnlyContentType = Just <$> parseContentType' proxy hdr+ }++ | name == "grpc-status"+ = modify $ liftProperTrailers $ \x -> x{+ properTrailersGrpcStatus = throwInvalidHeader hdr $+ case toGrpcStatus =<< readMaybe (BS.Strict.C8.unpack value) of+ Nothing -> throwError $ "Invalid status: " ++ show value+ Just v -> return v+ }++ | name == "grpc-message"+ = modify $ liftProperTrailers $ \x -> x{+ properTrailersGrpcMessage = throwInvalidHeader hdr $+ case PercentEncoding.decode value of+ Left err -> throwError $ show err+ Right msg -> return (Just msg)+ }++ | name == "grpc-status-details-bin"+ = modify $ liftProperTrailers $ \x -> x{+ properTrailersStatusDetails = throwInvalidHeader hdr $+ case parseBinaryValue value of+ Left err -> throwError err+ Right val -> return (Just val)++ }++ | name == "grpc-retry-pushback-ms"+ = modify $ liftProperTrailers $ \x -> x{+ properTrailersPushback =+ Just <$> parsePushback value+ }++ | name == "endpoint-load-metrics-bin"+ = modify $ liftProperTrailers $ \x -> x{+ properTrailersOrcaLoadReport = throwInvalidHeader hdr $ do+ value' <- parseBinaryValue value+ case Protobuf.parseStrict value' of+ Left err -> throwError err+ Right report -> return $ Just report+ }++ | otherwise+ = modify $ liftProperTrailers $ \x ->+ case parseCustomMetadata hdr of+ Left invalid -> x{+ properTrailersUnrecognized = Left $ mconcat [+ invalid+ , otherInvalid $ properTrailersUnrecognized x+ ]+ }+ Right md -> x{+ properTrailersMetadata =+ customMetadataMapInsert md $ properTrailersMetadata x+ }++ uninitTrailersOnly :: TrailersOnly' GrpcException+ uninitTrailersOnly = TrailersOnly {+ trailersOnlyContentType =+ throwError $+ invalidContentType+ "Missing content-type header"+ (MissingHeader Nothing "content-type")+ , trailersOnlyProper =+ simpleProperTrailers+ (throwError $ missingHeader Nothing "grpc-status")+ (return Nothing)+ (return Nothing)+ mempty+ }++ liftProperTrailers ::+ (ProperTrailers_ f -> ProperTrailers_ f)+ -> TrailersOnly_ f -> TrailersOnly_ f+ liftProperTrailers f trailersOnly = trailersOnly{+ trailersOnlyProper = f (trailersOnlyProper trailersOnly)+ }++{-------------------------------------------------------------------------------+ Pushback+-------------------------------------------------------------------------------}++-- | Serialize t'Pushback'+buildPushback :: Pushback -> Strict.ByteString+buildPushback (RetryAfter n) = BS.Strict.C8.pack $ show n+buildPushback DoNotRetry = "-1"++-- | Parse t'Pushback'+--+-- Parsing a pushback cannot fail; the spec mandates:+--+-- > If the value for pushback is negative or unparseble, then it will be seen+-- > as the server asking the client not to retry at all.+--+-- We therefore only require @Monad m@, not @MonadError m@ (having the @Monad@+-- constraint at all keeps the type signature consistent with other parsing+-- functions).+parsePushback :: Monad m => Strict.ByteString -> m Pushback+parsePushback bs =+ case readMaybe (BS.Strict.C8.unpack bs) of+ Just (n :: Int) ->+ -- The @Read@ instance for @Word@ /does/ allow for signs+ -- <https://gitlab.haskell.org/ghc/ghc/-/issues/24216>+ return $ if n < 0 then DoNotRetry else RetryAfter (fromIntegral n)+ Nothing ->+ return DoNotRetry++{-------------------------------------------------------------------------------+ Internal auxiliary+-------------------------------------------------------------------------------}++otherInvalid :: Either (InvalidHeaders e) () -> InvalidHeaders e+otherInvalid = either id (\() -> mempty)++decodeUtf8Lenient :: BS.Strict.C8.ByteString -> Text+#if MIN_VERSION_text(2,0,0)+decodeUtf8Lenient = Text.decodeUtf8Lenient+#else+decodeUtf8Lenient = Text.decodeUtf8With Text.lenientDecode+#endif
+ src/Network/GRPC/Spec/Serialization/LengthPrefixed.hs view
@@ -0,0 +1,179 @@+-- | Length-prefixed messages+--+-- These are used both for inputs and outputs.+module Network.GRPC.Spec.Serialization.LengthPrefixed (+ -- * Message prefix+ MessagePrefix(..)+ -- * Length-prefixex messages+ -- ** Construction+ , OutboundMeta(..)+ , buildInput+ , buildOutput+ -- ** Parsing+ , InboundMeta(..)+ , parseInput+ , parseOutput+ ) where++import Data.Binary.Get (Get)+import Data.Binary.Get qualified as Binary+import Data.ByteString.Builder (Builder)+import Data.ByteString.Builder qualified as Builder+import Data.ByteString.Lazy qualified as BS.Lazy+import Data.ByteString.Lazy qualified as Lazy (ByteString)+import Data.Proxy+import Data.Word++import Network.GRPC.Spec+import Network.GRPC.Spec.Util.Parser (Parser)+import Network.GRPC.Spec.Util.Parser qualified as Parser++{-------------------------------------------------------------------------------+ Message prefix+-------------------------------------------------------------------------------}++data MessagePrefix = MessagePrefix {+ msgIsCompressed :: Bool+ , msgLength :: Word32+ }+ deriving (Show)++buildMessagePrefix :: MessagePrefix -> Builder+buildMessagePrefix MessagePrefix{msgLength, msgIsCompressed} = mconcat [+ Builder.word8 $ if msgIsCompressed then 1 else 0+ , Builder.word32BE $ msgLength+ ]++getMessagePrefix :: Get MessagePrefix+getMessagePrefix = do+ msgIsCompressed <- Binary.getWord8 >>= \case+ 0 -> return False+ 1 -> return True+ n -> fail $ "parseMessagePrefix: unxpected " ++ show n+ msgLength <- Binary.getWord32be+ return MessagePrefix{msgIsCompressed, msgLength}++{-------------------------------------------------------------------------------+ Construction+-------------------------------------------------------------------------------}++-- | Serialize RPC input+--+-- > Length-Prefixed-Message → Compressed-Flag Message-Length Message+-- >+-- > Compressed-Flag → 0 / 1+-- > # encoded as 1 byte unsigned integer+-- > Message-Length → {length of Message}+-- > # encoded as 4 byte unsigned integer (big endian)+-- > Message → *{binary octet}+buildInput ::+ SupportsClientRpc rpc+ => Proxy rpc+ -> Compression+ -> (OutboundMeta, Input rpc)+ -> Builder+buildInput = buildMsg . rpcSerializeInput++-- | Serialize RPC output+buildOutput ::+ SupportsServerRpc rpc+ => Proxy rpc+ -> Compression+ -> (OutboundMeta, Output rpc)+ -> Builder+buildOutput = buildMsg . rpcSerializeOutput++-- | Generalization of 'buildInput' and 'buildOutput'+buildMsg ::+ (x -> Lazy.ByteString)+ -> Compression+ -> (OutboundMeta, x)+ -> Builder+buildMsg build compr (meta, x) = mconcat [+ buildMessagePrefix prefix+ , Builder.lazyByteString $+ if shouldCompress+ then compressed+ else uncompressed+ ]+ where+ uncompressed, compressed :: Lazy.ByteString+ uncompressed = build x+ compressed = compress compr uncompressed++ shouldCompress :: Bool+ shouldCompress = and [+ uncompressedSizeThreshold compr uncompressedLength+ , outboundEnableCompression meta+ , compressedLength < uncompressedLength+ ]+ where+ uncompressedLength = BS.Lazy.length uncompressed+ compressedLength = BS.Lazy.length compressed++ prefix :: MessagePrefix+ prefix+ | shouldCompress+ = MessagePrefix {+ msgIsCompressed = True+ , msgLength = fromIntegral $ BS.Lazy.length compressed+ }++ | otherwise+ = MessagePrefix {+ msgIsCompressed = False+ , msgLength = fromIntegral $ BS.Lazy.length uncompressed+ }++{-------------------------------------------------------------------------------+ Parsing+-------------------------------------------------------------------------------}++-- | Parse input+parseInput ::+ SupportsServerRpc rpc+ => Proxy rpc+ -> Compression+ -> Parser String (InboundMeta, Input rpc)+parseInput = parseMsg . rpcDeserializeInput++-- | Parse output+parseOutput ::+ SupportsClientRpc rpc+ => Proxy rpc+ -> Compression+ -> Parser String (InboundMeta, Output rpc)+parseOutput = parseMsg . rpcDeserializeOutput++parseMsg :: forall x.+ (Lazy.ByteString -> Either String x)+ -> Compression+ -> Parser String (InboundMeta, x)+parseMsg parse compr = do+ prefix <- Parser.getExactly 5 getMessagePrefix+ Parser.consumeExactly (fromIntegral $ msgLength prefix) $+ parseBody (msgIsCompressed prefix)+ where+ parseBody :: Bool -> Lazy.ByteString -> Either String (InboundMeta, x)+ parseBody False body =+ (meta,) <$> parse body+ where+ meta :: InboundMeta+ meta = InboundMeta {+ inboundCompressedSize = Nothing+ , inboundUncompressedSize = lengthOf body+ }+ parseBody True compressed =+ (meta,) <$> parse uncompressed+ where+ uncompressed :: Lazy.ByteString+ uncompressed = decompress compr compressed++ meta :: InboundMeta+ meta = InboundMeta {+ inboundCompressedSize = Just (lengthOf compressed)+ , inboundUncompressedSize = lengthOf uncompressed+ }++ lengthOf :: Num a => Lazy.ByteString -> a+ lengthOf = fromIntegral . BS.Lazy.length
+ src/Network/GRPC/Spec/Serialization/Status.hs view
@@ -0,0 +1,15 @@+module Network.GRPC.Spec.Serialization.Status (+ buildStatus+ , parseStatus+ ) where++import Data.ByteString qualified as Strict (ByteString)++import Network.GRPC.Spec+import Network.GRPC.Spec.Util.Protobuf++buildStatus :: Proto Status -> Strict.ByteString+buildStatus = buildStrict++parseStatus :: Strict.ByteString -> Either String (Proto Status)+parseStatus = parseStrict
+ src/Network/GRPC/Spec/Serialization/Timeout.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.GRPC.Spec.Serialization.Timeout (+ buildTimeout+ , parseTimeout+ ) where++import Control.Monad.Except+import Data.ByteString qualified as BS.Strict+import Data.ByteString qualified as Strict (ByteString)+import Data.ByteString.Char8 qualified as BS.Strict.C8+import Data.Char (isDigit)++import Network.GRPC.Spec++{-------------------------------------------------------------------------------+ Serialization++ > Timeout → "grpc-timeout" TimeoutValue TimeoutUnit+ > TimeoutValue → {positive integer as ASCII string of at most 8 digits}+ > TimeoutUnit → Hour / Minute / Second / Millisecond / Microsecond / Nanosecond+ > Hour → "H"+ > Minute → "M"+ > Second → "S"+ > Millisecond → "m"+ > Microsecond → "u"+ > Nanosecond → "n"+-------------------------------------------------------------------------------}++-- | Serialize t'Timeout'+buildTimeout :: Timeout -> Strict.ByteString+buildTimeout (Timeout unit val) = mconcat [+ BS.Strict.C8.pack $ show $ getTimeoutValue val+ , case unit of+ Hour -> "H"+ Minute -> "M"+ Second -> "S"+ Millisecond -> "m"+ Microsecond -> "u"+ Nanosecond -> "n"+ ]++-- | Parse t'Timeout'+parseTimeout :: forall m. MonadError String m => Strict.ByteString -> m Timeout+parseTimeout bs = do+ let (bsVal, bsUnit) = BS.Strict.C8.span isDigit bs++ val <-+ if BS.Strict.length bsVal < 1 || BS.Strict.length bsVal > 8+ then invalid+ else return . TimeoutValue $ read (BS.Strict.C8.unpack bsVal)++ charUnit <-+ case BS.Strict.C8.uncons bsUnit of+ Nothing ->+ invalid+ Just (u, remainder) ->+ if BS.Strict.null remainder+ then return u+ else invalid++ unit <-+ case charUnit of+ 'H' -> return Hour+ 'M' -> return Minute+ 'S' -> return Second+ 'm' -> return Millisecond+ 'u' -> return Microsecond+ 'n' -> return Nanosecond+ _ -> invalid++ return $ Timeout unit val+ where+ invalid :: m a+ invalid = throwError $ "Could not parse timeout " ++ show bs+
+ src/Network/GRPC/Spec/Serialization/TraceContext.hs view
@@ -0,0 +1,130 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Network.GRPC.Spec.Serialization.TraceContext (+ buildTraceContext+ , parseTraceContext+ ) where++import Control.Applicative (many)+import Control.Monad.Except+import Data.Binary (Binary(..))+import Data.Binary qualified as Binary+import Data.Binary.Get qualified as Get+import Data.Binary.Put qualified as Put+import Data.ByteString qualified as Strict (ByteString)+import Data.ByteString.Lazy qualified as BS.Lazy+import Data.Default+import Data.Maybe (maybeToList)+import Data.Word++import Network.GRPC.Spec++{-------------------------------------------------------------------------------+ Serialization+-------------------------------------------------------------------------------}++-- | Serialize t'TraceContext'+buildTraceContext :: TraceContext -> Strict.ByteString+buildTraceContext = BS.Lazy.toStrict . Binary.encode++-- | Parse t'TraceContext'+parseTraceContext :: MonadError String m => Strict.ByteString -> m TraceContext+parseTraceContext bs =+ case Binary.decodeOrFail (BS.Lazy.fromStrict bs) of+ Right (_, _, ctxt) -> return ctxt+ Left (_, _, err) -> throwError err++{-------------------------------------------------------------------------------+ Internal auxiliary: parsing++ <https://github.com/census-instrumentation/opencensus-specs/blob/master/encodings/BinaryEncoding.md>+-------------------------------------------------------------------------------}++instance Binary TraceId where+ put = Put.putByteString . getTraceId+ get = TraceId <$> Get.getByteString 16++instance Binary SpanId where+ put = Put.putByteString . getSpanId+ get = SpanId <$> Get.getByteString 8++instance Binary TraceOptions where+ put = Put.putWord8 . traceOptionsToWord8+ get = traceOptionsFromWord8 =<< Get.getWord8++instance Binary Field where+ put (FieldTraceId tid) = Put.putWord8 0 <> put tid+ put (FieldSpanId sid) = Put.putWord8 1 <> put sid+ put (FieldOptions opts) = Put.putWord8 2 <> put opts++ get = do+ fieldId <- Get.getWord8+ case fieldId of+ 0 -> FieldTraceId <$> get+ 1 -> FieldSpanId <$> get+ 2 -> FieldOptions <$> get+ _ -> fail $ "Invalid fieldId " ++ show fieldId++instance Binary TraceContext where+ put ctxt = mconcat [+ Put.putWord8 0 -- Version 0+ , foldMap put (traceContextToFields ctxt)+ ]++ get = do+ version <- Get.getWord8+ case version of+ 0 -> traceContextFromFields =<< many get+ _ -> fail $ "Invalid version " ++ show version++{-------------------------------------------------------------------------------+ Internal: fields+-------------------------------------------------------------------------------}++data Field =+ FieldTraceId TraceId+ | FieldSpanId SpanId+ | FieldOptions TraceOptions++traceContextToFields :: TraceContext -> [Field]+traceContextToFields (TraceContext tid sid opts) = concat [+ FieldTraceId <$> maybeToList tid+ , FieldSpanId <$> maybeToList sid+ , FieldOptions <$> maybeToList opts+ ]++traceContextFromFields :: forall m. MonadFail m => [Field] -> m TraceContext+traceContextFromFields = flip go def+ where+ go :: [Field] -> TraceContext -> m TraceContext+ go [] acc = return acc+ go (f:fs) acc =+ case f of+ FieldTraceId tid ->+ case traceContextTraceId acc of+ Nothing -> go fs $ acc{traceContextTraceId = Just tid}+ Just _ -> fail "Multiple TraceId fields"+ FieldSpanId sid ->+ case traceContextSpanId acc of+ Nothing -> go fs $ acc{traceContextSpanId = Just sid}+ Just _ -> fail "Multiple SpanId fields"+ FieldOptions opts ->+ case traceContextOptions acc of+ Nothing -> go fs $ acc{traceContextOptions = Just opts}+ Just _ -> fail "Multiple TraceOptions fields"++{-------------------------------------------------------------------------------+ Internal: dealing with 'TraceOptions'++ We take advantage of the fact that currently only a single option is defined.+ Once we have more than one, this code will be a bit more complicated.+-------------------------------------------------------------------------------}++traceOptionsToWord8 :: TraceOptions -> Word8+traceOptionsToWord8 (TraceOptions False) = 0+traceOptionsToWord8 (TraceOptions True) = 1++traceOptionsFromWord8 :: MonadFail m => Word8 -> m TraceOptions+traceOptionsFromWord8 0 = return $ TraceOptions False+traceOptionsFromWord8 1 = return $ TraceOptions True+traceOptionsFromWord8 n = fail $ "Invalid TraceOptions " ++ show n
+ src/Network/GRPC/Spec/Status.hs view
@@ -0,0 +1,297 @@+module Network.GRPC.Spec.Status (+ -- * GRPC status+ GrpcStatus(..)+ , GrpcError(..)+ , fromGrpcStatus+ , fromGrpcError+ , toGrpcStatus+ , toGrpcError+ -- * Exceptions+ , GrpcException(..)+ , throwGrpcError+ -- * Details+ , Status+ ) where++import Control.Exception+import Data.ByteString qualified as Strict (ByteString)+import Data.List (intercalate)+import Data.Text (Text)+import Data.Text qualified as Text+import GHC.Generics (Generic)++import Network.GRPC.Spec.CustomMetadata.Raw (CustomMetadata)++import Proto.Status++{-------------------------------------------------------------------------------+ gRPC status+-------------------------------------------------------------------------------}++-- | gRPC status+--+-- Defined in <https://github.com/grpc/grpc/blob/master/doc/statuscodes.md>.+data GrpcStatus =+ GrpcOk+ | GrpcError GrpcError+ deriving stock (Show, Eq, Generic)++-- | gRPC error code+--+-- This is a subset of the gRPC status codes. See 'GrpcStatus'.+data GrpcError =+ -- | Cancelled+ --+ -- The operation was cancelled, typically by the caller.+ GrpcCancelled++ -- | Unknown error+ --+ -- For example, this error may be returned when a @Status@ value received+ -- from another address space belongs to an error space that is not known in+ -- this address space. Also errors raised by APIs that do not return enough+ -- error information may be converted to this error.+ | GrpcUnknown++ -- | Invalid argument+ --+ -- The client specified an invalid argument. Note that this differs from+ -- 'GrpcFailedPrecondition': 'GrpcInvalidArgument' indicates arguments that+ -- are problematic regardless of the state of the system (e.g., a malformed+ -- file name).+ | GrpcInvalidArgument++ -- | Deadline exceeded+ --+ -- The deadline expired before the operation could complete. For operations+ -- that change the state of the system, this error may be returned even if+ -- the operation has completed successfully. For example, a successful+ -- response from a server could have been delayed long.+ | GrpcDeadlineExceeded++ -- | Not found+ --+ -- Some requested entity (e.g., file or directory) was not found.+ --+ -- Note to server developers: if a request is denied for an entire class of+ -- users, such as gradual feature rollout or undocumented allowlist,+ -- 'GrpcNotFound' may be used.+ --+ -- If a request is denied for some users within a class of users, such as+ -- user-based access control, 'GrpcPermissionDenied' must be used.+ | GrpcNotFound++ -- | Already exists+ --+ -- The entity that a client attempted to create (e.g., file or directory)+ -- already exists.+ | GrpcAlreadyExists++ -- | Permission denied+ --+ -- The caller does not have permission to execute the specified operation.+ --+ -- * 'GrpcPermissionDenied' must not be used for rejections caused by+ -- exhausting some resource (use 'GrpcResourceExhausted' instead for those+ -- errors).+ -- * 'GrpcPermissionDenied' must not be used if the caller can not be+ -- identified (use 'GrpcUnauthenticated' instead for those errors).+ --+ -- This error code does not imply the request is valid or the requested+ -- entity exists or satisfies other pre-conditions.+ | GrpcPermissionDenied++ -- | Resource exhausted+ --+ -- Some resource has been exhausted, perhaps a per-user quota, or perhaps+ -- the entire file system is out of space.+ | GrpcResourceExhausted++ -- | Failed precondition+ --+ -- The operation was rejected because the system is not in a state required+ -- for the operation's execution. For example, the directory to be deleted+ -- is non-empty, an rmdir operation is applied to a non-directory, etc.+ --+ -- Service implementors can use the following guidelines to decide between+ -- 'GrpcFailedPrecondition', 'GrpcAborted', and 'GrpcUnavailable':+ --+ -- (a) Use 'GrpcUnavailable' if the client can retry just the failing call.+ -- (b) Use 'GrpcAborted' if the client should retry at a higher level (e.g.,+ -- when a client-specified test-and-set fails, indicating the client+ -- should restart a read-modify-write sequence).+ -- (c) Use `GrpcFailedPrecondition` if the client should not retry until the+ -- system state has been explicitly fixed. E.g., if an @rmdir@ fails+ -- because the directory is non-empty, 'GrpcFailedPrecondition' should+ -- be returned since the client should not retry unless the files are+ -- deleted from the directory.+ | GrpcFailedPrecondition++ -- | Aborted+ --+ -- The operation was aborted, typically due to a concurrency issue such as a+ -- sequencer check failure or transaction abort. See the guidelines above+ -- for deciding between 'GrpcFailedPrecondition', 'GrpcAborted', and+ -- 'GrpcUnavailable'.+ | GrpcAborted++ -- | Out of range+ --+ -- The operation was attempted past the valid range. E.g., seeking or+ -- reading past end-of-file.+ --+ -- Unlike 'GrpcInvalidArgument', this error indicates a problem that may be+ -- fixed if the system state changes. For example, a 32-bit file system will+ -- generate 'GrpcInvalidArgument' if asked to read at an offset that is not+ -- in the range @[0, 2^32-1]@, but it will generate 'GrpcOutOfRange' if+ -- asked to read from an offset past the current file size.+ --+ -- There is a fair bit of overlap between 'GrpcFailedPrecondition' and+ -- 'GrpcOutOfRange'. We recommend using 'GrpcOutOfRange' (the more specific+ -- error) when it applies so that callers who are iterating through a space+ -- can easily look for an 'GrpcOutOfRange' error to detect when they are+ -- done.+ | GrpcOutOfRange++ -- | Unimplemented+ --+ -- The operation is not implemented or is not supported/enabled in this+ -- service.+ | GrpcUnimplemented++ -- | Internal errors+ --+ -- This means that some invariants expected by the underlying system have+ -- been broken. This error code is reserved for serious errors.+ | GrpcInternal++ -- | Unavailable+ --+ -- The service is currently unavailable. This is most likely a transient+ -- condition, which can be corrected by retrying with a backoff. Note that+ -- it is not always safe to retry non-idempotent operations.+ | GrpcUnavailable++ -- | Data loss+ --+ -- Unrecoverable data loss or corruption.+ | GrpcDataLoss++ -- | Unauthenticated+ --+ -- The request does not have valid authentication credentials for the+ -- operation.+ | GrpcUnauthenticated+ deriving stock (Show, Eq, Ord, Generic)+ deriving anyclass (Exception)++{-------------------------------------------------------------------------------+ Status codes+-------------------------------------------------------------------------------}++-- | Translate 'GrpcStatus' to numerical status code+--+-- See <https://grpc.github.io/grpc/core/md_doc_statuscodes.html>+fromGrpcStatus :: GrpcStatus -> Word+fromGrpcStatus GrpcOk = 0+fromGrpcStatus (GrpcError err) = fromGrpcError err++-- | Translate 'GrpcError' to numerical status code+--+-- See also 'fromGrpcStatus'+fromGrpcError :: GrpcError -> Word+fromGrpcError GrpcCancelled = 1+fromGrpcError GrpcUnknown = 2+fromGrpcError GrpcInvalidArgument = 3+fromGrpcError GrpcDeadlineExceeded = 4+fromGrpcError GrpcNotFound = 5+fromGrpcError GrpcAlreadyExists = 6+fromGrpcError GrpcPermissionDenied = 7+fromGrpcError GrpcResourceExhausted = 8+fromGrpcError GrpcFailedPrecondition = 9+fromGrpcError GrpcAborted = 10+fromGrpcError GrpcOutOfRange = 11+fromGrpcError GrpcUnimplemented = 12+fromGrpcError GrpcInternal = 13+fromGrpcError GrpcUnavailable = 14+fromGrpcError GrpcDataLoss = 15+fromGrpcError GrpcUnauthenticated = 16++-- | Inverse to 'fromGrpcStatus'+toGrpcStatus :: Word -> Maybe GrpcStatus+toGrpcStatus 0 = Just $ GrpcOk+toGrpcStatus s = GrpcError <$> toGrpcError s++-- | Inverse to 'fromGrpcError'+toGrpcError :: Word -> Maybe GrpcError+toGrpcError 1 = Just $ GrpcCancelled+toGrpcError 2 = Just $ GrpcUnknown+toGrpcError 3 = Just $ GrpcInvalidArgument+toGrpcError 4 = Just $ GrpcDeadlineExceeded+toGrpcError 5 = Just $ GrpcNotFound+toGrpcError 6 = Just $ GrpcAlreadyExists+toGrpcError 7 = Just $ GrpcPermissionDenied+toGrpcError 8 = Just $ GrpcResourceExhausted+toGrpcError 9 = Just $ GrpcFailedPrecondition+toGrpcError 10 = Just $ GrpcAborted+toGrpcError 11 = Just $ GrpcOutOfRange+toGrpcError 12 = Just $ GrpcUnimplemented+toGrpcError 13 = Just $ GrpcInternal+toGrpcError 14 = Just $ GrpcUnavailable+toGrpcError 15 = Just $ GrpcDataLoss+toGrpcError 16 = Just $ GrpcUnauthenticated+toGrpcError _ = Nothing++{-------------------------------------------------------------------------------+ gRPC exceptions+-------------------------------------------------------------------------------}++-- | Server indicated a gRPC error+--+-- For the common case where you just want to set 'grpcError', you can use+-- 'throwGrpcError'.+data GrpcException = GrpcException {+ grpcError :: GrpcError+ , grpcErrorMessage :: Maybe Text+ , grpcErrorDetails :: Maybe Strict.ByteString+ , grpcErrorMetadata :: [CustomMetadata]+ }+ deriving stock (Show, Eq)++instance Exception GrpcException where+ displayException GrpcException{+ grpcError+ , grpcErrorMessage+ , grpcErrorDetails+ , grpcErrorMetadata+ } = (intercalate "\n" . concat) [+ [ concat [+ "gRPC exception "+ , show grpcError+ , " ("+ , show (fromGrpcError grpcError)+ , ")"+ ]+ ]+ , [ intercalate "\n" $+ "Error message:"+ : (map ("| " ++) . lines $ Text.unpack msg)+ | Just msg <- [grpcErrorMessage]+ ]+ , [ "Additional details are available (see 'grpcErrorDetails')."+ | Just _details <- [grpcErrorDetails]+ ]+ , [ show md+ | md <- grpcErrorMetadata+ ]+ ]+++-- | Convenience function to throw an t'GrpcException' with the specified error+throwGrpcError :: GrpcError -> IO a+throwGrpcError grpcError = throwIO $ GrpcException {+ grpcError+ , grpcErrorMessage = Nothing+ , grpcErrorDetails = Nothing+ , grpcErrorMetadata = []+ }
+ src/Network/GRPC/Spec/Timeout.hs view
@@ -0,0 +1,94 @@+module Network.GRPC.Spec.Timeout (+ -- * Timeouts+ Timeout(..)+ , TimeoutValue(TimeoutValue, getTimeoutValue)+ , TimeoutUnit(..)+ , isValidTimeoutValue+ -- * Translation+ , timeoutToMicro+ ) where++import GHC.Generics (Generic)+import GHC.Show++{-------------------------------------------------------------------------------+ Timeouts+-------------------------------------------------------------------------------}++-- | Timeout+data Timeout = Timeout TimeoutUnit TimeoutValue+ deriving stock (Show, Eq, Generic)++-- | Positive integer with ASCII representation of at most 8 digits+newtype TimeoutValue = UnsafeTimeoutValue {+ getTimeoutValue :: Word+ }+ deriving newtype (Eq)+ deriving stock (Generic)++-- | 'Show' instance relies on the v'TimeoutValue' pattern synonym+instance Show TimeoutValue where+ showsPrec p (UnsafeTimeoutValue val) = showParen (p >= appPrec1) $+ showString "TimeoutValue "+ . showsPrec appPrec1 val++pattern TimeoutValue :: Word -> TimeoutValue+pattern TimeoutValue t <- UnsafeTimeoutValue t+ where+ TimeoutValue t+ | isValidTimeoutValue t = UnsafeTimeoutValue t+ | otherwise = error $ "invalid TimeoutValue: " ++ show t++{-# COMPLETE TimeoutValue #-}++-- | Valid timeout values+--+-- Timeout values cannot exceed 8 digits. If you need a longer timeout, consider+-- using a different 'TimeoutUnit' instead.+isValidTimeoutValue :: Word -> Bool+isValidTimeoutValue t = length (show t) <= 8++-- | Timeout unit+data TimeoutUnit =+ Hour -- ^ Hours+ | Minute -- ^ Minutes+ | Second -- ^ Seconds+ | Millisecond -- ^ Milliseconds+ | Microsecond -- ^ Microseconds+ | Nanosecond -- ^ Nanoseconds+ --+ -- Although some servers may be able to interpret this in a+ -- meaningful way, /we/ cannot, and round this up to the nearest+ -- microsecond.+ deriving stock (Show, Eq, Generic)++{-------------------------------------------------------------------------------+ Translation+-------------------------------------------------------------------------------}++-- | Translate t'Timeout' to microseconds+--+-- For 'Nanosecond' timeout we round up.+--+-- Note: the choice of 'Integer' for the result is important: timeouts can be+-- quite long, and might easily exceed the range of a 32-bit int: @2^31@+-- microseconds is roughly 35 minutes (on 64-bit architectures this is much less+-- important; @2^63@ microseconds is 292,277.2 /years/). We could use @Int64@ or+-- @Word64@, but 'Integer' works nicely with the @unbounded-delays@ package.+timeoutToMicro :: Timeout -> Integer+timeoutToMicro = \case+ Timeout Hour (TimeoutValue n) -> mult n $ 1 * 1_000 * 1_000 * 60 * 24+ Timeout Minute (TimeoutValue n) -> mult n $ 1 * 1_000 * 1_000 * 60+ Timeout Second (TimeoutValue n) -> mult n $ 1 * 1_000 * 1_000+ Timeout Millisecond (TimeoutValue n) -> mult n $ 1 * 1_000+ Timeout Microsecond (TimeoutValue n) -> mult n $ 1+ Timeout Nanosecond (TimeoutValue n) -> nano n+ where+ mult :: Word -> Integer -> Integer+ mult n m = fromIntegral n * m++ nano :: Word -> Integer+ nano n = fromIntegral $+ mu + if n' == 0 then 0 else 1+ where+ (mu, n') = divMod n 1_000
+ src/Network/GRPC/Spec/TraceContext.hs view
@@ -0,0 +1,129 @@+-- | Trace context+--+-- See documentation of t'TraceContext'.+module Network.GRPC.Spec.TraceContext (+ -- * Definition+ TraceContext(..)+ , TraceId(..)+ , SpanId(..)+ , TraceOptions(..)+ ) where++import Data.ByteString qualified as Strict (ByteString)+import Data.ByteString.Base16 qualified as BS.Strict.Base16+import Data.ByteString.Char8 qualified as BS.Strict.Char8+import Data.Default+import Data.String+import GHC.Generics (Generic)++{-------------------------------------------------------------------------------+ Definition+-------------------------------------------------------------------------------}++-- | Trace context+--+-- Representation of the \"trace context\" in OpenTelemetry, corresponding+-- directly to the W3C @traceparent@ header.+--+-- References:+--+-- * <https://www.w3.org/TR/trace-context/#traceparent-header>+-- W3C spec+--+-- * <https://github.com/census-instrumentation/opencensus-specs/blob/master/encodings/BinaryEncoding.md>+-- Binary format used for the @grpc-trace-bin@ header+--+-- * <https://github.com/open-telemetry/opentelemetry-specification/issues/639>+-- Current status of the binary encoding.+--+-- Relation to Haskell OpenTelemetry implementations:+--+-- * The Haskell @opentelemetry@ package calls this a @SpanContext@, but+-- provides no binary @PropagationFormat@, and does not support+-- t'TraceOptions'.+--+-- <https://hackage.haskell.org/package/opentelemetry>+--+-- * The Haskell @hs-opentelemetry@ ecosystem defines @SpanContext@, which is+-- the combination of the W3C @traceparent@ header (our t'TraceContext') and+-- the W3C @tracestate@ header (which we do not support). It too does not+-- support the @grpc-trace-bin@ binary format.+--+-- <https://github.com/iand675/hs-opentelemetry>+-- <https://hackage.haskell.org/package/hs-opentelemetry-propagator-w3c>+data TraceContext = TraceContext {+ traceContextTraceId :: Maybe TraceId+ , traceContextSpanId :: Maybe SpanId+ , traceContextOptions :: Maybe TraceOptions+ }+ deriving stock (Show, Eq, Generic)++instance Default TraceContext where+ def = TraceContext {+ traceContextTraceId = Nothing+ , traceContextSpanId = Nothing+ , traceContextOptions = Nothing+ }++-- | Trace ID+--+-- The ID of the whole trace forest. Must be a 16-byte string.+newtype TraceId = TraceId {+ getTraceId :: Strict.ByteString+ }+ deriving stock (Eq, Generic)++-- | Span ID+--+-- ID of the caller span (parent). Must be an 8-byte string.+newtype SpanId = SpanId {+ getSpanId :: Strict.ByteString+ }+ deriving stock (Eq, Generic)++-- | Tracing options+--+-- The flags are recommendations given by the caller rather than strict rules to+-- follow for 3 reasons:+--+-- * Trust and abuse.+-- * Bug in caller+-- * Different load between caller service and callee service might force callee+-- to down sample.+data TraceOptions = TraceOptions {+ -- | Sampled+ --+ -- When set, denotes that the caller may have recorded trace data. When+ -- unset, the caller did not record trace data out-of-band.+ traceOptionsSampled :: Bool+ }+ deriving stock (Show, Eq, Generic)++{-------------------------------------------------------------------------------+ Show instances for IDs++ We follow the W3C spec and show these as base16 strings.+-------------------------------------------------------------------------------}++instance Show TraceId where+ show (TraceId tid) =+ show . BS.Strict.Char8.unpack $+ BS.Strict.Base16.encode tid++instance IsString TraceId where+ fromString str =+ case BS.Strict.Base16.decode (BS.Strict.Char8.pack str) of+ Left err -> error err+ Right tid -> TraceId tid++instance Show SpanId where+ show (SpanId tid) =+ show . BS.Strict.Char8.unpack $+ BS.Strict.Base16.encode tid++instance IsString SpanId where+ fromString str =+ case BS.Strict.Base16.decode (BS.Strict.Char8.pack str) of+ Left err -> error err+ Right tid -> SpanId tid+
+ src/Network/GRPC/Spec/Util/ByteString.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE CPP #-}++module Network.GRPC.Spec.Util.ByteString (+ ascii+ , strip+ ) where++import Data.ByteString qualified as BS.Strict+import Data.ByteString qualified as Strict (ByteString)+import Data.Char+import Data.Word+import GHC.Stack++ascii :: HasCallStack => Char -> Word8+ascii c+ | 0 <= x && x <= 127 = fromIntegral x+ | otherwise = error $ "ascii: not an ASCII character " ++ show c+ where+ x :: Int+ x = ord c++strip :: Strict.ByteString -> Strict.ByteString+strip =+ BS.Strict.dropWhileEnd isWhitespace+ . BS.Strict.dropWhile isWhitespace+ where+ isWhitespace :: Word8 -> Bool+ isWhitespace c = or [+ c == ascii ' '+ , c == ascii '\t'+ ]
+ src/Network/GRPC/Spec/Util/HKD.hs view
@@ -0,0 +1,205 @@+-- | Small module to support the higher-kinded data (HKD) pattern+--+-- This module is similar in spirit to libraries such as @barbies@ (and to+-- lesser degree @hkd@), but the technical details of the approach are somewhat+-- different.+--+-- Intended for qualified import.+--+-- > import Network.GRPC.Spec.Util.HKD (HKD, Undecorated, DecoratedWith) import+-- > Network.GRPC.Spec.Util.HKD qualified as HKD+module Network.GRPC.Spec.Util.HKD (+ -- * Definition+ HKD+ , DecoratedWith+ , Undecorated+ -- * Dealing with HKD records+ , Coerce(..)+ , Traversable(..)+ , sequence+ , map+ -- * Dealing with HKD fields+ , ValidDecoration+ , pure+ -- * Error decorations+ , Checked+ , sequenceChecked+ ) where++import Prelude hiding (Traversable(..), pure, map)+import Prelude qualified++import Control.Monad.Except (MonadError, throwError)+import Data.Functor.Identity+import Data.Kind+import Data.Proxy+import Unsafe.Coerce (unsafeCoerce)++{-------------------------------------------------------------------------------+ Definition+-------------------------------------------------------------------------------}++-- | Marker for undecorated fields+--+-- @HKD Undecorated x@ is equivalent to simply @x@. See 'HKD' for details.+data Undecorated (x :: Type)++-- | Marker for fields decorated with type constructor @f@+--+-- @HKD (DecoratedWith f) x@ is equivalent to @(f x)@. See 'HKD' for details.+data DecoratedWith (f :: Type -> Type) (x :: Type)++-- | Marker for fields of HKD types+--+-- A common pattern for datatypes is to wrap every field in a type constructor:+--+-- > data RequestHeaders_ f = RequestHeaders {+-- > requestTimeout :: f (Maybe Timeout)+-- > , requestCompression :: f (Maybe CompressionId)+-- > , ..+-- > }+--+-- The downside of such an approach is that if we don't need that type+-- constructor, we must instantiate @f@ to t'Identity', which results in+-- syntactic overhead.+-- (See also+-- [The Haskell Unfolder episode 14: Higher-kinded types]+-- (https://www.youtube.com/watch?v=EXgsXy1BR-0&list=PLD8gywOEY4HaG5VSrKVnHxCptlJv2GAn7&index=15).)+-- The @HKD@ family is designed to avoid this overhead:+--+-- > data RequestHeaders_ f = RequestHeaders {+-- > requestTimeout :: HKD f (Maybe Timeout)+-- > , requestCompression :: HKD f (Maybe CompressionId)+-- > , ..+-- > }+--+-- There are then two valid choices for @f@:+--+-- * 'Undecorated': @HKD Undecorated x@ is simply equal to @x@.+-- This avoids the overhead mentioned above.+-- * 'DecoratedWith' @f@, for some @f@:+-- @HKD (DecoratedWith f) x@ is equal to @f x@.+--+-- This explicit distinction between 'Undecorated' and 'DecoratedWith' is the+-- main difference between the approach in this module and other libraries that+-- provide similar functionality.+type family HKD (f :: Type -> Type) (x :: Type) :: Type++type instance HKD Undecorated x = x+type instance HKD (DecoratedWith f) x = f x++{-------------------------------------------------------------------------------+ Dealing with HKD records+-------------------------------------------------------------------------------}++-- | Witness the isomorphism between @Undecorated@ and @DecoratedWith Identity@.+class Coerce t where+ -- | Drop decoration+ --+ -- /NOTE/: The default instance is valid only for datatypes that are morally+ -- have a "higher order representative role"; that is, the type of every field+ -- of @t (DecoratedWith Identity)@ must be representationally equal to the+ -- corresponding type of @t Undecorated@. In the typical case of+ --+ -- > data SomeRecord f = MkSomeRecord {+ -- > field1 :: HKD f a1+ -- > , field2 :: HKD f a2+ -- > ..+ -- > , fieldN :: aN+ -- > , ..+ -- > , fieldM :: HKD f aM+ -- > }+ --+ -- where every field either has type @HKD f a@ or @a@ (not mentioning @f@ at+ -- all), this will automatically be the case.+ undecorate :: t (DecoratedWith Identity) -> t Undecorated+ undecorate = unsafeCoerce++ -- | Introduce trivial decoration+ --+ -- See 'undecorate' for discussion of the validity of the default definitino.+ decorate :: t Undecorated -> t (DecoratedWith Identity)+ decorate = unsafeCoerce++-- | Higher-kinded equivalent of 'Prelude.Traversable'+class Coerce t => Traversable t where+ traverse ::+ Applicative m+ => (forall a. f a -> m (g a))+ -> t (DecoratedWith f)+ -> m (t (DecoratedWith g))++-- | Higher-kinded equivalent of 'Prelude.sequence'+sequence ::+ (Traversable t, Applicative m)+ => t (DecoratedWith m) -> m (t Undecorated)+sequence = fmap undecorate . traverse (fmap Identity)++-- | Higher-kinded equivalent of 'Prelude.map'+map ::+ Traversable t+ => (forall a. f a -> g a)+ -> t (DecoratedWith f)+ -> t (DecoratedWith g)+map f = runIdentity . traverse (Identity . f)++{-------------------------------------------------------------------------------+ Dealing with HKD fields+-------------------------------------------------------------------------------}++data IsValidDecoration (c :: (Type -> Type) -> Constraint) f where+ ValidUndecorated :: IsValidDecoration c Undecorated+ ValidDecoratedWith :: c f => IsValidDecoration c (DecoratedWith f)++-- | Valid decorations+--+-- These are only two valid decorations (and new instances of this class cannot+-- be defined):+--+-- * @ValidDecoration c Undecorated@, for any @c@+-- * @ValidDecoration c (DecoratedWith f)@, for any @f@ satisfying @c@+class ValidDecoration (c :: (Type -> Type) -> Constraint) f where+ validDecoration :: IsValidDecoration c f+ validDecoration = undefined++instance ValidDecoration c Undecorated where+ validDecoration = ValidUndecorated++instance c f => ValidDecoration c (DecoratedWith f) where+ validDecoration = ValidDecoratedWith++-- | Specify field value of record with unknown decoration+--+-- You may need an additional type annotation also for @a@; for example+--+-- > HKD.pure (Proxy @f) Nothing+--+-- will result in an error message such as+--+-- > Couldn't match expected type: HKD f (Maybe SomeConcreteType)+-- > with actual type: HKD f (Maybe a0)+--+-- This is because @HKD@ is a type family in two arguments (even though in an+-- ideal world it should be defined as a type family in /one/ argument).+pure :: forall f a. ValidDecoration Applicative f => Proxy f -> a -> HKD f a+pure _ =+ case validDecoration :: IsValidDecoration Applicative f of+ ValidDecoratedWith -> Prelude.pure+ ValidUndecorated -> id++{-------------------------------------------------------------------------------+ Error decorations+-------------------------------------------------------------------------------}++-- | Decorate with potential errors+type Checked e = DecoratedWith (Either e)++-- | Throw all errors found in the datatype+--+-- Given a datatype decorated with potential errors, find and throw any errors;+-- if no errors are found, return the undecorated value.+sequenceChecked ::+ (MonadError e m, Traversable t)+ => t (Checked e) -> m (t Undecorated)+sequenceChecked = either throwError return . sequence+
+ src/Network/GRPC/Spec/Util/Parser.hs view
@@ -0,0 +1,251 @@+-- | Incremental parser interface+--+-- Intended for qualified import.+--+-- > import Network.GRPC.Spec.Util.Parser (Parser)+-- > import Network.GRPC.Spec.Util.Parser qualified as Parser+module Network.GRPC.Spec.Util.Parser (+ Parser -- opaque+ -- * Construction+ , consumeExactly+ , getExactly+ -- * Execution+ , IsFinal+ , Leftover+ , ProcessResult(..)+ , processAll+ ) where++import Control.Monad+import Data.Bifunctor+import Data.Binary (Get)+import Data.Binary.Get qualified as Binary+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.Int++{-------------------------------------------------------------------------------+ Definition+-------------------------------------------------------------------------------}++-- | Simple incremental parser+--+-- This is used to parse a stream of values, where we know ahead of time for+-- each value how much data to expect (perhaps based on the previous value).+-- Individual values are not parsed incrementally; see 'consumeExactly' or+-- 'getExactly'.+newtype Parser e a = Parser {+ runParser :: Accumulator -> Result e a+ }++data Result e a =+ -- | Parsing failed+ --+ -- This implies that we can stop parsing: getting more data won't fix the+ -- problem (see also 'NeedData')+ Failed e++ -- | We make some partial progress, but we need more data to continue+ | NeedData (Parser e a) Accumulator++ -- | Parsing succeeded+ --+ -- Also returns the left-over data+ | Done a Accumulator++instance Bifunctor Result where+ bimap f _ (Failed e) = Failed (f e)+ bimap _ g (Done a bs) = Done (g a) bs+ bimap f g (NeedData p bs) = NeedData (bimap f g p) bs++instance Functor (Result e) where+ fmap = second++instance Bifunctor Parser where+ bimap f g (Parser p) = Parser (bimap f g . p)++instance Functor (Parser e) where+ fmap = second++instance Applicative (Parser e) where+ pure x = Parser $ Done x+ (<*>) = ap++instance Monad (Parser e) where+ f >>= g = Parser $ \bs ->+ case runParser f bs of+ Failed e -> Failed e+ NeedData f' bs' -> NeedData (f' >>= g) bs'+ Done a bs' -> runParser (g a) bs'++instance MonadFail (Parser String) where+ fail err = Parser $ \_ -> Failed err++{-------------------------------------------------------------------------------+ Accumulated input++ This is an internal abstraction only; client code never sees this.+-------------------------------------------------------------------------------}++data Accumulator = Accumulator {+ -- | All the chunks received so far, in reverse order+ accumulatedChunks :: [Strict.ByteString]++ -- | Total accumulated length+ , accumulatedLength :: !Int64+ }++nil :: Accumulator+nil = Accumulator {+ accumulatedChunks = []+ , accumulatedLength = 0+ }++-- | Append chunks at the end of the accumulator+--+-- @O(1)@ (this is the raison d'être of this abstraction)+snoc :: Accumulator -> Strict.ByteString -> Accumulator+snoc acc chunk = Accumulator {+ accumulatedChunks =+ chunk : accumulatedChunks acc+ , accumulatedLength =+ accumulatedLength acc + fromIntegral (BS.Strict.length chunk)+ }++toLazy :: Accumulator -> Lazy.ByteString+toLazy = BS.Lazy.fromChunks . reverse . accumulatedChunks++split :: Int64 -> Accumulator -> Maybe (Lazy.ByteString, Accumulator)+split n acc+ | n > accumulatedLength acc+ = Nothing++ | otherwise+ = let bs = toLazy acc+ (front, back) = BS.Lazy.splitAt n bs+ remainder = Accumulator {+ accumulatedChunks = reverse (BS.Lazy.toChunks back)+ , accumulatedLength = accumulatedLength acc - n+ }+ in Just (front, remainder)++{-------------------------------------------------------------------------------+ Construction+-------------------------------------------------------------------------------}++-- | Consume a specified number of bytes+--+-- In order to use the t'Parser' interface we must know for each value exactly+-- how big it will be ahead of time. Typically this will be done by first+-- calling 'consumeExactly' for some kind of fixed size header, indicating how+-- big the value actual value is, which will then inform the next call to+-- 'consumeExactly'.+consumeExactly :: forall e a.+ Int64 -- ^ Length+ -> (Lazy.ByteString -> Either e a) -- ^ Parser+ -> Parser e a+consumeExactly len parse = go+ where+ go :: Parser e a+ go = Parser $ \acc ->+ case split len acc of+ Nothing -> NeedData go acc+ Just (raw, left) -> either Failed (flip Done left) $ parse raw++-- | Convenience wrapper around 'consumeExactly'+getExactly :: Int64 -> Get a -> Parser String a+getExactly len get =+ consumeExactly len $ either failed ok . Binary.runGetOrFail get+ where+ failed :: (Lazy.ByteString, Binary.ByteOffset, String) -> Either String a+ failed (_, _, err) = Left err++ ok :: (Lazy.ByteString, Binary.ByteOffset, a) -> Either String a+ ok (unconsumed, lenConsumed, a)+ | not (BS.Lazy.null unconsumed) = Left "Unconsumed data"+ | lenConsumed /= len = error "impossible"+ | otherwise = Right a++{-------------------------------------------------------------------------------+ Execution+-------------------------------------------------------------------------------}++-- | Is this the final chunk in the input?+type IsFinal = Bool++-- | Leftover data+type Leftover = Lazy.ByteString++-- | Result from processing all chunks in the input+--+-- See 'processAll'.+data ProcessResult e b =+ -- | Parse error during processing+ ProcessError e++ -- | Parsing succeeded (compare to 'ProcessedWithoutFinal')+ | ProcessedWithFinal b Leftover++ -- | Parsing succeeded, but we did not recognize the final message on time+ --+ -- There are two ways that parsing can terminate: the final few chunks may+ -- look like this:+ --+ -- > chunk1 -- not marked final+ -- > chunk2 -- not marked final+ -- > chunk3 -- marked final+ --+ -- or like this:+ --+ -- > chunk1 -- not marked final+ -- > chunk2 -- not marked final+ -- > chunk3 -- not marked final+ -- > empty chunk -- marked final+ --+ -- In the former case, we know that we are processing the final message /as/+ -- we are processing it ('ProcessedWithFinal'); in the latter case, we+ -- realize this only after we receive the final empty chunk.+ | ProcessedWithoutFinal Leftover++-- | Process all incoming data+--+-- Returns any unprocessed data.+-- Also returns if we knew that the final result+-- was in fact the final result when we received it (this may or may not be the+-- case, depending on+processAll :: forall m e a b.+ Monad m+ => m (Strict.ByteString, IsFinal) -- ^ Get next chunk+ -> (a -> m ()) -- ^ Process value+ -> (a -> m b) -- ^ Process final value+ -> Parser e a -- ^ Parser+ -> m (ProcessResult e b)+processAll getChunk processOne processFinal parser =+ go $ runParser parser nil+ where+ go :: Result e a -> m (ProcessResult e b)+ go (Failed err) = return $ ProcessError err+ go (Done a left) = processOne a >> go (runParser parser left)+ go (NeedData parser' left) = do+ (bs, isFinal) <- getChunk+ if not isFinal+ then go $ runParser parser' (left `snoc` bs)+ else goFinal [] $ runParser parser' (left `snoc` bs)++ -- We have received the final chunk; extract all messages until we are done+ goFinal :: [a] -> Result e a -> m (ProcessResult e b)+ goFinal _ (Failed err) = return $ ProcessError err+ goFinal acc (Done a left) = goFinal (a:acc) $ runParser parser left+ goFinal acc (NeedData _ left) = do+ mb <- processLastFew (reverse acc)+ return $ case mb of+ Just b -> ProcessedWithFinal b $ toLazy left+ Nothing -> ProcessedWithoutFinal $ toLazy left++ processLastFew :: [a] -> m (Maybe b)+ processLastFew [] = return Nothing+ processLastFew [a] = Just <$> processFinal a+ processLastFew (a:as) = processOne a >> processLastFew as+
+ src/Network/GRPC/Spec/Util/Protobuf.hs view
@@ -0,0 +1,59 @@+-- | Protobuf utilities+--+-- Intended for qualified import.+--+-- > import Network.GRPC.Spec.Util.Protobuf qualified as Protobuf+module Network.GRPC.Spec.Util.Protobuf (+ -- * Serialization+ parseStrict+ , parseLazy+ , buildStrict+ , buildLazy+ ) where++import Data.Binary.Builder qualified as Builder+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.ProtoLens (Message)+import Data.ProtoLens qualified as Protobuf+import Data.ProtoLens.Encoding.Parser (Parser)+import Data.ProtoLens.Encoding.Parser qualified as Protobuf+import Data.Proxy+import Data.Text qualified as Text++{-------------------------------------------------------------------------------+ Serialization+-------------------------------------------------------------------------------}++parseStrict :: Message msg => Strict.ByteString -> Either String msg+parseStrict = Protobuf.runParser parseMessage++-- | Parse lazy bytestring+--+-- TODO: <https://github.com/well-typed/grapesy/issues/119>.+-- We currently turn this into a strict bytestring before parsing.+parseLazy :: Message msg => Lazy.ByteString -> Either String msg+parseLazy = parseStrict . BS.Lazy.toStrict++buildStrict :: Message msg => msg -> Strict.ByteString+buildStrict = BS.Lazy.toStrict . buildLazy++buildLazy :: Message msg => msg -> Lazy.ByteString+buildLazy = Builder.toLazyByteString . Protobuf.buildMessage++{-------------------------------------------------------------------------------+ Internal auxilairy+-------------------------------------------------------------------------------}++parseMessage :: forall msg. Protobuf.Message msg => Parser msg+parseMessage = do+ msg <- Protobuf.parseMessage+ atEnd <- Protobuf.atEnd+ if atEnd then+ return msg+ else+ fail $ concat [+ Text.unpack $ Protobuf.messageName $ Proxy @msg+ , ": unconsumed bytes"+ ]
+ test-grpc-spec/Main.hs view
@@ -0,0 +1,44 @@+{-# 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++import Test.Prop.IncrementalParsing qualified as IncrementalParsing+import Test.Prop.Serialization qualified as Serialization+--import Test.Sanity.BrokenDeployments qualified as BrokenDeployments+--import Test.Sanity.Compression qualified as Compression+--import Test.Sanity.Disconnect qualified as Disconnect+--import Test.Sanity.EndOfStream qualified as EndOfStream+--import Test.Sanity.Exception qualified as Exception+--import Test.Sanity.Interop qualified as Interop+--import Test.Sanity.StreamingType.CustomFormat qualified as StreamingType.CustomFormat+--import Test.Sanity.StreamingType.NonStreaming qualified as StreamingType.NonStreaming++main :: IO ()+main = do+ defaultMain $ testGroup "test-grpc" [+ testGroup "Sanity" [+{-+ Disconnect.tests+ , EndOfStream.tests+ , testGroup "StreamingType" [+ StreamingType.NonStreaming.tests+ , StreamingType.CustomFormat.tests+ ]+ , Compression.tests+ , Exception.tests+ , Interop.tests+ , BrokenDeployments.tests+-}+ ]+ , testGroup "Prop" [+ IncrementalParsing.tests+ , Serialization.tests+ ]+ ]
+ test-grpc-spec/Test/Prop/IncrementalParsing.hs view
@@ -0,0 +1,222 @@+module Test.Prop.IncrementalParsing (tests) where++import Control.Monad+import Control.Monad.Except (MonadError, Except, runExcept, throwError)+import Control.Monad.State (MonadState, StateT, runStateT, state)+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.List (inits)+import Data.List qualified as List+import Data.Word+import Test.Tasty+import Test.Tasty.QuickCheck++import Network.GRPC.Spec.Util.Parser (Parser)+import Network.GRPC.Spec.Util.Parser qualified as Parser++{-------------------------------------------------------------------------------+ Tests proper+-------------------------------------------------------------------------------}++tests :: TestTree+tests = testGroup "Test.Prop.IncrementalParsing" [+ testProperty "parser" test_parser+ ]++test_parser :: MarkLast -> Input -> [ChunkSize] -> PhraseSize -> Property+test_parser markLast input splits phraseSize =+ counterexample ("chunks: " ++ show chunks)+ $ case processAll markLast chunks phraseSize of+ Left err ->+ counterexample ("Unexpected failure " ++ show err) $ False+ Right unconsumed ->+ fromIntegral (BS.Lazy.length unconsumed)+ === inputLength input `mod` getPhraseSize phraseSize+ where+ chunks :: [Strict.ByteString]+ chunks = mkChunks input splits++{-------------------------------------------------------------------------------+ Pure parser execution+-------------------------------------------------------------------------------}++-- | Monad in which we can execute the parser+--+-- 'StateT' is used to feed chunks of the input to the parser ('getChunk').+newtype Pure a = Pure {+ unwrapPure :: StateT [Strict.ByteString] (Except String) a+ }+ deriving newtype (+ Functor+ , Applicative+ , Monad+ , MonadState [Strict.ByteString]+ , MonadError String+ )++runPure ::+ [Strict.ByteString]+ -> Pure a+ -> Either String (a, [Strict.ByteString])+runPure chunks =+ runExcept+ . flip runStateT chunks+ . unwrapPure++getChunk :: MarkLast -> Pure (Strict.ByteString, Bool)+getChunk (MarkLast markLast) =+ state $ \case+ [] -> ((BS.Strict.empty, True), [])+ [c] -> ((c, markLast), [])+ c:cs -> ((c, False), cs)++processAll ::+ MarkLast+ -> [Strict.ByteString]+ -> PhraseSize+ -> Either String Lazy.ByteString+processAll markLast chunks phraseSize =+ runPure chunks aux >>= verifyAllChunksConsumed+ where+ p :: Parser String [Word8]+ p = parsePhrase phraseSize++ -- 'processAll' does not assume that the monad @m@ in which it is executed+ -- has any way of reporting errors: if there is a parse failure during+ -- execution, this failure is returned as a value. For the specific case of+ -- 'Pure', however, we /can/ throw errors in @m@ (to allow 'processOne' to+ -- throw errors), so we can reuse that also for any parse failures.+ aux :: Pure Lazy.ByteString+ aux =+ Parser.processAll (getChunk markLast) processPhrase processPhrase p+ >>= throwParseErrors++ -- 'processAll' should run until all chunks are used+ verifyAllChunksConsumed ::+ (Lazy.ByteString, [Strict.ByteString])+ -> Either String Lazy.ByteString+ verifyAllChunksConsumed (unconsumed, leftoverChunks)+ | null leftoverChunks+ = Right unconsumed++ | otherwise+ = Left "not all chunks consumed"++ throwParseErrors :: Parser.ProcessResult String () -> Pure Lazy.ByteString+ throwParseErrors (Parser.ProcessError err) =+ throwError err+ throwParseErrors (Parser.ProcessedWithFinal () bs) = do+ unless canMarkFinal $ throwError "Unexpected ProcessedWithFinal"+ return bs+ throwParseErrors (Parser.ProcessedWithoutFinal bs) = do+ when canMarkFinal $ throwError "Unexpected ProcessedWithoutFinal"+ return bs++ -- We can mark the final phrase as final if the final chunk is marked as+ -- final, and when we get that chunk, it contains at least one phrase.+ canMarkFinal :: Bool+ canMarkFinal = and [+ getMarkLast markLast+ , case reverse chunks of+ [] -> False+ c:cs -> let left = sum (map BS.Strict.length cs)+ `mod` getPhraseSize phraseSize+ in (left + BS.Strict.length c) >= getPhraseSize phraseSize+ ]++{-------------------------------------------------------------------------------+ Test input++ The strategy is as follows:++ * We construct an 'Input' of arbitrary length in the form++ ```+ [0, 1, 2, .., 255, 0, 1, 2, .., 255, 0, ..]+ ```++ * We split this input into non-empty chunks of varying sizes @[ChunkSize]@.+ We sometimes mark the last chunk as being the last, and sometimes don't+ (see <https://github.com/well-typed/grapesy/issues/114>).++ * We then choose a non-zero 'PhraseSize' @n@. The idea is that the parser+ splits the input into phrases of @n@ bytes++ ```+ [0, 1, 2, .., 255, 0, 1, 2, .., 255, 0, ..]+ \-----/\-----/\-----/\-----/\-----/+ n n n n n+ ```++ The parser returns the phrase after checking its length. This verifies that+ the parser framework gives us correct size inputs, independent of the sizes+ of the chunks of the input.++ * To process each phrase, we verify that each value in the phrase is the+ successor of the previous (mod 256). This verifies that the parser framework+ does not duplicate or miss any chunks.++ * Finally, in the main property, we check that no parse errors are reported+ and that the unconsumed input has the expected length. We also verify+ (in 'processAll') that all input chunks are fed to the parser.+-------------------------------------------------------------------------------}++newtype MarkLast = MarkLast { getMarkLast :: Bool } deriving (Show)+newtype Input = Input { getInputBytes :: [Word8] } deriving (Show)+newtype ChunkSize = ChunkSize { getChunkSize :: Int } deriving (Show)+newtype PhraseSize = PhraseSize { getPhraseSize :: Int } deriving (Show)++inputLength :: Input -> Int+inputLength = length . getInputBytes++mkChunks :: Input -> [ChunkSize] -> [Strict.ByteString]+mkChunks (Input bytes) =+ go bytes+ where+ go :: [Word8] -> [ChunkSize] -> [Strict.ByteString]+ go [] _ = []+ go bs [] = [BS.Strict.pack bs]+ go bs (s:ss) = let (pref, suf) = List.splitAt (getChunkSize s) bs+ in BS.Strict.pack pref : go suf ss++parsePhrase :: PhraseSize -> Parser String [Word8]+parsePhrase (PhraseSize n) =+ Parser.consumeExactly (fromIntegral n) checkLength+ where+ checkLength :: Lazy.ByteString -> Either String [Word8]+ checkLength bs+ | BS.Lazy.length bs /= fromIntegral n+ = Left $ "Unexpected phrase length"++ | otherwise+ = Right $ BS.Lazy.unpack bs++processPhrase :: [Word8] -> Pure ()+processPhrase phrase =+ case phrase of+ [] -> throwError "Empty phrase"+ (x:xs) -> go x xs+ where+ go :: Word8 -> [Word8] -> Pure ()+ go _ [] = return ()+ go prev (x:xs)+ | x == prev + 1 = go x xs+ | otherwise = throwError $ "Invalid phrase " ++ show phrase++{-------------------------------------------------------------------------------+ Arbitrary instances+-------------------------------------------------------------------------------}++deriving newtype instance Arbitrary MarkLast++instance Arbitrary Input where+ arbitrary = sized $ \n -> do+ len <- choose (0, n * 100)+ return $ Input $ take len $ cycle [0 .. 255]+ shrink = map Input . init . inits . getInputBytes++deriving via Positive Int instance Arbitrary ChunkSize+deriving via Positive Int instance Arbitrary PhraseSize+
+ test-grpc-spec/Test/Prop/Serialization.hs view
@@ -0,0 +1,703 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLabels #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Test.Prop.Serialization (tests) where++import Control.Lens ((.~))+import Control.Monad+import Control.Monad.Except (Except, runExcept)+import Control.Monad.State+import Data.Bifunctor+import Data.ByteString qualified as BS.Strict+import Data.ByteString qualified as Strict (ByteString)+import Data.ByteString.Base64 qualified as BS.Strict.Base64+import Data.ByteString.Char8 qualified as BS.Strict.Char8+import Data.CaseInsensitive qualified as CI+import Data.Char (isSpace)+import Data.Function+import Data.List (nubBy, uncons, intersperse)+import Data.Maybe (mapMaybe)+import Data.ProtoLens.Labels ()+import Data.ProtoLens.Message+import Data.Proxy+import Data.Text.Lazy qualified as Text.Lazy+import Data.TreeDiff (ToExpr, ediff, ansiWlEditExpr)+import Data.Void (Void)+import Network.HTTP.Types qualified as HTTP+import Prettyprinter (Doc)+import Prettyprinter qualified as PP+import Prettyprinter.Render.Terminal (AnsiStyle)+import Prettyprinter.Render.Terminal qualified as PP.Ansi+import Test.Tasty hiding (Timeout)+import Test.Tasty.QuickCheck++import Network.GRPC.Spec+import Network.GRPC.Spec.Serialization++import Test.Util.Awkward+import Test.Util.Orphans ()++tests :: TestTree+tests = testGroup "Test.Prop.Serialization" [+ testGroup "Base64" [+ testProperty "roundtrip" $+ roundtrip buildBinaryValue parseBinaryValue+ , testProperty "emitUnpadded" $ \(Awkward value) ->+ binaryNotPadded value+ , testProperty "acceptPadded" $+ roundtrip buildBinaryPadded parseBinaryValue+ , testProperty "acceptCommas" $ \cs ->+ roundtripWith+ (showIntermediate .*. labelHasMultipleChunks)+ (buildBinaryChunked cs)+ parseBinaryValue+ ]+ , testGroup "Headers" [+ testProperty "CustomMetadata" $+ roundtrip buildCustomMetadata parseCustomMetadata+ , testProperty "Timeout" $+ roundtrip buildTimeout parseTimeout+ , testProperty "Pushback" $+ roundtrip @Void buildPushback parsePushback+ , testProperty "RequestHeaders" $+ roundtrip (buildRequestHeaders rpc)+ (parseRequestHeaders rpc)+ , testProperty "ResponseHeaders" $+ roundtrip (buildResponseHeaders rpc)+ (parseResponseHeaders rpc)+ , testProperty "ProperTrailers" $+ roundtrip buildProperTrailers+ (parseProperTrailers rpc)+ , testProperty "TrailersOnly" $+ roundtrip (buildTrailersOnly' rpc)+ (parseTrailersOnly rpc)+ ]+ , testGroup "Duplicates" [+ testProperty "RequestHeaders" $ \dups ->+ roundtripWith+ (showIntermediate .*. labelDups)+ (introduceDups dups . buildRequestHeaders rpc)+ ( parseRequestHeaders rpc)+ , testProperty "ResponseHeaders" $ \dups ->+ roundtripWith+ (showIntermediate .*. labelDups)+ (introduceDups dups . buildResponseHeaders rpc)+ ( parseResponseHeaders rpc)+ , testProperty "ProperTrailers" $ \dups ->+ roundtripWith+ (showIntermediate .*. labelDups)+ (introduceDups dups . buildProperTrailers)+ ( parseProperTrailers rpc)+ , testProperty "TrailersOnly" $ \dups ->+ roundtripWith+ (showIntermediate .*. labelDups)+ (introduceDups dups . buildTrailersOnly' rpc)+ ( parseTrailersOnly rpc)+ ]+ , testGroup "Padding" [+ testProperty "RequestHeaders" $ \padding ->+ roundtripWith+ (showIntermediate .*. labelPadding)+ (introducePadding padding . buildRequestHeaders rpc)+ ( parseRequestHeaders rpc)+ , testProperty "ResponseHeaders" $ \padding ->+ roundtripWith+ (showIntermediate .*. labelPadding)+ (introducePadding padding . buildResponseHeaders rpc)+ ( parseResponseHeaders rpc)+ , testProperty "ProperTrailers" $ \padding ->+ roundtripWith+ (showIntermediate .*. labelPadding)+ (introducePadding padding . buildProperTrailers)+ ( parseProperTrailers rpc)+ , testProperty "TrailersOnly" $ \padding ->+ roundtripWith+ (showIntermediate .*. labelPadding)+ (introducePadding padding . buildTrailersOnly' rpc)+ ( parseTrailersOnly rpc)+ ]+ ]+ where+ rpc = Proxy @(RawRpc "serv" "meth")++{-------------------------------------------------------------------------------+ Binary headers+-------------------------------------------------------------------------------}++-- | The gRPC spec mandates we should not /create/ padded values+binaryNotPadded :: Strict.ByteString -> Bool+binaryNotPadded = BS.Strict.Char8.all (/= '=') . buildBinaryValue++-- | The gRPC spec mandates we must /accept/ padded values+--+-- We cannot call 'buildBinaryValue' here, because it creates padded values+-- (as tested with 'binaryNotPadded').+buildBinaryPadded :: Strict.ByteString -> Strict.ByteString+buildBinaryPadded = BS.Strict.Base64.encode++-- | Build binary value by encoding chunks separately and joining the results+--+-- See 'parseBinaryValue' for detailed discussion.+--+-- We depend on the presence of commas here; see discussion in 'introduceDups',+-- with the corresponding statistics relevant to this case collected by+-- 'labelHasMultipleChunks'.+buildBinaryChunked :: [Bool] -> Strict.ByteString -> Strict.ByteString+buildBinaryChunked ds value =+ mconcat . intersperse "," $+ map buildBinaryValue chunks+ where+ chunks :: [Strict.ByteString]+ (chunks, _) = splitHeaderValueBS ds value++labelHasMultipleChunks :: (a, Strict.ByteString) -> Property -> Property+labelHasMultipleChunks (_, bs) =+ tabulate "has multiple chunks" [+ show $ ',' `BS.Strict.Char8.elem` bs+ ]++{-------------------------------------------------------------------------------+ Duplicates in Custom-Metadata++ The spec mandates:++ > Custom-Metadata header order is not guaranteed to be preserved except for+ > values with duplicate header names. Duplicate header names may have their+ > values joined with "," as the delimiter and be considered semantically+ > equivalent.++ We need to be careful with whitespace around the delimeter here; the spec+ mandates++ > ASCII-Value should not have leading or trailing whitespace. If it contains+ > leading or trailing whitespace, it may be stripped.++ Since we use an internal representation that does not allow for duplicates, we+ test this by introducing duplicates in the /serialized/ form.+-------------------------------------------------------------------------------}++-- | Introduce duplicte headers+--+-- We introduce duplicates by splitting existing custom-metadata at existing+-- limiters (so that the roundtrip still passes), /if/ the corresponding 'Bool'+-- value is 'True' (so that we can shrink towards not introducing duplicates).+--+-- NOTE: Our generator for strict bytestrings generates commas with relatively+-- high probability, which ensures that we have enough source material here to+-- generate duplicate headers. We should keep an eye on the statistics however+-- to ensure that this continues to be the case (see 'labelDups').+introduceDups :: [Bool] -> [HTTP.Header] -> [HTTP.Header]+introduceDups = \dups -> concat . flip evalState dups . mapM go+ where+ go :: HTTP.Header -> State [Bool] [HTTP.Header]+ go hdr@(name, value)+ -- Don't split reserved headers (only metadata)+ | Nothing <- safeHeaderName (CI.foldedCase name)+ = return [hdr]++ -- We can split ASCII or binary headers+ | otherwise+ = state $ \dups -> first (map (name,)) $ splitHeaderValueBS dups value++splitHeaderValueBS ::+ [Bool]+ -> Strict.ByteString+ -> ([Strict.ByteString], [Bool])+splitHeaderValueBS ds =+ first (map BS.Strict.Char8.pack)+ . splitHeaderValue ds+ . BS.Strict.Char8.unpack++-- | Split a header value+--+-- We split the header value at @","@ boundaries, /provided/ that the comma is+-- not preceded or followed by whitespace (otherwise that whitespace would be+-- lost, since individual headers are trimmed).+--+-- Examples:+--+-- > splitHeaderValue [] "abc,def,ghi" == (["abc,def,ghi"] , [])+-- > splitHeaderValue [True] "abc,def,ghi" == (["abc","def,ghi"] , [])+-- > splitHeaderValue [False] "abc,def,ghi" == (["abc,def,ghi"] , [])+-- > splitHeaderValue [False,True] "abc,def,ghi" == (["abc,def","ghi"] , [])+-- > splitHeaderValue [True,True] "abc,def,ghi" == (["abc","def","ghi"] , [])+-- > splitHeaderValue [True,False,True] "abc,def" == (["abc","def"] , [False,True])+-- > splitHeaderValue [True] "abc, def,ghi" == (["abc, def","ghi"] , [])+-- > splitHeaderValue [True] "abc ,def,ghi" == (["abc ,def","ghi"] , [])+splitHeaderValue ::+ [Bool] -- ^ Allowed splits (useful to shrink towards splitting less)+ -> String -- ^ String to split+ -> ([String], [Bool])+splitHeaderValue = go []+ where+ go ::+ [Char] -- Accumulated chunk, in reverse order+ -> [Bool] -- Allowed splits left+ -> String -- String left to process+ -> ([String], [Bool])+ go acc [] xs = finalize acc [] xs+ go acc ds [] = finalize acc ds []+ go acc (d:ds) (x:xs)+ | canSplit, d = first (reverse acc :) $ go [] ds xs+ | canSplit, not d = go (x:acc) ds xs+ | otherwise = go (x:acc) (d:ds) xs+ where+ prevIsSpace, nextIsSpace, canSplit :: Bool+ prevIsSpace = maybe False (isSpace . fst) $ uncons acc+ nextIsSpace = maybe False (isSpace . fst) $ uncons xs+ canSplit = x == ',' && not prevIsSpace && not nextIsSpace++ finalize :: [Char] -> [Bool] -> String -> ([String], [Bool])+ finalize acc ds xs = ([reverse acc ++ xs], ds)++labelDups :: (a, [HTTP.Header]) -> Property -> Property+labelDups (_a, headers) =+ tabulate "has duplicate headers" [+ show $ length headers /= length (nubBy ((==) `on` fst) headers)+ ]++{-------------------------------------------------------------------------------+ Roundtrip tests+-------------------------------------------------------------------------------}++roundtrip :: forall e a b.+ (Eq a, ToExpr a, Show b, Show e)+ => (a -> b) -- ^ There+ -> (b -> Except e a) -- ^ and back again+ -> Awkward a -> Property+roundtrip = roundtripWith showIntermediate++roundtripWith :: forall e a b.+ (Eq a, ToExpr a, Show e)+ => ((a, b) -> Property -> Property) -- ^ Statistics, metadata, ..+ -> (a -> b) -- ^ There+ -> (b -> Except e a) -- ^ and back again+ -> Awkward a -> Property+roundtripWith modProp there back (Awkward a) =+ modProp (a, b) $+ let ma' = runExcept (back b)+ in case ma' of+ Left err ->+ counterexample (show err) False+ Right a'+ | a == a' ->+ property True+ | otherwise ->+ counterexample (renderDoc $ ansiWlEditExpr $ ediff a a') False+ where+ b :: b+ b = there a++showIntermediate :: Show b => (a, b) -> Property -> Property+showIntermediate (_, b) = counterexample (show b)++(.*.) ::+ ((a, b) -> Property -> Property)+ -> ((a, b) -> Property -> Property)+ -> ((a, b) -> Property -> Property)+(.*.) f g (a, b) = f (a, b) . g (a, b)++{-------------------------------------------------------------------------------+ Padding+-------------------------------------------------------------------------------}++newtype Padding = Padding {+ getPadding :: Strict.ByteString+ }+ deriving Show++instance Arbitrary Padding where+ arbitrary = do+ n <- choose (0, 5)+ Padding . BS.Strict.Char8.pack <$> replicateM n (elements " \t")+ shrink =+ map (Padding . BS.Strict.pack)+ . shrinkList (const []) -- only remove elements from the list+ . BS.Strict.unpack+ . getPadding++newtype PaddingPerHeader = PaddingPerHeader {+ -- | Left and right padding for each header+ getPaddingPerHeader :: [(Padding, Padding)]+ }+ deriving stock (Show)++instance Arbitrary PaddingPerHeader where+ arbitrary = sized $ \sz -> do+ n <- choose (0, sz)+ PaddingPerHeader <$> replicateM n genPadding+ where+ -- Most of the time, no padding+ genPadding :: Gen (Padding, Padding)+ genPadding = frequency [+ (7, (,) <$> pure (Padding "") <*> pure (Padding ""))+ , (1, (,) <$> arbitrary <*> pure (Padding ""))+ , (1, (,) <$> pure (Padding "") <*> arbitrary)+ , (1, (,) <$> arbitrary <*> arbitrary)+ ]+++ shrink =+ map PaddingPerHeader+ . shrinkList shrink+ . getPaddingPerHeader++introducePadding :: PaddingPerHeader -> [HTTP.Header] -> [HTTP.Header]+introducePadding = \(PaddingPerHeader padding) ->+ flip evalState padding . mapM go+ where+ go :: HTTP.Header -> State [(Padding, Padding)] HTTP.Header+ go (name, value) = state $ \case+ [] ->+ ((name, value), [])+ (l, r) : padding' ->+ ((name, getPadding l <> value <> getPadding r), padding')++labelPadding :: (a, [HTTP.Header]) -> Property -> Property+labelPadding (_a, headers) =+ tabulate "has padding" [+ show $ any (hasPadding . snd) headers+ ]+ where+ hasPadding :: Strict.ByteString -> Bool+ hasPadding bs = or [+ not . BS.Strict.null $ BS.Strict.Char8.takeWhile isSpace bs+ , not . BS.Strict.null $ BS.Strict.Char8.takeWhileEnd isSpace bs+ ]++{-------------------------------------------------------------------------------+ Arbitrary instances++ We do not yet provide shrinkers for each definition; they should be defined if+ and when a test breaks.+-------------------------------------------------------------------------------}++instance Arbitrary (Awkward CustomMetadata) where+ arbitrary = Awkward <$> do+ name <- genName+ awkward `suchThatMap` safeCustomMetadata name+ where+ genName :: Gen HeaderName+ genName = oneof [+ getAwkward <$> arbitrary+ , fmap (<> "-bin") $ getAwkward <$> arbitrary+ ] `suchThatMap` safeHeaderName++ -- For now we shrink only the value+ shrink (Awkward (CustomMetadata name value)) =+ mapMaybe (fmap Awkward . safeCustomMetadata name) $ shrink value++instance Arbitrary (Awkward CustomMetadataMap) where+ arbitrary = Awkward <$>+ customMetadataMapFromList <$> awkward+ shrink =+ map (Awkward . customMetadataMapFromList . map getAwkward)+ . shrink+ . (map Awkward . customMetadataMapToList . getAwkward)++instance Arbitrary (Awkward RequestHeaders) where+ arbitrary = Awkward <$> do+ requestTimeout <- awkward+ requestCompression <- awkward+ requestAcceptCompression <- awkward+ requestContentType <- Just <$> awkward -- cannot be missing+ requestMessageType <- Just <$> awkward -- cannot be missing+ requestUserAgent <- awkward+ requestIncludeTE <- arbitrary+ requestTraceContext <- awkward+ requestPreviousRpcAttempts <- awkward+ requestMetadata <- awkward+ return $ RequestHeaders{+ requestTimeout+ , requestCompression+ , requestAcceptCompression+ , requestContentType+ , requestMessageType+ , requestUserAgent+ , requestIncludeTE+ , requestTraceContext+ , requestPreviousRpcAttempts+ , requestMetadata+ , requestUnrecognized = ()+ }+ shrink h@(Awkward h') = concat [+ shrinkAwkward (\x -> h'{requestTimeout = x}) requestTimeout h+ , shrinkAwkward (\x -> h'{requestCompression = x}) requestCompression h+ , shrinkAwkward (\x -> h'{requestAcceptCompression = x}) requestAcceptCompression h+ , shrinkAwkward (\x -> h'{requestUserAgent = x}) requestUserAgent h+ , shrinkRegular (\x -> h'{requestIncludeTE = x}) requestIncludeTE h+ , shrinkAwkward (\x -> h'{requestTraceContext = x}) requestTraceContext h+ , shrinkAwkward (\x -> h'{requestPreviousRpcAttempts = x}) requestPreviousRpcAttempts h+ , shrinkAwkward (\x -> h'{requestMetadata = x}) requestMetadata h+ ]++instance Arbitrary (Awkward ResponseHeaders) where+ arbitrary = Awkward <$> do+ responseCompression <- awkward+ responseAcceptCompression <- awkward+ responseContentType <- Just <$> awkward+ responseMetadata <- awkward+ return ResponseHeaders {+ responseCompression+ , responseAcceptCompression+ , responseContentType+ , responseMetadata+ , responseUnrecognized = ()+ }++ shrink h@(Awkward h') = concat [+ shrinkAwkward (\x -> h'{responseCompression = x}) responseCompression h+ , shrinkAwkward (\x -> h'{responseAcceptCompression = x}) responseAcceptCompression h+ , shrinkAwkward (\x -> h'{responseMetadata = x}) responseMetadata h+ ]++instance Arbitrary (Awkward ProperTrailers) where+ arbitrary = Awkward <$> do+ properTrailersGrpcStatus <- awkward+ properTrailersGrpcMessage <- awkward+ properTrailersStatusDetails <- awkward+ properTrailersPushback <- awkward+ properTrailersOrcaLoadReport <- awkward+ properTrailersMetadata <- awkward+ return $ ProperTrailers{+ properTrailersGrpcStatus+ , properTrailersGrpcMessage+ , properTrailersStatusDetails+ , properTrailersPushback+ , properTrailersOrcaLoadReport+ , properTrailersMetadata+ , properTrailersUnrecognized = ()+ }++ shrink h@(Awkward h') = concat [+ shrinkAwkward (\x -> h'{properTrailersGrpcStatus = x}) properTrailersGrpcStatus h+ , shrinkAwkward (\x -> h'{properTrailersGrpcMessage = x}) properTrailersGrpcMessage h+ , shrinkAwkward (\x -> h'{properTrailersMetadata = x}) properTrailersMetadata h+ , shrinkAwkward (\x -> h'{properTrailersPushback = x}) properTrailersPushback h+ , shrinkAwkward (\x -> h'{properTrailersOrcaLoadReport = x}) properTrailersOrcaLoadReport h+ ]++instance Arbitrary (Awkward TrailersOnly) where+ arbitrary = Awkward <$> do+ trailersOnlyContentType <- Just <$> awkward+ trailersOnlyProper <- awkward+ return $ TrailersOnly {+ trailersOnlyContentType+ , trailersOnlyProper+ }++ shrink h@(Awkward h') = concat [+ shrinkAwkward (\x -> h'{trailersOnlyContentType = x}) trailersOnlyContentType h+ , shrinkAwkward (\x -> h'{trailersOnlyProper = x}) trailersOnlyProper h+ ]++instance Arbitrary (Awkward Timeout) where+ arbitrary = fmap Awkward $+ Timeout <$> awkward <*> awkward++instance Arbitrary (Awkward TimeoutUnit) where+ arbitrary = Awkward <$> elements [+ Hour+ , Minute+ , Second+ , Millisecond+ , Microsecond+ , Nanosecond+ ]++instance Arbitrary (Awkward TimeoutValue) where+ arbitrary = fmap Awkward $+ TimeoutValue <$> arbitrary `suchThat` isValidTimeoutValue+ shrink (Awkward (TimeoutValue x)) =+ map (Awkward . TimeoutValue) $ shrink x++instance Arbitrary (Awkward CompressionId) where+ arbitrary = Awkward <$> oneof [+ pure Identity+ , pure GZip+ , pure Deflate+ , pure Snappy+ , Custom <$> awkward `suchThatMap` validCompressionId+ ]+ shrink (Awkward cid) = Awkward <$>+ case cid of+ Identity -> []+ GZip -> [Identity]+ Deflate -> [Identity]+ Snappy -> [Identity]+ Custom x -> concat [+ [Identity]+ , mapMaybe (fmap Custom . validCompressionId) $ shrink x+ ]++instance Arbitrary (Awkward ContentType) where+ arbitrary = Awkward <$>+ oneof [+ pure $ ContentTypeDefault+ , (\format -> ContentTypeOverride $ defaultRpcContentType format)+ <$> awkward `suchThatMap` validFormat+ ]+ shrink (Awkward ct) = Awkward <$>+ case ct of+ ContentTypeDefault -> []+ ContentTypeOverride bs -> concat [+ [ContentTypeDefault]+ , [ ContentTypeOverride $ defaultRpcContentType format'+ | Just format <- [BS.Strict.Char8.stripPrefix ("application/grpc+") bs]+ , format' <- mapMaybe (validFormat . getAwkward) $ shrink (Awkward format)+ ]+ ]++instance Arbitrary (Awkward MessageType) where+ arbitrary = Awkward <$>+ oneof [+ pure $ MessageTypeDefault+ , MessageTypeOverride <$> awkward `suchThat` validMessageType+ ]++ shrink (Awkward mt) = Awkward <$>+ case mt of+ MessageTypeDefault -> []+ MessageTypeOverride x -> concat [+ [MessageTypeDefault]+ , [ MessageTypeOverride x'+ | x' <- shrink x+ , validMessageType x'+ ]+ ]++instance Arbitrary (Awkward TraceContext) where+ arbitrary = Awkward <$> do+ traceContextTraceId <- awkward+ traceContextSpanId <- awkward+ traceContextOptions <- awkward+ return TraceContext {+ traceContextTraceId+ , traceContextSpanId+ , traceContextOptions+ }++instance Arbitrary (Awkward TraceId) where+ arbitrary = Awkward <$> do+ tid <- replicateM 16 arbitrary -- length is fixed+ return $ TraceId $ BS.Strict.pack tid++instance Arbitrary (Awkward SpanId) where+ arbitrary = Awkward <$> do+ tid <- replicateM 8 arbitrary -- length is fixed+ return $ SpanId $ BS.Strict.pack tid++instance Arbitrary (Awkward TraceOptions) where+ arbitrary = Awkward <$> do+ traceOptionsSampled <- arbitrary+ return TraceOptions {+ traceOptionsSampled+ }++instance Arbitrary (Awkward GrpcStatus) where+ arbitrary = Awkward <$>+ elements [+ GrpcOk+ , GrpcError GrpcCancelled+ , GrpcError GrpcUnknown+ , GrpcError GrpcInvalidArgument+ , GrpcError GrpcDeadlineExceeded+ , GrpcError GrpcNotFound+ , GrpcError GrpcAlreadyExists+ , GrpcError GrpcPermissionDenied+ , GrpcError GrpcResourceExhausted+ , GrpcError GrpcFailedPrecondition+ , GrpcError GrpcAborted+ , GrpcError GrpcOutOfRange+ , GrpcError GrpcUnimplemented+ , GrpcError GrpcInternal+ , GrpcError GrpcUnavailable+ , GrpcError GrpcDataLoss+ , GrpcError GrpcUnauthenticated+ ]++instance Arbitrary (Awkward Pushback) where+ arbitrary = Awkward <$>+ oneof [+ RetryAfter <$> arbitrary+ , pure DoNotRetry+ ]++instance Arbitrary (Awkward OrcaLoadReport) where+ arbitrary = Awkward <$> do+ -- @rps@ is a deprecated field, we omit it from the test+ cpuUtilization <- awkward+ memUtilization <- awkward+ requestCost <- awkward+ utilization <- awkward+ rpsFractional <- awkward+ eps <- awkward+ namedMetrics <- awkward+ applicationUtilization <- awkward+ return $+ defMessage+ & #cpuUtilization .~ cpuUtilization+ & #memUtilization .~ memUtilization+ & #requestCost .~ requestCost+ & #utilization .~ utilization+ & #rpsFractional .~ rpsFractional+ & #eps .~ eps+ & #namedMetrics .~ namedMetrics+ & #applicationUtilization .~ applicationUtilization++{-------------------------------------------------------------------------------+ Generating valid values+-------------------------------------------------------------------------------}++validCompressionId :: String -> Maybe String+validCompressionId cid =+ case filter (not . forbiddenChar) cid of+ "" -> Nothing+ cid' -> Just cid'+ where+ forbiddenChar :: Char -> Bool+ forbiddenChar c = or [+ isSpace c+ , c `elem` [',']+ ]++validFormat :: Strict.ByteString -> Maybe Strict.ByteString+validFormat format =+ case BS.Strict.Char8.filter (not . forbiddenChar) format of+ "" -> Nothing+ "grpc" -> Nothing -- Would be parsed as @ContentTypeDefault@+ cid' -> Just cid'+ where+ forbiddenChar :: Char -> Bool+ forbiddenChar c = or [+ isSpace c+ , c `elem` [';']+ ]++validMessageType :: Strict.ByteString -> Bool+validMessageType "Void" = False -- Would be parsed as @MessageTypeDefault@+validMessageType _ = True++{-------------------------------------------------------------------------------+ Auxiliary+-------------------------------------------------------------------------------}++renderDoc :: Doc AnsiStyle -> String+renderDoc =+ Text.Lazy.unpack+ . PP.Ansi.renderLazy+ . resetTerminal+ . PP.layoutPretty PP.defaultLayoutOptions+ where+ -- Reset the vivid red from tasty+ resetTerminal :: PP.SimpleDocStream AnsiStyle -> PP.SimpleDocStream AnsiStyle+ resetTerminal = PP.SAnnPush $ PP.Ansi.color PP.Ansi.Black++buildTrailersOnly' :: IsRPC rpc => Proxy rpc -> TrailersOnly -> [HTTP.Header]+buildTrailersOnly' rpc = buildTrailersOnly (Just . chooseContentType rpc)++type instance RequestMetadata (RawRpc "serv" "meth") = NoMetadata+type instance ResponseInitialMetadata (RawRpc "serv" "meth") = NoMetadata+type instance ResponseTrailingMetadata (RawRpc "serv" "meth") = NoMetadata
+ test-grpc-spec/Test/Util/Awkward.hs view
@@ -0,0 +1,154 @@+module Test.Util.Awkward (+ Awkward(..)+ -- * Support for defining instances+ , awkward+ , arbitraryAwkward+ , shrinkAwkward+ , shrinkRegular+ ) where++import Control.Monad+import Data.ByteString qualified as BS.Strict+import Data.ByteString qualified as Strict (ByteString)+import Data.ByteString.Char8 qualified as Strict.BS.Char8+import Data.Char (ord, chr, isSpace)+import Data.List.NonEmpty (NonEmpty)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Word+import Test.QuickCheck+import Test.QuickCheck.Instances ()++{-------------------------------------------------------------------------------+ \"Awkward\" instances+-------------------------------------------------------------------------------}++-- | Newtype wrapper for \"awkward\" 'Arbitrary' instances+--+-- In most property tests we don't explore edge cases, preferring for example+-- to use only simple header names, rather than check encoding issues. But in+-- these serialization tests the edge cases are of course important.+newtype Awkward a = Awkward { getAwkward :: a }+ deriving stock (Show, Functor)++awkward :: Arbitrary (Awkward a) => Gen a+awkward = getAwkward <$> arbitrary++arbitraryAwkward :: Arbitrary (Awkward a) => (a -> b) -> Gen (Awkward b)+arbitraryAwkward f = Awkward . f <$> awkward++shrinkAwkward ::+ Arbitrary (Awkward a)+ => (a -> b)+ -> (b -> a)+ -> Awkward b -> [Awkward b]+shrinkAwkward f g =+ map (Awkward . f . getAwkward)+ . shrink+ . Awkward . g . getAwkward++-- | Non-awkward fields of awkward types+shrinkRegular ::+ Arbitrary a+ => (a -> b)+ -> (b -> a)+ -> Awkward b -> [Awkward b]+shrinkRegular f g = map (Awkward . f) . shrink . g . getAwkward++{-------------------------------------------------------------------------------+ Standard instances+-------------------------------------------------------------------------------}++distrib :: Functor f => f (Awkward a) -> Awkward (f a)+distrib = Awkward . fmap getAwkward++undistrib :: Functor f => Awkward (f a) -> f (Awkward a)+undistrib = fmap Awkward . getAwkward++instance Arbitrary (Awkward a) => Arbitrary (Awkward (Maybe a)) where+ arbitrary = distrib <$> arbitrary+ shrink = map distrib . shrink . undistrib++instance Arbitrary (Awkward a) => Arbitrary (Awkward [a]) where+ arbitrary = distrib <$> arbitrary+ shrink = map distrib . shrink . undistrib++instance Arbitrary (Awkward a) => Arbitrary (Awkward (NonEmpty a)) where+ arbitrary = distrib <$> arbitrary+ shrink = map distrib . shrink . undistrib++instance ( Arbitrary (Awkward a)+ , Arbitrary (Awkward b)+ ) => Arbitrary (Awkward (a, b)) where+ arbitrary = fmap Awkward $ (,) <$> awkward <*> awkward+ shrink pair@(Awkward (x, y)) = concat [+ shrinkAwkward (\x' -> (x', y )) fst pair+ , shrinkAwkward (\y' -> (x , y')) snd pair+ ]++instance ( Arbitrary (Awkward k)+ , Arbitrary (Awkward v)+ , Ord k+ ) => Arbitrary (Awkward (Map k v)) where+ arbitrary = arbitraryAwkward Map.fromList+ shrink = shrinkAwkward Map.fromList Map.toList++instance Arbitrary (Awkward Strict.ByteString) where+ arbitrary = sized $ \sz -> Awkward <$> do+ n <- choose (0, sz)+ trimByteString . BS.Strict.pack <$> replicateM n genChar+ where+ -- Generate commas with relatively high probability, so that the tests+ -- for duplicate headers have enough material to work with.+ genChar :: Gen Word8+ genChar = frequency [+ (9, arbitrary)+ , (1, pure $ fromIntegral (ord ','))+ ]++ shrink =+ map (Awkward . trimByteString . BS.Strict.pack)+ . shrinkList shrinkChar+ . BS.Strict.unpack . getAwkward+ where+ -- shrink as 'Char'+ shrinkChar :: Word8 -> [Word8]+ shrinkChar = map (fromIntegral . ord) . shrink . (chr . fromIntegral)++instance {-# OVERLAPPING #-} Arbitrary (Awkward String) where+ arbitrary = Awkward . trim <$> arbitrary+ shrink = map (Awkward . trim) . shrink . getAwkward++instance Arbitrary (Awkward Text) where+ arbitrary = Awkward . Text.pack . trim . getAwkward <$> arbitrary+ shrink = map (Awkward . Text.pack . trim) . shrink . (Text.unpack . getAwkward)++instance Arbitrary (Awkward Int) where+ arbitrary = Awkward <$> arbitrary+ shrink = map Awkward . shrink . getAwkward++instance Arbitrary (Awkward Double) where+ arbitrary = Awkward <$> arbitrary+ shrink = map Awkward . shrink . getAwkward++{-------------------------------------------------------------------------------+ Trimming++ Generate only trimmed strings; if we generate a value that has leading or+ trailing whitespace, we might not be able to parse that value, as parsing may+ trim the value.+-------------------------------------------------------------------------------}++trim :: String -> String+trim =+ dropWhile isSpace+ . reverse+ . dropWhile isSpace+ . reverse++trimByteString :: Strict.ByteString -> Strict.ByteString+trimByteString =+ Strict.BS.Char8.dropWhile isSpace+ . Strict.BS.Char8.dropWhileEnd isSpace
+ test-grpc-spec/Test/Util/Orphans.hs view
@@ -0,0 +1,42 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Test.Util.Orphans () where++import Data.CaseInsensitive+import Data.TreeDiff++import Network.GRPC.Spec++import Test.Util.Protobuf++{-------------------------------------------------------------------------------+ ToExpr (tree-diff)+-------------------------------------------------------------------------------}++instance ToExpr a => ToExpr (CI a) where+ toExpr = toExpr . foldedCase++instance ToExpr OrcaLoadReport where+ toExpr = messageToExpr++deriving anyclass instance ToExpr CompressionId+deriving anyclass instance ToExpr ContentType+deriving anyclass instance ToExpr CustomMetadata+deriving anyclass instance ToExpr CustomMetadataMap+deriving anyclass instance ToExpr GrpcError+deriving anyclass instance ToExpr GrpcStatus+deriving anyclass instance ToExpr HeaderName+deriving anyclass instance ToExpr MessageType+deriving anyclass instance ToExpr ProperTrailers+deriving anyclass instance ToExpr Pushback+deriving anyclass instance ToExpr RequestHeaders+deriving anyclass instance ToExpr ResponseHeaders+deriving anyclass instance ToExpr SpanId+deriving anyclass instance ToExpr Timeout+deriving anyclass instance ToExpr TimeoutUnit+deriving anyclass instance ToExpr TimeoutValue+deriving anyclass instance ToExpr TraceContext+deriving anyclass instance ToExpr TraceId+deriving anyclass instance ToExpr TraceOptions+deriving anyclass instance ToExpr TrailersOnly+
+ test-grpc-spec/Test/Util/Protobuf.hs view
@@ -0,0 +1,84 @@+-- | Utilities for working with Protobuf messages+module Test.Util.Protobuf (+ messageToExpr+ ) where++import Data.ProtoLens.Message+import Data.Proxy+import Data.Text qualified as Text+import Data.TreeDiff+import Data.TreeDiff.OMap qualified as OMap+import Control.Lens ((^.), Lens', (.~))+import Data.Map qualified as Map+import Data.Function ((&))+import Data.ProtoLens.Encoding.Wire++{-------------------------------------------------------------------------------+ TreeDiff+-------------------------------------------------------------------------------}++messageToExpr :: forall msg. Message msg => msg -> Expr+messageToExpr =+ Rec (Text.unpack $ messageName (Proxy @msg))+ . OMap.fromList+ . fields++fields :: Message msg => msg -> [(FieldName, Expr)]+fields msg = concat [+ map (knownField msg) allFields+ , map unknownField (msg ^. unknownFields)+ ]++knownField :: msg -> FieldDescriptor msg -> (FieldName, Expr)+knownField msg (FieldDescriptor name typ acc) = (+ name+ , case acc of+ PlainField _ f -> plainField typ $ msg ^. f+ OptionalField f -> toExpr $ plainField typ <$> msg ^. f+ RepeatedField _ f -> toExpr $ plainField typ <$> msg ^. f+ MapField k v f -> toExpr $+ (messageToExpr . pairToMsg k v) <$> Map.toList (msg ^. f)+ )++plainField :: FieldTypeDescriptor value -> value -> Expr+plainField (MessageField _) = messageToExpr+plainField (ScalarField typ) = scalarField typ++scalarField :: ScalarField value -> value -> Expr+scalarField EnumField = enumField+scalarField Int32Field = toExpr+scalarField Int64Field = toExpr+scalarField UInt32Field = toExpr+scalarField UInt64Field = toExpr+scalarField SInt32Field = toExpr+scalarField SInt64Field = toExpr+scalarField Fixed32Field = toExpr+scalarField Fixed64Field = toExpr+scalarField SFixed32Field = toExpr+scalarField SFixed64Field = toExpr+scalarField FloatField = toExpr+scalarField DoubleField = toExpr+scalarField BoolField = toExpr+scalarField StringField = toExpr+scalarField BytesField = toExpr++enumField :: MessageEnum value => value -> Expr+enumField = toExpr . fromEnum++unknownField :: TaggedValue -> (FieldName, Expr)+unknownField (TaggedValue (Tag tag) value) = (show tag, wireValue value)++wireValue :: WireValue -> Expr+wireValue (Fixed32 x) = toExpr x+wireValue (Fixed64 x) = toExpr x+wireValue (Lengthy x) = toExpr x+wireValue (VarInt x) = toExpr x+wireValue StartGroup = toExpr ()+wireValue EndGroup = toExpr ()++{-------------------------------------------------------------------------------+ Auxiliary: working with maps+-------------------------------------------------------------------------------}++pairToMsg :: Message msg => Lens' msg k -> Lens' msg v -> (k, v) -> msg+pairToMsg k v (x, y) = defMessage & k .~ x & v .~ y