-- |
-- Copyright        : (c) Raghu Kaippully, 2020
-- License          : MPL-2.0
-- Maintainer       : rkaippully@gmail.com
--
-- Middlewares related to HTTP headers.
--
module WebGear.Middlewares.Header
  ( -- * Traits
    Header
  , Header'
  , HeaderNotFound (..)
  , HeaderParseError (..)
  , HeaderMatch
  , HeaderMatch'
  , HeaderMismatch (..)

    -- * Middlewares
  , header
  , optionalHeader
  , lenientHeader
  , optionalLenientHeader
  , headerMatch
  , optionalHeaderMatch
  , requestContentTypeHeader
  , addResponseHeader
  ) where

import Control.Arrow (Kleisli (..))
import Control.Monad ((>=>))
import Data.ByteString (ByteString)
import Data.Kind (Type)
import Data.Proxy (Proxy (..))
import Data.String (fromString)
import Data.Text (Text)
import Data.Void (Void, absurd)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Network.HTTP.Types (HeaderName)
import Text.Printf (printf)
import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..))

import WebGear.Modifiers (Existence (..), ParseStyle (..))
import WebGear.Trait (Result (..), Trait (..), probe)
import WebGear.Types (MonadRouter (..), Request, RequestMiddleware', Response (..),
                      ResponseMiddleware', badRequest400, requestHeader, responseHeader,
                      setResponseHeader)

import qualified Data.ByteString.Lazy as LBS


-- | A 'Trait' for capturing an HTTP header of specified @name@ and
-- converting it to some type @val@ via 'FromHttpApiData'. The
-- modifiers @e@ and @p@ determine how missing headers and parsing
-- errors are handled. The header name is compared case-insensitively.
data Header' (e :: Existence) (p :: ParseStyle) (name :: Symbol) (val :: Type)

-- | A 'Trait' for capturing a header with name @name@ in a request or
-- response and convert it to some type @val@ via 'FromHttpApiData'.
type Header (name :: Symbol) (val :: Type) = Header' Required Strict name val

-- | Indicates a missing header
data HeaderNotFound = HeaderNotFound
  deriving stock (ReadPrec [HeaderNotFound]
ReadPrec HeaderNotFound
Int -> ReadS HeaderNotFound
ReadS [HeaderNotFound]
(Int -> ReadS HeaderNotFound)
-> ReadS [HeaderNotFound]
-> ReadPrec HeaderNotFound
-> ReadPrec [HeaderNotFound]
-> Read HeaderNotFound
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [HeaderNotFound]
$creadListPrec :: ReadPrec [HeaderNotFound]
readPrec :: ReadPrec HeaderNotFound
$creadPrec :: ReadPrec HeaderNotFound
readList :: ReadS [HeaderNotFound]
$creadList :: ReadS [HeaderNotFound]
readsPrec :: Int -> ReadS HeaderNotFound
$creadsPrec :: Int -> ReadS HeaderNotFound
Read, Int -> HeaderNotFound -> ShowS
[HeaderNotFound] -> ShowS
HeaderNotFound -> String
(Int -> HeaderNotFound -> ShowS)
-> (HeaderNotFound -> String)
-> ([HeaderNotFound] -> ShowS)
-> Show HeaderNotFound
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HeaderNotFound] -> ShowS
$cshowList :: [HeaderNotFound] -> ShowS
show :: HeaderNotFound -> String
$cshow :: HeaderNotFound -> String
showsPrec :: Int -> HeaderNotFound -> ShowS
$cshowsPrec :: Int -> HeaderNotFound -> ShowS
Show, HeaderNotFound -> HeaderNotFound -> Bool
(HeaderNotFound -> HeaderNotFound -> Bool)
-> (HeaderNotFound -> HeaderNotFound -> Bool) -> Eq HeaderNotFound
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HeaderNotFound -> HeaderNotFound -> Bool
$c/= :: HeaderNotFound -> HeaderNotFound -> Bool
== :: HeaderNotFound -> HeaderNotFound -> Bool
$c== :: HeaderNotFound -> HeaderNotFound -> Bool
Eq)

-- | Error in converting a header
newtype HeaderParseError = HeaderParseError Text
  deriving stock (ReadPrec [HeaderParseError]
ReadPrec HeaderParseError
Int -> ReadS HeaderParseError
ReadS [HeaderParseError]
(Int -> ReadS HeaderParseError)
-> ReadS [HeaderParseError]
-> ReadPrec HeaderParseError
-> ReadPrec [HeaderParseError]
-> Read HeaderParseError
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [HeaderParseError]
$creadListPrec :: ReadPrec [HeaderParseError]
readPrec :: ReadPrec HeaderParseError
$creadPrec :: ReadPrec HeaderParseError
readList :: ReadS [HeaderParseError]
$creadList :: ReadS [HeaderParseError]
readsPrec :: Int -> ReadS HeaderParseError
$creadsPrec :: Int -> ReadS HeaderParseError
Read, Int -> HeaderParseError -> ShowS
[HeaderParseError] -> ShowS
HeaderParseError -> String
(Int -> HeaderParseError -> ShowS)
-> (HeaderParseError -> String)
-> ([HeaderParseError] -> ShowS)
-> Show HeaderParseError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HeaderParseError] -> ShowS
$cshowList :: [HeaderParseError] -> ShowS
show :: HeaderParseError -> String
$cshow :: HeaderParseError -> String
showsPrec :: Int -> HeaderParseError -> ShowS
$cshowsPrec :: Int -> HeaderParseError -> ShowS
Show, HeaderParseError -> HeaderParseError -> Bool
(HeaderParseError -> HeaderParseError -> Bool)
-> (HeaderParseError -> HeaderParseError -> Bool)
-> Eq HeaderParseError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HeaderParseError -> HeaderParseError -> Bool
$c/= :: HeaderParseError -> HeaderParseError -> Bool
== :: HeaderParseError -> HeaderParseError -> Bool
$c== :: HeaderParseError -> HeaderParseError -> Bool
Eq)

deriveRequestHeader :: (KnownSymbol name, FromHttpApiData val)
                    => Proxy name -> Request -> (Maybe (Either Text val) -> r) -> r
deriveRequestHeader :: Proxy name -> Request -> (Maybe (Either Text val) -> r) -> r
deriveRequestHeader Proxy name
proxy Request
req Maybe (Either Text val) -> r
cont =
  let s :: HeaderName
s = String -> HeaderName
forall a. IsString a => String -> a
fromString (String -> HeaderName) -> String -> HeaderName
forall a b. (a -> b) -> a -> b
$ Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy name
proxy
  in Maybe (Either Text val) -> r
cont (Maybe (Either Text val) -> r) -> Maybe (Either Text val) -> r
forall a b. (a -> b) -> a -> b
$ ByteString -> Either Text val
forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader (ByteString -> Either Text val)
-> Maybe ByteString -> Maybe (Either Text val)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeaderName -> Request -> Maybe ByteString
requestHeader HeaderName
s Request
req

deriveResponseHeader :: (KnownSymbol name, FromHttpApiData val)
                    => Proxy name -> Response a -> (Maybe (Either Text val) -> r) -> r
deriveResponseHeader :: Proxy name -> Response a -> (Maybe (Either Text val) -> r) -> r
deriveResponseHeader Proxy name
proxy Response a
res Maybe (Either Text val) -> r
cont =
  let s :: HeaderName
s = String -> HeaderName
forall a. IsString a => String -> a
fromString (String -> HeaderName) -> String -> HeaderName
forall a b. (a -> b) -> a -> b
$ Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy name
proxy
  in Maybe (Either Text val) -> r
cont (Maybe (Either Text val) -> r) -> Maybe (Either Text val) -> r
forall a b. (a -> b) -> a -> b
$ ByteString -> Either Text val
forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader (ByteString -> Either Text val)
-> Maybe ByteString -> Maybe (Either Text val)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HeaderName -> Response a -> Maybe ByteString
forall a. HeaderName -> Response a -> Maybe ByteString
responseHeader HeaderName
s Response a
res


instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (Header' Required Strict name val) Request m where
  type Attribute (Header' Required Strict name val) Request = val
  type Absence (Header' Required Strict name val) Request = Either HeaderNotFound HeaderParseError

  toAttribute :: Request -> m (Result (Header' Required Strict name val) Request)
  toAttribute :: Request -> m (Result (Header' 'Required 'Strict name val) Request)
toAttribute Request
r = Result (Header' 'Required 'Strict name val) Request
-> m (Result (Header' 'Required 'Strict name val) Request)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result (Header' 'Required 'Strict name val) Request
 -> m (Result (Header' 'Required 'Strict name val) Request))
-> Result (Header' 'Required 'Strict name val) Request
-> m (Result (Header' 'Required 'Strict name val) Request)
forall a b. (a -> b) -> a -> b
$ Proxy name
-> Request
-> (Maybe (Either Text val)
    -> Result (Header' 'Required 'Strict name val) Request)
-> Result (Header' 'Required 'Strict name val) Request
forall (name :: Symbol) val r.
(KnownSymbol name, FromHttpApiData val) =>
Proxy name -> Request -> (Maybe (Either Text val) -> r) -> r
deriveRequestHeader (Proxy name
forall k (t :: k). Proxy t
Proxy @name) Request
r ((Maybe (Either Text val)
  -> Result (Header' 'Required 'Strict name val) Request)
 -> Result (Header' 'Required 'Strict name val) Request)
-> (Maybe (Either Text val)
    -> Result (Header' 'Required 'Strict name val) Request)
-> Result (Header' 'Required 'Strict name val) Request
forall a b. (a -> b) -> a -> b
$ \case
    Maybe (Either Text val)
Nothing        -> Absence (Header' 'Required 'Strict name val) Request
-> Result (Header' 'Required 'Strict name val) Request
forall k (t :: k) a. Absence t a -> Result t a
NotFound (HeaderNotFound -> Either HeaderNotFound HeaderParseError
forall a b. a -> Either a b
Left HeaderNotFound
HeaderNotFound)
    Just (Left Text
e)  -> Absence (Header' 'Required 'Strict name val) Request
-> Result (Header' 'Required 'Strict name val) Request
forall k (t :: k) a. Absence t a -> Result t a
NotFound (HeaderParseError -> Either HeaderNotFound HeaderParseError
forall a b. b -> Either a b
Right (HeaderParseError -> Either HeaderNotFound HeaderParseError)
-> HeaderParseError -> Either HeaderNotFound HeaderParseError
forall a b. (a -> b) -> a -> b
$ Text -> HeaderParseError
HeaderParseError Text
e)
    Just (Right val
x) -> Attribute (Header' 'Required 'Strict name val) Request
-> Result (Header' 'Required 'Strict name val) Request
forall k (t :: k) a. Attribute t a -> Result t a
Found val
Attribute (Header' 'Required 'Strict name val) Request
x


instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (Header' Optional Strict name val) Request m where
  type Attribute (Header' Optional Strict name val) Request = Maybe val
  type Absence (Header' Optional Strict name val) Request = HeaderParseError

  toAttribute :: Request -> m (Result (Header' Optional Strict name val) Request)
  toAttribute :: Request -> m (Result (Header' 'Optional 'Strict name val) Request)
toAttribute Request
r = Result (Header' 'Optional 'Strict name val) Request
-> m (Result (Header' 'Optional 'Strict name val) Request)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result (Header' 'Optional 'Strict name val) Request
 -> m (Result (Header' 'Optional 'Strict name val) Request))
-> Result (Header' 'Optional 'Strict name val) Request
-> m (Result (Header' 'Optional 'Strict name val) Request)
forall a b. (a -> b) -> a -> b
$ Proxy name
-> Request
-> (Maybe (Either Text val)
    -> Result (Header' 'Optional 'Strict name val) Request)
-> Result (Header' 'Optional 'Strict name val) Request
forall (name :: Symbol) val r.
(KnownSymbol name, FromHttpApiData val) =>
Proxy name -> Request -> (Maybe (Either Text val) -> r) -> r
deriveRequestHeader (Proxy name
forall k (t :: k). Proxy t
Proxy @name) Request
r ((Maybe (Either Text val)
  -> Result (Header' 'Optional 'Strict name val) Request)
 -> Result (Header' 'Optional 'Strict name val) Request)
-> (Maybe (Either Text val)
    -> Result (Header' 'Optional 'Strict name val) Request)
-> Result (Header' 'Optional 'Strict name val) Request
forall a b. (a -> b) -> a -> b
$ \case
    Maybe (Either Text val)
Nothing        -> Attribute (Header' 'Optional 'Strict name val) Request
-> Result (Header' 'Optional 'Strict name val) Request
forall k (t :: k) a. Attribute t a -> Result t a
Found Attribute (Header' 'Optional 'Strict name val) Request
forall a. Maybe a
Nothing
    Just (Left Text
e)  -> Absence (Header' 'Optional 'Strict name val) Request
-> Result (Header' 'Optional 'Strict name val) Request
forall k (t :: k) a. Absence t a -> Result t a
NotFound (Absence (Header' 'Optional 'Strict name val) Request
 -> Result (Header' 'Optional 'Strict name val) Request)
-> Absence (Header' 'Optional 'Strict name val) Request
-> Result (Header' 'Optional 'Strict name val) Request
forall a b. (a -> b) -> a -> b
$ Text -> HeaderParseError
HeaderParseError Text
e
    Just (Right val
x) -> Attribute (Header' 'Optional 'Strict name val) Request
-> Result (Header' 'Optional 'Strict name val) Request
forall k (t :: k) a. Attribute t a -> Result t a
Found (val -> Maybe val
forall a. a -> Maybe a
Just val
x)


instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (Header' Required Lenient name val) Request m where
  type Attribute (Header' Required Lenient name val) Request = Either Text val
  type Absence (Header' Required Lenient name val) Request = HeaderNotFound

  toAttribute :: Request -> m (Result (Header' Required Lenient name val) Request)
  toAttribute :: Request -> m (Result (Header' 'Required 'Lenient name val) Request)
toAttribute Request
r = Result (Header' 'Required 'Lenient name val) Request
-> m (Result (Header' 'Required 'Lenient name val) Request)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result (Header' 'Required 'Lenient name val) Request
 -> m (Result (Header' 'Required 'Lenient name val) Request))
-> Result (Header' 'Required 'Lenient name val) Request
-> m (Result (Header' 'Required 'Lenient name val) Request)
forall a b. (a -> b) -> a -> b
$ Proxy name
-> Request
-> (Maybe (Either Text val)
    -> Result (Header' 'Required 'Lenient name val) Request)
-> Result (Header' 'Required 'Lenient name val) Request
forall (name :: Symbol) val r.
(KnownSymbol name, FromHttpApiData val) =>
Proxy name -> Request -> (Maybe (Either Text val) -> r) -> r
deriveRequestHeader (Proxy name
forall k (t :: k). Proxy t
Proxy @name) Request
r ((Maybe (Either Text val)
  -> Result (Header' 'Required 'Lenient name val) Request)
 -> Result (Header' 'Required 'Lenient name val) Request)
-> (Maybe (Either Text val)
    -> Result (Header' 'Required 'Lenient name val) Request)
-> Result (Header' 'Required 'Lenient name val) Request
forall a b. (a -> b) -> a -> b
$ \case
    Maybe (Either Text val)
Nothing        -> Absence (Header' 'Required 'Lenient name val) Request
-> Result (Header' 'Required 'Lenient name val) Request
forall k (t :: k) a. Absence t a -> Result t a
NotFound Absence (Header' 'Required 'Lenient name val) Request
HeaderNotFound
HeaderNotFound
    Just (Left Text
e)  -> Attribute (Header' 'Required 'Lenient name val) Request
-> Result (Header' 'Required 'Lenient name val) Request
forall k (t :: k) a. Attribute t a -> Result t a
Found (Text -> Either Text val
forall a b. a -> Either a b
Left Text
e)
    Just (Right val
x) -> Attribute (Header' 'Required 'Lenient name val) Request
-> Result (Header' 'Required 'Lenient name val) Request
forall k (t :: k) a. Attribute t a -> Result t a
Found (val -> Either Text val
forall a b. b -> Either a b
Right val
x)


instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (Header' Optional Lenient name val) Request m where
  type Attribute (Header' Optional Lenient name val) Request = Maybe (Either Text val)
  type Absence (Header' Optional Lenient name val) Request = Void

  toAttribute :: Request -> m (Result (Header' Optional Lenient name val) Request)
  toAttribute :: Request -> m (Result (Header' 'Optional 'Lenient name val) Request)
toAttribute Request
r = Result (Header' 'Optional 'Lenient name val) Request
-> m (Result (Header' 'Optional 'Lenient name val) Request)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result (Header' 'Optional 'Lenient name val) Request
 -> m (Result (Header' 'Optional 'Lenient name val) Request))
-> Result (Header' 'Optional 'Lenient name val) Request
-> m (Result (Header' 'Optional 'Lenient name val) Request)
forall a b. (a -> b) -> a -> b
$ Proxy name
-> Request
-> (Maybe (Either Text val)
    -> Result (Header' 'Optional 'Lenient name val) Request)
-> Result (Header' 'Optional 'Lenient name val) Request
forall (name :: Symbol) val r.
(KnownSymbol name, FromHttpApiData val) =>
Proxy name -> Request -> (Maybe (Either Text val) -> r) -> r
deriveRequestHeader (Proxy name
forall k (t :: k). Proxy t
Proxy @name) Request
r ((Maybe (Either Text val)
  -> Result (Header' 'Optional 'Lenient name val) Request)
 -> Result (Header' 'Optional 'Lenient name val) Request)
-> (Maybe (Either Text val)
    -> Result (Header' 'Optional 'Lenient name val) Request)
-> Result (Header' 'Optional 'Lenient name val) Request
forall a b. (a -> b) -> a -> b
$ \case
    Maybe (Either Text val)
Nothing        -> Attribute (Header' 'Optional 'Lenient name val) Request
-> Result (Header' 'Optional 'Lenient name val) Request
forall k (t :: k) a. Attribute t a -> Result t a
Found Attribute (Header' 'Optional 'Lenient name val) Request
forall a. Maybe a
Nothing
    Just (Left Text
e)  -> Attribute (Header' 'Optional 'Lenient name val) Request
-> Result (Header' 'Optional 'Lenient name val) Request
forall k (t :: k) a. Attribute t a -> Result t a
Found (Either Text val -> Maybe (Either Text val)
forall a. a -> Maybe a
Just (Text -> Either Text val
forall a b. a -> Either a b
Left Text
e))
    Just (Right val
x) -> Attribute (Header' 'Optional 'Lenient name val) Request
-> Result (Header' 'Optional 'Lenient name val) Request
forall k (t :: k) a. Attribute t a -> Result t a
Found (Either Text val -> Maybe (Either Text val)
forall a. a -> Maybe a
Just (val -> Either Text val
forall a b. b -> Either a b
Right val
x))


instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (Header' Required Strict name val) (Response a) m where
  type Attribute (Header' Required Strict name val) (Response a) = val
  type Absence (Header' Required Strict name val) (Response a) = Either HeaderNotFound HeaderParseError

  toAttribute :: Response a -> m (Result (Header' Required Strict name val) (Response a))
  toAttribute :: Response a
-> m (Result (Header' 'Required 'Strict name val) (Response a))
toAttribute Response a
r = Result (Header' 'Required 'Strict name val) (Response a)
-> m (Result (Header' 'Required 'Strict name val) (Response a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result (Header' 'Required 'Strict name val) (Response a)
 -> m (Result (Header' 'Required 'Strict name val) (Response a)))
-> Result (Header' 'Required 'Strict name val) (Response a)
-> m (Result (Header' 'Required 'Strict name val) (Response a))
forall a b. (a -> b) -> a -> b
$ Proxy name
-> Response a
-> (Maybe (Either Text val)
    -> Result (Header' 'Required 'Strict name val) (Response a))
-> Result (Header' 'Required 'Strict name val) (Response a)
forall (name :: Symbol) val a r.
(KnownSymbol name, FromHttpApiData val) =>
Proxy name -> Response a -> (Maybe (Either Text val) -> r) -> r
deriveResponseHeader (Proxy name
forall k (t :: k). Proxy t
Proxy @name) Response a
r ((Maybe (Either Text val)
  -> Result (Header' 'Required 'Strict name val) (Response a))
 -> Result (Header' 'Required 'Strict name val) (Response a))
-> (Maybe (Either Text val)
    -> Result (Header' 'Required 'Strict name val) (Response a))
-> Result (Header' 'Required 'Strict name val) (Response a)
forall a b. (a -> b) -> a -> b
$ \case
    Maybe (Either Text val)
Nothing        -> Absence (Header' 'Required 'Strict name val) (Response a)
-> Result (Header' 'Required 'Strict name val) (Response a)
forall k (t :: k) a. Absence t a -> Result t a
NotFound (HeaderNotFound -> Either HeaderNotFound HeaderParseError
forall a b. a -> Either a b
Left HeaderNotFound
HeaderNotFound)
    Just (Left Text
e)  -> Absence (Header' 'Required 'Strict name val) (Response a)
-> Result (Header' 'Required 'Strict name val) (Response a)
forall k (t :: k) a. Absence t a -> Result t a
NotFound (HeaderParseError -> Either HeaderNotFound HeaderParseError
forall a b. b -> Either a b
Right (HeaderParseError -> Either HeaderNotFound HeaderParseError)
-> HeaderParseError -> Either HeaderNotFound HeaderParseError
forall a b. (a -> b) -> a -> b
$ Text -> HeaderParseError
HeaderParseError Text
e)
    Just (Right val
x) -> Attribute (Header' 'Required 'Strict name val) (Response a)
-> Result (Header' 'Required 'Strict name val) (Response a)
forall k (t :: k) a. Attribute t a -> Result t a
Found val
Attribute (Header' 'Required 'Strict name val) (Response a)
x


instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (Header' Optional Strict name val) (Response a) m where
  type Attribute (Header' Optional Strict name val) (Response a) = Maybe val
  type Absence (Header' Optional Strict name val) (Response a) = HeaderParseError

  toAttribute :: Response a -> m (Result (Header' Optional Strict name val) (Response a))
  toAttribute :: Response a
-> m (Result (Header' 'Optional 'Strict name val) (Response a))
toAttribute Response a
r = Result (Header' 'Optional 'Strict name val) (Response a)
-> m (Result (Header' 'Optional 'Strict name val) (Response a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result (Header' 'Optional 'Strict name val) (Response a)
 -> m (Result (Header' 'Optional 'Strict name val) (Response a)))
-> Result (Header' 'Optional 'Strict name val) (Response a)
-> m (Result (Header' 'Optional 'Strict name val) (Response a))
forall a b. (a -> b) -> a -> b
$ Proxy name
-> Response a
-> (Maybe (Either Text val)
    -> Result (Header' 'Optional 'Strict name val) (Response a))
-> Result (Header' 'Optional 'Strict name val) (Response a)
forall (name :: Symbol) val a r.
(KnownSymbol name, FromHttpApiData val) =>
Proxy name -> Response a -> (Maybe (Either Text val) -> r) -> r
deriveResponseHeader (Proxy name
forall k (t :: k). Proxy t
Proxy @name) Response a
r ((Maybe (Either Text val)
  -> Result (Header' 'Optional 'Strict name val) (Response a))
 -> Result (Header' 'Optional 'Strict name val) (Response a))
-> (Maybe (Either Text val)
    -> Result (Header' 'Optional 'Strict name val) (Response a))
-> Result (Header' 'Optional 'Strict name val) (Response a)
forall a b. (a -> b) -> a -> b
$ \case
    Maybe (Either Text val)
Nothing        -> Attribute (Header' 'Optional 'Strict name val) (Response a)
-> Result (Header' 'Optional 'Strict name val) (Response a)
forall k (t :: k) a. Attribute t a -> Result t a
Found Attribute (Header' 'Optional 'Strict name val) (Response a)
forall a. Maybe a
Nothing
    Just (Left Text
e)  -> Absence (Header' 'Optional 'Strict name val) (Response a)
-> Result (Header' 'Optional 'Strict name val) (Response a)
forall k (t :: k) a. Absence t a -> Result t a
NotFound (Absence (Header' 'Optional 'Strict name val) (Response a)
 -> Result (Header' 'Optional 'Strict name val) (Response a))
-> Absence (Header' 'Optional 'Strict name val) (Response a)
-> Result (Header' 'Optional 'Strict name val) (Response a)
forall a b. (a -> b) -> a -> b
$ Text -> HeaderParseError
HeaderParseError Text
e
    Just (Right val
x) -> Attribute (Header' 'Optional 'Strict name val) (Response a)
-> Result (Header' 'Optional 'Strict name val) (Response a)
forall k (t :: k) a. Attribute t a -> Result t a
Found (val -> Maybe val
forall a. a -> Maybe a
Just val
x)


instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (Header' Required Lenient name val) (Response a) m where
  type Attribute (Header' Required Lenient name val) (Response a) = Either Text val
  type Absence (Header' Required Lenient name val) (Response a) = HeaderNotFound

  toAttribute :: Response a -> m (Result (Header' Required Lenient name val) (Response a))
  toAttribute :: Response a
-> m (Result (Header' 'Required 'Lenient name val) (Response a))
toAttribute Response a
r = Result (Header' 'Required 'Lenient name val) (Response a)
-> m (Result (Header' 'Required 'Lenient name val) (Response a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result (Header' 'Required 'Lenient name val) (Response a)
 -> m (Result (Header' 'Required 'Lenient name val) (Response a)))
-> Result (Header' 'Required 'Lenient name val) (Response a)
-> m (Result (Header' 'Required 'Lenient name val) (Response a))
forall a b. (a -> b) -> a -> b
$ Proxy name
-> Response a
-> (Maybe (Either Text val)
    -> Result (Header' 'Required 'Lenient name val) (Response a))
-> Result (Header' 'Required 'Lenient name val) (Response a)
forall (name :: Symbol) val a r.
(KnownSymbol name, FromHttpApiData val) =>
Proxy name -> Response a -> (Maybe (Either Text val) -> r) -> r
deriveResponseHeader (Proxy name
forall k (t :: k). Proxy t
Proxy @name) Response a
r ((Maybe (Either Text val)
  -> Result (Header' 'Required 'Lenient name val) (Response a))
 -> Result (Header' 'Required 'Lenient name val) (Response a))
-> (Maybe (Either Text val)
    -> Result (Header' 'Required 'Lenient name val) (Response a))
-> Result (Header' 'Required 'Lenient name val) (Response a)
forall a b. (a -> b) -> a -> b
$ \case
    Maybe (Either Text val)
Nothing        -> Absence (Header' 'Required 'Lenient name val) (Response a)
-> Result (Header' 'Required 'Lenient name val) (Response a)
forall k (t :: k) a. Absence t a -> Result t a
NotFound Absence (Header' 'Required 'Lenient name val) (Response a)
HeaderNotFound
HeaderNotFound
    Just (Left Text
e)  -> Attribute (Header' 'Required 'Lenient name val) (Response a)
-> Result (Header' 'Required 'Lenient name val) (Response a)
forall k (t :: k) a. Attribute t a -> Result t a
Found (Text -> Either Text val
forall a b. a -> Either a b
Left Text
e)
    Just (Right val
x) -> Attribute (Header' 'Required 'Lenient name val) (Response a)
-> Result (Header' 'Required 'Lenient name val) (Response a)
forall k (t :: k) a. Attribute t a -> Result t a
Found (val -> Either Text val
forall a b. b -> Either a b
Right val
x)


instance (KnownSymbol name, FromHttpApiData val, Monad m) => Trait (Header' Optional Lenient name val) (Response a) m where
  type Attribute (Header' Optional Lenient name val) (Response a) = Maybe (Either Text val)
  type Absence (Header' Optional Lenient name val) (Response a) = ()

  toAttribute :: Response a -> m (Result (Header' Optional Lenient name val) (Response a))
  toAttribute :: Response a
-> m (Result (Header' 'Optional 'Lenient name val) (Response a))
toAttribute Response a
r = Result (Header' 'Optional 'Lenient name val) (Response a)
-> m (Result (Header' 'Optional 'Lenient name val) (Response a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result (Header' 'Optional 'Lenient name val) (Response a)
 -> m (Result (Header' 'Optional 'Lenient name val) (Response a)))
-> Result (Header' 'Optional 'Lenient name val) (Response a)
-> m (Result (Header' 'Optional 'Lenient name val) (Response a))
forall a b. (a -> b) -> a -> b
$ Proxy name
-> Response a
-> (Maybe (Either Text val)
    -> Result (Header' 'Optional 'Lenient name val) (Response a))
-> Result (Header' 'Optional 'Lenient name val) (Response a)
forall (name :: Symbol) val a r.
(KnownSymbol name, FromHttpApiData val) =>
Proxy name -> Response a -> (Maybe (Either Text val) -> r) -> r
deriveResponseHeader (Proxy name
forall k (t :: k). Proxy t
Proxy @name) Response a
r ((Maybe (Either Text val)
  -> Result (Header' 'Optional 'Lenient name val) (Response a))
 -> Result (Header' 'Optional 'Lenient name val) (Response a))
-> (Maybe (Either Text val)
    -> Result (Header' 'Optional 'Lenient name val) (Response a))
-> Result (Header' 'Optional 'Lenient name val) (Response a)
forall a b. (a -> b) -> a -> b
$ \case
    Maybe (Either Text val)
Nothing        -> Attribute (Header' 'Optional 'Lenient name val) (Response a)
-> Result (Header' 'Optional 'Lenient name val) (Response a)
forall k (t :: k) a. Attribute t a -> Result t a
Found Attribute (Header' 'Optional 'Lenient name val) (Response a)
forall a. Maybe a
Nothing
    Just (Left Text
e)  -> Attribute (Header' 'Optional 'Lenient name val) (Response a)
-> Result (Header' 'Optional 'Lenient name val) (Response a)
forall k (t :: k) a. Attribute t a -> Result t a
Found (Either Text val -> Maybe (Either Text val)
forall a. a -> Maybe a
Just (Text -> Either Text val
forall a b. a -> Either a b
Left Text
e))
    Just (Right val
x) -> Attribute (Header' 'Optional 'Lenient name val) (Response a)
-> Result (Header' 'Optional 'Lenient name val) (Response a)
forall k (t :: k) a. Attribute t a -> Result t a
Found (Either Text val -> Maybe (Either Text val)
forall a. a -> Maybe a
Just (val -> Either Text val
forall a b. b -> Either a b
Right val
x))


-- | A 'Trait' for ensuring that an HTTP header with specified @name@
-- has value @val@. The modifier @e@ determines how missing headers
-- are handled. The header name is compared case-insensitively.
data HeaderMatch' (e :: Existence) (name :: Symbol) (val :: Symbol)

-- | A 'Trait' for ensuring that a header with a specified @name@ has
-- value @val@.
type HeaderMatch (name :: Symbol) (val :: Symbol) = HeaderMatch' Required name val

-- | Failure in extracting a header value
data HeaderMismatch = HeaderMismatch
  { HeaderMismatch -> ByteString
expectedHeader :: ByteString
  , HeaderMismatch -> ByteString
actualHeader   :: ByteString
  }
  deriving stock (HeaderMismatch -> HeaderMismatch -> Bool
(HeaderMismatch -> HeaderMismatch -> Bool)
-> (HeaderMismatch -> HeaderMismatch -> Bool) -> Eq HeaderMismatch
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HeaderMismatch -> HeaderMismatch -> Bool
$c/= :: HeaderMismatch -> HeaderMismatch -> Bool
== :: HeaderMismatch -> HeaderMismatch -> Bool
$c== :: HeaderMismatch -> HeaderMismatch -> Bool
Eq, ReadPrec [HeaderMismatch]
ReadPrec HeaderMismatch
Int -> ReadS HeaderMismatch
ReadS [HeaderMismatch]
(Int -> ReadS HeaderMismatch)
-> ReadS [HeaderMismatch]
-> ReadPrec HeaderMismatch
-> ReadPrec [HeaderMismatch]
-> Read HeaderMismatch
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [HeaderMismatch]
$creadListPrec :: ReadPrec [HeaderMismatch]
readPrec :: ReadPrec HeaderMismatch
$creadPrec :: ReadPrec HeaderMismatch
readList :: ReadS [HeaderMismatch]
$creadList :: ReadS [HeaderMismatch]
readsPrec :: Int -> ReadS HeaderMismatch
$creadsPrec :: Int -> ReadS HeaderMismatch
Read, Int -> HeaderMismatch -> ShowS
[HeaderMismatch] -> ShowS
HeaderMismatch -> String
(Int -> HeaderMismatch -> ShowS)
-> (HeaderMismatch -> String)
-> ([HeaderMismatch] -> ShowS)
-> Show HeaderMismatch
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HeaderMismatch] -> ShowS
$cshowList :: [HeaderMismatch] -> ShowS
show :: HeaderMismatch -> String
$cshow :: HeaderMismatch -> String
showsPrec :: Int -> HeaderMismatch -> ShowS
$cshowsPrec :: Int -> HeaderMismatch -> ShowS
Show)


instance (KnownSymbol name, KnownSymbol val, Monad m) => Trait (HeaderMatch' Required name val) Request m where
  type Attribute (HeaderMatch' Required name val) Request = ()
  type Absence (HeaderMatch' Required name val) Request = Maybe HeaderMismatch

  toAttribute :: Request -> m (Result (HeaderMatch' Required name val) Request)
  toAttribute :: Request -> m (Result (HeaderMatch' 'Required name val) Request)
toAttribute Request
r = Result (HeaderMatch' 'Required name val) Request
-> m (Result (HeaderMatch' 'Required name val) Request)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result (HeaderMatch' 'Required name val) Request
 -> m (Result (HeaderMatch' 'Required name val) Request))
-> Result (HeaderMatch' 'Required name val) Request
-> m (Result (HeaderMatch' 'Required name val) Request)
forall a b. (a -> b) -> a -> b
$
    let
      name :: HeaderName
name = String -> HeaderName
forall a. IsString a => String -> a
fromString (String -> HeaderName) -> String -> HeaderName
forall a b. (a -> b) -> a -> b
$ Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy name
forall k (t :: k). Proxy t
Proxy @name)
      expected :: ByteString
expected = String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Proxy val -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy val
forall k (t :: k). Proxy t
Proxy @val)
    in
      case HeaderName -> Request -> Maybe ByteString
requestHeader HeaderName
name Request
r of
        Maybe ByteString
Nothing                  -> Absence (HeaderMatch' 'Required name val) Request
-> Result (HeaderMatch' 'Required name val) Request
forall k (t :: k) a. Absence t a -> Result t a
NotFound Absence (HeaderMatch' 'Required name val) Request
forall a. Maybe a
Nothing
        Just ByteString
hv | ByteString
hv ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
expected -> Attribute (HeaderMatch' 'Required name val) Request
-> Result (HeaderMatch' 'Required name val) Request
forall k (t :: k) a. Attribute t a -> Result t a
Found ()
                | Bool
otherwise      -> Absence (HeaderMatch' 'Required name val) Request
-> Result (HeaderMatch' 'Required name val) Request
forall k (t :: k) a. Absence t a -> Result t a
NotFound (Absence (HeaderMatch' 'Required name val) Request
 -> Result (HeaderMatch' 'Required name val) Request)
-> Absence (HeaderMatch' 'Required name val) Request
-> Result (HeaderMatch' 'Required name val) Request
forall a b. (a -> b) -> a -> b
$ HeaderMismatch -> Maybe HeaderMismatch
forall a. a -> Maybe a
Just HeaderMismatch :: ByteString -> ByteString -> HeaderMismatch
HeaderMismatch {expectedHeader :: ByteString
expectedHeader = ByteString
expected, actualHeader :: ByteString
actualHeader = ByteString
hv}

instance (KnownSymbol name, KnownSymbol val, Monad m) => Trait (HeaderMatch' Optional name val) Request m where
  type Attribute (HeaderMatch' Optional name val) Request = Maybe ()
  type Absence (HeaderMatch' Optional name val) Request = HeaderMismatch

  toAttribute :: Request -> m (Result (HeaderMatch' Optional name val) Request)
  toAttribute :: Request -> m (Result (HeaderMatch' 'Optional name val) Request)
toAttribute Request
r = Result (HeaderMatch' 'Optional name val) Request
-> m (Result (HeaderMatch' 'Optional name val) Request)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result (HeaderMatch' 'Optional name val) Request
 -> m (Result (HeaderMatch' 'Optional name val) Request))
-> Result (HeaderMatch' 'Optional name val) Request
-> m (Result (HeaderMatch' 'Optional name val) Request)
forall a b. (a -> b) -> a -> b
$
    let
      name :: HeaderName
name = String -> HeaderName
forall a. IsString a => String -> a
fromString (String -> HeaderName) -> String -> HeaderName
forall a b. (a -> b) -> a -> b
$ Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy name
forall k (t :: k). Proxy t
Proxy @name)
      expected :: ByteString
expected = String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Proxy val -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy val
forall k (t :: k). Proxy t
Proxy @val)
    in
      case HeaderName -> Request -> Maybe ByteString
requestHeader HeaderName
name Request
r of
        Maybe ByteString
Nothing                  -> Attribute (HeaderMatch' 'Optional name val) Request
-> Result (HeaderMatch' 'Optional name val) Request
forall k (t :: k) a. Attribute t a -> Result t a
Found Attribute (HeaderMatch' 'Optional name val) Request
forall a. Maybe a
Nothing
        Just ByteString
hv | ByteString
hv ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
expected -> Attribute (HeaderMatch' 'Optional name val) Request
-> Result (HeaderMatch' 'Optional name val) Request
forall k (t :: k) a. Attribute t a -> Result t a
Found (() -> Maybe ()
forall a. a -> Maybe a
Just ())
                | Bool
otherwise      -> Absence (HeaderMatch' 'Optional name val) Request
-> Result (HeaderMatch' 'Optional name val) Request
forall k (t :: k) a. Absence t a -> Result t a
NotFound HeaderMismatch :: ByteString -> ByteString -> HeaderMismatch
HeaderMismatch {expectedHeader :: ByteString
expectedHeader = ByteString
expected, actualHeader :: ByteString
actualHeader = ByteString
hv}


-- | A middleware to extract a header value and convert it to a value
-- of type @val@ using 'FromHttpApiData'.
--
-- Example usage:
--
-- > header @"Content-Length" @Integer handler
--
-- The associated trait attribute has type @val@. A 400 Bad Request
-- response is returned if the header is not found or could not be
-- parsed.
header :: forall name val m req a.
          (KnownSymbol name, FromHttpApiData val, MonadRouter m)
       => RequestMiddleware' m req (Header name val:req) a
header :: RequestMiddleware' m req (Header name val : req) a
header Handler' m (Header name val : req) a
handler = (Linked req Request -> m (Response a))
-> Kleisli m (Linked req Request) (Response a)
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli ((Linked req Request -> m (Response a))
 -> Kleisli m (Linked req Request) (Response a))
-> (Linked req Request -> m (Response a))
-> Kleisli m (Linked req Request) (Response a)
forall a b. (a -> b) -> a -> b
$
  forall (ts :: [*]) a (m :: * -> *).
Trait (Header name val) a m =>
Linked ts a
-> m (Either
        (Absence (Header name val) a) (Linked (Header name val : ts) a))
forall t (ts :: [*]) a (m :: * -> *).
Trait t a m =>
Linked ts a -> m (Either (Absence t a) (Linked (t : ts) a))
probe @(Header name val) (Linked req Request
 -> m (Either
         (Either HeaderNotFound HeaderParseError)
         (Linked (Header name val : req) Request)))
-> (Either
      (Either HeaderNotFound HeaderParseError)
      (Linked (Header name val : req) Request)
    -> m (Response a))
-> Linked req Request
-> m (Response a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (Either HeaderNotFound HeaderParseError -> m (Response a))
-> (Linked (Header name val : req) Request -> m (Response a))
-> Either
     (Either HeaderNotFound HeaderParseError)
     (Linked (Header name val : req) Request)
-> m (Response a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Response ByteString -> m (Response a)
forall (m :: * -> *) a. MonadRouter m => Response ByteString -> m a
errorResponse (Response ByteString -> m (Response a))
-> (Either HeaderNotFound HeaderParseError -> Response ByteString)
-> Either HeaderNotFound HeaderParseError
-> m (Response a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either HeaderNotFound HeaderParseError -> Response ByteString
mkError) (Handler' m (Header name val : req) a
-> Linked (Header name val : req) Request -> m (Response a)
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli Handler' m (Header name val : req) a
handler)
  where
    headerName :: String
    headerName :: String
headerName = Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy name -> String) -> Proxy name -> String
forall a b. (a -> b) -> a -> b
$ Proxy name
forall k (t :: k). Proxy t
Proxy @name

    mkError :: Either HeaderNotFound HeaderParseError -> Response LBS.ByteString
    mkError :: Either HeaderNotFound HeaderParseError -> Response ByteString
mkError (Left HeaderNotFound
HeaderNotFound) = ByteString -> Response ByteString
forall a. a -> Response a
badRequest400 (ByteString -> Response ByteString)
-> ByteString -> Response ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Could not find header %s" String
headerName
    mkError (Right (HeaderParseError Text
_)) = ByteString -> Response ByteString
forall a. a -> Response a
badRequest400 (ByteString -> Response ByteString)
-> ByteString -> Response ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$
      String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Invalid value for header %s" String
headerName

-- | A middleware to extract a header value and convert it to a value
-- of type @val@ using 'FromHttpApiData'.
--
-- Example usage:
--
-- > optionalHeader @"Content-Length" @Integer handler
--
-- The associated trait attribute has type @Maybe val@; a @Nothing@
-- value indicates that the header is missing from the request. A 400
-- Bad Request response is returned if the header could not be parsed.
optionalHeader :: forall name val m req a.
                  (KnownSymbol name, FromHttpApiData val, MonadRouter m)
               => RequestMiddleware' m req (Header' Optional Strict name val:req) a
optionalHeader :: RequestMiddleware'
  m req (Header' 'Optional 'Strict name val : req) a
optionalHeader Handler' m (Header' 'Optional 'Strict name val : req) a
handler = (Linked req Request -> m (Response a))
-> Kleisli m (Linked req Request) (Response a)
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli ((Linked req Request -> m (Response a))
 -> Kleisli m (Linked req Request) (Response a))
-> (Linked req Request -> m (Response a))
-> Kleisli m (Linked req Request) (Response a)
forall a b. (a -> b) -> a -> b
$
  forall (ts :: [*]) a (m :: * -> *).
Trait (Header' 'Optional 'Strict name val) a m =>
Linked ts a
-> m (Either
        (Absence (Header' 'Optional 'Strict name val) a)
        (Linked (Header' 'Optional 'Strict name val : ts) a))
forall t (ts :: [*]) a (m :: * -> *).
Trait t a m =>
Linked ts a -> m (Either (Absence t a) (Linked (t : ts) a))
probe @(Header' Optional Strict name val) (Linked req Request
 -> m (Either
         HeaderParseError
         (Linked (Header' 'Optional 'Strict name val : req) Request)))
-> (Either
      HeaderParseError
      (Linked (Header' 'Optional 'Strict name val : req) Request)
    -> m (Response a))
-> Linked req Request
-> m (Response a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (HeaderParseError -> m (Response a))
-> (Linked (Header' 'Optional 'Strict name val : req) Request
    -> m (Response a))
-> Either
     HeaderParseError
     (Linked (Header' 'Optional 'Strict name val : req) Request)
-> m (Response a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Response ByteString -> m (Response a)
forall (m :: * -> *) a. MonadRouter m => Response ByteString -> m a
errorResponse (Response ByteString -> m (Response a))
-> (HeaderParseError -> Response ByteString)
-> HeaderParseError
-> m (Response a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderParseError -> Response ByteString
mkError) (Handler' m (Header' 'Optional 'Strict name val : req) a
-> Linked (Header' 'Optional 'Strict name val : req) Request
-> m (Response a)
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli Handler' m (Header' 'Optional 'Strict name val : req) a
handler)
  where
    headerName :: String
    headerName :: String
headerName = Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy name -> String) -> Proxy name -> String
forall a b. (a -> b) -> a -> b
$ Proxy name
forall k (t :: k). Proxy t
Proxy @name

    mkError :: HeaderParseError -> Response LBS.ByteString
    mkError :: HeaderParseError -> Response ByteString
mkError (HeaderParseError Text
_) = ByteString -> Response ByteString
forall a. a -> Response a
badRequest400 (ByteString -> Response ByteString)
-> ByteString -> Response ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$
      String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Invalid value for header %s" String
headerName

-- | A middleware to extract a header value and convert it to a value
-- of type @val@ using 'FromHttpApiData'.
--
-- Example usage:
--
-- > lenientHeader @"Content-Length" @Integer handler
--
-- The associated trait attribute has type @Either Text val@. A 400
-- Bad Request reponse is returned if the header is missing. The
-- parsing is done leniently; the trait attribute is set to @Left
-- Text@ in case of parse errors or @Right val@ on success.
lenientHeader :: forall name val m req a.
                 (KnownSymbol name, FromHttpApiData val, MonadRouter m)
              => RequestMiddleware' m req (Header' Required Lenient name val:req) a
lenientHeader :: RequestMiddleware'
  m req (Header' 'Required 'Lenient name val : req) a
lenientHeader Handler' m (Header' 'Required 'Lenient name val : req) a
handler = (Linked req Request -> m (Response a))
-> Kleisli m (Linked req Request) (Response a)
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli ((Linked req Request -> m (Response a))
 -> Kleisli m (Linked req Request) (Response a))
-> (Linked req Request -> m (Response a))
-> Kleisli m (Linked req Request) (Response a)
forall a b. (a -> b) -> a -> b
$
  forall (ts :: [*]) a (m :: * -> *).
Trait (Header' 'Required 'Lenient name val) a m =>
Linked ts a
-> m (Either
        (Absence (Header' 'Required 'Lenient name val) a)
        (Linked (Header' 'Required 'Lenient name val : ts) a))
forall t (ts :: [*]) a (m :: * -> *).
Trait t a m =>
Linked ts a -> m (Either (Absence t a) (Linked (t : ts) a))
probe @(Header' Required Lenient name val) (Linked req Request
 -> m (Either
         HeaderNotFound
         (Linked (Header' 'Required 'Lenient name val : req) Request)))
-> (Either
      HeaderNotFound
      (Linked (Header' 'Required 'Lenient name val : req) Request)
    -> m (Response a))
-> Linked req Request
-> m (Response a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (HeaderNotFound -> m (Response a))
-> (Linked (Header' 'Required 'Lenient name val : req) Request
    -> m (Response a))
-> Either
     HeaderNotFound
     (Linked (Header' 'Required 'Lenient name val : req) Request)
-> m (Response a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Response ByteString -> m (Response a)
forall (m :: * -> *) a. MonadRouter m => Response ByteString -> m a
errorResponse (Response ByteString -> m (Response a))
-> (HeaderNotFound -> Response ByteString)
-> HeaderNotFound
-> m (Response a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderNotFound -> Response ByteString
mkError) (Handler' m (Header' 'Required 'Lenient name val : req) a
-> Linked (Header' 'Required 'Lenient name val : req) Request
-> m (Response a)
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli Handler' m (Header' 'Required 'Lenient name val : req) a
handler)
  where
    headerName :: String
    headerName :: String
headerName = Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy name -> String) -> Proxy name -> String
forall a b. (a -> b) -> a -> b
$ Proxy name
forall k (t :: k). Proxy t
Proxy @name

    mkError :: HeaderNotFound -> Response LBS.ByteString
    mkError :: HeaderNotFound -> Response ByteString
mkError HeaderNotFound
HeaderNotFound = ByteString -> Response ByteString
forall a. a -> Response a
badRequest400 (ByteString -> Response ByteString)
-> ByteString -> Response ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Could not find header %s" String
headerName

-- | A middleware to extract an optional header value and convert it
-- to a value of type @val@ using 'FromHttpApiData'.
--
-- Example usage:
--
-- > optionalLenientHeader @"Content-Length" @Integer handler
--
-- The associated trait attribute has type @Maybe (Either Text
-- val)@. This middleware never fails.
optionalLenientHeader :: forall name val m req a.
                         (KnownSymbol name, FromHttpApiData val, MonadRouter m)
                      => RequestMiddleware' m req (Header' Optional Lenient name val:req) a
optionalLenientHeader :: RequestMiddleware'
  m req (Header' 'Optional 'Lenient name val : req) a
optionalLenientHeader Handler' m (Header' 'Optional 'Lenient name val : req) a
handler = (Linked req Request -> m (Response a))
-> Kleisli m (Linked req Request) (Response a)
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli ((Linked req Request -> m (Response a))
 -> Kleisli m (Linked req Request) (Response a))
-> (Linked req Request -> m (Response a))
-> Kleisli m (Linked req Request) (Response a)
forall a b. (a -> b) -> a -> b
$
  forall (ts :: [*]) a (m :: * -> *).
Trait (Header' 'Optional 'Lenient name val) a m =>
Linked ts a
-> m (Either
        (Absence (Header' 'Optional 'Lenient name val) a)
        (Linked (Header' 'Optional 'Lenient name val : ts) a))
forall t (ts :: [*]) a (m :: * -> *).
Trait t a m =>
Linked ts a -> m (Either (Absence t a) (Linked (t : ts) a))
probe @(Header' Optional Lenient name val) (Linked req Request
 -> m (Either
         Void (Linked (Header' 'Optional 'Lenient name val : req) Request)))
-> (Either
      Void (Linked (Header' 'Optional 'Lenient name val : req) Request)
    -> m (Response a))
-> Linked req Request
-> m (Response a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (Void -> m (Response a))
-> (Linked (Header' 'Optional 'Lenient name val : req) Request
    -> m (Response a))
-> Either
     Void (Linked (Header' 'Optional 'Lenient name val : req) Request)
-> m (Response a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Void -> m (Response a)
forall a. Void -> a
absurd (Handler' m (Header' 'Optional 'Lenient name val : req) a
-> Linked (Header' 'Optional 'Lenient name val : req) Request
-> m (Response a)
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli Handler' m (Header' 'Optional 'Lenient name val : req) a
handler)

-- | A middleware to ensure that a header in the request has a
-- specific value. Fails the handler with a 400 Bad Request response
-- if the header does not exist or does not match.
headerMatch :: forall name val m req a.
               (KnownSymbol name, KnownSymbol val, MonadRouter m)
            => RequestMiddleware' m req (HeaderMatch name val:req) a
headerMatch :: RequestMiddleware' m req (HeaderMatch name val : req) a
headerMatch Handler' m (HeaderMatch name val : req) a
handler = (Linked req Request -> m (Response a))
-> Kleisli m (Linked req Request) (Response a)
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli ((Linked req Request -> m (Response a))
 -> Kleisli m (Linked req Request) (Response a))
-> (Linked req Request -> m (Response a))
-> Kleisli m (Linked req Request) (Response a)
forall a b. (a -> b) -> a -> b
$
  forall (ts :: [*]) a (m :: * -> *).
Trait (HeaderMatch name val) a m =>
Linked ts a
-> m (Either
        (Absence (HeaderMatch name val) a)
        (Linked (HeaderMatch name val : ts) a))
forall t (ts :: [*]) a (m :: * -> *).
Trait t a m =>
Linked ts a -> m (Either (Absence t a) (Linked (t : ts) a))
probe @(HeaderMatch name val) (Linked req Request
 -> m (Either
         (Maybe HeaderMismatch)
         (Linked (HeaderMatch name val : req) Request)))
-> (Either
      (Maybe HeaderMismatch)
      (Linked (HeaderMatch name val : req) Request)
    -> m (Response a))
-> Linked req Request
-> m (Response a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (Maybe HeaderMismatch -> m (Response a))
-> (Linked (HeaderMatch name val : req) Request -> m (Response a))
-> Either
     (Maybe HeaderMismatch)
     (Linked (HeaderMatch name val : req) Request)
-> m (Response a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Response ByteString -> m (Response a)
forall (m :: * -> *) a. MonadRouter m => Response ByteString -> m a
errorResponse (Response ByteString -> m (Response a))
-> (Maybe HeaderMismatch -> Response ByteString)
-> Maybe HeaderMismatch
-> m (Response a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe HeaderMismatch -> Response ByteString
mkError) (Handler' m (HeaderMatch name val : req) a
-> Linked (HeaderMatch name val : req) Request -> m (Response a)
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli Handler' m (HeaderMatch name val : req) a
handler)
  where
    headerName :: String
    headerName :: String
headerName = Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy name -> String) -> Proxy name -> String
forall a b. (a -> b) -> a -> b
$ Proxy name
forall k (t :: k). Proxy t
Proxy @name

    mkError :: Maybe HeaderMismatch -> Response LBS.ByteString
    mkError :: Maybe HeaderMismatch -> Response ByteString
mkError Maybe HeaderMismatch
Nothing  = ByteString -> Response ByteString
forall a. a -> Response a
badRequest400 (ByteString -> Response ByteString)
-> ByteString -> Response ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Could not find header %s" String
headerName
    mkError (Just HeaderMismatch
e) = ByteString -> Response ByteString
forall a. a -> Response a
badRequest400 (ByteString -> Response ByteString)
-> ByteString -> Response ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$
      String -> String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Expected header %s to have value %s but found %s" String
headerName (ByteString -> String
forall a. Show a => a -> String
show (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ HeaderMismatch -> ByteString
expectedHeader HeaderMismatch
e) (ByteString -> String
forall a. Show a => a -> String
show (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ HeaderMismatch -> ByteString
actualHeader HeaderMismatch
e)

-- | A middleware to ensure that an optional header in the request has
-- a specific value. Fails the handler with a 400 Bad Request response
-- if the header has a different value.
optionalHeaderMatch :: forall name val m req a.
                       (KnownSymbol name, KnownSymbol val, MonadRouter m)
                    => RequestMiddleware' m req (HeaderMatch' Optional name val:req) a
optionalHeaderMatch :: RequestMiddleware' m req (HeaderMatch' 'Optional name val : req) a
optionalHeaderMatch Handler' m (HeaderMatch' 'Optional name val : req) a
handler = (Linked req Request -> m (Response a))
-> Kleisli m (Linked req Request) (Response a)
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli ((Linked req Request -> m (Response a))
 -> Kleisli m (Linked req Request) (Response a))
-> (Linked req Request -> m (Response a))
-> Kleisli m (Linked req Request) (Response a)
forall a b. (a -> b) -> a -> b
$
  forall (ts :: [*]) a (m :: * -> *).
Trait (HeaderMatch' 'Optional name val) a m =>
Linked ts a
-> m (Either
        (Absence (HeaderMatch' 'Optional name val) a)
        (Linked (HeaderMatch' 'Optional name val : ts) a))
forall t (ts :: [*]) a (m :: * -> *).
Trait t a m =>
Linked ts a -> m (Either (Absence t a) (Linked (t : ts) a))
probe @(HeaderMatch' Optional name val) (Linked req Request
 -> m (Either
         HeaderMismatch
         (Linked (HeaderMatch' 'Optional name val : req) Request)))
-> (Either
      HeaderMismatch
      (Linked (HeaderMatch' 'Optional name val : req) Request)
    -> m (Response a))
-> Linked req Request
-> m (Response a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (HeaderMismatch -> m (Response a))
-> (Linked (HeaderMatch' 'Optional name val : req) Request
    -> m (Response a))
-> Either
     HeaderMismatch
     (Linked (HeaderMatch' 'Optional name val : req) Request)
-> m (Response a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Response ByteString -> m (Response a)
forall (m :: * -> *) a. MonadRouter m => Response ByteString -> m a
errorResponse (Response ByteString -> m (Response a))
-> (HeaderMismatch -> Response ByteString)
-> HeaderMismatch
-> m (Response a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderMismatch -> Response ByteString
mkError) (Handler' m (HeaderMatch' 'Optional name val : req) a
-> Linked (HeaderMatch' 'Optional name val : req) Request
-> m (Response a)
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli Handler' m (HeaderMatch' 'Optional name val : req) a
handler)
  where
    headerName :: String
    headerName :: String
headerName = Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy name -> String) -> Proxy name -> String
forall a b. (a -> b) -> a -> b
$ Proxy name
forall k (t :: k). Proxy t
Proxy @name

    mkError :: HeaderMismatch -> Response LBS.ByteString
    mkError :: HeaderMismatch -> Response ByteString
mkError HeaderMismatch
e = ByteString -> Response ByteString
forall a. a -> Response a
badRequest400 (ByteString -> Response ByteString)
-> ByteString -> Response ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$
      String -> String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Expected header %s to have value %s but found %s" String
headerName (ByteString -> String
forall a. Show a => a -> String
show (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ HeaderMismatch -> ByteString
expectedHeader HeaderMismatch
e) (ByteString -> String
forall a. Show a => a -> String
show (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ HeaderMismatch -> ByteString
actualHeader HeaderMismatch
e)

-- | A middleware to check that the Content-Type header in the request
-- has a specific value. It will fail the handler if the header did
-- not match.
--
-- Example usage:
--
-- > requestContentTypeHeader @"application/json" handler
--
requestContentTypeHeader :: forall val m req a. (KnownSymbol val, MonadRouter m)
                         => RequestMiddleware' m req (HeaderMatch "Content-Type" val:req) a
requestContentTypeHeader :: RequestMiddleware' m req (HeaderMatch "Content-Type" val : req) a
requestContentTypeHeader = forall (name :: Symbol) (val :: Symbol) (m :: * -> *) (req :: [*])
       a.
(KnownSymbol name, KnownSymbol val, MonadRouter m) =>
RequestMiddleware' m req (HeaderMatch name val : req) a
forall (m :: * -> *) (req :: [*]) a.
(KnownSymbol "Content-Type", KnownSymbol val, MonadRouter m) =>
RequestMiddleware' m req (HeaderMatch "Content-Type" val : req) a
headerMatch @"Content-Type" @val

-- | A middleware to create or update a response header.
--
-- Example usage:
--
-- > addResponseHeader "Content-type" "application/json" handler
--
addResponseHeader :: forall t m req a. (ToHttpApiData t, Monad m)
                  => HeaderName -> t -> ResponseMiddleware' m req a a
addResponseHeader :: HeaderName -> t -> ResponseMiddleware' m req a a
addResponseHeader HeaderName
name t
val Handler' m req a
handler = (Linked req Request -> m (Response a)) -> Handler' m req a
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli ((Linked req Request -> m (Response a)) -> Handler' m req a)
-> (Linked req Request -> m (Response a)) -> Handler' m req a
forall a b. (a -> b) -> a -> b
$ Handler' m req a -> Linked req Request -> m (Response a)
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli Handler' m req a
handler (Linked req Request -> m (Response a))
-> (Response a -> m (Response a))
-> Linked req Request
-> m (Response a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Response a -> m (Response a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response a -> m (Response a))
-> (Response a -> Response a) -> Response a -> m (Response a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> ByteString -> Response a -> Response a
forall a. HeaderName -> ByteString -> Response a -> Response a
setResponseHeader HeaderName
name (t -> ByteString
forall a. ToHttpApiData a => a -> ByteString
toHeader t
val)