{- | 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 linked 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
  Header (..),
  HeaderNotFound (..),
  HeaderParseError (..),
  RequiredHeader,
  OptionalHeader,

  -- * 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 (..), Linked, Set, Trait (..), TraitAbsence (..), plant, probe)

-- | 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)

{- | 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 Header (e :: Existence) (p :: ParseStyle) (name :: Symbol) (val :: Type) = Header

-- | A `Header` that is required and parsed strictly
type RequiredHeader = Header Required Strict

-- | A `Header` that is optional and parsed strictly
type OptionalHeader = Header Optional Strict

instance Trait (Header Required Strict name val) Request where
  type Attribute (Header Required Strict name val) Request = val

instance TraitAbsence (Header Required Strict name val) Request where
  type Absence (Header Required Strict name val) Request = Either HeaderNotFound HeaderParseError

instance Trait (Header Optional Strict name val) Request where
  type Attribute (Header Optional Strict name val) Request = Maybe val

instance TraitAbsence (Header Optional Strict name val) Request where
  type Absence (Header Optional Strict name val) Request = HeaderParseError

instance Trait (Header Required Lenient name val) Request where
  type Attribute (Header Required Lenient name val) Request = Either Text val

instance TraitAbsence (Header Required Lenient name val) Request where
  type Absence (Header Required Lenient name val) Request = HeaderNotFound

instance Trait (Header Optional Lenient name val) Request where
  type Attribute (Header Optional Lenient name val) Request = Maybe (Either Text val)

instance TraitAbsence (Header Optional Lenient name val) Request where
  type Absence (Header Optional Lenient name val) Request = Void

headerHandler ::
  forall name val e p h req.
  (Get h (Header e p name val) Request, ArrowChoice h) =>
  -- | error handler
  h (Linked req Request, Absence (Header e p name val) Request) Response ->
  Middleware h req (Header e p name val : req)
headerHandler :: h (Linked req Request, Absence (Header e p name val) Request)
  Response
-> Middleware h req (Header e p name val : req)
headerHandler h (Linked req Request, Absence (Header e p name val) Request)
  Response
errorHandler RequestHandler h (Header e p name val : req)
nextHandler = proc Linked req Request
request -> do
  Either
  (Absence (Header e p name val) Request)
  (Linked (Header e p name val : req) Request)
result <- Header e p name val
-> h (Linked req Request)
     (Either
        (Absence (Header e p name val) Request)
        (Linked (Header e p name val : req) Request))
forall t (ts :: [*]) (h :: * -> * -> *) a.
Get h t a =>
t -> h (Linked ts a) (Either (Absence t a) (Linked (t : ts) a))
probe Header e p name val
forall (e :: Existence) (p :: ParseStyle) (name :: Symbol) val.
Header e p name val
Header -< Linked req Request
request
  case Either
  (Absence (Header e p name val) Request)
  (Linked (Header e p name val : req) Request)
result of
    Left Absence (Header e p name val) Request
err -> h (Linked req Request, Absence (Header e p name val) Request)
  Response
errorHandler -< (Linked req Request
request, Absence (Header e p name val) Request
err)
    Right Linked (Header e p name val : req) Request
val -> RequestHandler h (Header e p name val : req)
nextHandler -< Linked (Header e p name val : req) Request
val

{- | 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 req.
  (Get h (Header Required Strict name val) Request, ArrowChoice h) =>
  -- | Error handler
  h (Linked req Request, Either HeaderNotFound HeaderParseError) Response ->
  Middleware h req (Header Required Strict name val : req)
header :: h (Linked req Request, Either HeaderNotFound HeaderParseError)
  Response
-> Middleware h req (Header 'Required 'Strict name val : req)
header = h (Linked req Request, Either HeaderNotFound HeaderParseError)
  Response
-> Middleware h req (Header 'Required 'Strict name val : req)
forall (name :: Symbol) val (e :: Existence) (p :: ParseStyle)
       (h :: * -> * -> *) (req :: [*]).
(Get h (Header e p name val) Request, ArrowChoice h) =>
h (Linked req Request, Absence (Header e p name val) Request)
  Response
-> Middleware h req (Header e p name val : req)
headerHandler

{- | 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 req.
  (Get h (Header Optional Strict name val) Request, ArrowChoice h) =>
  -- | Error handler
  h (Linked req Request, HeaderParseError) Response ->
  Middleware h req (Header Optional Strict name val : req)
optionalHeader :: h (Linked req Request, HeaderParseError) Response
-> Middleware h req (Header 'Optional 'Strict name val : req)
optionalHeader = h (Linked req Request, HeaderParseError) Response
-> Middleware h req (Header 'Optional 'Strict name val : req)
forall (name :: Symbol) val (e :: Existence) (p :: ParseStyle)
       (h :: * -> * -> *) (req :: [*]).
(Get h (Header e p name val) Request, ArrowChoice h) =>
h (Linked req Request, Absence (Header e p name val) Request)
  Response
-> Middleware h req (Header e p name val : req)
headerHandler

{- | 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 req.
  (Get h (Header Required Lenient name val) Request, ArrowChoice h) =>
  -- | Error handler
  h (Linked req Request, HeaderNotFound) Response ->
  Middleware h req (Header Required Lenient name val : req)
lenientHeader :: h (Linked req Request, HeaderNotFound) Response
-> Middleware h req (Header 'Required 'Lenient name val : req)
lenientHeader = h (Linked req Request, HeaderNotFound) Response
-> Middleware h req (Header 'Required 'Lenient name val : req)
forall (name :: Symbol) val (e :: Existence) (p :: ParseStyle)
       (h :: * -> * -> *) (req :: [*]).
(Get h (Header e p name val) Request, ArrowChoice h) =>
h (Linked req Request, Absence (Header e p name val) Request)
  Response
-> Middleware h req (Header e p name val : req)
headerHandler

{- | 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 req.
  (Get h (Header Optional Lenient name val) Request, ArrowChoice h) =>
  Middleware h req (Header Optional Lenient name val : req)
optionalLenientHeader :: Middleware h req (Header 'Optional 'Lenient name val : req)
optionalLenientHeader = h (Linked req Request,
   Absence (Header 'Optional 'Lenient name val) Request)
  Response
-> Middleware h req (Header 'Optional 'Lenient name val : req)
forall (name :: Symbol) val (e :: Existence) (p :: ParseStyle)
       (h :: * -> * -> *) (req :: [*]).
(Get h (Header e p name val) Request, ArrowChoice h) =>
h (Linked req Request, Absence (Header e p name val) Request)
  Response
-> Middleware h req (Header e p name val : req)
headerHandler (h (Linked req Request,
    Absence (Header 'Optional 'Lenient name val) Request)
   Response
 -> Middleware h req (Header 'Optional 'Lenient name val : req))
-> h (Linked req Request,
      Absence (Header 'Optional 'Lenient name val) Request)
     Response
-> Middleware h req (Header 'Optional 'Lenient name val : req)
forall a b. (a -> b) -> a -> b
$ ((Linked req Request, Void) -> Response)
-> h (Linked req Request, Void) Response
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Void -> Response
forall a. Void -> a
absurd (Void -> Response)
-> ((Linked req Request, Void) -> Void)
-> (Linked req Request, Void)
-> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Linked req Request, Void) -> Void
forall a b. (a, b) -> b
snd)

instance Trait (Header Required Strict name val) Response where
  type Attribute (Header Required Strict name val) Response = val

instance Trait (Header Optional Strict name val) Response where
  type Attribute (Header Optional Strict name val) Response = Maybe val

{- | Set a header value in a response.

 Example usage:

 > response' <- setHeader @"Content-Length" -< (response, 42)
-}
setHeader ::
  forall name val a h res.
  Set h (Header Required Strict name val) Response =>
  h a (Linked res Response) ->
  h (val, a) (Linked (Header Required Strict name val : res) Response)
setHeader :: h a (Linked res Response)
-> h (val, a)
     (Linked (Header 'Required 'Strict name val : res) Response)
setHeader h a (Linked res Response)
prevHandler = proc (val
val, a
a) -> do
  Linked res Response
r <- h a (Linked res Response)
prevHandler -< a
a
  Header 'Required 'Strict name val
-> h (Linked res Response,
      Attribute (Header 'Required 'Strict name val) Response)
     (Linked (Header 'Required 'Strict name val : res) Response)
forall t (ts :: [*]) (h :: * -> * -> *) a.
Set h t a =>
t -> h (Linked ts a, Attribute t a) (Linked (t : ts) a)
plant Header 'Required 'Strict name val
forall (e :: Existence) (p :: ParseStyle) (name :: Symbol) val.
Header e p name val
Header -< (Linked res Response
r, val
val)

{- | 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 a h res.
  Set h (Header Optional Strict name val) Response =>
  h a (Linked res Response) ->
  h (Maybe val, a) (Linked (Header Optional Strict name val : res) Response)
setOptionalHeader :: h a (Linked res Response)
-> h (Maybe val, a)
     (Linked (Header 'Optional 'Strict name val : res) Response)
setOptionalHeader h a (Linked res Response)
prevHandler = proc (Maybe val
val, a
a) -> do
  Linked res Response
r <- h a (Linked res Response)
prevHandler -< a
a
  Header 'Optional 'Strict name val
-> h (Linked res Response,
      Attribute (Header 'Optional 'Strict name val) Response)
     (Linked (Header 'Optional 'Strict name val : res) Response)
forall t (ts :: [*]) (h :: * -> * -> *) a.
Set h t a =>
t -> h (Linked ts a, Attribute t a) (Linked (t : ts) a)
plant Header 'Optional 'Strict name val
forall (e :: Existence) (p :: ParseStyle) (name :: Symbol) val.
Header e p name val
Header -< (Linked res Response
r, Maybe val
val)