module WebGear.Middlewares.Header
(
Header
, Header'
, HeaderNotFound (..)
, HeaderParseError (..)
, HeaderMatch
, HeaderMatch'
, HeaderMismatch (..)
, 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
data (e :: Existence) (p :: ParseStyle) (name :: Symbol) (val :: Type)
type (name :: Symbol) (val :: Type) = Header' Required Strict name val
data =
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)
newtype = 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
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
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))
data (e :: Existence) (name :: Symbol) (val :: Symbol)
type (name :: Symbol) (val :: Symbol) = HeaderMatch' Required name val
data =
{ :: ByteString
, :: 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}
header :: forall name val m req a.
(KnownSymbol name, FromHttpApiData val, MonadRouter m)
=> RequestMiddleware' m req (Header name val:req) a
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
optionalHeader :: forall name val m req a.
(KnownSymbol name, FromHttpApiData val, MonadRouter m)
=> RequestMiddleware' m req (Header' Optional Strict name val:req) a
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
lenientHeader :: forall name val m req a.
(KnownSymbol name, FromHttpApiData val, MonadRouter m)
=> RequestMiddleware' m req (Header' Required Lenient name val:req) a
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
optionalLenientHeader :: forall name val m req a.
(KnownSymbol name, FromHttpApiData val, MonadRouter m)
=> RequestMiddleware' m req (Header' Optional Lenient name val:req) a
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)
headerMatch :: forall name val m req a.
(KnownSymbol name, KnownSymbol val, MonadRouter m)
=> RequestMiddleware' m req (HeaderMatch name val:req) a
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)
optionalHeaderMatch :: forall name val m req a.
(KnownSymbol name, KnownSymbol val, MonadRouter m)
=> RequestMiddleware' m req (HeaderMatch' Optional name val:req) a
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)
requestContentTypeHeader :: forall val m req a. (KnownSymbol val, MonadRouter m)
=> RequestMiddleware' m req (HeaderMatch "Content-Type" val:req) a
= 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
addResponseHeader :: forall t m req a. (ToHttpApiData t, Monad m)
=> HeaderName -> t -> ResponseMiddleware' m req a a
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)