Support the endpoint-load-metrics-bin header

We are still a long way from supporting ORCA (#72) but at least clients will be
able to read the ORCA load report sent by the server.

This restores compatibility with the interop test suite.

grapesy.cabal

@@ -121,6 +121,7 @@ library
       Network.GRPC.Spec.CustomMetadata.Raw
       Network.GRPC.Spec.CustomMetadata.Typed
       Network.GRPC.Spec.LengthPrefixed
+      Network.GRPC.Spec.OrcaLoadReport
       Network.GRPC.Spec.PercentEncoding
       Network.GRPC.Spec.PseudoHeaders
       Network.GRPC.Spec.Request
@@ -139,6 +140,7 @@ library
       Network.GRPC.Util.HTTP2
       Network.GRPC.Util.HTTP2.Stream
       Network.GRPC.Util.Parser
+      Network.GRPC.Util.Protobuf
       Network.GRPC.Util.RedundantConstraint
       Network.GRPC.Util.Session
       Network.GRPC.Util.Session.API
@@ -255,6 +257,7 @@ test-suite test-grapesy
 
       Proto.Empty
       Proto.Messages
+      Proto.OrcaLoadReport
       Proto.Test
   build-depends:
       -- Internal dependencies

src/Network/GRPC/Server/Call.hs

@@ -362,10 +362,11 @@ serverExceptionToClientError err
 
     | otherwise
     = ProperTrailers {
-          properTrailersGrpcStatus  = GrpcError GrpcUnknown
-        , properTrailersGrpcMessage = Just $ Text.pack (show err)
-        , properTrailersMetadata    = mempty
-        , properTrailersPushback    = Nothing
+          properTrailersGrpcStatus     = GrpcError GrpcUnknown
+        , properTrailersGrpcMessage    = Just $ Text.pack (show err)
+        , properTrailersMetadata       = mempty
+        , properTrailersPushback       = Nothing
+        , properTrailersOrcaLoadReport = Nothing
         }
 
 {-------------------------------------------------------------------------------
@@ -433,11 +434,12 @@ sendOutputWithEnvelope call@Call{callChannel} msg = do
   where
     mkTrailers :: ResponseTrailingMetadata rpc -> ProperTrailers
     mkTrailers metadata = ProperTrailers {
-          properTrailersGrpcStatus  = GrpcOk
-        , properTrailersGrpcMessage = Nothing
-        , properTrailersMetadata    = customMetadataMapFromList $
-                                        buildMetadata metadata
-        , properTrailersPushback    = Nothing
+          properTrailersGrpcStatus     = GrpcOk
+        , properTrailersGrpcMessage    = Nothing
+        , properTrailersMetadata       = customMetadataMapFromList $
+                                           buildMetadata metadata
+        , properTrailersPushback       = Nothing
+        , properTrailersOrcaLoadReport = Nothing
         }
 
 -- | Send 'GrpcException' to the client
@@ -548,10 +550,11 @@ sendTrailersOnly Call{ callContext
     trailers = TrailersOnly {
           trailersOnlyContentType = Context.serverContentType params
         , trailersOnlyProper      = ProperTrailers {
-              properTrailersGrpcStatus  = GrpcOk
-            , properTrailersGrpcMessage = Nothing
-            , properTrailersMetadata    = customMetadataMapFromList metadata
-            , properTrailersPushback    = Nothing
+              properTrailersGrpcStatus     = GrpcOk
+            , properTrailersGrpcMessage    = Nothing
+            , properTrailersMetadata       = customMetadataMapFromList metadata
+            , properTrailersPushback       = Nothing
+            , properTrailersOrcaLoadReport = Nothing
             }
         }
 

src/Network/GRPC/Spec.hs

@@ -157,6 +157,8 @@ module Network.GRPC.Spec (
   , TraceOptions(..)
   , buildTraceContext
   , parseTraceContext
+    -- * ORCA
+  , OrcaLoadReport
   ) where
 
 import Network.GRPC.Spec.Call
@@ -167,6 +169,7 @@ import Network.GRPC.Spec.CustomMetadata.NoMetadata
 import Network.GRPC.Spec.CustomMetadata.Raw
 import Network.GRPC.Spec.CustomMetadata.Typed
 import Network.GRPC.Spec.LengthPrefixed
+import Network.GRPC.Spec.OrcaLoadReport
 import Network.GRPC.Spec.PseudoHeaders
 import Network.GRPC.Spec.Request
 import Network.GRPC.Spec.Response

src/Network/GRPC/Spec/OrcaLoadReport.hs

@@ -0,0 +1,5 @@
+module Network.GRPC.Spec.OrcaLoadReport (
+    OrcaLoadReport
+  ) where
+
+import Proto.OrcaLoadReport

src/Network/GRPC/Spec/RPC/Protobuf.hs

@@ -3,13 +3,9 @@
 -- | gRPC with Protobuf
 module Network.GRPC.Spec.RPC.Protobuf (Protobuf) where
 
-import Data.ByteString.Builder qualified as Builder
-import Data.ByteString.Lazy qualified as BS.Lazy
 import Data.Kind
-import Data.ProtoLens qualified as Protobuf
-import Data.ProtoLens.Encoding.Parser (Parser)
-import Data.ProtoLens.Encoding.Parser qualified as Protobuf
-import Data.ProtoLens.Service.Types as Protobuf
+import Data.ProtoLens
+import Data.ProtoLens.Service.Types
 import Data.Proxy
 import Data.Text qualified as Text
 import GHC.TypeLits
@@ -18,6 +14,7 @@ import Network.GRPC.Spec.CustomMetadata.NoMetadata
 import Network.GRPC.Spec.CustomMetadata.Typed
 import Network.GRPC.Spec.RPC
 import Network.GRPC.Spec.RPC.StreamType
+import Network.GRPC.Util.Protobuf qualified as Protobuf
 
 {-------------------------------------------------------------------------------
   The spec defines the following in Appendix A, "GRPC for Protobuf":
@@ -51,36 +48,25 @@ instance ( HasMethodImpl      serv meth
                        , symbolVal $ Proxy @(ServiceName serv)
                        ]
   rpcMethodName  _ = Text.pack . symbolVal $ Proxy @(MethodName  serv meth)
-  rpcMessageType _ = Protobuf.messageName  $ Proxy @(MethodInput serv meth)
+  rpcMessageType _ = messageName  $ Proxy @(MethodInput serv meth)
 
 instance ( HasMethodImpl      serv meth
          , Show (MethodInput  serv meth)
          , Show (MethodOutput serv meth)
          ) => SupportsClientRpc (Protobuf serv meth) where
-  rpcSerializeInput    _ = Builder.toLazyByteString . Protobuf.buildMessage
-  rpcDeserializeOutput _ = Protobuf.runParser parseMessage . BS.Lazy.toStrict
+  rpcSerializeInput    _ = Protobuf.buildLazy
+  rpcDeserializeOutput _ = Protobuf.parseLazy
 
 instance ( HasMethodImpl      serv meth
          , Show (MethodInput  serv meth)
          , Show (MethodOutput serv meth)
          ) => SupportsServerRpc (Protobuf serv meth) where
-  rpcDeserializeInput _ = Protobuf.runParser parseMessage . BS.Lazy.toStrict
-  rpcSerializeOutput  _ = Builder.toLazyByteString . Protobuf.buildMessage
+  rpcDeserializeInput _ = Protobuf.parseLazy
+  rpcSerializeOutput  _ = Protobuf.buildLazy
 
 instance styp ~ MethodStreamingType serv meth
       => SupportsStreamingType (Protobuf serv meth) styp
 
 instance HasStreamingType (Protobuf serv meth) where
   type RpcStreamingType (Protobuf serv meth) = MethodStreamingType serv meth
 
-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"
-        ]

src/Network/GRPC/Spec/Response.hs

@@ -52,12 +52,14 @@ import Network.GRPC.Spec.Common
 import Network.GRPC.Spec.Compression (CompressionId)
 import Network.GRPC.Spec.CustomMetadata.Map
 import Network.GRPC.Spec.CustomMetadata.Raw
+import Network.GRPC.Spec.CustomMetadata.Typed
+import Network.GRPC.Spec.OrcaLoadReport
 import Network.GRPC.Spec.PercentEncoding qualified as PercentEncoding
 import Network.GRPC.Spec.RPC
 import Network.GRPC.Spec.Status
 import Network.GRPC.Util.HKD (HKD, Undecorated, DecoratedWith)
 import Network.GRPC.Util.HKD qualified as HKD
-import Network.GRPC.Spec.CustomMetadata.Typed
+import Network.GRPC.Util.Protobuf qualified as Protobuf
 
 {-------------------------------------------------------------------------------
   Outputs (messages received from the peer)
@@ -119,6 +121,11 @@ data ProperTrailers_ f = ProperTrailers {
 
       -- | Server pushback
     , properTrailersPushback :: HKD f (Maybe Pushback)
+
+      -- | ORCA load report
+      --
+      -- See <https://github.com/grpc/proposal/blob/master/A51-custom-backend-metrics.md>
+    , properTrailersOrcaLoadReport :: HKD f (Maybe OrcaLoadReport)
     }
 
 type ProperTrailers = ProperTrailers_ Undecorated
@@ -129,10 +136,11 @@ deriving stock instance Eq   ProperTrailers
 instance HKD.Traversable ProperTrailers_ where
   sequence x =
       ProperTrailers
-        <$> properTrailersGrpcStatus  x
-        <*> properTrailersGrpcMessage x
-        <*> properTrailersMetadata    x
-        <*> properTrailersPushback    x
+        <$> properTrailersGrpcStatus     x
+        <*> properTrailersGrpcMessage    x
+        <*> properTrailersMetadata       x
+        <*> properTrailersPushback       x
+        <*> properTrailersOrcaLoadReport x
 
 -- | Trailers sent in the gRPC Trailers-Only case
 --
@@ -276,10 +284,11 @@ grpcExceptionToTrailers GrpcException{
                           , grpcErrorMessage
                           , grpcErrorMetadata
                           } = ProperTrailers{
-      properTrailersGrpcStatus  = GrpcError grpcError
-    , properTrailersGrpcMessage = grpcErrorMessage
-    , properTrailersMetadata    = customMetadataMapFromList grpcErrorMetadata
-    , properTrailersPushback    = Nothing
+      properTrailersGrpcStatus     = GrpcError grpcError
+    , properTrailersGrpcMessage    = grpcErrorMessage
+    , properTrailersMetadata       = customMetadataMapFromList grpcErrorMetadata
+    , properTrailersPushback       = Nothing
+    , properTrailersOrcaLoadReport = Nothing
     }
 
 {-------------------------------------------------------------------------------
@@ -416,6 +425,7 @@ buildProperTrailers ProperTrailers{
                       , properTrailersGrpcMessage
                       , properTrailersMetadata
                       , properTrailersPushback
+                      , properTrailersOrcaLoadReport
                       } = concat [
       [ ( "grpc-status"
         , BS.Strict.C8.pack $ show $ fromGrpcStatus properTrailersGrpcStatus
@@ -432,6 +442,11 @@ buildProperTrailers ProperTrailers{
         )
       | Just x <- [properTrailersPushback]
       ]
+    , [ ( "endpoint-load-metrics-bin"
+        , buildBinaryValue $ Protobuf.buildStrict x
+        )
+      | Just x <- [properTrailersOrcaLoadReport]
+      ]
     ]
 
 -- | Build trailers for the Trailers-Only case
@@ -509,6 +524,15 @@ parseTrailersOnly proxy =
               Just <$> parsePushback value
           }
 
+      | name == "endpoint-load-metrics-bin"
+      = modify $ liftProperTrailers $ \x -> x{
+            properTrailersOrcaLoadReport = do
+              value' <- parseBinaryValue value
+              case Protobuf.parseStrict value' of
+                Left  err    -> throwError err
+                Right report -> return $ Just report
+          }
+
       | otherwise
       = modify $ liftProperTrailers $ \x -> x{
             properTrailersMetadata = do
@@ -520,10 +544,11 @@ parseTrailersOnly proxy =
     uninitTrailersOnly = TrailersOnly {
           trailersOnlyContentType = return Nothing
         , trailersOnlyProper      = ProperTrailers {
-              properTrailersGrpcStatus  = throwError "missing: grpc-status"
-            , properTrailersGrpcMessage = return Nothing
-            , properTrailersMetadata    = return mempty
-            , properTrailersPushback    = return Nothing
+              properTrailersGrpcStatus     = throwError "missing: grpc-status"
+            , properTrailersGrpcMessage    = return Nothing
+            , properTrailersMetadata       = return mempty
+            , properTrailersPushback       = return Nothing
+            , properTrailersOrcaLoadReport = return Nothing
             }
         }
 

src/Network/GRPC/Util/Protobuf.hs

@@ -0,0 +1,55 @@
+-- | Protobuf utilities
+--
+-- Intended for qualified import.
+--
+-- > import Network.GRPC.Util.Protobuf qualified as Protobuf
+module Network.GRPC.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
+
+parseLazy :: Message msg => Lazy.ByteString -> Either String msg
+parseLazy = parseStrict . BS.Lazy.toStrict
+
+buildStrict :: Message msg => msg -> Strict.ByteString
+buildStrict = BS.Lazy.toStrict . buildLazy
+
+buildLazy :: Message msg => msg -> Lazy.ByteString
+buildLazy = Builder.toLazyByteString . Protobuf.buildMessage
+
+{-------------------------------------------------------------------------------
+  Internal auxilairy
+-------------------------------------------------------------------------------}
+
+parseMessage :: forall msg. Protobuf.Message msg => Parser msg
+parseMessage = do
+    msg   <- Protobuf.parseMessage
+    atEnd <- Protobuf.atEnd
+    if atEnd then
+      return msg
+    else
+      fail $ concat [
+          Text.unpack $ Protobuf.messageName $ Proxy @msg
+        , ": unconsumed bytes"
+        ]

test-grapesy/Test/Prop/Serialization.hs

@@ -1,4 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLabels  #-}
+
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Test.Prop.Serialization (tests) where
@@ -23,6 +25,7 @@ import Test.Tasty.QuickCheck
 
 import Network.GRPC.Common
 import Network.GRPC.Common.Compression qualified as Compr
+import Network.GRPC.Common.Protobuf
 import Network.GRPC.Spec
 
 import Test.Util.Awkward
@@ -340,15 +343,17 @@ instance Arbitrary (Awkward ResponseHeaders) where
 
 instance Arbitrary (Awkward ProperTrailers) where
   arbitrary = Awkward <$> do
-      properTrailersGrpcStatus  <- awkward
-      properTrailersGrpcMessage <- awkward
-      properTrailersMetadata    <- awkward
-      properTrailersPushback    <- awkward
+      properTrailersGrpcStatus     <- awkward
+      properTrailersGrpcMessage    <- awkward
+      properTrailersMetadata       <- awkward
+      properTrailersPushback       <- awkward
+      properTrailersOrcaLoadReport <- awkward
       return $ ProperTrailers{
           properTrailersGrpcStatus
         , properTrailersGrpcMessage
         , properTrailersMetadata
         , properTrailersPushback
+        , properTrailersOrcaLoadReport
         }
 
   shrink h@(Awkward h') = concat [
@@ -491,6 +496,28 @@ instance Arbitrary (Awkward Pushback) where
         , 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
+
 {-------------------------------------------------------------------------------
   Auxiliary
 -------------------------------------------------------------------------------}