Support grpc-previous-rpc-attempts

This is a tiny step towards #104.

src/Network/GRPC/Client/Connection.hs

@@ -356,6 +356,8 @@ startRPC Connection{connMetaVar, connParams, connStateVar} _ callParams = do
             True
         , requestTraceContext =
             Nothing
+        , requestPreviousRpcAttempts =
+            Nothing
         }
 
     callSession :: ClientSession rpc

src/Network/GRPC/Spec/Request.hs

@@ -42,6 +42,7 @@ import Network.GRPC.Util.HKD (HKD, Undecorated, DecoratedWith)
 import Network.GRPC.Util.HKD qualified as HKD
 
 import Paths_grapesy qualified as Grapesy
+import Text.Read (readMaybe)
 
 {-------------------------------------------------------------------------------
   Inputs (message sent to the peer)
@@ -100,6 +101,12 @@ data RequestHeaders_ f = RequestHeaders {
 
       -- | Trace context (for OpenTelemetry)
     , requestTraceContext :: HKD f (Maybe TraceContext)
+
+      -- | Previous RPC attempts
+      --
+      -- This is part of automatic retries.
+      -- See <https://github.com/grpc/proposal/blob/master/A6-client-retries.md>.
+    , requestPreviousRpcAttempts :: HKD f (Maybe Int)
     }
 
 type RequestHeaders = RequestHeaders_ Undecorated
@@ -110,14 +117,15 @@ deriving stock instance Eq   RequestHeaders
 instance HKD.Traversable RequestHeaders_ where
   sequence x =
       RequestHeaders
-        <$> requestTimeout           x
-        <*> requestMetadata          x
-        <*> requestCompression       x
-        <*> requestAcceptCompression x
-        <*> requestContentType       x
-        <*> requestMessageType       x
-        <*> requestIncludeTE         x
-        <*> requestTraceContext      x
+        <$> requestTimeout             x
+        <*> requestMetadata            x
+        <*> requestCompression         x
+        <*> requestAcceptCompression   x
+        <*> requestContentType         x
+        <*> requestMessageType         x
+        <*> requestIncludeTE           x
+        <*> requestTraceContext        x
+        <*> requestPreviousRpcAttempts x
 
 -- | Mark a input sent as final
 data IsFinal = Final | NotFinal
@@ -179,6 +187,7 @@ callDefinition proxy = \hdrs -> catMaybes [
     , buildMessageAcceptEncoding <$> requestAcceptCompression hdrs
     , Just $ buildUserAgent
     , buildGrpcTraceBin <$> requestTraceContext hdrs
+    , buildPreviousRpcAttempts <$> requestPreviousRpcAttempts hdrs
     ]
   where
     hdrTimeout :: Timeout -> HTTP.Header
@@ -229,6 +238,12 @@ callDefinition proxy = \hdrs -> catMaybes [
         , buildBinaryValue $ buildTraceContext ctxt
         )
 
+    buildPreviousRpcAttempts :: Int -> HTTP.Header
+    buildPreviousRpcAttempts n = (
+          "grpc-previous-rpc-attempts"
+        , BS.Strict.C8.pack $ show n
+        )
+
 {-------------------------------------------------------------------------------
   Parsing
 -------------------------------------------------------------------------------}
@@ -299,6 +314,16 @@ parseRequestHeaders proxy =
               return True
           }
 
+      | name == "grpc-previous-rpc-attempts"
+      = modify $ \x -> x {
+            requestPreviousRpcAttempts = do
+              httpError HTTP.badRequest400 $
+                maybe
+                  (Left $ "grpc-previous-rpc-attempts: invalid " ++ show value)
+                  (Right . Just)
+                  (readMaybe $ BS.Strict.C8.unpack value)
+          }
+
       | otherwise
       = modify $ \x -> x {
             requestMetadata = do
@@ -308,14 +333,15 @@ parseRequestHeaders proxy =
 
     uninitRequestHeaders :: RequestHeaders_ (DecoratedWith m)
     uninitRequestHeaders = RequestHeaders {
-          requestTimeout           = return Nothing
-        , requestMetadata          = return mempty
-        , requestCompression       = return Nothing
-        , requestAcceptCompression = return Nothing
-        , requestContentType       = return Nothing
-        , requestMessageType       = return False
-        , requestIncludeTE         = return False
-        , requestTraceContext      = return Nothing
+          requestTimeout             = return Nothing
+        , requestMetadata            = return mempty
+        , requestCompression         = return Nothing
+        , requestAcceptCompression   = return Nothing
+        , requestContentType         = return Nothing
+        , requestMessageType         = return False
+        , requestIncludeTE           = return False
+        , requestTraceContext        = return Nothing
+        , requestPreviousRpcAttempts = return Nothing
         }
 
     httpError ::

src/Network/GRPC/Spec/Response.hs

@@ -120,6 +120,9 @@ data ProperTrailers_ f = ProperTrailers {
     , properTrailersMetadata :: HKD f CustomMetadataMap
 
       -- | Server pushback
+      --
+      -- This is part of automatic retries.
+      -- See <https://github.com/grpc/proposal/blob/master/A6-client-retries.md>.
     , properTrailersPushback :: HKD f (Maybe Pushback)
 
       -- | ORCA load report

test-grapesy/Test/Prop/Serialization.hs

@@ -300,6 +300,7 @@ instance Arbitrary (Awkward RequestHeaders) where
       requestMessageType         <- arbitrary
       requestIncludeTE           <- arbitrary
       requestTraceContext        <- awkward
+      requestPreviousRpcAttempts <- awkward
       return $ RequestHeaders{
           requestTimeout
         , requestMetadata
@@ -309,6 +310,7 @@ instance Arbitrary (Awkward RequestHeaders) where
         , requestMessageType
         , requestIncludeTE
         , requestTraceContext
+        , requestPreviousRpcAttempts
         }
   shrink h@(Awkward h') = concat [
         shrinkAwkward (\x -> h'{requestTimeout             = x}) requestTimeout             h
@@ -319,6 +321,7 @@ instance Arbitrary (Awkward RequestHeaders) where
       , shrinkRegular (\x -> h'{requestMessageType         = x}) requestMessageType         h
       , shrinkRegular (\x -> h'{requestIncludeTE           = x}) requestIncludeTE           h
       , shrinkAwkward (\x -> h'{requestTraceContext        = x}) requestTraceContext        h
+      , shrinkAwkward (\x -> h'{requestPreviousRpcAttempts = x}) requestPreviousRpcAttempts h
       ]
 
 instance Arbitrary (Awkward ResponseHeaders) where
@@ -357,10 +360,11 @@ instance Arbitrary (Awkward ProperTrailers) where
         }
 
   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'{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

test-grapesy/Test/Util/Awkward.hs

@@ -124,6 +124,10 @@ instance Arbitrary (Awkward Text) where
   arbitrary = Awkward . Text.pack . getAwkward <$> arbitrary
   shrink    = map (Awkward . Text.pack) . 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