{-# 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 :: forall {k} (rpc :: k).
IsRPC rpc =>
Proxy rpc
-> Status
-> [Header]
-> Maybe ByteString
-> Either
     (TrailersOnly' GrpcException) (ResponseHeaders' GrpcException)
classifyServerResponse Proxy rpc
rpc Status
status [Header]
headers Maybe ByteString
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.
  | [Header] -> Bool
hasGrpcStatus [Header]
headers
  = TrailersOnly' GrpcException
-> Either
     (TrailersOnly' GrpcException) (ResponseHeaders' GrpcException)
forall a b. a -> Either a b
Left (TrailersOnly' GrpcException
 -> Either
      (TrailersOnly' GrpcException) (ResponseHeaders' GrpcException))
-> TrailersOnly' GrpcException
-> Either
     (TrailersOnly' GrpcException) (ResponseHeaders' GrpcException)
forall a b. (a -> b) -> a -> b
$ Proxy rpc -> [Header] -> TrailersOnly' GrpcException
forall {k} (rpc :: k).
IsRPC rpc =>
Proxy rpc -> [Header] -> TrailersOnly' GrpcException
parseTrailersOnly' Proxy rpc
rpc [Header]
headers

  | Int
200 <- Int
statusCode
  = ResponseHeaders' GrpcException
-> Either
     (TrailersOnly' GrpcException) (ResponseHeaders' GrpcException)
forall a b. b -> Either a b
Right (ResponseHeaders' GrpcException
 -> Either
      (TrailersOnly' GrpcException) (ResponseHeaders' GrpcException))
-> ResponseHeaders' GrpcException
-> Either
     (TrailersOnly' GrpcException) (ResponseHeaders' GrpcException)
forall a b. (a -> b) -> a -> b
$ Proxy rpc -> [Header] -> ResponseHeaders' GrpcException
forall {k} (rpc :: k).
IsRPC rpc =>
Proxy rpc -> [Header] -> ResponseHeaders' GrpcException
parseResponseHeaders' Proxy rpc
rpc [Header]
headers

  | Bool
otherwise
  = TrailersOnly' GrpcException
-> Either
     (TrailersOnly' GrpcException) (ResponseHeaders' GrpcException)
forall a b. a -> Either a b
Left (TrailersOnly' GrpcException
 -> Either
      (TrailersOnly' GrpcException) (ResponseHeaders' GrpcException))
-> TrailersOnly' GrpcException
-> Either
     (TrailersOnly' GrpcException) (ResponseHeaders' GrpcException)
forall a b. (a -> b) -> a -> b
$
      case Int
statusCode of
        Int
400 -> GrpcError -> TrailersOnly' GrpcException
synthesize GrpcError
GrpcInternal         -- Bad request
        Int
401 -> GrpcError -> TrailersOnly' GrpcException
synthesize GrpcError
GrpcUnauthenticated  -- Unauthorized
        Int
403 -> GrpcError -> TrailersOnly' GrpcException
synthesize GrpcError
GrpcPermissionDenied -- Forbidden
        Int
404 -> GrpcError -> TrailersOnly' GrpcException
synthesize GrpcError
GrpcUnimplemented    -- Not found
        Int
429 -> GrpcError -> TrailersOnly' GrpcException
synthesize GrpcError
GrpcUnavailable      -- Too many requests
        Int
502 -> GrpcError -> TrailersOnly' GrpcException
synthesize GrpcError
GrpcUnavailable      -- Bad gateway
        Int
503 -> GrpcError -> TrailersOnly' GrpcException
synthesize GrpcError
GrpcUnavailable      -- Service unavailable
        Int
504 -> GrpcError -> TrailersOnly' GrpcException
synthesize GrpcError
GrpcUnavailable      -- Gateway timeout
        Int
_   -> GrpcError -> TrailersOnly' GrpcException
synthesize GrpcError
GrpcUnknown
  where
    HTTP.Status{Int
statusCode :: Int
statusCode :: Status -> Int
statusCode, ByteString
statusMessage :: ByteString
statusMessage :: Status -> ByteString
statusMessage} = Status
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 :: GrpcError -> TrailersOnly' GrpcException
synthesize GrpcError
err = TrailersOnly' GrpcException
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  InvalidHeaders GrpcException
_err   -> Maybe ContentType
-> Either (InvalidHeaders GrpcException) (Maybe ContentType)
forall a b. b -> Either a b
Right Maybe ContentType
forall a. Maybe a
Nothing
              Right Maybe ContentType
mCType -> Maybe ContentType
-> Either (InvalidHeaders GrpcException) (Maybe ContentType)
forall a b. b -> Either a b
Right Maybe ContentType
mCType
        , trailersOnlyProper = parsedTrailers {
              properTrailersGrpcStatus = Right $
                GrpcError err
            , properTrailersGrpcMessage = Right $
                case properTrailersGrpcMessage parsedTrailers of
                  Right (Just Text
msg) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
msg
                  HKD (Checked (InvalidHeaders GrpcException)) (Maybe Text)
_otherwise       -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
defaultMsg
            }
        }
      where
        parsed :: TrailersOnly' GrpcException
        parsed :: TrailersOnly' GrpcException
parsed = Proxy rpc -> [Header] -> TrailersOnly' GrpcException
forall {k} (rpc :: k).
IsRPC rpc =>
Proxy rpc -> [Header] -> TrailersOnly' GrpcException
parseTrailersOnly' Proxy rpc
rpc [Header]
headers

        parsedTrailers :: ProperTrailers'
        parsedTrailers :: ProperTrailers_ (Checked (InvalidHeaders GrpcException))
parsedTrailers = TrailersOnly' GrpcException
-> ProperTrailers_ (Checked (InvalidHeaders GrpcException))
forall (f :: * -> *). TrailersOnly_ f -> ProperTrailers_ f
trailersOnlyProper TrailersOnly' GrpcException
parsed

        defaultMsg :: Text
        defaultMsg :: Text
defaultMsg = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [
              Text
"Unexpected HTTP status code "
            , String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show Int
statusCode)
            , if Bool -> Bool
not (ByteString -> Bool
BS.Strict.null ByteString
statusMessage)
                then Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
decodeUtf8Lenient ByteString
statusMessage Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
                else Text
forall a. Monoid a => a
mempty
            , case Maybe ByteString
mBody of
                Just ByteString
body | Bool -> Bool
not (ByteString -> Bool
BS.Lazy.null ByteString
body) -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [
                    Text
"\nResponse body:\n"
                  , ByteString -> Text
decodeUtf8Lenient (ByteString -> ByteString
BS.Lazy.toStrict ByteString
body)
                  ]
                Maybe ByteString
_otherwise ->
                  Text
forall a. Monoid a => a
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 :: [Header] -> Bool
hasGrpcStatus = Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ByteString -> Bool)
-> ([Header] -> Maybe ByteString) -> [Header] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> [Header] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"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 :: forall {k} (rpc :: k).
SupportsServerRpc rpc =>
Proxy rpc -> ResponseHeaders -> [Header]
buildResponseHeaders Proxy rpc
proxy
             ResponseHeaders{ HKD Undecorated (Maybe CompressionId)
responseCompression :: HKD Undecorated (Maybe CompressionId)
responseCompression :: forall (f :: * -> *).
ResponseHeaders_ f -> HKD f (Maybe CompressionId)
responseCompression
                            , HKD Undecorated (Maybe (NonEmpty CompressionId))
responseAcceptCompression :: HKD Undecorated (Maybe (NonEmpty CompressionId))
responseAcceptCompression :: forall (f :: * -> *).
ResponseHeaders_ f -> HKD f (Maybe (NonEmpty CompressionId))
responseAcceptCompression
                            , CustomMetadataMap
responseMetadata :: CustomMetadataMap
responseMetadata :: forall (f :: * -> *). ResponseHeaders_ f -> CustomMetadataMap
responseMetadata
                            , HKD Undecorated (Maybe ContentType)
responseContentType :: HKD Undecorated (Maybe ContentType)
responseContentType :: forall (f :: * -> *).
ResponseHeaders_ f -> HKD f (Maybe ContentType)
responseContentType
                            } = [[Header]] -> [Header]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
      [ Maybe ByteString -> Header
buildContentType (Maybe ByteString -> Header) -> Maybe ByteString -> Header
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Proxy rpc -> ContentType -> ByteString
forall {k} (rpc :: k).
IsRPC rpc =>
Proxy rpc -> ContentType -> ByteString
chooseContentType Proxy rpc
proxy ContentType
x)
      | Just ContentType
x <- [Maybe ContentType
HKD Undecorated (Maybe ContentType)
responseContentType]
      ]
    , [ CompressionId -> Header
buildMessageEncoding CompressionId
x
      | Just CompressionId
x <- [Maybe CompressionId
HKD Undecorated (Maybe CompressionId)
responseCompression]
      ]
    , [ NonEmpty CompressionId -> Header
buildMessageAcceptEncoding NonEmpty CompressionId
x
      | Just NonEmpty CompressionId
x <- [Maybe (NonEmpty CompressionId)
HKD Undecorated (Maybe (NonEmpty CompressionId))
responseAcceptCompression]
      ]
    , [ Proxy rpc -> Header
forall {k} (rpc :: k). SupportsServerRpc rpc => Proxy rpc -> Header
buildTrailer Proxy rpc
proxy ]
    , [ CustomMetadata -> Header
buildCustomMetadata CustomMetadata
x
      | CustomMetadata
x <- CustomMetadataMap -> [CustomMetadata]
customMetadataMapToList CustomMetadataMap
responseMetadata
      ]
    ]

-- | Parse response headers
parseResponseHeaders :: forall rpc m.
     (IsRPC rpc, MonadError (InvalidHeaders GrpcException) m)
  => Proxy rpc -> [HTTP.Header] -> m ResponseHeaders
parseResponseHeaders :: forall {k} (rpc :: k) (m :: * -> *).
(IsRPC rpc, MonadError (InvalidHeaders GrpcException) m) =>
Proxy rpc -> [Header] -> m ResponseHeaders
parseResponseHeaders Proxy rpc
proxy = ResponseHeaders' GrpcException -> m ResponseHeaders
forall e (m :: * -> *) (t :: (* -> *) -> *).
(MonadError e m, Traversable t) =>
t (Checked e) -> m (t Undecorated)
HKD.sequenceChecked (ResponseHeaders' GrpcException -> m ResponseHeaders)
-> ([Header] -> ResponseHeaders' GrpcException)
-> [Header]
-> m ResponseHeaders
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy rpc -> [Header] -> ResponseHeaders' GrpcException
forall {k} (rpc :: k).
IsRPC rpc =>
Proxy rpc -> [Header] -> ResponseHeaders' GrpcException
parseResponseHeaders' Proxy rpc
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' :: forall {k} (rpc :: k).
IsRPC rpc =>
Proxy rpc -> [Header] -> ResponseHeaders' GrpcException
parseResponseHeaders' Proxy rpc
proxy =
      (State (ResponseHeaders' GrpcException) ()
 -> ResponseHeaders' GrpcException
 -> ResponseHeaders' GrpcException)
-> ResponseHeaders' GrpcException
-> State (ResponseHeaders' GrpcException) ()
-> ResponseHeaders' GrpcException
forall a b c. (a -> b -> c) -> b -> a -> c
flip State (ResponseHeaders' GrpcException) ()
-> ResponseHeaders' GrpcException -> ResponseHeaders' GrpcException
forall s a. State s a -> s -> s
execState ResponseHeaders' GrpcException
uninitResponseHeaders
    (State (ResponseHeaders' GrpcException) ()
 -> ResponseHeaders' GrpcException)
-> ([Header] -> State (ResponseHeaders' GrpcException) ())
-> [Header]
-> ResponseHeaders' GrpcException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Header -> State (ResponseHeaders' GrpcException) ())
-> [Header] -> State (ResponseHeaders' GrpcException) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Header -> State (ResponseHeaders' GrpcException) ()
parseHeader (Header -> State (ResponseHeaders' GrpcException) ())
-> (Header -> Header)
-> Header
-> State (ResponseHeaders' GrpcException) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString) -> Header -> Header
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ByteString -> ByteString
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 :: Header -> State (ResponseHeaders' GrpcException) ()
parseHeader hdr :: Header
hdr@(HeaderName
name, ByteString
_value)
      | HeaderName
name HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
"content-type"
      = (ResponseHeaders' GrpcException -> ResponseHeaders' GrpcException)
-> State (ResponseHeaders' GrpcException) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ResponseHeaders' GrpcException -> ResponseHeaders' GrpcException)
 -> State (ResponseHeaders' GrpcException) ())
-> (ResponseHeaders' GrpcException
    -> ResponseHeaders' GrpcException)
-> State (ResponseHeaders' GrpcException) ()
forall a b. (a -> b) -> a -> b
$ \ResponseHeaders' GrpcException
x -> ResponseHeaders' GrpcException
x {
            responseContentType = Just <$> parseContentType' proxy hdr
          }

      | HeaderName
name HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
"grpc-encoding"
      = (ResponseHeaders' GrpcException -> ResponseHeaders' GrpcException)
-> State (ResponseHeaders' GrpcException) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ResponseHeaders' GrpcException -> ResponseHeaders' GrpcException)
 -> State (ResponseHeaders' GrpcException) ())
-> (ResponseHeaders' GrpcException
    -> ResponseHeaders' GrpcException)
-> State (ResponseHeaders' GrpcException) ()
forall a b. (a -> b) -> a -> b
$ \ResponseHeaders' GrpcException
x -> ResponseHeaders' GrpcException
x {
            responseCompression = Just <$> parseMessageEncoding hdr
          }

      | HeaderName
name HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
"grpc-accept-encoding"
      = (ResponseHeaders' GrpcException -> ResponseHeaders' GrpcException)
-> State (ResponseHeaders' GrpcException) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ResponseHeaders' GrpcException -> ResponseHeaders' GrpcException)
 -> State (ResponseHeaders' GrpcException) ())
-> (ResponseHeaders' GrpcException
    -> ResponseHeaders' GrpcException)
-> State (ResponseHeaders' GrpcException) ()
forall a b. (a -> b) -> a -> b
$ \ResponseHeaders' GrpcException
x -> ResponseHeaders' GrpcException
x {
            responseAcceptCompression = Just <$> parseMessageAcceptEncoding hdr
          }

      | HeaderName
name HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
"trailer"
      = () -> State (ResponseHeaders' GrpcException) ()
forall a. a -> StateT (ResponseHeaders' GrpcException) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- ignore the HTTP trailer header

      | Bool
otherwise
      = (ResponseHeaders' GrpcException -> ResponseHeaders' GrpcException)
-> State (ResponseHeaders' GrpcException) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ResponseHeaders' GrpcException -> ResponseHeaders' GrpcException)
 -> State (ResponseHeaders' GrpcException) ())
-> (ResponseHeaders' GrpcException
    -> ResponseHeaders' GrpcException)
-> State (ResponseHeaders' GrpcException) ()
forall a b. (a -> b) -> a -> b
$ \ResponseHeaders' GrpcException
x ->
          case Header -> Either (InvalidHeaders GrpcException) CustomMetadata
forall (m :: * -> *).
MonadError (InvalidHeaders GrpcException) m =>
Header -> m CustomMetadata
parseCustomMetadata Header
hdr of
            Left InvalidHeaders GrpcException
invalid -> ResponseHeaders' GrpcException
x{
                responseUnrecognized = Left $ mconcat [
                    invalid
                  , otherInvalid $ responseUnrecognized x
                  ]
              }
            Right CustomMetadata
md -> ResponseHeaders' GrpcException
x{
                responseMetadata =
                  customMetadataMapInsert md $ responseMetadata x
              }

    uninitResponseHeaders :: ResponseHeaders' GrpcException
    uninitResponseHeaders :: ResponseHeaders' GrpcException
uninitResponseHeaders = ResponseHeaders {
          responseCompression :: HKD (Checked (InvalidHeaders GrpcException)) (Maybe CompressionId)
responseCompression       = Maybe CompressionId
-> Either (InvalidHeaders GrpcException) (Maybe CompressionId)
forall a. a -> Either (InvalidHeaders GrpcException) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe CompressionId
forall a. Maybe a
Nothing
        , responseAcceptCompression :: HKD
  (Checked (InvalidHeaders GrpcException))
  (Maybe (NonEmpty CompressionId))
responseAcceptCompression = Maybe (NonEmpty CompressionId)
-> Either
     (InvalidHeaders GrpcException) (Maybe (NonEmpty CompressionId))
forall a. a -> Either (InvalidHeaders GrpcException) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (NonEmpty CompressionId)
forall a. Maybe a
Nothing
        , responseMetadata :: CustomMetadataMap
responseMetadata          = CustomMetadataMap
forall a. Monoid a => a
mempty
        , responseUnrecognized :: HKD (Checked (InvalidHeaders GrpcException)) ()
responseUnrecognized      = () -> Either (InvalidHeaders GrpcException) ()
forall a. a -> Either (InvalidHeaders GrpcException) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

          -- special cases

        , responseContentType :: HKD (Checked (InvalidHeaders GrpcException)) (Maybe ContentType)
responseContentType =
            InvalidHeaders GrpcException
-> Either (InvalidHeaders GrpcException) (Maybe ContentType)
forall a.
InvalidHeaders GrpcException
-> Either (InvalidHeaders GrpcException) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (InvalidHeaders GrpcException
 -> Either (InvalidHeaders GrpcException) (Maybe ContentType))
-> InvalidHeaders GrpcException
-> Either (InvalidHeaders GrpcException) (Maybe ContentType)
forall a b. (a -> b) -> a -> b
$
              String
-> InvalidHeader HandledSynthesized -> InvalidHeaders GrpcException
invalidContentType
                String
"Missing content-type header"
                (Maybe Status -> HeaderName -> InvalidHeader HandledSynthesized
forall e. Maybe Status -> HeaderName -> InvalidHeader e
MissingHeader Maybe Status
forall a. Maybe a
Nothing HeaderName
"content-type")
        }

{-------------------------------------------------------------------------------
  Content type

  See 'parseContentType' for discussion.
-------------------------------------------------------------------------------}

parseContentType' ::
     IsRPC rpc
  => Proxy rpc
  -> HTTP.Header
  -> Either (InvalidHeaders GrpcException) ContentType
parseContentType' :: forall {k} (rpc :: k).
IsRPC rpc =>
Proxy rpc
-> Header -> Either (InvalidHeaders GrpcException) ContentType
parseContentType' Proxy rpc
proxy Header
hdr =
    Proxy rpc
-> (String -> InvalidHeaders GrpcException)
-> Header
-> Either (InvalidHeaders GrpcException) ContentType
forall {k} (m :: * -> *) (rpc :: k).
(MonadError (InvalidHeaders GrpcException) m, IsRPC rpc) =>
Proxy rpc
-> (String -> InvalidHeaders GrpcException)
-> Header
-> m ContentType
parseContentType
      Proxy rpc
proxy
      (\String
err -> String
-> InvalidHeader HandledSynthesized -> InvalidHeaders GrpcException
invalidContentType String
err (Maybe Status
-> Header -> String -> InvalidHeader HandledSynthesized
forall e. Maybe Status -> Header -> String -> InvalidHeader e
InvalidHeader Maybe Status
forall a. Maybe a
Nothing Header
hdr String
err))
      Header
hdr

invalidContentType ::
     String
  -> InvalidHeader HandledSynthesized
  -> InvalidHeaders GrpcException
invalidContentType :: String
-> InvalidHeader HandledSynthesized -> InvalidHeaders GrpcException
invalidContentType String
err = GrpcException
-> InvalidHeader HandledSynthesized -> InvalidHeaders GrpcException
forall e. e -> InvalidHeader HandledSynthesized -> InvalidHeaders e
invalidHeaderSynthesize GrpcException {
      grpcError :: GrpcError
grpcError         = GrpcError
GrpcUnknown
    , grpcErrorMessage :: Maybe Text
grpcErrorMessage  = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
err
    , grpcErrorDetails :: Maybe ByteString
grpcErrorDetails  = Maybe ByteString
forall a. Maybe a
Nothing
    , grpcErrorMetadata :: [CustomMetadata]
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 :: forall {k} (rpc :: k). SupportsServerRpc rpc => Proxy rpc -> Header
buildTrailer Proxy rpc
_ = (
      HeaderName
"Trailer"
    , ByteString -> [ByteString] -> ByteString
BS.Strict.intercalate ByteString
", " [ByteString]
allPotentialTrailers
    )
  where
    allPotentialTrailers :: [Strict.ByteString]
    allPotentialTrailers :: [ByteString]
allPotentialTrailers = [[ByteString]] -> [ByteString]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
          [ByteString]
reservedTrailers
        , (HeaderName -> ByteString) -> [HeaderName] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (HeaderName -> ByteString
forall s. CI s -> s
CI.original (HeaderName -> ByteString)
-> (HeaderName -> HeaderName) -> HeaderName -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> HeaderName
buildHeaderName) ([HeaderName] -> [ByteString]) -> [HeaderName] -> [ByteString]
forall a b. (a -> b) -> a -> b
$
            Proxy (ResponseTrailingMetadata rpc) -> [HeaderName]
forall a. StaticMetadata a => Proxy a -> [HeaderName]
metadataHeaderNames (forall t. Proxy t
forall {k} (t :: k). Proxy t
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 :: [ByteString]
reservedTrailers = [
          ByteString
"grpc-status"
        , ByteString
"grpc-message"
        , ByteString
"grpc-retry-pushback-ms"
        , ByteString
"endpoint-load-metrics-bin"
        ]

-- | Build trailers (see 'buildTrailersOnly' for the Trailers-Only case)
buildProperTrailers :: ProperTrailers -> [HTTP.Header]
buildProperTrailers :: ProperTrailers -> [Header]
buildProperTrailers ProperTrailers{
                        HKD Undecorated GrpcStatus
properTrailersGrpcStatus :: forall (f :: * -> *). ProperTrailers_ f -> HKD f GrpcStatus
properTrailersGrpcStatus :: HKD Undecorated GrpcStatus
properTrailersGrpcStatus
                      , HKD Undecorated (Maybe Text)
properTrailersGrpcMessage :: forall (f :: * -> *). ProperTrailers_ f -> HKD f (Maybe Text)
properTrailersGrpcMessage :: HKD Undecorated (Maybe Text)
properTrailersGrpcMessage
                      , HKD Undecorated (Maybe ByteString)
properTrailersStatusDetails :: HKD Undecorated (Maybe ByteString)
properTrailersStatusDetails :: forall (f :: * -> *). ProperTrailers_ f -> HKD f (Maybe ByteString)
properTrailersStatusDetails
                      , CustomMetadataMap
properTrailersMetadata :: CustomMetadataMap
properTrailersMetadata :: forall (f :: * -> *). ProperTrailers_ f -> CustomMetadataMap
properTrailersMetadata
                      , HKD Undecorated (Maybe Pushback)
properTrailersPushback :: HKD Undecorated (Maybe Pushback)
properTrailersPushback :: forall (f :: * -> *). ProperTrailers_ f -> HKD f (Maybe Pushback)
properTrailersPushback
                      , HKD Undecorated (Maybe OrcaLoadReport)
properTrailersOrcaLoadReport :: HKD Undecorated (Maybe OrcaLoadReport)
properTrailersOrcaLoadReport :: forall (f :: * -> *).
ProperTrailers_ f -> HKD f (Maybe OrcaLoadReport)
properTrailersOrcaLoadReport
                      } = [[Header]] -> [Header]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
    -- NOTE: If we add additional (reserved) headers here, we also need to add
    -- them to 'buildTrailer'.
      [ ( HeaderName
"grpc-status"
        , String -> ByteString
BS.Strict.C8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Word -> String
forall a. Show a => a -> String
show (Word -> String) -> Word -> String
forall a b. (a -> b) -> a -> b
$ GrpcStatus -> Word
fromGrpcStatus HKD Undecorated GrpcStatus
GrpcStatus
properTrailersGrpcStatus
        )
      ]
    , [ (HeaderName
"grpc-message", Text -> ByteString
PercentEncoding.encode Text
x)
      | Just Text
x <- [Maybe Text
HKD Undecorated (Maybe Text)
properTrailersGrpcMessage]
      ]
    , [ (HeaderName
"grpc-status-details-bin", ByteString -> ByteString
buildBinaryValue ByteString
x)
      | Just ByteString
x <- [Maybe ByteString
HKD Undecorated (Maybe ByteString)
properTrailersStatusDetails]
      ]
    , [ ( HeaderName
"grpc-retry-pushback-ms"
        , Pushback -> ByteString
buildPushback Pushback
x
        )
      | Just Pushback
x <- [Maybe Pushback
HKD Undecorated (Maybe Pushback)
properTrailersPushback]
      ]
    , [ ( HeaderName
"endpoint-load-metrics-bin"
        , ByteString -> ByteString
buildBinaryValue (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ OrcaLoadReport -> ByteString
forall msg. Message msg => msg -> ByteString
Protobuf.buildStrict OrcaLoadReport
x
        )
      | Just OrcaLoadReport
x <- [Maybe OrcaLoadReport
HKD Undecorated (Maybe OrcaLoadReport)
properTrailersOrcaLoadReport]
      ]
    , [ CustomMetadata -> Header
buildCustomMetadata CustomMetadata
x
      | CustomMetadata
x <- CustomMetadataMap -> [CustomMetadata]
customMetadataMapToList CustomMetadataMap
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 :: (ContentType -> Maybe ByteString) -> TrailersOnly -> [Header]
buildTrailersOnly ContentType -> Maybe ByteString
f TrailersOnly{
                            HKD Undecorated (Maybe ContentType)
trailersOnlyContentType :: forall (f :: * -> *). TrailersOnly_ f -> HKD f (Maybe ContentType)
trailersOnlyContentType :: HKD Undecorated (Maybe ContentType)
trailersOnlyContentType
                          , ProperTrailers
trailersOnlyProper :: forall (f :: * -> *). TrailersOnly_ f -> ProperTrailers_ f
trailersOnlyProper :: ProperTrailers
trailersOnlyProper
                          } = [[Header]] -> [Header]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
      [ Maybe ByteString -> Header
buildContentType (Maybe ByteString -> Header) -> Maybe ByteString -> Header
forall a b. (a -> b) -> a -> b
$ ContentType -> Maybe ByteString
f ContentType
x
      | Just ContentType
x <- [Maybe ContentType
HKD Undecorated (Maybe ContentType)
trailersOnlyContentType]
      ]
    , ProperTrailers -> [Header]
buildProperTrailers ProperTrailers
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 :: forall {k} (rpc :: k) (m :: * -> *).
(IsRPC rpc, MonadError (InvalidHeaders GrpcException) m) =>
Proxy rpc -> [Header] -> m ProperTrailers
parseProperTrailers Proxy rpc
proxy = ProperTrailers_ (Checked (InvalidHeaders GrpcException))
-> m ProperTrailers
forall e (m :: * -> *) (t :: (* -> *) -> *).
(MonadError e m, Traversable t) =>
t (Checked e) -> m (t Undecorated)
HKD.sequenceChecked (ProperTrailers_ (Checked (InvalidHeaders GrpcException))
 -> m ProperTrailers)
-> ([Header]
    -> ProperTrailers_ (Checked (InvalidHeaders GrpcException)))
-> [Header]
-> m ProperTrailers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy rpc
-> [Header]
-> ProperTrailers_ (Checked (InvalidHeaders GrpcException))
forall {k} (rpc :: k).
IsRPC rpc =>
Proxy rpc
-> [Header]
-> ProperTrailers_ (Checked (InvalidHeaders GrpcException))
parseProperTrailers' Proxy rpc
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' :: forall {k} (rpc :: k).
IsRPC rpc =>
Proxy rpc
-> [Header]
-> ProperTrailers_ (Checked (InvalidHeaders GrpcException))
parseProperTrailers' Proxy rpc
proxy [Header]
hdrs =
    case TrailersOnly' GrpcException
-> (ProperTrailers_ (Checked (InvalidHeaders GrpcException)),
    HKD (Checked (InvalidHeaders GrpcException)) (Maybe ContentType))
forall (f :: * -> *).
TrailersOnly_ f -> (ProperTrailers_ f, HKD f (Maybe ContentType))
trailersOnlyToProperTrailers TrailersOnly' GrpcException
trailersOnly of
      (ProperTrailers_ (Checked (InvalidHeaders GrpcException))
properTrailers, Right Maybe ContentType
Nothing) ->
         ProperTrailers_ (Checked (InvalidHeaders GrpcException))
properTrailers
      (ProperTrailers_ (Checked (InvalidHeaders GrpcException))
properTrailers, Right (Just ContentType
_ct)) ->
         ProperTrailers_ (Checked (InvalidHeaders GrpcException))
properTrailers {
             properTrailersUnrecognized = Left $ mconcat [
                 unexpectedHeader "content-type"
               , otherInvalid $ properTrailersUnrecognized properTrailers
               ]
           }
      (ProperTrailers_ (Checked (InvalidHeaders GrpcException))
properTrailers, Left InvalidHeaders GrpcException
invalid) ->
         case InvalidHeaders GrpcException -> InvalidHeaders HandledSynthesized
forall e. InvalidHeaders e -> InvalidHeaders HandledSynthesized
dropSynthesized InvalidHeaders GrpcException
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_ (Checked (InvalidHeaders GrpcException))
properTrailers
           -- The @content-type@ header is present, /and/ invalid!
           InvalidHeaders HandledSynthesized
_otherwise ->
             ProperTrailers_ (Checked (InvalidHeaders GrpcException))
properTrailers {
               properTrailersUnrecognized = Left $ mconcat [
                   unexpectedHeader "content-type"
                 , invalid
                 , otherInvalid $ properTrailersUnrecognized properTrailers
                 ]
         }
  where
    trailersOnly :: TrailersOnly' GrpcException
    trailersOnly :: TrailersOnly' GrpcException
trailersOnly = Proxy rpc -> [Header] -> TrailersOnly' GrpcException
forall {k} (rpc :: k).
IsRPC rpc =>
Proxy rpc -> [Header] -> TrailersOnly' GrpcException
parseTrailersOnly' Proxy rpc
proxy [Header]
hdrs

-- | Parse t'TrailersOnly'
parseTrailersOnly :: forall m rpc.
     (IsRPC rpc, MonadError (InvalidHeaders GrpcException) m)
  => Proxy rpc -> [HTTP.Header] -> m TrailersOnly
parseTrailersOnly :: forall {k} (m :: * -> *) (rpc :: k).
(IsRPC rpc, MonadError (InvalidHeaders GrpcException) m) =>
Proxy rpc -> [Header] -> m TrailersOnly
parseTrailersOnly Proxy rpc
proxy = TrailersOnly' GrpcException -> m TrailersOnly
forall e (m :: * -> *) (t :: (* -> *) -> *).
(MonadError e m, Traversable t) =>
t (Checked e) -> m (t Undecorated)
HKD.sequenceChecked (TrailersOnly' GrpcException -> m TrailersOnly)
-> ([Header] -> TrailersOnly' GrpcException)
-> [Header]
-> m TrailersOnly
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy rpc -> [Header] -> TrailersOnly' GrpcException
forall {k} (rpc :: k).
IsRPC rpc =>
Proxy rpc -> [Header] -> TrailersOnly' GrpcException
parseTrailersOnly' Proxy rpc
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' :: forall {k} (rpc :: k).
IsRPC rpc =>
Proxy rpc -> [Header] -> TrailersOnly' GrpcException
parseTrailersOnly' Proxy rpc
proxy =
      (State (TrailersOnly' GrpcException) ()
 -> TrailersOnly' GrpcException -> TrailersOnly' GrpcException)
-> TrailersOnly' GrpcException
-> State (TrailersOnly' GrpcException) ()
-> TrailersOnly' GrpcException
forall a b c. (a -> b -> c) -> b -> a -> c
flip State (TrailersOnly' GrpcException) ()
-> TrailersOnly' GrpcException -> TrailersOnly' GrpcException
forall s a. State s a -> s -> s
execState TrailersOnly' GrpcException
uninitTrailersOnly
    (State (TrailersOnly' GrpcException) ()
 -> TrailersOnly' GrpcException)
-> ([Header] -> State (TrailersOnly' GrpcException) ())
-> [Header]
-> TrailersOnly' GrpcException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Header -> State (TrailersOnly' GrpcException) ())
-> [Header] -> State (TrailersOnly' GrpcException) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Header -> State (TrailersOnly' GrpcException) ()
parseHeader (Header -> State (TrailersOnly' GrpcException) ())
-> (Header -> Header)
-> Header
-> State (TrailersOnly' GrpcException) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString) -> Header -> Header
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ByteString -> ByteString
trim)
  where
    parseHeader :: HTTP.Header -> State (TrailersOnly' GrpcException) ()
    parseHeader :: Header -> State (TrailersOnly' GrpcException) ()
parseHeader hdr :: Header
hdr@(HeaderName
name, ByteString
value)
      | HeaderName
name HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
"content-type"
      = (TrailersOnly' GrpcException -> TrailersOnly' GrpcException)
-> State (TrailersOnly' GrpcException) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TrailersOnly' GrpcException -> TrailersOnly' GrpcException)
 -> State (TrailersOnly' GrpcException) ())
-> (TrailersOnly' GrpcException -> TrailersOnly' GrpcException)
-> State (TrailersOnly' GrpcException) ()
forall a b. (a -> b) -> a -> b
$ \TrailersOnly' GrpcException
x -> TrailersOnly' GrpcException
x {
            trailersOnlyContentType = Just <$> parseContentType' proxy hdr
          }

      | HeaderName
name HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
"grpc-status"
      = (TrailersOnly' GrpcException -> TrailersOnly' GrpcException)
-> State (TrailersOnly' GrpcException) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TrailersOnly' GrpcException -> TrailersOnly' GrpcException)
 -> State (TrailersOnly' GrpcException) ())
-> (TrailersOnly' GrpcException -> TrailersOnly' GrpcException)
-> State (TrailersOnly' GrpcException) ()
forall a b. (a -> b) -> a -> b
$ (ProperTrailers_ (Checked (InvalidHeaders GrpcException))
 -> ProperTrailers_ (Checked (InvalidHeaders GrpcException)))
-> TrailersOnly' GrpcException -> TrailersOnly' GrpcException
forall (f :: * -> *).
(ProperTrailers_ f -> ProperTrailers_ f)
-> TrailersOnly_ f -> TrailersOnly_ f
liftProperTrailers ((ProperTrailers_ (Checked (InvalidHeaders GrpcException))
  -> ProperTrailers_ (Checked (InvalidHeaders GrpcException)))
 -> TrailersOnly' GrpcException -> TrailersOnly' GrpcException)
-> (ProperTrailers_ (Checked (InvalidHeaders GrpcException))
    -> ProperTrailers_ (Checked (InvalidHeaders GrpcException)))
-> TrailersOnly' GrpcException
-> TrailersOnly' GrpcException
forall a b. (a -> b) -> a -> b
$ \ProperTrailers_ (Checked (InvalidHeaders GrpcException))
x -> ProperTrailers_ (Checked (InvalidHeaders GrpcException))
x{
            properTrailersGrpcStatus = throwInvalidHeader hdr $
              case toGrpcStatus =<< readMaybe (BS.Strict.C8.unpack value) of
                Maybe GrpcStatus
Nothing -> String -> Either String GrpcStatus
forall a. String -> Either String a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Either String GrpcStatus)
-> String -> Either String GrpcStatus
forall a b. (a -> b) -> a -> b
$ String
"Invalid status: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
value
                Just GrpcStatus
v  -> GrpcStatus -> Either String GrpcStatus
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return GrpcStatus
v
          }

      | HeaderName
name HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
"grpc-message"
      = (TrailersOnly' GrpcException -> TrailersOnly' GrpcException)
-> State (TrailersOnly' GrpcException) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TrailersOnly' GrpcException -> TrailersOnly' GrpcException)
 -> State (TrailersOnly' GrpcException) ())
-> (TrailersOnly' GrpcException -> TrailersOnly' GrpcException)
-> State (TrailersOnly' GrpcException) ()
forall a b. (a -> b) -> a -> b
$ (ProperTrailers_ (Checked (InvalidHeaders GrpcException))
 -> ProperTrailers_ (Checked (InvalidHeaders GrpcException)))
-> TrailersOnly' GrpcException -> TrailersOnly' GrpcException
forall (f :: * -> *).
(ProperTrailers_ f -> ProperTrailers_ f)
-> TrailersOnly_ f -> TrailersOnly_ f
liftProperTrailers ((ProperTrailers_ (Checked (InvalidHeaders GrpcException))
  -> ProperTrailers_ (Checked (InvalidHeaders GrpcException)))
 -> TrailersOnly' GrpcException -> TrailersOnly' GrpcException)
-> (ProperTrailers_ (Checked (InvalidHeaders GrpcException))
    -> ProperTrailers_ (Checked (InvalidHeaders GrpcException)))
-> TrailersOnly' GrpcException
-> TrailersOnly' GrpcException
forall a b. (a -> b) -> a -> b
$ \ProperTrailers_ (Checked (InvalidHeaders GrpcException))
x -> ProperTrailers_ (Checked (InvalidHeaders GrpcException))
x{
            properTrailersGrpcMessage = throwInvalidHeader hdr $
              case PercentEncoding.decode value of
                Left  DecodeException
err -> String -> Either String (Maybe Text)
forall a. String -> Either String a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Either String (Maybe Text))
-> String -> Either String (Maybe Text)
forall a b. (a -> b) -> a -> b
$ DecodeException -> String
forall a. Show a => a -> String
show DecodeException
err
                Right Text
msg -> Maybe Text -> Either String (Maybe Text)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
msg)
          }

      | HeaderName
name HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
"grpc-status-details-bin"
      = (TrailersOnly' GrpcException -> TrailersOnly' GrpcException)
-> State (TrailersOnly' GrpcException) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TrailersOnly' GrpcException -> TrailersOnly' GrpcException)
 -> State (TrailersOnly' GrpcException) ())
-> (TrailersOnly' GrpcException -> TrailersOnly' GrpcException)
-> State (TrailersOnly' GrpcException) ()
forall a b. (a -> b) -> a -> b
$ (ProperTrailers_ (Checked (InvalidHeaders GrpcException))
 -> ProperTrailers_ (Checked (InvalidHeaders GrpcException)))
-> TrailersOnly' GrpcException -> TrailersOnly' GrpcException
forall (f :: * -> *).
(ProperTrailers_ f -> ProperTrailers_ f)
-> TrailersOnly_ f -> TrailersOnly_ f
liftProperTrailers ((ProperTrailers_ (Checked (InvalidHeaders GrpcException))
  -> ProperTrailers_ (Checked (InvalidHeaders GrpcException)))
 -> TrailersOnly' GrpcException -> TrailersOnly' GrpcException)
-> (ProperTrailers_ (Checked (InvalidHeaders GrpcException))
    -> ProperTrailers_ (Checked (InvalidHeaders GrpcException)))
-> TrailersOnly' GrpcException
-> TrailersOnly' GrpcException
forall a b. (a -> b) -> a -> b
$ \ProperTrailers_ (Checked (InvalidHeaders GrpcException))
x -> ProperTrailers_ (Checked (InvalidHeaders GrpcException))
x{
            properTrailersStatusDetails = throwInvalidHeader hdr $
              case parseBinaryValue value of
                Left  String
err -> String -> Either String (Maybe ByteString)
forall a. String -> Either String a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
err
                Right ByteString
val -> Maybe ByteString -> Either String (Maybe ByteString)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
val)

          }

      | HeaderName
name HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
"grpc-retry-pushback-ms"
      = (TrailersOnly' GrpcException -> TrailersOnly' GrpcException)
-> State (TrailersOnly' GrpcException) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TrailersOnly' GrpcException -> TrailersOnly' GrpcException)
 -> State (TrailersOnly' GrpcException) ())
-> (TrailersOnly' GrpcException -> TrailersOnly' GrpcException)
-> State (TrailersOnly' GrpcException) ()
forall a b. (a -> b) -> a -> b
$ (ProperTrailers_ (Checked (InvalidHeaders GrpcException))
 -> ProperTrailers_ (Checked (InvalidHeaders GrpcException)))
-> TrailersOnly' GrpcException -> TrailersOnly' GrpcException
forall (f :: * -> *).
(ProperTrailers_ f -> ProperTrailers_ f)
-> TrailersOnly_ f -> TrailersOnly_ f
liftProperTrailers ((ProperTrailers_ (Checked (InvalidHeaders GrpcException))
  -> ProperTrailers_ (Checked (InvalidHeaders GrpcException)))
 -> TrailersOnly' GrpcException -> TrailersOnly' GrpcException)
-> (ProperTrailers_ (Checked (InvalidHeaders GrpcException))
    -> ProperTrailers_ (Checked (InvalidHeaders GrpcException)))
-> TrailersOnly' GrpcException
-> TrailersOnly' GrpcException
forall a b. (a -> b) -> a -> b
$ \ProperTrailers_ (Checked (InvalidHeaders GrpcException))
x -> ProperTrailers_ (Checked (InvalidHeaders GrpcException))
x{
            properTrailersPushback =
              Just <$> parsePushback value
          }

      | HeaderName
name HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
"endpoint-load-metrics-bin"
      = (TrailersOnly' GrpcException -> TrailersOnly' GrpcException)
-> State (TrailersOnly' GrpcException) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TrailersOnly' GrpcException -> TrailersOnly' GrpcException)
 -> State (TrailersOnly' GrpcException) ())
-> (TrailersOnly' GrpcException -> TrailersOnly' GrpcException)
-> State (TrailersOnly' GrpcException) ()
forall a b. (a -> b) -> a -> b
$ (ProperTrailers_ (Checked (InvalidHeaders GrpcException))
 -> ProperTrailers_ (Checked (InvalidHeaders GrpcException)))
-> TrailersOnly' GrpcException -> TrailersOnly' GrpcException
forall (f :: * -> *).
(ProperTrailers_ f -> ProperTrailers_ f)
-> TrailersOnly_ f -> TrailersOnly_ f
liftProperTrailers ((ProperTrailers_ (Checked (InvalidHeaders GrpcException))
  -> ProperTrailers_ (Checked (InvalidHeaders GrpcException)))
 -> TrailersOnly' GrpcException -> TrailersOnly' GrpcException)
-> (ProperTrailers_ (Checked (InvalidHeaders GrpcException))
    -> ProperTrailers_ (Checked (InvalidHeaders GrpcException)))
-> TrailersOnly' GrpcException
-> TrailersOnly' GrpcException
forall a b. (a -> b) -> a -> b
$ \ProperTrailers_ (Checked (InvalidHeaders GrpcException))
x -> ProperTrailers_ (Checked (InvalidHeaders GrpcException))
x{
            properTrailersOrcaLoadReport = throwInvalidHeader hdr $ do
              value' <- parseBinaryValue value
              case Protobuf.parseStrict value' of
                Left  String
err    -> String -> Either String (Maybe OrcaLoadReport)
forall a. String -> Either String a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
err
                Right OrcaLoadReport
report -> Maybe OrcaLoadReport -> Either String (Maybe OrcaLoadReport)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe OrcaLoadReport -> Either String (Maybe OrcaLoadReport))
-> Maybe OrcaLoadReport -> Either String (Maybe OrcaLoadReport)
forall a b. (a -> b) -> a -> b
$ OrcaLoadReport -> Maybe OrcaLoadReport
forall a. a -> Maybe a
Just OrcaLoadReport
report
          }

      | Bool
otherwise
      = (TrailersOnly' GrpcException -> TrailersOnly' GrpcException)
-> State (TrailersOnly' GrpcException) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TrailersOnly' GrpcException -> TrailersOnly' GrpcException)
 -> State (TrailersOnly' GrpcException) ())
-> (TrailersOnly' GrpcException -> TrailersOnly' GrpcException)
-> State (TrailersOnly' GrpcException) ()
forall a b. (a -> b) -> a -> b
$ (ProperTrailers_ (Checked (InvalidHeaders GrpcException))
 -> ProperTrailers_ (Checked (InvalidHeaders GrpcException)))
-> TrailersOnly' GrpcException -> TrailersOnly' GrpcException
forall (f :: * -> *).
(ProperTrailers_ f -> ProperTrailers_ f)
-> TrailersOnly_ f -> TrailersOnly_ f
liftProperTrailers ((ProperTrailers_ (Checked (InvalidHeaders GrpcException))
  -> ProperTrailers_ (Checked (InvalidHeaders GrpcException)))
 -> TrailersOnly' GrpcException -> TrailersOnly' GrpcException)
-> (ProperTrailers_ (Checked (InvalidHeaders GrpcException))
    -> ProperTrailers_ (Checked (InvalidHeaders GrpcException)))
-> TrailersOnly' GrpcException
-> TrailersOnly' GrpcException
forall a b. (a -> b) -> a -> b
$ \ProperTrailers_ (Checked (InvalidHeaders GrpcException))
x ->
          case Header -> Either (InvalidHeaders GrpcException) CustomMetadata
forall (m :: * -> *).
MonadError (InvalidHeaders GrpcException) m =>
Header -> m CustomMetadata
parseCustomMetadata Header
hdr of
            Left InvalidHeaders GrpcException
invalid -> ProperTrailers_ (Checked (InvalidHeaders GrpcException))
x{
                properTrailersUnrecognized = Left $ mconcat [
                    invalid
                  , otherInvalid $ properTrailersUnrecognized x
                  ]
              }
            Right CustomMetadata
md -> ProperTrailers_ (Checked (InvalidHeaders GrpcException))
x{
                properTrailersMetadata =
                  customMetadataMapInsert md $ properTrailersMetadata x
              }

    uninitTrailersOnly :: TrailersOnly' GrpcException
    uninitTrailersOnly :: TrailersOnly' GrpcException
uninitTrailersOnly = TrailersOnly {
          trailersOnlyContentType :: HKD (Checked (InvalidHeaders GrpcException)) (Maybe ContentType)
trailersOnlyContentType =
            InvalidHeaders GrpcException
-> Either (InvalidHeaders GrpcException) (Maybe ContentType)
forall a.
InvalidHeaders GrpcException
-> Either (InvalidHeaders GrpcException) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (InvalidHeaders GrpcException
 -> Either (InvalidHeaders GrpcException) (Maybe ContentType))
-> InvalidHeaders GrpcException
-> Either (InvalidHeaders GrpcException) (Maybe ContentType)
forall a b. (a -> b) -> a -> b
$
              String
-> InvalidHeader HandledSynthesized -> InvalidHeaders GrpcException
invalidContentType
                String
"Missing content-type header"
                (Maybe Status -> HeaderName -> InvalidHeader HandledSynthesized
forall e. Maybe Status -> HeaderName -> InvalidHeader e
MissingHeader Maybe Status
forall a. Maybe a
Nothing HeaderName
"content-type")
        , trailersOnlyProper :: ProperTrailers_ (Checked (InvalidHeaders GrpcException))
trailersOnlyProper =
            HKD (Checked (InvalidHeaders GrpcException)) GrpcStatus
-> HKD (Checked (InvalidHeaders GrpcException)) (Maybe Text)
-> HKD (Checked (InvalidHeaders GrpcException)) (Maybe ByteString)
-> CustomMetadataMap
-> ProperTrailers_ (Checked (InvalidHeaders GrpcException))
forall (f :: * -> *).
ValidDecoration Applicative f =>
HKD f GrpcStatus
-> HKD f (Maybe Text)
-> HKD f (Maybe ByteString)
-> CustomMetadataMap
-> ProperTrailers_ f
simpleProperTrailers
              (InvalidHeaders GrpcException
-> Either (InvalidHeaders GrpcException) GrpcStatus
forall a.
InvalidHeaders GrpcException
-> Either (InvalidHeaders GrpcException) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (InvalidHeaders GrpcException
 -> Either (InvalidHeaders GrpcException) GrpcStatus)
-> InvalidHeaders GrpcException
-> Either (InvalidHeaders GrpcException) GrpcStatus
forall a b. (a -> b) -> a -> b
$ Maybe Status -> HeaderName -> InvalidHeaders GrpcException
forall e. Maybe Status -> HeaderName -> InvalidHeaders e
missingHeader Maybe Status
forall a. Maybe a
Nothing HeaderName
"grpc-status")
              (Maybe Text -> Either (InvalidHeaders GrpcException) (Maybe Text)
forall a. a -> Either (InvalidHeaders GrpcException) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing)
              (Maybe ByteString
-> Either (InvalidHeaders GrpcException) (Maybe ByteString)
forall a. a -> Either (InvalidHeaders GrpcException) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing)
              CustomMetadataMap
forall a. Monoid a => a
mempty
        }

    liftProperTrailers ::
         (ProperTrailers_ f -> ProperTrailers_ f)
      -> TrailersOnly_ f -> TrailersOnly_ f
    liftProperTrailers :: forall (f :: * -> *).
(ProperTrailers_ f -> ProperTrailers_ f)
-> TrailersOnly_ f -> TrailersOnly_ f
liftProperTrailers ProperTrailers_ f -> ProperTrailers_ f
f TrailersOnly_ f
trailersOnly = TrailersOnly_ f
trailersOnly{
          trailersOnlyProper = f (trailersOnlyProper trailersOnly)
        }

{-------------------------------------------------------------------------------
  Pushback
-------------------------------------------------------------------------------}

-- | Serialize t'Pushback'
buildPushback :: Pushback -> Strict.ByteString
buildPushback :: Pushback -> ByteString
buildPushback (RetryAfter Word
n) = String -> ByteString
BS.Strict.C8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Word -> String
forall a. Show a => a -> String
show Word
n
buildPushback Pushback
DoNotRetry     = ByteString
"-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 :: forall (m :: * -> *). Monad m => ByteString -> m Pushback
parsePushback ByteString
bs =
    case String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (ByteString -> String
BS.Strict.C8.unpack ByteString
bs) of
      Just (Int
n :: Int) ->
        -- The @Read@ instance for @Word@ /does/ allow for signs
        -- <https://gitlab.haskell.org/ghc/ghc/-/issues/24216>
        Pushback -> m Pushback
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pushback -> m Pushback) -> Pushback -> m Pushback
forall a b. (a -> b) -> a -> b
$ if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Pushback
DoNotRetry else Word -> Pushback
RetryAfter (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
      Maybe Int
Nothing ->
        Pushback -> m Pushback
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Pushback
DoNotRetry

{-------------------------------------------------------------------------------
  Internal auxiliary
-------------------------------------------------------------------------------}

otherInvalid :: Either (InvalidHeaders e) () -> InvalidHeaders e
otherInvalid :: forall e. Either (InvalidHeaders e) () -> InvalidHeaders e
otherInvalid = (InvalidHeaders e -> InvalidHeaders e)
-> (() -> InvalidHeaders e)
-> Either (InvalidHeaders e) ()
-> InvalidHeaders e
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either InvalidHeaders e -> InvalidHeaders e
forall a. a -> a
id (\() -> InvalidHeaders e
forall a. Monoid a => a
mempty)

decodeUtf8Lenient :: BS.Strict.C8.ByteString -> Text
#if MIN_VERSION_text(2,0,0)
decodeUtf8Lenient :: ByteString -> Text
decodeUtf8Lenient = ByteString -> Text
Text.decodeUtf8Lenient
#else
decodeUtf8Lenient = Text.decodeUtf8With Text.lenientDecode
#endif