grpc-spec-1.0.0: src/Network/GRPC/Spec/Serialization/Headers/Response.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Deal with HTTP2 responses
--
-- Intended for unqualified import.
module Network.GRPC.Spec.Serialization.Headers.Response (
-- * ResponseHeaders
buildResponseHeaders
, parseResponseHeaders
, parseResponseHeaders'
-- * ProperTrailers
, buildProperTrailers
, parseProperTrailers
, parseProperTrailers'
-- * TrailersOnly
, buildTrailersOnly
, parseTrailersOnly
, parseTrailersOnly'
-- * Classify server response
, classifyServerResponse
-- * Pushback
, buildPushback
, parsePushback
) where
import Control.Monad.Except
import Control.Monad.State
import Data.Bifunctor
import Data.ByteString qualified as BS.Strict
import Data.ByteString qualified as Strict (ByteString)
import Data.ByteString.Char8 qualified as BS.Strict.C8
import Data.ByteString.Lazy qualified as BS.Lazy
import Data.ByteString.Lazy qualified as Lazy (ByteString)
import Data.CaseInsensitive qualified as CI
import Data.Maybe (isJust)
import Data.Proxy
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Network.HTTP.Types qualified as HTTP
import Text.Read (readMaybe)
#if !MIN_VERSION_text(2,0,0)
import Data.Text.Encoding.Error qualified as Text
#endif
import Network.GRPC.Spec
import Network.GRPC.Spec.PercentEncoding qualified as PercentEncoding
import Network.GRPC.Spec.Serialization.CustomMetadata
import Network.GRPC.Spec.Serialization.Headers.Common
import Network.GRPC.Spec.Util.HKD qualified as HKD
import Network.GRPC.Spec.Util.Protobuf qualified as Protobuf
{-------------------------------------------------------------------------------
Classify server response
-------------------------------------------------------------------------------}
-- | Classify server response
--
-- gRPC servers are supposed to respond with HTTP status @200 OK@ no matter
-- whether the call was successful or not; if not successful, the information
-- about the failure should be reported using @grpc-status@ and related headers
-- (@grpc-message@, @grpc-status-details-bin@).
--
-- The gRPC spec mandates that if we get a non-200 status from a broken
-- deployment, we synthesize a gRPC exception with an appropriate status and
-- status message. The spec itself does not provide any guidance on what such an
-- appropriate status would look like, but the official gRPC repo does provide a
-- partial mapping between HTTP status codes and gRPC status codes at
-- <https://github.com/grpc/grpc/blob/master/doc/http-grpc-status-mapping.md>.
-- This is the mapping we implement here.
classifyServerResponse :: forall rpc.
IsRPC rpc
=> Proxy rpc
-> HTTP.Status -- ^ HTTP status
-> [HTTP.Header] -- ^ Headers
-> Maybe Lazy.ByteString -- ^ Response body, if known (used for errors only)
-> Either (TrailersOnly' GrpcException) (ResponseHeaders' GrpcException)
classifyServerResponse rpc status headers mBody
-- The "HTTP to gRPC Status Code Mapping" is explicit:
--
-- > (..) to be used only for clients that received a response that did not
-- > include grpc-status. If grpc-status was provided, it must be used.
--
-- Therefore if @grpc-status@ is present, we ignore the HTTP status.
| hasGrpcStatus headers
= Left $ parseTrailersOnly' rpc headers
| 200 <- statusCode
= Right $ parseResponseHeaders' rpc headers
| otherwise
= Left $
case statusCode of
400 -> synthesize GrpcInternal -- Bad request
401 -> synthesize GrpcUnauthenticated -- Unauthorized
403 -> synthesize GrpcPermissionDenied -- Forbidden
404 -> synthesize GrpcUnimplemented -- Not found
429 -> synthesize GrpcUnavailable -- Too many requests
502 -> synthesize GrpcUnavailable -- Bad gateway
503 -> synthesize GrpcUnavailable -- Service unavailable
504 -> synthesize GrpcUnavailable -- Gateway timeout
_ -> synthesize GrpcUnknown
where
HTTP.Status{statusCode, statusMessage} = status
-- The @grpc-status@ header not present, and HTTP status not @200 OK@.
-- We classify the response as an error response (hence 'TrailersOnly''):
--
-- * We set 'properTrailersGrpcStatus' based on the HTTP status.
-- * We leave 'properTrailersGrpcMessage' alone if @grpc-message@ present
-- and valid, and replace it with a default message otherwise.
--
-- The resulting 'TrailersOnly'' cannot contain any parse errors
-- (only @grpc-status@ is required, and only @grpc-message@ can fail).
synthesize :: GrpcError -> TrailersOnly' GrpcException
synthesize err = parsed {
trailersOnlyContentType =
-- We tried to parse the headers that were there, but there will
-- almost certainly not be a content-type header present in the
-- case of a non-200 HTTP status. We don't want to synthesize /that/
-- error, so we override it.
case trailersOnlyContentType parsed of
Left _err -> Right Nothing
Right mCType -> Right mCType
, trailersOnlyProper = parsedTrailers {
properTrailersGrpcStatus = Right $
GrpcError err
, properTrailersGrpcMessage = Right $
case properTrailersGrpcMessage parsedTrailers of
Right (Just msg) -> Just msg
_otherwise -> Just defaultMsg
}
}
where
parsed :: TrailersOnly' GrpcException
parsed = parseTrailersOnly' rpc headers
parsedTrailers :: ProperTrailers'
parsedTrailers = trailersOnlyProper parsed
defaultMsg :: Text
defaultMsg = mconcat [
"Unexpected HTTP status code "
, Text.pack (show statusCode)
, if not (BS.Strict.null statusMessage)
then " (" <> decodeUtf8Lenient statusMessage <> ")"
else mempty
, case mBody of
Just body | not (BS.Lazy.null body) -> mconcat [
"\nResponse body:\n"
, decodeUtf8Lenient (BS.Lazy.toStrict body)
]
_otherwise ->
mempty
]
-- | Is the @grpc-status@ header set?
--
-- We use this as a proxy to determine if we are in the Trailers-Only case.
--
-- It might be tempting to use the HTTP @Content-Length@ header instead, but
-- this is doubly wrong:
--
-- * There might be servers who use the Trailers-Only case but do not set the
-- @Content-Length@ header (although such a server would not conform to the
-- HTTP spec: "An origin server SHOULD send a @Content-Length@ header field
-- when the content size is known prior to sending the complete header
-- section"; see
-- <https://www.rfc-editor.org/rfc/rfc9110.html#name-content-length>).
-- * Conversely, there might be servers or proxies who /do/ set @Content-Length@
-- header even when it's /not/ the Trailers-Only case (e.g., see
-- <https://github.com/grpc/grpc-web/issues/1101> or
-- <https://github.com/envoyproxy/envoy/issues/5554>).
--
-- We therefore check for the presence of the @grpc-status@ header instead.
hasGrpcStatus :: [HTTP.Header] -> Bool
hasGrpcStatus = isJust . lookup "grpc-status"
{-------------------------------------------------------------------------------
> Response-Headers →
> HTTP-Status
> [Message-Encoding]
> [Message-Accept-Encoding]
> Content-Type
> *Custom-Metadata
We do not deal with @HTTP-Status@ here; @http2@ deals this separately.
-------------------------------------------------------------------------------}
-- | Build response headers
buildResponseHeaders :: forall rpc.
SupportsServerRpc rpc
=> Proxy rpc -> ResponseHeaders -> [HTTP.Header]
buildResponseHeaders proxy
ResponseHeaders{ responseCompression
, responseAcceptCompression
, responseMetadata
, responseContentType
} = concat [
[ buildContentType $ Just (chooseContentType proxy x)
| Just x <- [responseContentType]
]
, [ buildMessageEncoding x
| Just x <- [responseCompression]
]
, [ buildMessageAcceptEncoding x
| Just x <- [responseAcceptCompression]
]
, [ buildTrailer proxy ]
, [ buildCustomMetadata x
| x <- customMetadataMapToList responseMetadata
]
]
-- | Parse response headers
parseResponseHeaders :: forall rpc m.
(IsRPC rpc, MonadError (InvalidHeaders GrpcException) m)
=> Proxy rpc -> [HTTP.Header] -> m ResponseHeaders
parseResponseHeaders proxy = HKD.sequenceChecked . parseResponseHeaders' proxy
-- | Generalization of 'parseResponseHeaders' that does not throw errors
--
-- See also 'Network.GRPC.Spec.parseRequestHeaders' versus
-- ''Network.GRPC.Spec.parseRequestHeaders'' for a similar pair of functions.
parseResponseHeaders' :: forall rpc.
IsRPC rpc
=> Proxy rpc -> [HTTP.Header] -> ResponseHeaders' GrpcException
parseResponseHeaders' proxy =
flip execState uninitResponseHeaders
. mapM_ (parseHeader . second trim)
where
-- HTTP2 header names are always lowercase, and must be ASCII.
-- <https://datatracker.ietf.org/doc/html/rfc7540#section-8.1.2>
parseHeader :: HTTP.Header -> State (ResponseHeaders' GrpcException) ()
parseHeader hdr@(name, _value)
| name == "content-type"
= modify $ \x -> x {
responseContentType = Just <$> parseContentType' proxy hdr
}
| name == "grpc-encoding"
= modify $ \x -> x {
responseCompression = Just <$> parseMessageEncoding hdr
}
| name == "grpc-accept-encoding"
= modify $ \x -> x {
responseAcceptCompression = Just <$> parseMessageAcceptEncoding hdr
}
| name == "trailer"
= return () -- ignore the HTTP trailer header
| otherwise
= modify $ \x ->
case parseCustomMetadata hdr of
Left invalid -> x{
responseUnrecognized = Left $ mconcat [
invalid
, otherInvalid $ responseUnrecognized x
]
}
Right md -> x{
responseMetadata =
customMetadataMapInsert md $ responseMetadata x
}
uninitResponseHeaders :: ResponseHeaders' GrpcException
uninitResponseHeaders = ResponseHeaders {
responseCompression = return Nothing
, responseAcceptCompression = return Nothing
, responseMetadata = mempty
, responseUnrecognized = return ()
-- special cases
, responseContentType =
throwError $
invalidContentType
"Missing content-type header"
(MissingHeader Nothing "content-type")
}
{-------------------------------------------------------------------------------
Content type
See 'parseContentType' for discussion.
-------------------------------------------------------------------------------}
parseContentType' ::
IsRPC rpc
=> Proxy rpc
-> HTTP.Header
-> Either (InvalidHeaders GrpcException) ContentType
parseContentType' proxy hdr =
parseContentType
proxy
(\err -> invalidContentType err (InvalidHeader Nothing hdr err))
hdr
invalidContentType ::
String
-> InvalidHeader HandledSynthesized
-> InvalidHeaders GrpcException
invalidContentType err = invalidHeaderSynthesize GrpcException {
grpcError = GrpcUnknown
, grpcErrorMessage = Just $ Text.pack err
, grpcErrorDetails = Nothing
, grpcErrorMetadata = []
}
{-------------------------------------------------------------------------------
> Trailers → Status [Status-Message] *Custom-Metadata Status →
> "grpc-status" 1*DIGIT ; 0-9 Status-Message → "grpc-message" Percent-Encoded
> Status-Details → "grpc-status-details-bin" {base64 encoded value}
where
> Status-Details is allowed only if Status is not OK. If it is set, it
> contains additional information about the RPC error. If it contains a status
> code field, it MUST NOT contradict the Status header. The consumer MUST
> verify this requirement.
-------------------------------------------------------------------------------}
-- | Construct the HTTP @Trailer@ header
--
-- This lists all headers that /might/ be present in the trailers.
--
-- See
--
-- * <https://datatracker.ietf.org/doc/html/rfc7230#section-4.4>
-- * <https://www.rfc-editor.org/rfc/rfc9110#name-processing-trailer-fields>
buildTrailer :: forall rpc. SupportsServerRpc rpc => Proxy rpc -> HTTP.Header
buildTrailer _ = (
"Trailer"
, BS.Strict.intercalate ", " allPotentialTrailers
)
where
allPotentialTrailers :: [Strict.ByteString]
allPotentialTrailers = concat [
reservedTrailers
, map (CI.original . buildHeaderName) $
metadataHeaderNames (Proxy @(ResponseTrailingMetadata rpc))
]
-- These cannot be 'HeaderName' (which disallow reserved names)
--
-- This list must match the names used by 'buildProperTrailers'
-- and recognized by 'parseProperTrailers'.
reservedTrailers :: [Strict.ByteString]
reservedTrailers = [
"grpc-status"
, "grpc-message"
, "grpc-retry-pushback-ms"
, "endpoint-load-metrics-bin"
]
-- | Build trailers (see 'buildTrailersOnly' for the Trailers-Only case)
buildProperTrailers :: ProperTrailers -> [HTTP.Header]
buildProperTrailers ProperTrailers{
properTrailersGrpcStatus
, properTrailersGrpcMessage
, properTrailersStatusDetails
, properTrailersMetadata
, properTrailersPushback
, properTrailersOrcaLoadReport
} = concat [
-- NOTE: If we add additional (reserved) headers here, we also need to add
-- them to 'buildTrailer'.
[ ( "grpc-status"
, BS.Strict.C8.pack $ show $ fromGrpcStatus properTrailersGrpcStatus
)
]
, [ ("grpc-message", PercentEncoding.encode x)
| Just x <- [properTrailersGrpcMessage]
]
, [ ("grpc-status-details-bin", buildBinaryValue x)
| Just x <- [properTrailersStatusDetails]
]
, [ ( "grpc-retry-pushback-ms"
, buildPushback x
)
| Just x <- [properTrailersPushback]
]
, [ ( "endpoint-load-metrics-bin"
, buildBinaryValue $ Protobuf.buildStrict x
)
| Just x <- [properTrailersOrcaLoadReport]
]
, [ buildCustomMetadata x
| x <- customMetadataMapToList properTrailersMetadata
]
]
-- | Build trailers for the Trailers-Only case
buildTrailersOnly ::
(ContentType -> Maybe BS.Strict.C8.ByteString)
-- ^ Interpret 'ContentType'
--
-- Under normal circumstances this should be @Just .@ 'chooseContentType'.
-- In some cases, however, the content-type might not be known. For
-- example, when a request comes in for an unknown method, the gRPC server
-- is supposed to respond with a @Trailers-Only@ message, with an
-- @UNIMPLEMENTED@ error code. Frustratingly, @Trailers-Only@ requires a
-- @Content-Type@ header, /even though there is no content/. This
-- @Content-Type@ header normally indicates the serialization format (e.g.,
-- @application/grpc+proto@), but this format depends on the specific
-- method, which was not found!
--
-- To resolve this catch-22, this function is allowed to return @Nothing@,
-- in which case the @Content-Type@ we will use @application/grpc@, with no
-- format specifier. Fortunately, this is allowed by the spec.
-> TrailersOnly -> [HTTP.Header]
buildTrailersOnly f TrailersOnly{
trailersOnlyContentType
, trailersOnlyProper
} = concat [
[ buildContentType $ f x
| Just x <- [trailersOnlyContentType]
]
, buildProperTrailers trailersOnlyProper
]
-- | Parse response trailers
--
-- The gRPC spec defines:
--
-- > Trailers → ..
-- > Trailers-Only → HTTP-Status Content-Type Trailers
--
-- This means that Trailers-Only is a superset of the Trailers; we make use of
-- this here, and error out if we get an unexpected @Content-Type@ override.
parseProperTrailers :: forall rpc m.
(IsRPC rpc, MonadError (InvalidHeaders GrpcException) m)
=> Proxy rpc -> [HTTP.Header] -> m ProperTrailers
parseProperTrailers proxy = HKD.sequenceChecked . parseProperTrailers' proxy
-- | Generalization of 'parseProperTrailers' that does not throw errors.
--
-- See also 'Network.GRPC.Spec.parseRequestHeaders' versus
-- ''Network.GRPC.Spec.parseRequestHeaders'' for a similar pair of functions.
-- See t'ProperTrailers'' for a discussion of why 'ProperTrailers'' is not
-- parameterized (unlike t'ResponseHeaders'' and
-- t'Network.GRPC.Spec.RequestHeaders'').
parseProperTrailers' :: forall rpc.
IsRPC rpc
=> Proxy rpc -> [HTTP.Header] -> ProperTrailers'
parseProperTrailers' proxy hdrs =
case trailersOnlyToProperTrailers trailersOnly of
(properTrailers, Right Nothing) ->
properTrailers
(properTrailers, Right (Just _ct)) ->
properTrailers {
properTrailersUnrecognized = Left $ mconcat [
unexpectedHeader "content-type"
, otherInvalid $ properTrailersUnrecognized properTrailers
]
}
(properTrailers, Left invalid) ->
case dropSynthesized invalid of
-- The content-type header is "invalid" because it's missing.
-- In our case, this actually means everything is as it should be.
InvalidHeaders [MissingHeader{}] ->
properTrailers
-- The @content-type@ header is present, /and/ invalid!
_otherwise ->
properTrailers {
properTrailersUnrecognized = Left $ mconcat [
unexpectedHeader "content-type"
, invalid
, otherInvalid $ properTrailersUnrecognized properTrailers
]
}
where
trailersOnly :: TrailersOnly' GrpcException
trailersOnly = parseTrailersOnly' proxy hdrs
-- | Parse t'TrailersOnly'
parseTrailersOnly :: forall m rpc.
(IsRPC rpc, MonadError (InvalidHeaders GrpcException) m)
=> Proxy rpc -> [HTTP.Header] -> m TrailersOnly
parseTrailersOnly proxy = HKD.sequenceChecked . parseTrailersOnly' proxy
-- | Generalization of 'parseTrailersOnly' does that not throw errors.
--
-- See also 'Network.GRPC.Spec.parseRequestHeaders' versus
-- ''Network.GRPC.Spec.parseRequestHeaders'' for a similar pair of functions.
parseTrailersOnly' :: forall rpc.
IsRPC rpc
=> Proxy rpc -> [HTTP.Header] -> TrailersOnly' GrpcException
parseTrailersOnly' proxy =
flip execState uninitTrailersOnly
. mapM_ (parseHeader . second trim)
where
parseHeader :: HTTP.Header -> State (TrailersOnly' GrpcException) ()
parseHeader hdr@(name, value)
| name == "content-type"
= modify $ \x -> x {
trailersOnlyContentType = Just <$> parseContentType' proxy hdr
}
| name == "grpc-status"
= modify $ liftProperTrailers $ \x -> x{
properTrailersGrpcStatus = throwInvalidHeader hdr $
case toGrpcStatus =<< readMaybe (BS.Strict.C8.unpack value) of
Nothing -> throwError $ "Invalid status: " ++ show value
Just v -> return v
}
| name == "grpc-message"
= modify $ liftProperTrailers $ \x -> x{
properTrailersGrpcMessage = throwInvalidHeader hdr $
case PercentEncoding.decode value of
Left err -> throwError $ show err
Right msg -> return (Just msg)
}
| name == "grpc-status-details-bin"
= modify $ liftProperTrailers $ \x -> x{
properTrailersStatusDetails = throwInvalidHeader hdr $
case parseBinaryValue value of
Left err -> throwError err
Right val -> return (Just val)
}
| name == "grpc-retry-pushback-ms"
= modify $ liftProperTrailers $ \x -> x{
properTrailersPushback =
Just <$> parsePushback value
}
| name == "endpoint-load-metrics-bin"
= modify $ liftProperTrailers $ \x -> x{
properTrailersOrcaLoadReport = throwInvalidHeader hdr $ do
value' <- parseBinaryValue value
case Protobuf.parseStrict value' of
Left err -> throwError err
Right report -> return $ Just report
}
| otherwise
= modify $ liftProperTrailers $ \x ->
case parseCustomMetadata hdr of
Left invalid -> x{
properTrailersUnrecognized = Left $ mconcat [
invalid
, otherInvalid $ properTrailersUnrecognized x
]
}
Right md -> x{
properTrailersMetadata =
customMetadataMapInsert md $ properTrailersMetadata x
}
uninitTrailersOnly :: TrailersOnly' GrpcException
uninitTrailersOnly = TrailersOnly {
trailersOnlyContentType =
throwError $
invalidContentType
"Missing content-type header"
(MissingHeader Nothing "content-type")
, trailersOnlyProper =
simpleProperTrailers
(throwError $ missingHeader Nothing "grpc-status")
(return Nothing)
(return Nothing)
mempty
}
liftProperTrailers ::
(ProperTrailers_ f -> ProperTrailers_ f)
-> TrailersOnly_ f -> TrailersOnly_ f
liftProperTrailers f trailersOnly = trailersOnly{
trailersOnlyProper = f (trailersOnlyProper trailersOnly)
}
{-------------------------------------------------------------------------------
Pushback
-------------------------------------------------------------------------------}
-- | Serialize t'Pushback'
buildPushback :: Pushback -> Strict.ByteString
buildPushback (RetryAfter n) = BS.Strict.C8.pack $ show n
buildPushback DoNotRetry = "-1"
-- | Parse t'Pushback'
--
-- Parsing a pushback cannot fail; the spec mandates:
--
-- > If the value for pushback is negative or unparseble, then it will be seen
-- > as the server asking the client not to retry at all.
--
-- We therefore only require @Monad m@, not @MonadError m@ (having the @Monad@
-- constraint at all keeps the type signature consistent with other parsing
-- functions).
parsePushback :: Monad m => Strict.ByteString -> m Pushback
parsePushback bs =
case readMaybe (BS.Strict.C8.unpack bs) of
Just (n :: Int) ->
-- The @Read@ instance for @Word@ /does/ allow for signs
-- <https://gitlab.haskell.org/ghc/ghc/-/issues/24216>
return $ if n < 0 then DoNotRetry else RetryAfter (fromIntegral n)
Nothing ->
return DoNotRetry
{-------------------------------------------------------------------------------
Internal auxiliary
-------------------------------------------------------------------------------}
otherInvalid :: Either (InvalidHeaders e) () -> InvalidHeaders e
otherInvalid = either id (\() -> mempty)
decodeUtf8Lenient :: BS.Strict.C8.ByteString -> Text
#if MIN_VERSION_text(2,0,0)
decodeUtf8Lenient = Text.decodeUtf8Lenient
#else
decodeUtf8Lenient = Text.decodeUtf8With Text.lenientDecode
#endif