Response.hs

{-# LANGUAGE OverloadedStrings #-}

-- | Deal with HTTP2 responses
--
-- Intended for qualified import.
--
-- > import Network.GRPC.Spec.Response qualified as Resp
module Network.GRPC.Spec.Headers.Response (
    -- * Headers
    ResponseHeaders_(..)
  , ResponseHeaders
  , ResponseHeaders'
  , ProperTrailers_(..)
  , ProperTrailers
  , ProperTrailers'
  , TrailersOnly_(..)
  , TrailersOnly
  , TrailersOnly'
  , Pushback(..)
  , simpleProperTrailers
  , trailersOnlyToProperTrailers
  , properTrailersToTrailersOnly
    -- * Termination
  , GrpcNormalTermination(..)
  , grpcClassifyTermination
  , grpcExceptionToTrailers
  ) where

import Control.Exception
import Control.Monad.Except (throwError)
import Data.ByteString qualified as Strict (ByteString)
import Data.List.NonEmpty (NonEmpty)
import Data.Proxy
import Data.Text (Text)
import GHC.Generics (Generic)

import Network.GRPC.Spec.Compression (CompressionId)
import Network.GRPC.Spec.CustomMetadata.Map
import Network.GRPC.Spec.CustomMetadata.Raw
import Network.GRPC.Spec.Headers.Common
import Network.GRPC.Spec.Headers.Invalid
import Network.GRPC.Spec.OrcaLoadReport
import Network.GRPC.Spec.Status
import Network.GRPC.Spec.Util.HKD (HKD, Undecorated, Checked)
import Network.GRPC.Spec.Util.HKD qualified as HKD

{-------------------------------------------------------------------------------
  Outputs (messages received from the peer)
-------------------------------------------------------------------------------}

-- | Response headers
data ResponseHeaders_ f = ResponseHeaders {
      -- | Compression used for outbound messages
      responseCompression :: HKD f (Maybe CompressionId)

      -- | Compression accepted for inbound messages
    , responseAcceptCompression :: HKD f (Maybe (NonEmpty CompressionId))

      -- | Content-type
      --
      -- Set to 'Nothing' to omit the content-type header altogether.
    , responseContentType :: HKD f (Maybe ContentType)

      -- | Initial response metadata
      --
      -- The response can include additional metadata in the trailers; see
      -- 'properTrailersMetadata'.
    , responseMetadata :: CustomMetadataMap

      -- | Unrecognized headers
    , responseUnrecognized :: HKD f ()
    }
  deriving anyclass (HKD.Coerce)

-- | Response headers (without allowing for invalid headers)
--
-- See t'Network.GRPC.Spec.RequestHeaders' for an explanation of 'Undecorated'.
type ResponseHeaders = ResponseHeaders_ Undecorated

-- | Response headers allowing for invalid headers
--
-- See t'Network.GRPC.Spec.RequestHeaders'' for an explanation of 'Checked' and
-- the purpose of @e@.
type ResponseHeaders' e =  ResponseHeaders_ (Checked (InvalidHeaders e))

deriving stock instance Show    ResponseHeaders
deriving stock instance Eq      ResponseHeaders
deriving stock instance Generic ResponseHeaders

deriving stock instance Show e => Show (ResponseHeaders_ (Checked e))
deriving stock instance Eq   e => Eq   (ResponseHeaders_ (Checked e))

instance HKD.Traversable ResponseHeaders_ where
  traverse f x =
      ResponseHeaders
        <$> (f    $ responseCompression       x)
        <*> (f    $ responseAcceptCompression x)
        <*> (f    $ responseContentType       x)
        <*> (pure $ responseMetadata          x)
        <*> (f    $ responseUnrecognized      x)

-- | Information sent by the peer after the final output
--
-- Response trailers are a
-- [HTTP2 concept](https://datatracker.ietf.org/doc/html/rfc7540#section-8.1.3):
-- they are HTTP headers that are sent /after/ the content body. For example,
-- imagine the server is streaming a file that it's reading from disk; it could
-- use trailers to give the client an MD5 checksum when streaming is complete.
data ProperTrailers_ f = ProperTrailers {
      -- | gPRC status
      properTrailersGrpcStatus :: HKD f GrpcStatus

      -- | Additional status message
    , properTrailersGrpcMessage :: HKD f (Maybe Text)

      -- | Status details
      --
      -- This can be used to provide additional details about the RPC error;
      -- as this is a binary field, it can be used for structured data.
      --
      -- The spec imposes some additional restrictions on this field:
      --
      -- * @Status-Details@ is allowed only if @Status@ is not OK.
      -- * When using Protobuf this contains a @google.rpc.Status@ message.
      -- * If it contains a status code (as in the case of a @google.rpc.Status@
      --   message), it MUST NOT contradict the Status header.
      --
      -- The spec additionally mandates that consumers MUST verify that third
      -- requirement; however, it is impossible to verify this unless a specific
      -- format for the status details is known.
    , properTrailersStatusDetails :: HKD f (Maybe Strict.ByteString)

      -- | 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
      --
      -- See <https://github.com/grpc/proposal/blob/master/A51-custom-backend-metrics.md>
    , properTrailersOrcaLoadReport :: HKD f (Maybe OrcaLoadReport)

      -- | Trailing metadata
      --
      -- See also 'responseMetadata' for the initial metadata.
    , properTrailersMetadata :: CustomMetadataMap

      -- | Unrecognized trailers
    , properTrailersUnrecognized :: HKD f ()
    }
  deriving anyclass (HKD.Coerce)

-- | Default constructor for t'ProperTrailers'
simpleProperTrailers :: forall f.
     HKD.ValidDecoration Applicative f
  => HKD f GrpcStatus
  -> HKD f (Maybe Text)
  -> HKD f (Maybe Strict.ByteString)
  -> CustomMetadataMap
  -> ProperTrailers_ f
simpleProperTrailers status msg details metadata = ProperTrailers {
      properTrailersGrpcStatus     = status
    , properTrailersGrpcMessage    = msg
    , properTrailersStatusDetails  = details
    , properTrailersPushback       = HKD.pure (Proxy @f) (Nothing :: Maybe Pushback)
    , properTrailersOrcaLoadReport = HKD.pure (Proxy @f) (Nothing :: Maybe OrcaLoadReport)
    , properTrailersMetadata       = metadata
    , properTrailersUnrecognized   = HKD.pure (Proxy @f) ()
    }

-- | Trailers sent after the response (without allowing for invalid trailers)
type ProperTrailers = ProperTrailers_ Undecorated

-- | Trailers sent after the response, allowing for invalid trailers
--
-- We do not parameterize this over the type of synthesized errors: unlike
-- response (or request) headers, we have no opportunity to check the trailers
-- for synthesized errors ahead of time, so having a type to signal
-- "trailers without synthesized errors" is not particularly useful.
type ProperTrailers' = ProperTrailers_ (Checked (InvalidHeaders GrpcException))

deriving stock instance Show    ProperTrailers
deriving stock instance Eq      ProperTrailers
deriving stock instance Generic ProperTrailers

deriving stock instance Show e => Show (ProperTrailers_ (Checked e))
deriving stock instance Eq   e => Eq   (ProperTrailers_ (Checked e))

instance HKD.Traversable ProperTrailers_ where
  traverse f x =
      ProperTrailers
        <$> (f    $ properTrailersGrpcStatus     x)
        <*> (f    $ properTrailersGrpcMessage    x)
        <*> (f    $ properTrailersStatusDetails  x)
        <*> (f    $ properTrailersPushback       x)
        <*> (f    $ properTrailersOrcaLoadReport x)
        <*> (pure $ properTrailersMetadata       x)
        <*> (f    $ properTrailersUnrecognized   x)

-- | Trailers sent in the gRPC Trailers-Only case
--
-- We deal with the HTTP status elsewhere.
data TrailersOnly_ f = TrailersOnly {
      -- | Content type
      --
      -- Set to 'Nothing' to omit the content-type altogether.
      trailersOnlyContentType :: HKD f (Maybe ContentType)

      -- | All regular trailers can also appear in the Trailers-Only case
    , trailersOnlyProper :: ProperTrailers_ f
    }
  deriving anyclass (HKD.Coerce)

-- | Trailers for the Trailers-Only case (without allowing for invalid trailers)
type TrailersOnly = TrailersOnly_ Undecorated

-- | Trailers for the Trailers-Only case, allowing for invalid headers
type TrailersOnly' e = TrailersOnly_ (Checked (InvalidHeaders e))

deriving stock instance Show    TrailersOnly
deriving stock instance Eq      TrailersOnly
deriving stock instance Generic TrailersOnly

deriving stock instance Show e => Show (TrailersOnly_ (Checked e))
deriving stock instance Eq   e => Eq   (TrailersOnly_ (Checked e))

instance HKD.Traversable TrailersOnly_ where
  traverse f x =
      TrailersOnly
        <$> (f              $ trailersOnlyContentType x)
        <*> (HKD.traverse f $ trailersOnlyProper      x)

-- | t'ProperTrailers' is a subset of t'TrailersOnly'
properTrailersToTrailersOnly ::
     (ProperTrailers_ f, HKD f (Maybe ContentType))
  -> TrailersOnly_ f
properTrailersToTrailersOnly (proper, ct) = TrailersOnly {
      trailersOnlyProper      = proper
    , trailersOnlyContentType = ct
    }

-- | t'TrailersOnly' is a superset of t'ProperTrailers'
trailersOnlyToProperTrailers ::
      TrailersOnly_ f
   -> (ProperTrailers_ f, HKD f (Maybe ContentType))
trailersOnlyToProperTrailers TrailersOnly{
                                 trailersOnlyProper
                               , trailersOnlyContentType
                               } = (
      trailersOnlyProper
    , trailersOnlyContentType
    )

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

-- | Pushback
--
-- The server adds this header to push back against client retries. We do not
-- yet support automatic retries
-- (<https://github.com/well-typed/grapesy/issues/104>), but do /we/ parse this
-- header so that /if/ the server includes it, we do not throw a parser error.
--
-- See also <https://github.com/grpc/proposal/blob/master/A6-client-retries.md>
data Pushback =
    RetryAfter Word
  | DoNotRetry
  deriving (Show, Eq, Generic)

{-------------------------------------------------------------------------------
  Termination
-------------------------------------------------------------------------------}

-- | Server indicated normal termination
--
-- This is only an exception if the client tries to send any further messages.
data GrpcNormalTermination = GrpcNormalTermination {
      grpcTerminatedMetadata :: [CustomMetadata]
    }
  deriving stock (Show)
  deriving anyclass (Exception)

-- | Check if trailers correspond to an exceptional response
--
-- The gRPC spec states that
--
-- > Trailers-Only is permitted for calls that produce an immediate error
--
-- However, in practice gRPC servers can also respond with @Trailers-Only@ in
-- non-error cases, simply indicating that the server considers the
-- conversation over. To distinguish, we look at 'properTrailersGrpcStatus'.
grpcClassifyTermination ::
     ProperTrailers'
  -> Either GrpcException GrpcNormalTermination
grpcClassifyTermination =
    -- If there are any synthesized errors, those take precedence
    either Left aux . throwSynthesized throwError
  where
    aux ::
         ProperTrailers_ (Checked (InvalidHeaders HandledSynthesized))
      -> Either GrpcException GrpcNormalTermination
    aux ProperTrailers { properTrailersGrpcStatus
                       , properTrailersGrpcMessage
                       , properTrailersStatusDetails
                       , properTrailersMetadata
                       } =
        case properTrailersGrpcStatus of
          Right GrpcOk -> Right GrpcNormalTermination {
              grpcTerminatedMetadata =
                customMetadataMapToList properTrailersMetadata
            }
          Right (GrpcError err) -> Left GrpcException{
              grpcError = err
            , grpcErrorMessage =
                case (properTrailersGrpcMessage, properTrailersStatusDetails) of
                  (Right msg, Right _) ->
                    msg
                  (Left _, Right _) ->
                    Just "'grpc-message' invalid"
                  (Left  _, Left _) ->
                    Just "'grpc-message' and 'grpc-status-details-bin' invalid"
                  (Right Nothing, Left _) ->
                    Just "'grpc-status-details-bin' invalid"
                  (Right (Just msg), Left _) ->
                    -- This is the trickiest case. We have a valid grpc-message,
                    -- but grpc-status-details-bin is invalid. We cannot
                    -- construct an alternative value for 'grpcErrorDetails',
                    -- because we have no way of knowing which format it is
                    -- expected to be. So instead we add a remark here.
                    Just $ msg <> "\n'grpc-status-details-bin' invalid"
            , grpcErrorDetails =
                case properTrailersStatusDetails of
                  Right details -> details
                  Left  _       -> Nothing -- see above
            , grpcErrorMetadata =
                customMetadataMapToList properTrailersMetadata
            }
          Left _invalidStatus -> Left GrpcException {
              grpcError         = GrpcUnknown
            , grpcErrorMessage  = Just "Invalid grpc-status"
            , grpcErrorDetails  = Nothing
            , grpcErrorMetadata = customMetadataMapToList properTrailersMetadata
            }

-- | Translate gRPC exception to response trailers
grpcExceptionToTrailers ::  GrpcException -> ProperTrailers
grpcExceptionToTrailers GrpcException{
                            grpcError
                          , grpcErrorMessage
                          , grpcErrorDetails
                          , grpcErrorMetadata
                          } =
    simpleProperTrailers
      (GrpcError grpcError)
      grpcErrorMessage
      grpcErrorDetails
      (customMetadataMapFromList grpcErrorMetadata)