{-# 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
      forall (f :: * -> *).
ResponseHeaders_ f -> HKD f (Maybe CompressionId)
responseCompression :: HKD f (Maybe CompressionId)

      -- | Compression accepted for inbound messages
    , forall (f :: * -> *).
ResponseHeaders_ f -> HKD f (Maybe (NonEmpty CompressionId))
responseAcceptCompression :: HKD f (Maybe (NonEmpty CompressionId))

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

      -- | Initial response metadata
      --
      -- The response can include additional metadata in the trailers; see
      -- 'properTrailersMetadata'.
    , forall (f :: * -> *). ResponseHeaders_ f -> CustomMetadataMap
responseMetadata :: CustomMetadataMap

      -- | Unrecognized headers
    , forall (f :: * -> *). ResponseHeaders_ f -> HKD f ()
responseUnrecognized :: HKD f ()
    }
  deriving anyclass (ResponseHeaders_ (DecoratedWith Identity)
-> ResponseHeaders_ Undecorated
ResponseHeaders_ Undecorated
-> ResponseHeaders_ (DecoratedWith Identity)
(ResponseHeaders_ (DecoratedWith Identity)
 -> ResponseHeaders_ Undecorated)
-> (ResponseHeaders_ Undecorated
    -> ResponseHeaders_ (DecoratedWith Identity))
-> Coerce ResponseHeaders_
forall (t :: (* -> *) -> *).
(t (DecoratedWith Identity) -> t Undecorated)
-> (t Undecorated -> t (DecoratedWith Identity)) -> Coerce t
$cundecorate :: ResponseHeaders_ (DecoratedWith Identity)
-> ResponseHeaders_ Undecorated
undecorate :: ResponseHeaders_ (DecoratedWith Identity)
-> ResponseHeaders_ Undecorated
$cdecorate :: ResponseHeaders_ Undecorated
-> ResponseHeaders_ (DecoratedWith Identity)
decorate :: ResponseHeaders_ Undecorated
-> ResponseHeaders_ (DecoratedWith Identity)
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 :: forall (m :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative m =>
(forall a. f a -> m (g a))
-> ResponseHeaders_ (DecoratedWith f)
-> m (ResponseHeaders_ (DecoratedWith g))
traverse forall a. f a -> m (g a)
f ResponseHeaders_ (DecoratedWith f)
x =
      g (Maybe CompressionId)
-> g (Maybe (NonEmpty CompressionId))
-> g (Maybe ContentType)
-> CustomMetadataMap
-> g ()
-> ResponseHeaders_ (DecoratedWith g)
HKD (DecoratedWith g) (Maybe CompressionId)
-> HKD (DecoratedWith g) (Maybe (NonEmpty CompressionId))
-> HKD (DecoratedWith g) (Maybe ContentType)
-> CustomMetadataMap
-> HKD (DecoratedWith g) ()
-> ResponseHeaders_ (DecoratedWith g)
forall (f :: * -> *).
HKD f (Maybe CompressionId)
-> HKD f (Maybe (NonEmpty CompressionId))
-> HKD f (Maybe ContentType)
-> CustomMetadataMap
-> HKD f ()
-> ResponseHeaders_ f
ResponseHeaders
        (g (Maybe CompressionId)
 -> g (Maybe (NonEmpty CompressionId))
 -> g (Maybe ContentType)
 -> CustomMetadataMap
 -> g ()
 -> ResponseHeaders_ (DecoratedWith g))
-> m (g (Maybe CompressionId))
-> m (g (Maybe (NonEmpty CompressionId))
      -> g (Maybe ContentType)
      -> CustomMetadataMap
      -> g ()
      -> ResponseHeaders_ (DecoratedWith g))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (f (Maybe CompressionId) -> m (g (Maybe CompressionId))
forall a. f a -> m (g a)
f    (f (Maybe CompressionId) -> m (g (Maybe CompressionId)))
-> f (Maybe CompressionId) -> m (g (Maybe CompressionId))
forall a b. (a -> b) -> a -> b
$ ResponseHeaders_ (DecoratedWith f)
-> HKD (DecoratedWith f) (Maybe CompressionId)
forall (f :: * -> *).
ResponseHeaders_ f -> HKD f (Maybe CompressionId)
responseCompression       ResponseHeaders_ (DecoratedWith f)
x)
        m (g (Maybe (NonEmpty CompressionId))
   -> g (Maybe ContentType)
   -> CustomMetadataMap
   -> g ()
   -> ResponseHeaders_ (DecoratedWith g))
-> m (g (Maybe (NonEmpty CompressionId)))
-> m (g (Maybe ContentType)
      -> CustomMetadataMap -> g () -> ResponseHeaders_ (DecoratedWith g))
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (f (Maybe (NonEmpty CompressionId))
-> m (g (Maybe (NonEmpty CompressionId)))
forall a. f a -> m (g a)
f    (f (Maybe (NonEmpty CompressionId))
 -> m (g (Maybe (NonEmpty CompressionId))))
-> f (Maybe (NonEmpty CompressionId))
-> m (g (Maybe (NonEmpty CompressionId)))
forall a b. (a -> b) -> a -> b
$ ResponseHeaders_ (DecoratedWith f)
-> HKD (DecoratedWith f) (Maybe (NonEmpty CompressionId))
forall (f :: * -> *).
ResponseHeaders_ f -> HKD f (Maybe (NonEmpty CompressionId))
responseAcceptCompression ResponseHeaders_ (DecoratedWith f)
x)
        m (g (Maybe ContentType)
   -> CustomMetadataMap -> g () -> ResponseHeaders_ (DecoratedWith g))
-> m (g (Maybe ContentType))
-> m (CustomMetadataMap
      -> g () -> ResponseHeaders_ (DecoratedWith g))
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (f (Maybe ContentType) -> m (g (Maybe ContentType))
forall a. f a -> m (g a)
f    (f (Maybe ContentType) -> m (g (Maybe ContentType)))
-> f (Maybe ContentType) -> m (g (Maybe ContentType))
forall a b. (a -> b) -> a -> b
$ ResponseHeaders_ (DecoratedWith f)
-> HKD (DecoratedWith f) (Maybe ContentType)
forall (f :: * -> *).
ResponseHeaders_ f -> HKD f (Maybe ContentType)
responseContentType       ResponseHeaders_ (DecoratedWith f)
x)
        m (CustomMetadataMap -> g () -> ResponseHeaders_ (DecoratedWith g))
-> m CustomMetadataMap
-> m (g () -> ResponseHeaders_ (DecoratedWith g))
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (CustomMetadataMap -> m CustomMetadataMap
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CustomMetadataMap -> m CustomMetadataMap)
-> CustomMetadataMap -> m CustomMetadataMap
forall a b. (a -> b) -> a -> b
$ ResponseHeaders_ (DecoratedWith f) -> CustomMetadataMap
forall (f :: * -> *). ResponseHeaders_ f -> CustomMetadataMap
responseMetadata          ResponseHeaders_ (DecoratedWith f)
x)
        m (g () -> ResponseHeaders_ (DecoratedWith g))
-> m (g ()) -> m (ResponseHeaders_ (DecoratedWith g))
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (f () -> m (g ())
forall a. f a -> m (g a)
f    (f () -> m (g ())) -> f () -> m (g ())
forall a b. (a -> b) -> a -> b
$ ResponseHeaders_ (DecoratedWith f) -> HKD (DecoratedWith f) ()
forall (f :: * -> *). ResponseHeaders_ f -> HKD f ()
responseUnrecognized      ResponseHeaders_ (DecoratedWith f)
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
      forall (f :: * -> *). ProperTrailers_ f -> HKD f GrpcStatus
properTrailersGrpcStatus :: HKD f GrpcStatus

      -- | Additional status message
    , forall (f :: * -> *). ProperTrailers_ f -> HKD f (Maybe Text)
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.
    , forall (f :: * -> *). ProperTrailers_ f -> HKD f (Maybe ByteString)
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>.
    , forall (f :: * -> *). ProperTrailers_ f -> HKD f (Maybe Pushback)
properTrailersPushback :: HKD f (Maybe Pushback)

      -- | ORCA load report
      --
      -- See <https://github.com/grpc/proposal/blob/master/A51-custom-backend-metrics.md>
    , forall (f :: * -> *).
ProperTrailers_ f -> HKD f (Maybe OrcaLoadReport)
properTrailersOrcaLoadReport :: HKD f (Maybe OrcaLoadReport)

      -- | Trailing metadata
      --
      -- See also 'responseMetadata' for the initial metadata.
    , forall (f :: * -> *). ProperTrailers_ f -> CustomMetadataMap
properTrailersMetadata :: CustomMetadataMap

      -- | Unrecognized trailers
    , forall (f :: * -> *). ProperTrailers_ f -> HKD f ()
properTrailersUnrecognized :: HKD f ()
    }
  deriving anyclass (ProperTrailers_ (DecoratedWith Identity)
-> ProperTrailers_ Undecorated
ProperTrailers_ Undecorated
-> ProperTrailers_ (DecoratedWith Identity)
(ProperTrailers_ (DecoratedWith Identity)
 -> ProperTrailers_ Undecorated)
-> (ProperTrailers_ Undecorated
    -> ProperTrailers_ (DecoratedWith Identity))
-> Coerce ProperTrailers_
forall (t :: (* -> *) -> *).
(t (DecoratedWith Identity) -> t Undecorated)
-> (t Undecorated -> t (DecoratedWith Identity)) -> Coerce t
$cundecorate :: ProperTrailers_ (DecoratedWith Identity)
-> ProperTrailers_ Undecorated
undecorate :: ProperTrailers_ (DecoratedWith Identity)
-> ProperTrailers_ Undecorated
$cdecorate :: ProperTrailers_ Undecorated
-> ProperTrailers_ (DecoratedWith Identity)
decorate :: ProperTrailers_ Undecorated
-> ProperTrailers_ (DecoratedWith Identity)
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 :: forall (f :: * -> *).
ValidDecoration Applicative f =>
HKD f GrpcStatus
-> HKD f (Maybe Text)
-> HKD f (Maybe ByteString)
-> CustomMetadataMap
-> ProperTrailers_ f
simpleProperTrailers HKD f GrpcStatus
status HKD f (Maybe Text)
msg HKD f (Maybe ByteString)
details CustomMetadataMap
metadata = ProperTrailers {
      properTrailersGrpcStatus :: HKD f GrpcStatus
properTrailersGrpcStatus     = HKD f GrpcStatus
status
    , properTrailersGrpcMessage :: HKD f (Maybe Text)
properTrailersGrpcMessage    = HKD f (Maybe Text)
msg
    , properTrailersStatusDetails :: HKD f (Maybe ByteString)
properTrailersStatusDetails  = HKD f (Maybe ByteString)
details
    , properTrailersPushback :: HKD f (Maybe Pushback)
properTrailersPushback       = Proxy f -> Maybe Pushback -> HKD f (Maybe Pushback)
forall (f :: * -> *) a.
ValidDecoration Applicative f =>
Proxy f -> a -> HKD f a
HKD.pure (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @f) (Maybe Pushback
forall a. Maybe a
Nothing :: Maybe Pushback)
    , properTrailersOrcaLoadReport :: HKD f (Maybe OrcaLoadReport)
properTrailersOrcaLoadReport = Proxy f -> Maybe OrcaLoadReport -> HKD f (Maybe OrcaLoadReport)
forall (f :: * -> *) a.
ValidDecoration Applicative f =>
Proxy f -> a -> HKD f a
HKD.pure (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @f) (Maybe OrcaLoadReport
forall a. Maybe a
Nothing :: Maybe OrcaLoadReport)
    , properTrailersMetadata :: CustomMetadataMap
properTrailersMetadata       = CustomMetadataMap
metadata
    , properTrailersUnrecognized :: HKD f ()
properTrailersUnrecognized   = Proxy f -> () -> HKD f ()
forall (f :: * -> *) a.
ValidDecoration Applicative f =>
Proxy f -> a -> HKD f a
HKD.pure (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
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 :: forall (m :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative m =>
(forall a. f a -> m (g a))
-> ProperTrailers_ (DecoratedWith f)
-> m (ProperTrailers_ (DecoratedWith g))
traverse forall a. f a -> m (g a)
f ProperTrailers_ (DecoratedWith f)
x =
      g GrpcStatus
-> g (Maybe Text)
-> g (Maybe ByteString)
-> g (Maybe Pushback)
-> g (Maybe OrcaLoadReport)
-> CustomMetadataMap
-> g ()
-> ProperTrailers_ (DecoratedWith g)
HKD (DecoratedWith g) GrpcStatus
-> HKD (DecoratedWith g) (Maybe Text)
-> HKD (DecoratedWith g) (Maybe ByteString)
-> HKD (DecoratedWith g) (Maybe Pushback)
-> HKD (DecoratedWith g) (Maybe OrcaLoadReport)
-> CustomMetadataMap
-> HKD (DecoratedWith g) ()
-> ProperTrailers_ (DecoratedWith g)
forall (f :: * -> *).
HKD f GrpcStatus
-> HKD f (Maybe Text)
-> HKD f (Maybe ByteString)
-> HKD f (Maybe Pushback)
-> HKD f (Maybe OrcaLoadReport)
-> CustomMetadataMap
-> HKD f ()
-> ProperTrailers_ f
ProperTrailers
        (g GrpcStatus
 -> g (Maybe Text)
 -> g (Maybe ByteString)
 -> g (Maybe Pushback)
 -> g (Maybe OrcaLoadReport)
 -> CustomMetadataMap
 -> g ()
 -> ProperTrailers_ (DecoratedWith g))
-> m (g GrpcStatus)
-> m (g (Maybe Text)
      -> g (Maybe ByteString)
      -> g (Maybe Pushback)
      -> g (Maybe OrcaLoadReport)
      -> CustomMetadataMap
      -> g ()
      -> ProperTrailers_ (DecoratedWith g))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (f GrpcStatus -> m (g GrpcStatus)
forall a. f a -> m (g a)
f    (f GrpcStatus -> m (g GrpcStatus))
-> f GrpcStatus -> m (g GrpcStatus)
forall a b. (a -> b) -> a -> b
$ ProperTrailers_ (DecoratedWith f)
-> HKD (DecoratedWith f) GrpcStatus
forall (f :: * -> *). ProperTrailers_ f -> HKD f GrpcStatus
properTrailersGrpcStatus     ProperTrailers_ (DecoratedWith f)
x)
        m (g (Maybe Text)
   -> g (Maybe ByteString)
   -> g (Maybe Pushback)
   -> g (Maybe OrcaLoadReport)
   -> CustomMetadataMap
   -> g ()
   -> ProperTrailers_ (DecoratedWith g))
-> m (g (Maybe Text))
-> m (g (Maybe ByteString)
      -> g (Maybe Pushback)
      -> g (Maybe OrcaLoadReport)
      -> CustomMetadataMap
      -> g ()
      -> ProperTrailers_ (DecoratedWith g))
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (f (Maybe Text) -> m (g (Maybe Text))
forall a. f a -> m (g a)
f    (f (Maybe Text) -> m (g (Maybe Text)))
-> f (Maybe Text) -> m (g (Maybe Text))
forall a b. (a -> b) -> a -> b
$ ProperTrailers_ (DecoratedWith f)
-> HKD (DecoratedWith f) (Maybe Text)
forall (f :: * -> *). ProperTrailers_ f -> HKD f (Maybe Text)
properTrailersGrpcMessage    ProperTrailers_ (DecoratedWith f)
x)
        m (g (Maybe ByteString)
   -> g (Maybe Pushback)
   -> g (Maybe OrcaLoadReport)
   -> CustomMetadataMap
   -> g ()
   -> ProperTrailers_ (DecoratedWith g))
-> m (g (Maybe ByteString))
-> m (g (Maybe Pushback)
      -> g (Maybe OrcaLoadReport)
      -> CustomMetadataMap
      -> g ()
      -> ProperTrailers_ (DecoratedWith g))
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (f (Maybe ByteString) -> m (g (Maybe ByteString))
forall a. f a -> m (g a)
f    (f (Maybe ByteString) -> m (g (Maybe ByteString)))
-> f (Maybe ByteString) -> m (g (Maybe ByteString))
forall a b. (a -> b) -> a -> b
$ ProperTrailers_ (DecoratedWith f)
-> HKD (DecoratedWith f) (Maybe ByteString)
forall (f :: * -> *). ProperTrailers_ f -> HKD f (Maybe ByteString)
properTrailersStatusDetails  ProperTrailers_ (DecoratedWith f)
x)
        m (g (Maybe Pushback)
   -> g (Maybe OrcaLoadReport)
   -> CustomMetadataMap
   -> g ()
   -> ProperTrailers_ (DecoratedWith g))
-> m (g (Maybe Pushback))
-> m (g (Maybe OrcaLoadReport)
      -> CustomMetadataMap -> g () -> ProperTrailers_ (DecoratedWith g))
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (f (Maybe Pushback) -> m (g (Maybe Pushback))
forall a. f a -> m (g a)
f    (f (Maybe Pushback) -> m (g (Maybe Pushback)))
-> f (Maybe Pushback) -> m (g (Maybe Pushback))
forall a b. (a -> b) -> a -> b
$ ProperTrailers_ (DecoratedWith f)
-> HKD (DecoratedWith f) (Maybe Pushback)
forall (f :: * -> *). ProperTrailers_ f -> HKD f (Maybe Pushback)
properTrailersPushback       ProperTrailers_ (DecoratedWith f)
x)
        m (g (Maybe OrcaLoadReport)
   -> CustomMetadataMap -> g () -> ProperTrailers_ (DecoratedWith g))
-> m (g (Maybe OrcaLoadReport))
-> m (CustomMetadataMap
      -> g () -> ProperTrailers_ (DecoratedWith g))
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (f (Maybe OrcaLoadReport) -> m (g (Maybe OrcaLoadReport))
forall a. f a -> m (g a)
f    (f (Maybe OrcaLoadReport) -> m (g (Maybe OrcaLoadReport)))
-> f (Maybe OrcaLoadReport) -> m (g (Maybe OrcaLoadReport))
forall a b. (a -> b) -> a -> b
$ ProperTrailers_ (DecoratedWith f)
-> HKD (DecoratedWith f) (Maybe OrcaLoadReport)
forall (f :: * -> *).
ProperTrailers_ f -> HKD f (Maybe OrcaLoadReport)
properTrailersOrcaLoadReport ProperTrailers_ (DecoratedWith f)
x)
        m (CustomMetadataMap -> g () -> ProperTrailers_ (DecoratedWith g))
-> m CustomMetadataMap
-> m (g () -> ProperTrailers_ (DecoratedWith g))
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (CustomMetadataMap -> m CustomMetadataMap
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CustomMetadataMap -> m CustomMetadataMap)
-> CustomMetadataMap -> m CustomMetadataMap
forall a b. (a -> b) -> a -> b
$ ProperTrailers_ (DecoratedWith f) -> CustomMetadataMap
forall (f :: * -> *). ProperTrailers_ f -> CustomMetadataMap
properTrailersMetadata       ProperTrailers_ (DecoratedWith f)
x)
        m (g () -> ProperTrailers_ (DecoratedWith g))
-> m (g ()) -> m (ProperTrailers_ (DecoratedWith g))
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (f () -> m (g ())
forall a. f a -> m (g a)
f    (f () -> m (g ())) -> f () -> m (g ())
forall a b. (a -> b) -> a -> b
$ ProperTrailers_ (DecoratedWith f) -> HKD (DecoratedWith f) ()
forall (f :: * -> *). ProperTrailers_ f -> HKD f ()
properTrailersUnrecognized   ProperTrailers_ (DecoratedWith f)
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.
      forall (f :: * -> *). TrailersOnly_ f -> HKD f (Maybe ContentType)
trailersOnlyContentType :: HKD f (Maybe ContentType)

      -- | All regular trailers can also appear in the Trailers-Only case
    , forall (f :: * -> *). TrailersOnly_ f -> ProperTrailers_ f
trailersOnlyProper :: ProperTrailers_ f
    }
  deriving anyclass (TrailersOnly_ (DecoratedWith Identity) -> TrailersOnly_ Undecorated
TrailersOnly_ Undecorated -> TrailersOnly_ (DecoratedWith Identity)
(TrailersOnly_ (DecoratedWith Identity)
 -> TrailersOnly_ Undecorated)
-> (TrailersOnly_ Undecorated
    -> TrailersOnly_ (DecoratedWith Identity))
-> Coerce TrailersOnly_
forall (t :: (* -> *) -> *).
(t (DecoratedWith Identity) -> t Undecorated)
-> (t Undecorated -> t (DecoratedWith Identity)) -> Coerce t
$cundecorate :: TrailersOnly_ (DecoratedWith Identity) -> TrailersOnly_ Undecorated
undecorate :: TrailersOnly_ (DecoratedWith Identity) -> TrailersOnly_ Undecorated
$cdecorate :: TrailersOnly_ Undecorated -> TrailersOnly_ (DecoratedWith Identity)
decorate :: TrailersOnly_ Undecorated -> TrailersOnly_ (DecoratedWith Identity)
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 :: forall (m :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative m =>
(forall a. f a -> m (g a))
-> TrailersOnly_ (DecoratedWith f)
-> m (TrailersOnly_ (DecoratedWith g))
traverse forall a. f a -> m (g a)
f TrailersOnly_ (DecoratedWith f)
x =
      g (Maybe ContentType)
-> ProperTrailers_ (DecoratedWith g)
-> TrailersOnly_ (DecoratedWith g)
HKD (DecoratedWith g) (Maybe ContentType)
-> ProperTrailers_ (DecoratedWith g)
-> TrailersOnly_ (DecoratedWith g)
forall (f :: * -> *).
HKD f (Maybe ContentType) -> ProperTrailers_ f -> TrailersOnly_ f
TrailersOnly
        (g (Maybe ContentType)
 -> ProperTrailers_ (DecoratedWith g)
 -> TrailersOnly_ (DecoratedWith g))
-> m (g (Maybe ContentType))
-> m (ProperTrailers_ (DecoratedWith g)
      -> TrailersOnly_ (DecoratedWith g))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (f (Maybe ContentType) -> m (g (Maybe ContentType))
forall a. f a -> m (g a)
f              (f (Maybe ContentType) -> m (g (Maybe ContentType)))
-> f (Maybe ContentType) -> m (g (Maybe ContentType))
forall a b. (a -> b) -> a -> b
$ TrailersOnly_ (DecoratedWith f)
-> HKD (DecoratedWith f) (Maybe ContentType)
forall (f :: * -> *). TrailersOnly_ f -> HKD f (Maybe ContentType)
trailersOnlyContentType TrailersOnly_ (DecoratedWith f)
x)
        m (ProperTrailers_ (DecoratedWith g)
   -> TrailersOnly_ (DecoratedWith g))
-> m (ProperTrailers_ (DecoratedWith g))
-> m (TrailersOnly_ (DecoratedWith g))
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((forall a. f a -> m (g a))
-> ProperTrailers_ (DecoratedWith f)
-> m (ProperTrailers_ (DecoratedWith g))
forall (m :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative m =>
(forall a. f a -> m (g a))
-> ProperTrailers_ (DecoratedWith f)
-> m (ProperTrailers_ (DecoratedWith g))
forall (t :: (* -> *) -> *) (m :: * -> *) (f :: * -> *)
       (g :: * -> *).
(Traversable t, Applicative m) =>
(forall a. f a -> m (g a))
-> t (DecoratedWith f) -> m (t (DecoratedWith g))
HKD.traverse f a -> m (g a)
forall a. f a -> m (g a)
f (ProperTrailers_ (DecoratedWith f)
 -> m (ProperTrailers_ (DecoratedWith g)))
-> ProperTrailers_ (DecoratedWith f)
-> m (ProperTrailers_ (DecoratedWith g))
forall a b. (a -> b) -> a -> b
$ TrailersOnly_ (DecoratedWith f)
-> ProperTrailers_ (DecoratedWith f)
forall (f :: * -> *). TrailersOnly_ f -> ProperTrailers_ f
trailersOnlyProper      TrailersOnly_ (DecoratedWith f)
x)

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

-- | t'TrailersOnly' is a superset of t'ProperTrailers'
trailersOnlyToProperTrailers ::
      TrailersOnly_ f
   -> (ProperTrailers_ f, HKD f (Maybe ContentType))
trailersOnlyToProperTrailers :: forall (f :: * -> *).
TrailersOnly_ f -> (ProperTrailers_ f, HKD f (Maybe ContentType))
trailersOnlyToProperTrailers TrailersOnly{
                                 ProperTrailers_ f
trailersOnlyProper :: forall (f :: * -> *). TrailersOnly_ f -> ProperTrailers_ f
trailersOnlyProper :: ProperTrailers_ f
trailersOnlyProper
                               , HKD f (Maybe ContentType)
trailersOnlyContentType :: forall (f :: * -> *). TrailersOnly_ f -> HKD f (Maybe ContentType)
trailersOnlyContentType :: HKD f (Maybe ContentType)
trailersOnlyContentType
                               } = (
      ProperTrailers_ f
trailersOnlyProper
    , HKD f (Maybe ContentType)
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 (Int -> Pushback -> ShowS
[Pushback] -> ShowS
Pushback -> String
(Int -> Pushback -> ShowS)
-> (Pushback -> String) -> ([Pushback] -> ShowS) -> Show Pushback
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Pushback -> ShowS
showsPrec :: Int -> Pushback -> ShowS
$cshow :: Pushback -> String
show :: Pushback -> String
$cshowList :: [Pushback] -> ShowS
showList :: [Pushback] -> ShowS
Show, Pushback -> Pushback -> Bool
(Pushback -> Pushback -> Bool)
-> (Pushback -> Pushback -> Bool) -> Eq Pushback
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Pushback -> Pushback -> Bool
== :: Pushback -> Pushback -> Bool
$c/= :: Pushback -> Pushback -> Bool
/= :: Pushback -> Pushback -> Bool
Eq, (forall x. Pushback -> Rep Pushback x)
-> (forall x. Rep Pushback x -> Pushback) -> Generic Pushback
forall x. Rep Pushback x -> Pushback
forall x. Pushback -> Rep Pushback x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Pushback -> Rep Pushback x
from :: forall x. Pushback -> Rep Pushback x
$cto :: forall x. Rep Pushback x -> Pushback
to :: forall x. Rep Pushback x -> Pushback
Generic)

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

-- | Server indicated normal termination
--
-- This is only an exception if the client tries to send any further messages.
data GrpcNormalTermination = GrpcNormalTermination {
      GrpcNormalTermination -> [CustomMetadata]
grpcTerminatedMetadata :: [CustomMetadata]
    }
  deriving stock (Int -> GrpcNormalTermination -> ShowS
[GrpcNormalTermination] -> ShowS
GrpcNormalTermination -> String
(Int -> GrpcNormalTermination -> ShowS)
-> (GrpcNormalTermination -> String)
-> ([GrpcNormalTermination] -> ShowS)
-> Show GrpcNormalTermination
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GrpcNormalTermination -> ShowS
showsPrec :: Int -> GrpcNormalTermination -> ShowS
$cshow :: GrpcNormalTermination -> String
show :: GrpcNormalTermination -> String
$cshowList :: [GrpcNormalTermination] -> ShowS
showList :: [GrpcNormalTermination] -> ShowS
Show)
  deriving anyclass (Show GrpcNormalTermination
Typeable GrpcNormalTermination
(Typeable GrpcNormalTermination, Show GrpcNormalTermination) =>
(GrpcNormalTermination -> SomeException)
-> (SomeException -> Maybe GrpcNormalTermination)
-> (GrpcNormalTermination -> String)
-> (GrpcNormalTermination -> Bool)
-> Exception GrpcNormalTermination
SomeException -> Maybe GrpcNormalTermination
GrpcNormalTermination -> Bool
GrpcNormalTermination -> String
GrpcNormalTermination -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
$ctoException :: GrpcNormalTermination -> SomeException
toException :: GrpcNormalTermination -> SomeException
$cfromException :: SomeException -> Maybe GrpcNormalTermination
fromException :: SomeException -> Maybe GrpcNormalTermination
$cdisplayException :: GrpcNormalTermination -> String
displayException :: GrpcNormalTermination -> String
$cbacktraceDesired :: GrpcNormalTermination -> Bool
backtraceDesired :: GrpcNormalTermination -> Bool
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 :: ProperTrailers' -> Either GrpcException GrpcNormalTermination
grpcClassifyTermination =
    -- If there are any synthesized errors, those take precedence
    (GrpcException -> Either GrpcException GrpcNormalTermination)
-> (ProperTrailers_ (Checked (InvalidHeaders HandledSynthesized))
    -> Either GrpcException GrpcNormalTermination)
-> Either
     GrpcException
     (ProperTrailers_ (Checked (InvalidHeaders HandledSynthesized)))
-> Either GrpcException GrpcNormalTermination
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either GrpcException -> Either GrpcException GrpcNormalTermination
forall a b. a -> Either a b
Left ProperTrailers_ (Checked (InvalidHeaders HandledSynthesized))
-> Either GrpcException GrpcNormalTermination
aux (Either
   GrpcException
   (ProperTrailers_ (Checked (InvalidHeaders HandledSynthesized)))
 -> Either GrpcException GrpcNormalTermination)
-> (ProperTrailers'
    -> Either
         GrpcException
         (ProperTrailers_ (Checked (InvalidHeaders HandledSynthesized))))
-> ProperTrailers'
-> Either GrpcException GrpcNormalTermination
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. GrpcException -> Either GrpcException a)
-> ProperTrailers'
-> Either
     GrpcException
     (ProperTrailers_ (Checked (InvalidHeaders HandledSynthesized)))
forall (h :: (* -> *) -> *) (m :: * -> *).
(Traversable h, Monad m) =>
(forall a. GrpcException -> m a)
-> h (Checked (InvalidHeaders GrpcException))
-> m (h (Checked (InvalidHeaders HandledSynthesized)))
throwSynthesized GrpcException -> Either GrpcException a
forall a. GrpcException -> Either GrpcException a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
  where
    aux ::
         ProperTrailers_ (Checked (InvalidHeaders HandledSynthesized))
      -> Either GrpcException GrpcNormalTermination
    aux :: ProperTrailers_ (Checked (InvalidHeaders HandledSynthesized))
-> Either GrpcException GrpcNormalTermination
aux ProperTrailers { HKD (Checked (InvalidHeaders HandledSynthesized)) GrpcStatus
properTrailersGrpcStatus :: forall (f :: * -> *). ProperTrailers_ f -> HKD f GrpcStatus
properTrailersGrpcStatus :: HKD (Checked (InvalidHeaders HandledSynthesized)) GrpcStatus
properTrailersGrpcStatus
                       , HKD (Checked (InvalidHeaders HandledSynthesized)) (Maybe Text)
properTrailersGrpcMessage :: forall (f :: * -> *). ProperTrailers_ f -> HKD f (Maybe Text)
properTrailersGrpcMessage :: HKD (Checked (InvalidHeaders HandledSynthesized)) (Maybe Text)
properTrailersGrpcMessage
                       , HKD
  (Checked (InvalidHeaders HandledSynthesized)) (Maybe ByteString)
properTrailersStatusDetails :: forall (f :: * -> *). ProperTrailers_ f -> HKD f (Maybe ByteString)
properTrailersStatusDetails :: HKD
  (Checked (InvalidHeaders HandledSynthesized)) (Maybe ByteString)
properTrailersStatusDetails
                       , CustomMetadataMap
properTrailersMetadata :: forall (f :: * -> *). ProperTrailers_ f -> CustomMetadataMap
properTrailersMetadata :: CustomMetadataMap
properTrailersMetadata
                       } =
        case HKD (Checked (InvalidHeaders HandledSynthesized)) GrpcStatus
properTrailersGrpcStatus of
          Right GrpcStatus
GrpcOk -> GrpcNormalTermination -> Either GrpcException GrpcNormalTermination
forall a b. b -> Either a b
Right GrpcNormalTermination {
              grpcTerminatedMetadata :: [CustomMetadata]
grpcTerminatedMetadata =
                CustomMetadataMap -> [CustomMetadata]
customMetadataMapToList CustomMetadataMap
properTrailersMetadata
            }
          Right (GrpcError GrpcError
err) -> GrpcException -> Either GrpcException GrpcNormalTermination
forall a b. a -> Either a b
Left GrpcException{
              grpcError :: GrpcError
grpcError = GrpcError
err
            , grpcErrorMessage :: Maybe Text
grpcErrorMessage =
                case (Either (InvalidHeaders HandledSynthesized) (Maybe Text)
HKD (Checked (InvalidHeaders HandledSynthesized)) (Maybe Text)
properTrailersGrpcMessage, Either (InvalidHeaders HandledSynthesized) (Maybe ByteString)
HKD
  (Checked (InvalidHeaders HandledSynthesized)) (Maybe ByteString)
properTrailersStatusDetails) of
                  (Right Maybe Text
msg, Right Maybe ByteString
_) ->
                    Maybe Text
msg
                  (Left InvalidHeaders HandledSynthesized
_, Right Maybe ByteString
_) ->
                    Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"'grpc-message' invalid"
                  (Left  InvalidHeaders HandledSynthesized
_, Left InvalidHeaders HandledSynthesized
_) ->
                    Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"'grpc-message' and 'grpc-status-details-bin' invalid"
                  (Right Maybe Text
Nothing, Left InvalidHeaders HandledSynthesized
_) ->
                    Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"'grpc-status-details-bin' invalid"
                  (Right (Just Text
msg), Left InvalidHeaders HandledSynthesized
_) ->
                    -- 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.
                    Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n'grpc-status-details-bin' invalid"
            , grpcErrorDetails :: Maybe ByteString
grpcErrorDetails =
                case HKD
  (Checked (InvalidHeaders HandledSynthesized)) (Maybe ByteString)
properTrailersStatusDetails of
                  Right Maybe ByteString
details -> Maybe ByteString
details
                  Left  InvalidHeaders HandledSynthesized
_       -> Maybe ByteString
forall a. Maybe a
Nothing -- see above
            , grpcErrorMetadata :: [CustomMetadata]
grpcErrorMetadata =
                CustomMetadataMap -> [CustomMetadata]
customMetadataMapToList CustomMetadataMap
properTrailersMetadata
            }
          Left InvalidHeaders HandledSynthesized
_invalidStatus -> GrpcException -> Either GrpcException GrpcNormalTermination
forall a b. a -> Either a b
Left GrpcException {
              grpcError :: GrpcError
grpcError         = GrpcError
GrpcUnknown
            , grpcErrorMessage :: Maybe Text
grpcErrorMessage  = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Invalid grpc-status"
            , grpcErrorDetails :: Maybe ByteString
grpcErrorDetails  = Maybe ByteString
forall a. Maybe a
Nothing
            , grpcErrorMetadata :: [CustomMetadata]
grpcErrorMetadata = CustomMetadataMap -> [CustomMetadata]
customMetadataMapToList CustomMetadataMap
properTrailersMetadata
            }

-- | Translate gRPC exception to response trailers
grpcExceptionToTrailers ::  GrpcException -> ProperTrailers
grpcExceptionToTrailers :: GrpcException -> ProperTrailers_ Undecorated
grpcExceptionToTrailers GrpcException{
                            GrpcError
grpcError :: GrpcException -> GrpcError
grpcError :: GrpcError
grpcError
                          , Maybe Text
grpcErrorMessage :: GrpcException -> Maybe Text
grpcErrorMessage :: Maybe Text
grpcErrorMessage
                          , Maybe ByteString
grpcErrorDetails :: GrpcException -> Maybe ByteString
grpcErrorDetails :: Maybe ByteString
grpcErrorDetails
                          , [CustomMetadata]
grpcErrorMetadata :: GrpcException -> [CustomMetadata]
grpcErrorMetadata :: [CustomMetadata]
grpcErrorMetadata
                          } =
    HKD Undecorated GrpcStatus
-> HKD Undecorated (Maybe Text)
-> HKD Undecorated (Maybe ByteString)
-> CustomMetadataMap
-> ProperTrailers_ Undecorated
forall (f :: * -> *).
ValidDecoration Applicative f =>
HKD f GrpcStatus
-> HKD f (Maybe Text)
-> HKD f (Maybe ByteString)
-> CustomMetadataMap
-> ProperTrailers_ f
simpleProperTrailers
      (GrpcError -> GrpcStatus
GrpcError GrpcError
grpcError)
      Maybe Text
HKD Undecorated (Maybe Text)
grpcErrorMessage
      Maybe ByteString
HKD Undecorated (Maybe ByteString)
grpcErrorDetails
      ([CustomMetadata] -> CustomMetadataMap
customMetadataMapFromList [CustomMetadata]
grpcErrorMetadata)