{-# LANGUAGE OverloadedStrings #-}

-- | Dealing with invalid headers
module Network.GRPC.Spec.Headers.Invalid (
    InvalidHeaders(..)
  , InvalidHeader(..)
    -- * Construction
  , invalidHeader
  , missingHeader
  , unexpectedHeader
  , invalidHeaderSynthesize
  , throwInvalidHeader
    -- * Synthesized errors
  , HandledSynthesized
  , handledSynthesized
  , dropSynthesized
  , mapSynthesized
  , mapSynthesizedM
  , throwSynthesized
    -- * Utility
  , invalidHeaders
  , prettyInvalidHeaders
  , statusInvalidHeaders
  ) where

import Control.Monad.Except
import Data.ByteString.Builder qualified as Builder
import Data.ByteString.Builder qualified as ByteString (Builder)
import Data.ByteString.UTF8 qualified as BS.UTF8
import Data.CaseInsensitive qualified as CI
import Data.Foldable (asum)
import Data.Functor.Identity
import Data.Maybe (fromMaybe, mapMaybe)
import Network.HTTP.Types qualified as HTTP

import Network.GRPC.Spec.Status
import Network.GRPC.Spec.Util.HKD (Checked)
import Network.GRPC.Spec.Util.HKD qualified as HKD

{-------------------------------------------------------------------------------
  Definition
-------------------------------------------------------------------------------}

-- | Invalid headers
--
-- This is used for request headers, response headers, and response trailers.
newtype InvalidHeaders e = InvalidHeaders {
      forall e. InvalidHeaders e -> [InvalidHeader e]
getInvalidHeaders :: [InvalidHeader e]
    }
  deriving stock (Int -> InvalidHeaders e -> ShowS
[InvalidHeaders e] -> ShowS
InvalidHeaders e -> String
(Int -> InvalidHeaders e -> ShowS)
-> (InvalidHeaders e -> String)
-> ([InvalidHeaders e] -> ShowS)
-> Show (InvalidHeaders e)
forall e. Show e => Int -> InvalidHeaders e -> ShowS
forall e. Show e => [InvalidHeaders e] -> ShowS
forall e. Show e => InvalidHeaders e -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall e. Show e => Int -> InvalidHeaders e -> ShowS
showsPrec :: Int -> InvalidHeaders e -> ShowS
$cshow :: forall e. Show e => InvalidHeaders e -> String
show :: InvalidHeaders e -> String
$cshowList :: forall e. Show e => [InvalidHeaders e] -> ShowS
showList :: [InvalidHeaders e] -> ShowS
Show, InvalidHeaders e -> InvalidHeaders e -> Bool
(InvalidHeaders e -> InvalidHeaders e -> Bool)
-> (InvalidHeaders e -> InvalidHeaders e -> Bool)
-> Eq (InvalidHeaders e)
forall e. Eq e => InvalidHeaders e -> InvalidHeaders e -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall e. Eq e => InvalidHeaders e -> InvalidHeaders e -> Bool
== :: InvalidHeaders e -> InvalidHeaders e -> Bool
$c/= :: forall e. Eq e => InvalidHeaders e -> InvalidHeaders e -> Bool
/= :: InvalidHeaders e -> InvalidHeaders e -> Bool
Eq)
  deriving newtype (NonEmpty (InvalidHeaders e) -> InvalidHeaders e
InvalidHeaders e -> InvalidHeaders e -> InvalidHeaders e
(InvalidHeaders e -> InvalidHeaders e -> InvalidHeaders e)
-> (NonEmpty (InvalidHeaders e) -> InvalidHeaders e)
-> (forall b.
    Integral b =>
    b -> InvalidHeaders e -> InvalidHeaders e)
-> Semigroup (InvalidHeaders e)
forall b. Integral b => b -> InvalidHeaders e -> InvalidHeaders e
forall e. NonEmpty (InvalidHeaders e) -> InvalidHeaders e
forall e. InvalidHeaders e -> InvalidHeaders e -> InvalidHeaders e
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall e b. Integral b => b -> InvalidHeaders e -> InvalidHeaders e
$c<> :: forall e. InvalidHeaders e -> InvalidHeaders e -> InvalidHeaders e
<> :: InvalidHeaders e -> InvalidHeaders e -> InvalidHeaders e
$csconcat :: forall e. NonEmpty (InvalidHeaders e) -> InvalidHeaders e
sconcat :: NonEmpty (InvalidHeaders e) -> InvalidHeaders e
$cstimes :: forall e b. Integral b => b -> InvalidHeaders e -> InvalidHeaders e
stimes :: forall b. Integral b => b -> InvalidHeaders e -> InvalidHeaders e
Semigroup, Semigroup (InvalidHeaders e)
InvalidHeaders e
Semigroup (InvalidHeaders e) =>
InvalidHeaders e
-> (InvalidHeaders e -> InvalidHeaders e -> InvalidHeaders e)
-> ([InvalidHeaders e] -> InvalidHeaders e)
-> Monoid (InvalidHeaders e)
[InvalidHeaders e] -> InvalidHeaders e
InvalidHeaders e -> InvalidHeaders e -> InvalidHeaders e
forall e. Semigroup (InvalidHeaders e)
forall e. InvalidHeaders e
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall e. [InvalidHeaders e] -> InvalidHeaders e
forall e. InvalidHeaders e -> InvalidHeaders e -> InvalidHeaders e
$cmempty :: forall e. InvalidHeaders e
mempty :: InvalidHeaders e
$cmappend :: forall e. InvalidHeaders e -> InvalidHeaders e -> InvalidHeaders e
mappend :: InvalidHeaders e -> InvalidHeaders e -> InvalidHeaders e
$cmconcat :: forall e. [InvalidHeaders e] -> InvalidHeaders e
mconcat :: [InvalidHeaders e] -> InvalidHeaders e
Monoid)

-- | Invalid header
--
-- This corresponds to a single \"raw\" HTTP header. It is possible that a
-- particular field of, say, 'Network.GRPC.Spec.Headers.Request.RequestHeaders'
-- corresponds to /multiple/ t'InvalidHeader', when the value of that field is
-- determined by combining multiple HTTP headers. A special case of this is the
-- field for unrecognized headers (see
-- 'Network.GRPC.Spec.Headers.Request.requestUnrecognized',
-- 'Network.GRPC.Spec.Headers.Response.responseUnrecognized', etc.), which
-- collects /all/ unrecognized headers in one field (and has value @()@ if there
-- are none).
--
-- For some invalid headers the gRPC spec mandates a specific HTTP status;
-- if this status is not specified, then we use 400 Bad Request.
data InvalidHeader e =
    -- | We failed to parse this header
    --
    -- We record the original header and the reason parsing failed.
    InvalidHeader (Maybe HTTP.Status) HTTP.Header String

    -- | Missing header (header that should have been present but was not)
  | MissingHeader (Maybe HTTP.Status) HTTP.HeaderName

    -- | Unexpected header (header that should not have been present but was)
  | UnexpectedHeader HTTP.HeaderName

    -- | Synthesize gRPC exception
    --
    -- This will be instantiated to 'Network.GRPC.Spec.GrpcException' after
    -- parsing, and to 'HandledSynthesized' once synthesized errors have been
    -- handled. See 'HandledSynthesized' for more details.
    --
    -- We record both the actual error and the synthesized error.
  | InvalidHeaderSynthesize e (InvalidHeader HandledSynthesized)
  deriving stock (Int -> InvalidHeader e -> ShowS
[InvalidHeader e] -> ShowS
InvalidHeader e -> String
(Int -> InvalidHeader e -> ShowS)
-> (InvalidHeader e -> String)
-> ([InvalidHeader e] -> ShowS)
-> Show (InvalidHeader e)
forall e. Show e => Int -> InvalidHeader e -> ShowS
forall e. Show e => [InvalidHeader e] -> ShowS
forall e. Show e => InvalidHeader e -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall e. Show e => Int -> InvalidHeader e -> ShowS
showsPrec :: Int -> InvalidHeader e -> ShowS
$cshow :: forall e. Show e => InvalidHeader e -> String
show :: InvalidHeader e -> String
$cshowList :: forall e. Show e => [InvalidHeader e] -> ShowS
showList :: [InvalidHeader e] -> ShowS
Show, InvalidHeader e -> InvalidHeader e -> Bool
(InvalidHeader e -> InvalidHeader e -> Bool)
-> (InvalidHeader e -> InvalidHeader e -> Bool)
-> Eq (InvalidHeader e)
forall e. Eq e => InvalidHeader e -> InvalidHeader e -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall e. Eq e => InvalidHeader e -> InvalidHeader e -> Bool
== :: InvalidHeader e -> InvalidHeader e -> Bool
$c/= :: forall e. Eq e => InvalidHeader e -> InvalidHeader e -> Bool
/= :: InvalidHeader e -> InvalidHeader e -> Bool
Eq)

{-------------------------------------------------------------------------------
  Construction
-------------------------------------------------------------------------------}

-- | Convenience constructor around v'InvalidHeader'
invalidHeader :: Maybe HTTP.Status -> HTTP.Header -> String -> InvalidHeaders e
invalidHeader :: forall e. Maybe Status -> Header -> String -> InvalidHeaders e
invalidHeader Maybe Status
status Header
hdr String
err = InvalidHeader e -> InvalidHeaders e
forall e. InvalidHeader e -> InvalidHeaders e
wrapOne (InvalidHeader e -> InvalidHeaders e)
-> InvalidHeader e -> InvalidHeaders e
forall a b. (a -> b) -> a -> b
$ Maybe Status -> Header -> String -> InvalidHeader e
forall e. Maybe Status -> Header -> String -> InvalidHeader e
InvalidHeader Maybe Status
status Header
hdr String
err

-- | Convenience constructor around v'MissingHeader'
missingHeader :: Maybe HTTP.Status -> HTTP.HeaderName -> InvalidHeaders e
missingHeader :: forall e. Maybe Status -> HeaderName -> InvalidHeaders e
missingHeader Maybe Status
status HeaderName
name = InvalidHeader e -> InvalidHeaders e
forall e. InvalidHeader e -> InvalidHeaders e
wrapOne (InvalidHeader e -> InvalidHeaders e)
-> InvalidHeader e -> InvalidHeaders e
forall a b. (a -> b) -> a -> b
$ Maybe Status -> HeaderName -> InvalidHeader e
forall e. Maybe Status -> HeaderName -> InvalidHeader e
MissingHeader Maybe Status
status HeaderName
name

-- | Convenience constructor around v'UnexpectedHeader'
unexpectedHeader :: HTTP.HeaderName -> InvalidHeaders e
unexpectedHeader :: forall e. HeaderName -> InvalidHeaders e
unexpectedHeader HeaderName
name = InvalidHeader e -> InvalidHeaders e
forall e. InvalidHeader e -> InvalidHeaders e
wrapOne (InvalidHeader e -> InvalidHeaders e)
-> InvalidHeader e -> InvalidHeaders e
forall a b. (a -> b) -> a -> b
$ HeaderName -> InvalidHeader e
forall e. HeaderName -> InvalidHeader e
UnexpectedHeader HeaderName
name

-- | Convenience constructor around v'InvalidHeaderSynthesize'
invalidHeaderSynthesize ::
     e
  -> InvalidHeader HandledSynthesized
  -> InvalidHeaders e
invalidHeaderSynthesize :: forall e. e -> InvalidHeader HandledSynthesized -> InvalidHeaders e
invalidHeaderSynthesize e
e InvalidHeader HandledSynthesized
orig = InvalidHeader e -> InvalidHeaders e
forall e. InvalidHeader e -> InvalidHeaders e
wrapOne (InvalidHeader e -> InvalidHeaders e)
-> InvalidHeader e -> InvalidHeaders e
forall a b. (a -> b) -> a -> b
$ e -> InvalidHeader HandledSynthesized -> InvalidHeader e
forall e. e -> InvalidHeader HandledSynthesized -> InvalidHeader e
InvalidHeaderSynthesize e
e InvalidHeader HandledSynthesized
orig

-- | Convenience function for throwing an 'invalidHeader' exception.
throwInvalidHeader ::
     MonadError (InvalidHeaders e) m
  => HTTP.Header
  -> Either String a
  -> m a
throwInvalidHeader :: forall e (m :: * -> *) a.
MonadError (InvalidHeaders e) m =>
Header -> Either String a -> m a
throwInvalidHeader Header
_   (Right a
a)  = a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
throwInvalidHeader Header
hdr (Left String
err) = InvalidHeaders e -> m a
forall a. InvalidHeaders e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (InvalidHeaders e -> m a) -> InvalidHeaders e -> m a
forall a b. (a -> b) -> a -> b
$ Maybe Status -> Header -> String -> InvalidHeaders e
forall e. Maybe Status -> Header -> String -> InvalidHeaders e
invalidHeader Maybe Status
forall a. Maybe a
Nothing Header
hdr String
err

{-------------------------------------------------------------------------------
  Synthesized errors
-------------------------------------------------------------------------------}

-- | Indicate that all synthesized errors have been handled
--
-- For some headers the gRPC spec mandates a specific gRPC error that should
-- be synthesized when the header is invalid. We use 'HandledSynthesized'
-- in types to indicate that all errors that should have been synthesized have
-- already been thrown.
--
-- For example, 'Network.GRPC.Spec.RequestHeaders'' 'HandledSynthesized'
-- indicates that these request headers may still contain errors for some
-- headers, but no errors for which the spec mandates that we synthesize a
-- specific gRPC exception.
data HandledSynthesized

instance Show HandledSynthesized where
  show :: HandledSynthesized -> String
show = HandledSynthesized -> String
forall a. HandledSynthesized -> a
handledSynthesized

instance Eq HandledSynthesized where
  HandledSynthesized
x == :: HandledSynthesized -> HandledSynthesized -> Bool
== HandledSynthesized
_ = HandledSynthesized -> Bool
forall a. HandledSynthesized -> a
handledSynthesized HandledSynthesized
x

-- | Evidence that 'HandledSynthesized' is an empty type
handledSynthesized :: HandledSynthesized -> a
handledSynthesized :: forall a. HandledSynthesized -> a
handledSynthesized HandledSynthesized
x = case HandledSynthesized
x of {}

-- | Drop all synthesized errors, leaving just the original
dropSynthesized :: InvalidHeaders e -> InvalidHeaders HandledSynthesized
dropSynthesized :: forall e. InvalidHeaders e -> InvalidHeaders HandledSynthesized
dropSynthesized = \(InvalidHeaders [InvalidHeader e]
es) ->
    [InvalidHeader HandledSynthesized]
-> InvalidHeaders HandledSynthesized
forall e. [InvalidHeader e] -> InvalidHeaders e
InvalidHeaders ([InvalidHeader HandledSynthesized]
 -> InvalidHeaders HandledSynthesized)
-> [InvalidHeader HandledSynthesized]
-> InvalidHeaders HandledSynthesized
forall a b. (a -> b) -> a -> b
$ (InvalidHeader e -> InvalidHeader HandledSynthesized)
-> [InvalidHeader e] -> [InvalidHeader HandledSynthesized]
forall a b. (a -> b) -> [a] -> [b]
map InvalidHeader e -> InvalidHeader HandledSynthesized
forall e. InvalidHeader e -> InvalidHeader HandledSynthesized
aux [InvalidHeader e]
es
  where
    aux :: InvalidHeader e -> InvalidHeader HandledSynthesized
    aux :: forall e. InvalidHeader e -> InvalidHeader HandledSynthesized
aux (InvalidHeader Maybe Status
status (HeaderName
name, ByteString
value) String
err) =
        Maybe Status
-> Header -> String -> InvalidHeader HandledSynthesized
forall e. Maybe Status -> Header -> String -> InvalidHeader e
InvalidHeader Maybe Status
status (HeaderName
name, ByteString
value) String
err
    aux (MissingHeader Maybe Status
status HeaderName
name) =
        Maybe Status -> HeaderName -> InvalidHeader HandledSynthesized
forall e. Maybe Status -> HeaderName -> InvalidHeader e
MissingHeader Maybe Status
status HeaderName
name
    aux (UnexpectedHeader HeaderName
name) =
        HeaderName -> InvalidHeader HandledSynthesized
forall e. HeaderName -> InvalidHeader e
UnexpectedHeader HeaderName
name
    aux (InvalidHeaderSynthesize e
_ InvalidHeader HandledSynthesized
orig) =
        InvalidHeader HandledSynthesized
orig

-- | Map over the errors
mapSynthesizedM :: forall m e e'.
     Monad m
  => (e -> m e')
  ->    InvalidHeaders e
  -> m (InvalidHeaders e')
mapSynthesizedM :: forall (m :: * -> *) e e'.
Monad m =>
(e -> m e') -> InvalidHeaders e -> m (InvalidHeaders e')
mapSynthesizedM e -> m e'
f = \(InvalidHeaders [InvalidHeader e]
es) ->
    [InvalidHeader e'] -> InvalidHeaders e'
forall e. [InvalidHeader e] -> InvalidHeaders e
InvalidHeaders ([InvalidHeader e'] -> InvalidHeaders e')
-> m [InvalidHeader e'] -> m (InvalidHeaders e')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [InvalidHeader e'] -> [InvalidHeader e] -> m [InvalidHeader e']
go [] [InvalidHeader e]
es
  where
    go :: [InvalidHeader e'] -> [InvalidHeader e] -> m [InvalidHeader e']
    go :: [InvalidHeader e'] -> [InvalidHeader e] -> m [InvalidHeader e']
go [InvalidHeader e']
acc []     = [InvalidHeader e'] -> m [InvalidHeader e']
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([InvalidHeader e'] -> m [InvalidHeader e'])
-> [InvalidHeader e'] -> m [InvalidHeader e']
forall a b. (a -> b) -> a -> b
$ [InvalidHeader e'] -> [InvalidHeader e']
forall a. [a] -> [a]
reverse [InvalidHeader e']
acc
    go [InvalidHeader e']
acc (InvalidHeader e
x:[InvalidHeader e]
xs) =
        case InvalidHeader e
x of
          InvalidHeader Maybe Status
status (HeaderName
name, ByteString
value) String
err ->
            [InvalidHeader e'] -> [InvalidHeader e] -> m [InvalidHeader e']
go (Maybe Status -> Header -> String -> InvalidHeader e'
forall e. Maybe Status -> Header -> String -> InvalidHeader e
InvalidHeader Maybe Status
status (HeaderName
name, ByteString
value) String
err InvalidHeader e' -> [InvalidHeader e'] -> [InvalidHeader e']
forall a. a -> [a] -> [a]
: [InvalidHeader e']
acc) [InvalidHeader e]
xs
          MissingHeader Maybe Status
status HeaderName
name ->
            [InvalidHeader e'] -> [InvalidHeader e] -> m [InvalidHeader e']
go (Maybe Status -> HeaderName -> InvalidHeader e'
forall e. Maybe Status -> HeaderName -> InvalidHeader e
MissingHeader Maybe Status
status HeaderName
name InvalidHeader e' -> [InvalidHeader e'] -> [InvalidHeader e']
forall a. a -> [a] -> [a]
: [InvalidHeader e']
acc) [InvalidHeader e]
xs
          UnexpectedHeader HeaderName
name ->
            [InvalidHeader e'] -> [InvalidHeader e] -> m [InvalidHeader e']
go (HeaderName -> InvalidHeader e'
forall e. HeaderName -> InvalidHeader e
UnexpectedHeader HeaderName
name InvalidHeader e' -> [InvalidHeader e'] -> [InvalidHeader e']
forall a. a -> [a] -> [a]
: [InvalidHeader e']
acc) [InvalidHeader e]
xs
          InvalidHeaderSynthesize e
e InvalidHeader HandledSynthesized
orig -> do
            e' <- e -> m e'
f e
e
            go (InvalidHeaderSynthesize e' orig : acc) xs

-- | Pure version of 'mapSynthesizedM'
mapSynthesized :: (e -> e') -> InvalidHeaders e -> InvalidHeaders e'
mapSynthesized :: forall e e'. (e -> e') -> InvalidHeaders e -> InvalidHeaders e'
mapSynthesized e -> e'
f = Identity (InvalidHeaders e') -> InvalidHeaders e'
forall a. Identity a -> a
runIdentity (Identity (InvalidHeaders e') -> InvalidHeaders e')
-> (InvalidHeaders e -> Identity (InvalidHeaders e'))
-> InvalidHeaders e
-> InvalidHeaders e'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> Identity e')
-> InvalidHeaders e -> Identity (InvalidHeaders e')
forall (m :: * -> *) e e'.
Monad m =>
(e -> m e') -> InvalidHeaders e -> m (InvalidHeaders e')
mapSynthesizedM (e' -> Identity e'
forall a. a -> Identity a
Identity (e' -> Identity e') -> (e -> e') -> e -> Identity e'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> e'
f)

-- | Throw all synthesized errors
--
-- After this we are guaranteed that the synthesized errors have been handlded.
throwSynthesized ::
     (HKD.Traversable h, Monad m)
  => (forall a. GrpcException -> m a)
  ->    h (Checked (InvalidHeaders GrpcException))
  -> m (h (Checked (InvalidHeaders HandledSynthesized)))
throwSynthesized :: forall (h :: (* -> *) -> *) (m :: * -> *).
(Traversable h, Monad m) =>
(forall a. GrpcException -> m a)
-> h (Checked (InvalidHeaders GrpcException))
-> m (h (Checked (InvalidHeaders HandledSynthesized)))
throwSynthesized forall a. GrpcException -> m a
throw =
    (forall a.
 Either (InvalidHeaders GrpcException) a
 -> m (Either (InvalidHeaders HandledSynthesized) a))
-> h (Checked (InvalidHeaders GrpcException))
-> m (h (Checked (InvalidHeaders HandledSynthesized)))
forall (m :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative m =>
(forall a. f a -> m (g a))
-> h (DecoratedWith f) -> m (h (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 ((forall a.
  Either (InvalidHeaders GrpcException) a
  -> m (Either (InvalidHeaders HandledSynthesized) a))
 -> h (Checked (InvalidHeaders GrpcException))
 -> m (h (Checked (InvalidHeaders HandledSynthesized))))
-> (forall a.
    Either (InvalidHeaders GrpcException) a
    -> m (Either (InvalidHeaders HandledSynthesized) a))
-> h (Checked (InvalidHeaders GrpcException))
-> m (h (Checked (InvalidHeaders HandledSynthesized)))
forall a b. (a -> b) -> a -> b
$
      (InvalidHeaders GrpcException
 -> m (Either (InvalidHeaders HandledSynthesized) a))
-> (a -> m (Either (InvalidHeaders HandledSynthesized) a))
-> Either (InvalidHeaders GrpcException) a
-> m (Either (InvalidHeaders HandledSynthesized) a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
        ((InvalidHeaders HandledSynthesized
 -> Either (InvalidHeaders HandledSynthesized) a)
-> m (InvalidHeaders HandledSynthesized)
-> m (Either (InvalidHeaders HandledSynthesized) a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap InvalidHeaders HandledSynthesized
-> Either (InvalidHeaders HandledSynthesized) a
forall a b. a -> Either a b
Left  (m (InvalidHeaders HandledSynthesized)
 -> m (Either (InvalidHeaders HandledSynthesized) a))
-> (InvalidHeaders GrpcException
    -> m (InvalidHeaders HandledSynthesized))
-> InvalidHeaders GrpcException
-> m (Either (InvalidHeaders HandledSynthesized) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GrpcException -> m HandledSynthesized)
-> InvalidHeaders GrpcException
-> m (InvalidHeaders HandledSynthesized)
forall (m :: * -> *) e e'.
Monad m =>
(e -> m e') -> InvalidHeaders e -> m (InvalidHeaders e')
mapSynthesizedM GrpcException -> m HandledSynthesized
forall a. GrpcException -> m a
throw)
        ((a -> Either (InvalidHeaders HandledSynthesized) a)
-> m a -> m (Either (InvalidHeaders HandledSynthesized) a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either (InvalidHeaders HandledSynthesized) a
forall a b. b -> Either a b
Right (m a -> m (Either (InvalidHeaders HandledSynthesized) a))
-> (a -> m a)
-> a
-> m (Either (InvalidHeaders HandledSynthesized) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return)

{-------------------------------------------------------------------------------
  Utility
-------------------------------------------------------------------------------}

-- | Extract all invalid headers
invalidHeaders :: InvalidHeaders e -> [HTTP.Header]
invalidHeaders :: forall e. InvalidHeaders e -> [Header]
invalidHeaders = \InvalidHeaders e
invalid ->
    case InvalidHeaders e -> InvalidHeaders HandledSynthesized
forall e. InvalidHeaders e -> InvalidHeaders HandledSynthesized
dropSynthesized InvalidHeaders e
invalid of
      InvalidHeaders [InvalidHeader HandledSynthesized]
es -> (InvalidHeader HandledSynthesized -> Maybe Header)
-> [InvalidHeader HandledSynthesized] -> [Header]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe InvalidHeader HandledSynthesized -> Maybe Header
aux [InvalidHeader HandledSynthesized]
es
  where
    aux :: InvalidHeader HandledSynthesized -> Maybe HTTP.Header
    aux :: InvalidHeader HandledSynthesized -> Maybe Header
aux (InvalidHeader Maybe Status
_status Header
hdr String
_) = Header -> Maybe Header
forall a. a -> Maybe a
Just Header
hdr
    aux MissingHeader{}               = Maybe Header
forall a. Maybe a
Nothing
    aux UnexpectedHeader{}            = Maybe Header
forall a. Maybe a
Nothing
    aux (InvalidHeaderSynthesize HandledSynthesized
e InvalidHeader HandledSynthesized
_) = HandledSynthesized -> Maybe Header
forall a. HandledSynthesized -> a
handledSynthesized HandledSynthesized
e

-- | Render t'InvalidHeaders'
prettyInvalidHeaders :: InvalidHeaders HandledSynthesized -> ByteString.Builder
prettyInvalidHeaders :: InvalidHeaders HandledSynthesized -> Builder
prettyInvalidHeaders = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder)
-> (InvalidHeaders HandledSynthesized -> [Builder])
-> InvalidHeaders HandledSynthesized
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InvalidHeader HandledSynthesized -> Builder)
-> [InvalidHeader HandledSynthesized] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map InvalidHeader HandledSynthesized -> Builder
go ([InvalidHeader HandledSynthesized] -> [Builder])
-> (InvalidHeaders HandledSynthesized
    -> [InvalidHeader HandledSynthesized])
-> InvalidHeaders HandledSynthesized
-> [Builder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InvalidHeaders HandledSynthesized
-> [InvalidHeader HandledSynthesized]
forall e. InvalidHeaders e -> [InvalidHeader e]
getInvalidHeaders
  where
    go :: InvalidHeader HandledSynthesized -> ByteString.Builder
    go :: InvalidHeader HandledSynthesized -> Builder
go (InvalidHeader Maybe Status
_status (HeaderName
name, ByteString
value) String
err) = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [
          Builder
"Invalid header '"
        , ByteString -> Builder
Builder.byteString (HeaderName -> ByteString
forall s. CI s -> s
CI.original HeaderName
name)
        , Builder
"' with value '"
        , ByteString -> Builder
Builder.byteString ByteString
value
        , Builder
"': "
        , ByteString -> Builder
Builder.byteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BS.UTF8.fromString String
err
        , Builder
"\n"
        ]
    go (MissingHeader Maybe Status
_status HeaderName
name) = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [
          Builder
"Missing header '"
        , ByteString -> Builder
Builder.byteString (HeaderName -> ByteString
forall s. CI s -> s
CI.original HeaderName
name)
        , Builder
"'\n"
        ]
    go (UnexpectedHeader HeaderName
name) = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [
          Builder
"Unexpected header '"
        , ByteString -> Builder
Builder.byteString (HeaderName -> ByteString
forall s. CI s -> s
CI.original HeaderName
name)
        , Builder
"'\n"
        ]
    go (InvalidHeaderSynthesize HandledSynthesized
e InvalidHeader HandledSynthesized
_orig) =
        HandledSynthesized -> Builder
forall a. HandledSynthesized -> a
handledSynthesized HandledSynthesized
e

-- | HTTP status to report
--
-- If there are multiple headers, each of which with a mandated status, we
-- just use the first; the spec is essentially ambiguous in this case.
statusInvalidHeaders :: InvalidHeaders HandledSynthesized -> HTTP.Status
statusInvalidHeaders :: InvalidHeaders HandledSynthesized -> Status
statusInvalidHeaders (InvalidHeaders [InvalidHeader HandledSynthesized]
hs) =
    Status -> Maybe Status -> Status
forall a. a -> Maybe a -> a
fromMaybe Status
HTTP.badRequest400 (Maybe Status -> Status) -> Maybe Status -> Status
forall a b. (a -> b) -> a -> b
$ [Maybe Status] -> Maybe Status
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum ([Maybe Status] -> Maybe Status) -> [Maybe Status] -> Maybe Status
forall a b. (a -> b) -> a -> b
$ (InvalidHeader HandledSynthesized -> Maybe Status)
-> [InvalidHeader HandledSynthesized] -> [Maybe Status]
forall a b. (a -> b) -> [a] -> [b]
map InvalidHeader HandledSynthesized -> Maybe Status
getStatus [InvalidHeader HandledSynthesized]
hs
  where
    getStatus :: InvalidHeader HandledSynthesized -> Maybe HTTP.Status
    getStatus :: InvalidHeader HandledSynthesized -> Maybe Status
getStatus (InvalidHeader Maybe Status
status Header
_ String
_)        = Maybe Status
status
    getStatus (MissingHeader Maybe Status
status HeaderName
_)          = Maybe Status
status
    getStatus (UnexpectedHeader HeaderName
_)              = Maybe Status
forall a. Maybe a
Nothing
    getStatus (InvalidHeaderSynthesize HandledSynthesized
e InvalidHeader HandledSynthesized
_orig) = HandledSynthesized -> Maybe Status
forall a. HandledSynthesized -> a
handledSynthesized HandledSynthesized
e

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

wrapOne :: InvalidHeader e -> InvalidHeaders e
wrapOne :: forall e. InvalidHeader e -> InvalidHeaders e
wrapOne = [InvalidHeader e] -> InvalidHeaders e
forall e. [InvalidHeader e] -> InvalidHeaders e
InvalidHeaders ([InvalidHeader e] -> InvalidHeaders e)
-> (InvalidHeader e -> [InvalidHeader e])
-> InvalidHeader e
-> InvalidHeaders e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InvalidHeader e -> [InvalidHeader e] -> [InvalidHeader e]
forall a. a -> [a] -> [a]
:[])