diff --git a/src/Network/GRPC/Client/Connection.hs b/src/Network/GRPC/Client/Connection.hs index 663f58ba..e8c80092 100644 --- a/src/Network/GRPC/Client/Connection.hs +++ b/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 diff --git a/src/Network/GRPC/Spec/Request.hs b/src/Network/GRPC/Spec/Request.hs index 5b1f543e..3193a408 100644 --- a/src/Network/GRPC/Spec/Request.hs +++ b/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 . + , 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 :: diff --git a/src/Network/GRPC/Spec/Response.hs b/src/Network/GRPC/Spec/Response.hs index 12a8e82b..104365bb 100644 --- a/src/Network/GRPC/Spec/Response.hs +++ b/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 . , properTrailersPushback :: HKD f (Maybe Pushback) -- | ORCA load report diff --git a/test-grapesy/Test/Prop/Serialization.hs b/test-grapesy/Test/Prop/Serialization.hs index bda26b41..04b5c72c 100644 --- a/test-grapesy/Test/Prop/Serialization.hs +++ b/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 diff --git a/test-grapesy/Test/Util/Awkward.hs b/test-grapesy/Test/Util/Awkward.hs index 78bf65af..da64db00 100644 --- a/test-grapesy/Test/Util/Awkward.hs +++ b/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 \ No newline at end of file