module WebGear.Core.Trait.Header (
RequestHeader (..),
HeaderNotFound (..),
HeaderParseError (..),
RequiredRequestHeader,
OptionalRequestHeader,
ResponseHeader (..),
RequiredResponseHeader,
OptionalResponseHeader,
header,
optionalHeader,
lenientHeader,
optionalLenientHeader,
setHeader,
setOptionalHeader,
acceptMatch,
) where
import Control.Arrow (ArrowChoice, arr)
import Control.Arrow.Operations (ArrowError)
import Data.Kind (Type)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Void (Void, absurd)
import GHC.TypeLits (Symbol)
import qualified Network.HTTP.Media as HTTP
import qualified Network.HTTP.Types as HTTP
import WebGear.Core.Handler (Middleware, RouteMismatch, routeMismatch)
import WebGear.Core.MIMETypes (MIMEType (..))
import WebGear.Core.Modifiers (Existence (..), ParseStyle (..))
import WebGear.Core.Request (Request, requestHeader)
import WebGear.Core.Response (Response)
import WebGear.Core.Trait (
Get (..),
Prerequisite,
Set,
Trait (..),
TraitAbsence (..),
With,
plant,
probe,
unwitness,
)
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
$creadsPrec :: Int -> ReadS HeaderNotFound
readsPrec :: Int -> ReadS HeaderNotFound
$creadList :: ReadS [HeaderNotFound]
readList :: ReadS [HeaderNotFound]
$creadPrec :: ReadPrec HeaderNotFound
readPrec :: ReadPrec HeaderNotFound
$creadListPrec :: ReadPrec [HeaderNotFound]
readListPrec :: ReadPrec [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
$cshowsPrec :: Int -> HeaderNotFound -> ShowS
showsPrec :: Int -> HeaderNotFound -> ShowS
$cshow :: HeaderNotFound -> String
show :: HeaderNotFound -> String
$cshowList :: [HeaderNotFound] -> ShowS
showList :: [HeaderNotFound] -> ShowS
Show, HeaderNotFound -> HeaderNotFound -> Bool
(HeaderNotFound -> HeaderNotFound -> Bool)
-> (HeaderNotFound -> HeaderNotFound -> Bool) -> Eq HeaderNotFound
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HeaderNotFound -> HeaderNotFound -> Bool
== :: HeaderNotFound -> HeaderNotFound -> Bool
$c/= :: HeaderNotFound -> HeaderNotFound -> Bool
/= :: 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
$creadsPrec :: Int -> ReadS HeaderParseError
readsPrec :: Int -> ReadS HeaderParseError
$creadList :: ReadS [HeaderParseError]
readList :: ReadS [HeaderParseError]
$creadPrec :: ReadPrec HeaderParseError
readPrec :: ReadPrec HeaderParseError
$creadListPrec :: ReadPrec [HeaderParseError]
readListPrec :: ReadPrec [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
$cshowsPrec :: Int -> HeaderParseError -> ShowS
showsPrec :: Int -> HeaderParseError -> ShowS
$cshow :: HeaderParseError -> String
show :: HeaderParseError -> String
$cshowList :: [HeaderParseError] -> ShowS
showList :: [HeaderParseError] -> ShowS
Show, HeaderParseError -> HeaderParseError -> Bool
(HeaderParseError -> HeaderParseError -> Bool)
-> (HeaderParseError -> HeaderParseError -> Bool)
-> Eq HeaderParseError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HeaderParseError -> HeaderParseError -> Bool
== :: HeaderParseError -> HeaderParseError -> Bool
$c/= :: HeaderParseError -> HeaderParseError -> Bool
/= :: HeaderParseError -> HeaderParseError -> Bool
Eq)
data (e :: Existence) (p :: ParseStyle) (name :: Symbol) (val :: Type) =
type = RequestHeader Required Strict
type = RequestHeader Optional Strict
instance Trait (RequestHeader Required Strict name val) Request where
type Attribute (RequestHeader Required Strict name val) Request = val
instance TraitAbsence (RequestHeader Required Strict name val) Request where
type Absence (RequestHeader Required Strict name val) Request = Either HeaderNotFound HeaderParseError
instance Trait (RequestHeader Optional Strict name val) Request where
type Attribute (RequestHeader Optional Strict name val) Request = Maybe val
instance TraitAbsence (RequestHeader Optional Strict name val) Request where
type Absence (RequestHeader Optional Strict name val) Request = HeaderParseError
instance Trait (RequestHeader Required Lenient name val) Request where
type Attribute (RequestHeader Required Lenient name val) Request = Either Text val
instance TraitAbsence (RequestHeader Required Lenient name val) Request where
type Absence (RequestHeader Required Lenient name val) Request = HeaderNotFound
instance Trait (RequestHeader Optional Lenient name val) Request where
type Attribute (RequestHeader Optional Lenient name val) Request = Maybe (Either Text val)
instance TraitAbsence (RequestHeader Optional Lenient name val) Request where
type Absence (RequestHeader Optional Lenient name val) Request = Void
type instance Prerequisite (RequestHeader e p name val) ts Request = ()
headerHandler ::
forall name val e p h ts.
(Get h (RequestHeader e p name val) Request, ArrowChoice h) =>
h (Request `With` ts, Absence (RequestHeader e p name val) Request) Response ->
Middleware h ts (RequestHeader e p name val : ts)
headerHandler :: forall (name :: Symbol) val (e :: Existence) (p :: ParseStyle)
(h :: * -> * -> *) (ts :: [*]).
(Get h (RequestHeader e p name val) Request, ArrowChoice h) =>
h (With Request ts, Absence (RequestHeader e p name val) Request)
Response
-> Middleware h ts (RequestHeader e p name val : ts)
headerHandler h (With Request ts, Absence (RequestHeader e p name val) Request)
Response
errorHandler RequestHandler h (RequestHeader e p name val : ts)
nextHandler = proc With Request ts
request -> do
Either
(Absence (RequestHeader e p name val) Request)
(With Request (RequestHeader e p name val : ts))
result <- RequestHeader e p name val
-> h (With Request ts)
(Either
(Absence (RequestHeader e p name val) Request)
(With Request (RequestHeader e p name val : ts)))
forall t (ts :: [*]) (h :: * -> * -> *) a.
(Get h t a, Prerequisite t ts a) =>
t -> h (With a ts) (Either (Absence t a) (With a (t : ts)))
probe RequestHeader e p name val
forall (e :: Existence) (p :: ParseStyle) (name :: Symbol) val.
RequestHeader e p name val
RequestHeader -< With Request ts
request
case Either
(Absence (RequestHeader e p name val) Request)
(With Request (RequestHeader e p name val : ts))
result of
Left Absence (RequestHeader e p name val) Request
err -> h (With Request ts, Absence (RequestHeader e p name val) Request)
Response
errorHandler -< (With Request ts
request, Absence (RequestHeader e p name val) Request
err)
Right With Request (RequestHeader e p name val : ts)
val -> RequestHandler h (RequestHeader e p name val : ts)
nextHandler -< With Request (RequestHeader e p name val : ts)
val
{-# INLINE headerHandler #-}
header ::
forall name val h ts.
(Get h (RequestHeader Required Strict name val) Request, ArrowChoice h) =>
h (Request `With` ts, Either HeaderNotFound HeaderParseError) Response ->
Middleware h ts (RequestHeader Required Strict name val : ts)
= h (With Request ts, Either HeaderNotFound HeaderParseError)
Response
-> h (With Request (RequestHeader 'Required 'Strict name val : ts))
Response
-> h (With Request ts) Response
h (With Request ts,
Absence (RequestHeader 'Required 'Strict name val) Request)
Response
-> h (With Request (RequestHeader 'Required 'Strict name val : ts))
Response
-> h (With Request ts) Response
forall (name :: Symbol) val (e :: Existence) (p :: ParseStyle)
(h :: * -> * -> *) (ts :: [*]).
(Get h (RequestHeader e p name val) Request, ArrowChoice h) =>
h (With Request ts, Absence (RequestHeader e p name val) Request)
Response
-> Middleware h ts (RequestHeader e p name val : ts)
headerHandler
{-# INLINE header #-}
optionalHeader ::
forall name val h ts.
(Get h (RequestHeader Optional Strict name val) Request, ArrowChoice h) =>
h (Request `With` ts, HeaderParseError) Response ->
Middleware h ts (RequestHeader Optional Strict name val : ts)
= h (With Request ts,
Absence (RequestHeader 'Optional 'Strict name val) Request)
Response
-> Middleware h ts (RequestHeader 'Optional 'Strict name val : ts)
h (With Request ts, HeaderParseError) Response
-> Middleware h ts (RequestHeader 'Optional 'Strict name val : ts)
forall (name :: Symbol) val (e :: Existence) (p :: ParseStyle)
(h :: * -> * -> *) (ts :: [*]).
(Get h (RequestHeader e p name val) Request, ArrowChoice h) =>
h (With Request ts, Absence (RequestHeader e p name val) Request)
Response
-> Middleware h ts (RequestHeader e p name val : ts)
headerHandler
{-# INLINE optionalHeader #-}
lenientHeader ::
forall name val h ts.
(Get h (RequestHeader Required Lenient name val) Request, ArrowChoice h) =>
h (Request `With` ts, HeaderNotFound) Response ->
Middleware h ts (RequestHeader Required Lenient name val : ts)
= h (With Request ts,
Absence (RequestHeader 'Required 'Lenient name val) Request)
Response
-> Middleware h ts (RequestHeader 'Required 'Lenient name val : ts)
h (With Request ts, HeaderNotFound) Response
-> Middleware h ts (RequestHeader 'Required 'Lenient name val : ts)
forall (name :: Symbol) val (e :: Existence) (p :: ParseStyle)
(h :: * -> * -> *) (ts :: [*]).
(Get h (RequestHeader e p name val) Request, ArrowChoice h) =>
h (With Request ts, Absence (RequestHeader e p name val) Request)
Response
-> Middleware h ts (RequestHeader e p name val : ts)
headerHandler
{-# INLINE lenientHeader #-}
optionalLenientHeader ::
forall name val h ts.
(Get h (RequestHeader Optional Lenient name val) Request, ArrowChoice h) =>
Middleware h ts (RequestHeader Optional Lenient name val : ts)
= h (With Request ts,
Absence (RequestHeader 'Optional 'Lenient name val) Request)
Response
-> Middleware h ts (RequestHeader 'Optional 'Lenient name val : ts)
forall (name :: Symbol) val (e :: Existence) (p :: ParseStyle)
(h :: * -> * -> *) (ts :: [*]).
(Get h (RequestHeader e p name val) Request, ArrowChoice h) =>
h (With Request ts, Absence (RequestHeader e p name val) Request)
Response
-> Middleware h ts (RequestHeader e p name val : ts)
headerHandler (h (With Request ts,
Absence (RequestHeader 'Optional 'Lenient name val) Request)
Response
-> Middleware
h ts (RequestHeader 'Optional 'Lenient name val : ts))
-> h (With Request ts,
Absence (RequestHeader 'Optional 'Lenient name val) Request)
Response
-> Middleware h ts (RequestHeader 'Optional 'Lenient name val : ts)
forall a b. (a -> b) -> a -> b
$ ((With Request ts, Void) -> Response)
-> h (With Request ts, Void) Response
forall b c. (b -> c) -> h b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Void -> Response
forall a. Void -> a
absurd (Void -> Response)
-> ((With Request ts, Void) -> Void)
-> (With Request ts, Void)
-> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (With Request ts, Void) -> Void
forall a b. (a, b) -> b
snd)
{-# INLINE optionalLenientHeader #-}
data (e :: Existence) (name :: Symbol) (val :: Type) =
type = ResponseHeader Required
type = ResponseHeader Optional
instance Trait (ResponseHeader Required name val) Response where
type Attribute (ResponseHeader Required name val) Response = val
instance Trait (ResponseHeader Optional name val) Response where
type Attribute (ResponseHeader Optional name val) Response = Maybe val
setHeader ::
forall name val h ts.
(Set h (ResponseHeader Required name val) Response) =>
h (Response `With` ts, val) (Response `With` (ResponseHeader Required name val : ts))
= ResponseHeader 'Required name val
-> h (With Response ts,
Attribute (ResponseHeader 'Required name val) Response)
(With Response (ResponseHeader 'Required name val : ts))
forall t (ts :: [*]) (h :: * -> * -> *) a.
Set h t a =>
t -> h (With a ts, Attribute t a) (With a (t : ts))
plant ResponseHeader 'Required name val
forall (e :: Existence) (name :: Symbol) val.
ResponseHeader e name val
ResponseHeader
{-# INLINE setHeader #-}
setOptionalHeader ::
forall name val h ts.
(Set h (ResponseHeader Optional name val) Response) =>
h (Response `With` ts, Maybe val) (Response `With` (ResponseHeader Optional name val : ts))
= ResponseHeader 'Optional name val
-> h (With Response ts,
Attribute (ResponseHeader 'Optional name val) Response)
(With Response (ResponseHeader 'Optional name val : ts))
forall t (ts :: [*]) (h :: * -> * -> *) a.
Set h t a =>
t -> h (With a ts, Attribute t a) (With a (t : ts))
plant ResponseHeader 'Optional name val
forall (e :: Existence) (name :: Symbol) val.
ResponseHeader e name val
ResponseHeader
{-# INLINE setOptionalHeader #-}
acceptMatch :: (ArrowChoice h, ArrowError RouteMismatch h, MIMEType mt) => mt -> Middleware h ts ts
acceptMatch :: forall (h :: * -> * -> *) mt (ts :: [*]).
(ArrowChoice h, ArrowError RouteMismatch h, MIMEType mt) =>
mt -> Middleware h ts ts
acceptMatch mt
mt RequestHandler h ts
nextHandler =
proc With Request ts
request -> do
let acceptHeader :: ByteString
acceptHeader = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"*/*" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> Request -> Maybe ByteString
requestHeader HeaderName
HTTP.hAccept (Request -> Maybe ByteString) -> Request -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ With Request ts -> Request
forall a (ts :: [*]). With a ts -> a
unwitness With Request ts
request
case [MediaType] -> ByteString -> Maybe MediaType
forall a. Accept a => [a] -> ByteString -> Maybe a
HTTP.matchAccept [mt -> MediaType
forall mt. MIMEType mt => mt -> MediaType
mimeType mt
mt] ByteString
acceptHeader of
Just MediaType
_ -> RequestHandler h ts
nextHandler -< With Request ts
request
Maybe MediaType
Nothing -> h () Response
forall (h :: * -> * -> *) a b. ArrowError RouteMismatch h => h a b
routeMismatch -< ()