diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for grpc-spec + +## 1.0.0 -- 2025-01-22 + +* First released version. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/grpc-spec.cabal b/grpc-spec.cabal new file mode 100644 --- /dev/null +++ b/grpc-spec.cabal @@ -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 . + 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 diff --git a/proto/Proto/OrcaLoadReport.hs b/proto/Proto/OrcaLoadReport.hs new file mode 100644 --- /dev/null +++ b/proto/Proto/OrcaLoadReport.hs @@ -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" diff --git a/proto/Proto/Status.hs b/proto/Proto/Status.hs new file mode 100644 --- /dev/null +++ b/proto/Proto/Status.hs @@ -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" diff --git a/src/Network/GRPC/Spec.hs b/src/Network/GRPC/Spec.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec.hs @@ -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 diff --git a/src/Network/GRPC/Spec/Call.hs b/src/Network/GRPC/Spec/Call.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/Call.hs @@ -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 () + } + diff --git a/src/Network/GRPC/Spec/Compression.hs b/src/Network/GRPC/Spec/Compression.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/Compression.hs @@ -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: . + -- 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} = "" + +-- | 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 diff --git a/src/Network/GRPC/Spec/CustomMetadata/Map.hs b/src/Network/GRPC/Spec/CustomMetadata/Map.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/CustomMetadata/Map.hs @@ -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 diff --git a/src/Network/GRPC/Spec/CustomMetadata/NoMetadata.hs b/src/Network/GRPC/Spec/CustomMetadata/NoMetadata.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/CustomMetadata/NoMetadata.hs @@ -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 _ = [] diff --git a/src/Network/GRPC/Spec/CustomMetadata/Raw.hs b/src/Network/GRPC/Spec/CustomMetadata/Raw.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/CustomMetadata/Raw.hs @@ -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" + -- . + | 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 " diff --git a/src/Network/GRPC/Spec/CustomMetadata/Typed.hs b/src/Network/GRPC/Spec/CustomMetadata/Typed.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/CustomMetadata/Typed.hs @@ -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 +-- ). +-- +-- 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) + diff --git a/src/Network/GRPC/Spec/Headers/Common.hs b/src/Network/GRPC/Spec/Headers/Common.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/Headers/Common.hs @@ -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 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 diff --git a/src/Network/GRPC/Spec/Headers/Invalid.hs b/src/Network/GRPC/Spec/Headers/Invalid.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/Headers/Invalid.hs @@ -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 . (:[]) diff --git a/src/Network/GRPC/Spec/Headers/PseudoHeaders.hs b/src/Network/GRPC/Spec/Headers/PseudoHeaders.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/Headers/PseudoHeaders.hs @@ -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 +-- +-- +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 . +data Method = Post + deriving stock (Show) + +-- | Scheme +-- +-- See . +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) diff --git a/src/Network/GRPC/Spec/Headers/Request.hs b/src/Network/GRPC/Spec/Headers/Request.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/Headers/Request.hs @@ -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 . + -- 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 . + , 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) diff --git a/src/Network/GRPC/Spec/Headers/Response.hs b/src/Network/GRPC/Spec/Headers/Response.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/Headers/Response.hs @@ -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 . + , properTrailersPushback :: HKD f (Maybe Pushback) + + -- | ORCA load report + -- + -- See + , 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 +-- (), but do /we/ parse this +-- header so that /if/ the server includes it, we do not throw a parser error. +-- +-- See also +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) diff --git a/src/Network/GRPC/Spec/MessageMeta.hs b/src/Network/GRPC/Spec/MessageMeta.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/MessageMeta.hs @@ -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) + diff --git a/src/Network/GRPC/Spec/OrcaLoadReport.hs b/src/Network/GRPC/Spec/OrcaLoadReport.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/OrcaLoadReport.hs @@ -0,0 +1,5 @@ +module Network.GRPC.Spec.OrcaLoadReport ( + OrcaLoadReport + ) where + +import Proto.OrcaLoadReport diff --git a/src/Network/GRPC/Spec/PercentEncoding.hs b/src/Network/GRPC/Spec/PercentEncoding.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/PercentEncoding.hs @@ -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 diff --git a/src/Network/GRPC/Spec/RPC.hs b/src/Network/GRPC/Spec/RPC.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/RPC.hs @@ -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 + diff --git a/src/Network/GRPC/Spec/RPC/JSON.hs b/src/Network/GRPC/Spec/RPC/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/RPC/JSON.hs @@ -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 +-- ). 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 +-- 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: +-- 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 + diff --git a/src/Network/GRPC/Spec/RPC/Protobuf.hs b/src/Network/GRPC/Spec/RPC/Protobuf.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/RPC/Protobuf.hs @@ -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 + + * + * @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 +-- +-- +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) diff --git a/src/Network/GRPC/Spec/RPC/Raw.hs b/src/Network/GRPC/Spec/RPC/Raw.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/RPC/Raw.hs @@ -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 diff --git a/src/Network/GRPC/Spec/RPC/StreamType.hs b/src/Network/GRPC/Spec/RPC/StreamType.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/RPC/StreamType.hs @@ -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 diff --git a/src/Network/GRPC/Spec/Serialization.hs b/src/Network/GRPC/Spec/Serialization.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/Serialization.hs @@ -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 diff --git a/src/Network/GRPC/Spec/Serialization/Base64.hs b/src/Network/GRPC/Spec/Serialization/Base64.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/Serialization/Base64.hs @@ -0,0 +1,82 @@ +-- | gRPC-style base64-encoding +-- +-- The gRPC specification mandates standard Base64-encoding for binary headers +-- , /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 diff --git a/src/Network/GRPC/Spec/Serialization/CustomMetadata.hs b/src/Network/GRPC/Spec/Serialization/CustomMetadata.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/Serialization/CustomMetadata.hs @@ -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' diff --git a/src/Network/GRPC/Spec/Serialization/Headers/Common.hs b/src/Network/GRPC/Spec/Serialization/Headers/Common.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/Serialization/Headers/Common.hs @@ -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 . + -- 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+" + 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 +-- . +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 diff --git a/src/Network/GRPC/Spec/Serialization/Headers/PseudoHeaders.hs b/src/Network/GRPC/Spec/Serialization/Headers/PseudoHeaders.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/Serialization/Headers/PseudoHeaders.hs @@ -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} diff --git a/src/Network/GRPC/Spec/Serialization/Headers/Request.hs b/src/Network/GRPC/Spec/Serialization/Headers/Request.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/Serialization/Headers/Request.hs @@ -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: +-- .) 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 + , "." + ] diff --git a/src/Network/GRPC/Spec/Serialization/Headers/Response.hs b/src/Network/GRPC/Spec/Serialization/Headers/Response.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/Serialization/Headers/Response.hs @@ -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 +-- . +-- 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 +-- ). +-- * 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 +-- or +-- ). +-- +-- 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. + -- + 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 +-- +-- * +-- * +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 + -- + 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 diff --git a/src/Network/GRPC/Spec/Serialization/LengthPrefixed.hs b/src/Network/GRPC/Spec/Serialization/LengthPrefixed.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/Serialization/LengthPrefixed.hs @@ -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 diff --git a/src/Network/GRPC/Spec/Serialization/Status.hs b/src/Network/GRPC/Spec/Serialization/Status.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/Serialization/Status.hs @@ -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 diff --git a/src/Network/GRPC/Spec/Serialization/Timeout.hs b/src/Network/GRPC/Spec/Serialization/Timeout.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/Serialization/Timeout.hs @@ -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 + diff --git a/src/Network/GRPC/Spec/Serialization/TraceContext.hs b/src/Network/GRPC/Spec/Serialization/TraceContext.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/Serialization/TraceContext.hs @@ -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 + + +-------------------------------------------------------------------------------} + +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 diff --git a/src/Network/GRPC/Spec/Status.hs b/src/Network/GRPC/Spec/Status.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/Status.hs @@ -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 . +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 +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 = [] + } diff --git a/src/Network/GRPC/Spec/Timeout.hs b/src/Network/GRPC/Spec/Timeout.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/Timeout.hs @@ -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 diff --git a/src/Network/GRPC/Spec/TraceContext.hs b/src/Network/GRPC/Spec/TraceContext.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/TraceContext.hs @@ -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: +-- +-- * +-- W3C spec +-- +-- * +-- Binary format used for the @grpc-trace-bin@ header +-- +-- * +-- 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'. +-- +-- +-- +-- * 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. +-- +-- +-- +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 + diff --git a/src/Network/GRPC/Spec/Util/ByteString.hs b/src/Network/GRPC/Spec/Util/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/Util/ByteString.hs @@ -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' + ] diff --git a/src/Network/GRPC/Spec/Util/HKD.hs b/src/Network/GRPC/Spec/Util/HKD.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/Util/HKD.hs @@ -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 + diff --git a/src/Network/GRPC/Spec/Util/Parser.hs b/src/Network/GRPC/Spec/Util/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/Util/Parser.hs @@ -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 + diff --git a/src/Network/GRPC/Spec/Util/Protobuf.hs b/src/Network/GRPC/Spec/Util/Protobuf.hs new file mode 100644 --- /dev/null +++ b/src/Network/GRPC/Spec/Util/Protobuf.hs @@ -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: . +-- 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" + ] diff --git a/test-grpc-spec/Main.hs b/test-grpc-spec/Main.hs new file mode 100644 --- /dev/null +++ b/test-grpc-spec/Main.hs @@ -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 + ] + ] diff --git a/test-grpc-spec/Test/Prop/IncrementalParsing.hs b/test-grpc-spec/Test/Prop/IncrementalParsing.hs new file mode 100644 --- /dev/null +++ b/test-grpc-spec/Test/Prop/IncrementalParsing.hs @@ -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 ). + + * 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 + diff --git a/test-grpc-spec/Test/Prop/Serialization.hs b/test-grpc-spec/Test/Prop/Serialization.hs new file mode 100644 --- /dev/null +++ b/test-grpc-spec/Test/Prop/Serialization.hs @@ -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 diff --git a/test-grpc-spec/Test/Util/Awkward.hs b/test-grpc-spec/Test/Util/Awkward.hs new file mode 100644 --- /dev/null +++ b/test-grpc-spec/Test/Util/Awkward.hs @@ -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 diff --git a/test-grpc-spec/Test/Util/Orphans.hs b/test-grpc-spec/Test/Util/Orphans.hs new file mode 100644 --- /dev/null +++ b/test-grpc-spec/Test/Util/Orphans.hs @@ -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 + diff --git a/test-grpc-spec/Test/Util/Protobuf.hs b/test-grpc-spec/Test/Util/Protobuf.hs new file mode 100644 --- /dev/null +++ b/test-grpc-spec/Test/Util/Protobuf.hs @@ -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