{- | Traits and middlewares to handle request and response headers.

 There are a number of ways to extract a header value from a request:

 The `header` middleware can extract a header value trait and invoke
 another handler. An error handler is invoked if the header is missing
 or the parsing fails.

 The `optionalHeader` middleware is similar but will not invoke the
 error handling in case the header is missing. Instead, the trait
 value will be set to `Nothing` in that case.

 The `lenientHeader` middleware requires the header to be present. But
 the trait attribute will be set to 'Left' @msg@ if an error occurs
 while parsing it to a Haskell value. Here @msg@ will indicate the
 error in parsing.

 Finally, we have `optionalLenientHeader` which combines the behaviors
 of `optionalHeader` and `lenientHeader`. In this case, the header
 extraction never fails. Missing headers and parse errors are
 indicated in the trait attribute passed to next handler.

 A response header can be set using `setHeader` or `setOptionalHeader`
 arrows. They accept a witnessed response and a header value and sets
 the header in the response. You can generate an input response object
 using functions from "WebGear.Core.Trait.Status" module.
-}
module WebGear.Core.Trait.Header (
  -- * Traits
  RequestHeader (..),
  HeaderNotFound (..),
  HeaderParseError (..),
  RequiredRequestHeader,
  OptionalRequestHeader,
  ResponseHeader (..),
  RequiredResponseHeader,
  OptionalResponseHeader,

  -- * Middlewares
  header,
  optionalHeader,
  lenientHeader,
  optionalLenientHeader,
  setHeader,
  setOptionalHeader,
) where

import Control.Arrow (ArrowChoice, arr)
import Data.Kind (Type)
import Data.Text (Text)
import Data.Void (Void, absurd)
import GHC.TypeLits (Symbol)
import WebGear.Core.Handler (Middleware)
import WebGear.Core.Modifiers (Existence (..), ParseStyle (..))
import WebGear.Core.Request (Request)
import WebGear.Core.Response (Response)
import WebGear.Core.Trait (
  Get (..),
  Set,
  Trait (..),
  TraitAbsence (..),
  With,
  plant,
  probe,
 )

-- | Indicates a missing header
data HeaderNotFound = HeaderNotFound
  deriving stock (ReadPrec [HeaderNotFound]
ReadPrec HeaderNotFound
Int -> ReadS HeaderNotFound
ReadS [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
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
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]
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
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
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)

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

-- | A `Header` that is required in the request and parsed strictly
type RequiredRequestHeader = RequestHeader Required Strict

-- | A `Header` that is optional in the request and parsed strictly
type OptionalRequestHeader = 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

headerHandler ::
  forall name val e p h ts.
  (Get h (RequestHeader e p name val) Request, ArrowChoice h) =>
  -- | error handler
  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 <- forall t (ts :: [*]) (h :: * -> * -> *) a.
Get h t a =>
t -> h (With a ts) (Either (Absence t a) (With a (t : ts)))
probe 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 #-}

{- | Extract a header value and convert it to a value of type @val@.

 The associated trait attribute has type @val@.

 Example usage:

 > header @"Content-Length" @Integer errorHandler okHandler
-}
header ::
  forall name val h ts.
  (Get h (RequestHeader Required Strict name val) Request, ArrowChoice h) =>
  -- | Error handler
  h (Request `With` ts, Either HeaderNotFound HeaderParseError) Response ->
  Middleware h ts (RequestHeader Required Strict name val : ts)
header :: forall (name :: Symbol) val (h :: * -> * -> *) (ts :: [*]).
(Get h (RequestHeader 'Required 'Strict name val) Request,
 ArrowChoice h) =>
h (With Request ts, Either HeaderNotFound HeaderParseError)
  Response
-> Middleware h ts (RequestHeader 'Required 'Strict name val : ts)
header = 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 #-}

{- | Extract an optional header value and convert it to a value of type
 @val@.

 The associated trait attribute has type @Maybe val@; a @Nothing@
 value indicates that the header is missing from the request.

 Example usage:

 > optionalHeader @"Content-Length" @Integer errorHandler okHandler
-}
optionalHeader ::
  forall name val h ts.
  (Get h (RequestHeader Optional Strict name val) Request, ArrowChoice h) =>
  -- | Error handler
  h (Request `With` ts, HeaderParseError) Response ->
  Middleware h ts (RequestHeader Optional Strict name val : ts)
optionalHeader :: forall (name :: Symbol) val (h :: * -> * -> *) (ts :: [*]).
(Get h (RequestHeader 'Optional 'Strict name val) Request,
 ArrowChoice h) =>
h (With Request ts, HeaderParseError) Response
-> Middleware h ts (RequestHeader 'Optional 'Strict name val : ts)
optionalHeader = 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 #-}

{- | Extract a header value and convert it to a value of type @val@.

 The associated trait attribute has type @Either Text val@. The
 parsing is done leniently and any errors are reported in the trait
 attribute.

 Example usage:

 > lenientHeader @"Content-Length" @Integer errorHandler okHandler
-}
lenientHeader ::
  forall name val h ts.
  (Get h (RequestHeader Required Lenient name val) Request, ArrowChoice h) =>
  -- | Error handler
  h (Request `With` ts, HeaderNotFound) Response ->
  Middleware h ts (RequestHeader Required Lenient name val : ts)
lenientHeader :: forall (name :: Symbol) val (h :: * -> * -> *) (ts :: [*]).
(Get h (RequestHeader 'Required 'Lenient name val) Request,
 ArrowChoice h) =>
h (With Request ts, HeaderNotFound) Response
-> Middleware h ts (RequestHeader 'Required 'Lenient name val : ts)
lenientHeader = 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 #-}

{- | Extract a header value and convert it to a value of type @val@.

 The associated trait attribute has type @Maybe (Either Text
 val)@. The parsing is done leniently. Any parsing errors and
 missing header are reported in the trait attribute.

 Example usage:

 > optionalLenientHeader @"Content-Length" @Integer handler
-}
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)
optionalLenientHeader :: forall (name :: Symbol) val (h :: * -> * -> *) (ts :: [*]).
(Get h (RequestHeader 'Optional 'Lenient name val) Request,
 ArrowChoice h) =>
Middleware h ts (RequestHeader 'Optional 'Lenient name val : ts)
optionalLenientHeader = 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 forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (forall a. Void -> a
absurd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
{-# INLINE optionalLenientHeader #-}

{- | A 'Trait' for setting a header in the HTTP response. It has a
 specified @name@ and a value of type @val@ which can be converted to
 a 'ByteString'. The header name is compared case-insensitively. The
 modifier @e@ determines whether the header is mandatory or optional.
-}
data ResponseHeader (e :: Existence) (name :: Symbol) (val :: Type) = ResponseHeader

-- | A `Header` that is required in the response
type RequiredResponseHeader = ResponseHeader Required

-- | A `Header` that is optional in the response
type OptionalResponseHeader = 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

{- | Set a header value in a response.

 Example usage:

 > response' <- setHeader @"Content-Length" -< (response, 42)
-}
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))
setHeader :: forall (name :: Symbol) val (h :: * -> * -> *) (ts :: [*]).
Set h (ResponseHeader 'Required name val) Response =>
h (With Response ts, val)
  (With Response (ResponseHeader 'Required name val : ts))
setHeader = forall t (ts :: [*]) (h :: * -> * -> *) a.
Set h t a =>
t -> h (With a ts, Attribute t a) (With a (t : ts))
plant forall (e :: Existence) (name :: Symbol) val.
ResponseHeader e name val
ResponseHeader
{-# INLINE setHeader #-}

{- | Set an optional header value in a response.

 Setting the header to 'Nothing' will remove it from the response if
 it was previously set. The header will be considered as optional in
 all relevant places (such as documentation).

 Example usage:

 > response' <- setOptionalHeader @"Content-Length" -< (response, Just 42)
-}
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))
setOptionalHeader :: forall (name :: Symbol) val (h :: * -> * -> *) (ts :: [*]).
Set h (ResponseHeader 'Optional name val) Response =>
h (With Response ts, Maybe val)
  (With Response (ResponseHeader 'Optional name val : ts))
setOptionalHeader = forall t (ts :: [*]) (h :: * -> * -> *) a.
Set h t a =>
t -> h (With a ts, Attribute t a) (With a (t : ts))
plant forall (e :: Existence) (name :: Symbol) val.
ResponseHeader e name val
ResponseHeader
{-# INLINE setOptionalHeader #-}