-- | Traits and middlewares to handle cookies in requests and responses.
module WebGear.Core.Trait.Cookie (
  -- * Traits
  Cookie (..),
  CookieNotFound (..),
  CookieParseError (..),
  SetCookie (..),

  -- * Middlewares
  cookie,
  optionalCookie,
  setCookie,
  setOptionalCookie,
) where

import Control.Arrow (ArrowChoice)
import Data.Kind (Type)
import Data.Text (Text)
import GHC.TypeLits (Symbol)
import qualified Web.Cookie as Cookie
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,
  HasTrait,
  Prerequisite,
  Set,
  Trait (..),
  TraitAbsence (..),
  With,
  plant,
  probe,
 )
import WebGear.Core.Trait.Header (RequestHeader)

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

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

-- | Trait for a cookie in HTTP requests
data Cookie (e :: Existence) (name :: Symbol) (val :: Type) = Cookie

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

type instance
  Prerequisite (Cookie e name val) ts Request =
    HasTrait (RequestHeader e Strict "Cookie" Text) ts

instance TraitAbsence (Cookie Required name val) Request where
  type Absence (Cookie Required name val) Request = Either CookieNotFound CookieParseError

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

instance TraitAbsence (Cookie Optional name val) Request where
  type Absence (Cookie Optional name val) Request = CookieParseError

cookieHandler ::
  forall name val e h ts.
  ( ArrowChoice h
  , Get h (Cookie e name val) Request
  , HasTrait (RequestHeader e Strict "Cookie" Text) ts
  ) =>
  -- | error handler
  h (Request `With` ts, Absence (Cookie e name val) Request) Response ->
  Middleware h ts (Cookie e name val : ts)
cookieHandler :: forall (name :: Symbol) val (e :: Existence) (h :: * -> * -> *)
       (ts :: [*]).
(ArrowChoice h, Get h (Cookie e name val) Request,
 HasTrait (RequestHeader e 'Strict "Cookie" Text) ts) =>
h (With Request ts, Absence (Cookie e name val) Request) Response
-> Middleware h ts (Cookie e name val : ts)
cookieHandler h (With Request ts, Absence (Cookie e name val) Request) Response
errorHandler RequestHandler h (Cookie e name val : ts)
nextHandler = proc With Request ts
request -> do
  Either
  (Absence (Cookie e name val) Request)
  (With Request (Cookie e name val : ts))
result <- Cookie e name val
-> h (With Request ts)
     (Either
        (Absence (Cookie e name val) Request)
        (With Request (Cookie e 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 Cookie e name val
forall (e :: Existence) (name :: Symbol) val. Cookie e name val
Cookie -< With Request ts
request
  case Either
  (Absence (Cookie e name val) Request)
  (With Request (Cookie e name val : ts))
result of
    Left Absence (Cookie e name val) Request
err -> h (With Request ts, Absence (Cookie e name val) Request) Response
errorHandler -< (With Request ts
request, Absence (Cookie e name val) Request
err)
    Right With Request (Cookie e name val : ts)
val -> RequestHandler h (Cookie e name val : ts)
nextHandler -< With Request (Cookie e name val : ts)
val
{-# INLINE cookieHandler #-}

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

 The associated trait attribute has type @val@.

 Example usage:

 > cookie @"name" @Integer errorHandler okHandler
-}
cookie ::
  forall name val h ts.
  ( ArrowChoice h
  , Get h (Cookie Required name val) Request
  , HasTrait (RequestHeader Required Strict "Cookie" Text) ts
  ) =>
  -- | Error handler
  h (Request `With` ts, Either CookieNotFound CookieParseError) Response ->
  Middleware h ts (Cookie Required name val : ts)
cookie :: forall (name :: Symbol) val (h :: * -> * -> *) (ts :: [*]).
(ArrowChoice h, Get h (Cookie 'Required name val) Request,
 HasTrait (RequestHeader 'Required 'Strict "Cookie" Text) ts) =>
h (With Request ts, Either CookieNotFound CookieParseError)
  Response
-> Middleware h ts (Cookie 'Required name val : ts)
cookie = h (With Request ts, Either CookieNotFound CookieParseError)
  Response
-> h (With Request (Cookie 'Required name val : ts)) Response
-> h (With Request ts) Response
h (With Request ts, Absence (Cookie 'Required name val) Request)
  Response
-> h (With Request (Cookie 'Required name val : ts)) Response
-> h (With Request ts) Response
forall (name :: Symbol) val (e :: Existence) (h :: * -> * -> *)
       (ts :: [*]).
(ArrowChoice h, Get h (Cookie e name val) Request,
 HasTrait (RequestHeader e 'Strict "Cookie" Text) ts) =>
h (With Request ts, Absence (Cookie e name val) Request) Response
-> Middleware h ts (Cookie e name val : ts)
cookieHandler
{-# INLINE cookie #-}

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

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

 Example usage:

 > optionalCookie @"name" @Integer errorHandler okHandler
-}
optionalCookie ::
  forall name val h ts.
  ( ArrowChoice h
  , Get h (Cookie Optional name val) Request
  , HasTrait (RequestHeader Optional Strict "Cookie" Text) ts
  ) =>
  -- | Error handler
  h (Request `With` ts, CookieParseError) Response ->
  Middleware h ts (Cookie Optional name val : ts)
optionalCookie :: forall (name :: Symbol) val (h :: * -> * -> *) (ts :: [*]).
(ArrowChoice h, Get h (Cookie 'Optional name val) Request,
 HasTrait (RequestHeader 'Optional 'Strict "Cookie" Text) ts) =>
h (With Request ts, CookieParseError) Response
-> Middleware h ts (Cookie 'Optional name val : ts)
optionalCookie = h (With Request ts, Absence (Cookie 'Optional name val) Request)
  Response
-> Middleware h ts (Cookie 'Optional name val : ts)
h (With Request ts, CookieParseError) Response
-> Middleware h ts (Cookie 'Optional name val : ts)
forall (name :: Symbol) val (e :: Existence) (h :: * -> * -> *)
       (ts :: [*]).
(ArrowChoice h, Get h (Cookie e name val) Request,
 HasTrait (RequestHeader e 'Strict "Cookie" Text) ts) =>
h (With Request ts, Absence (Cookie e name val) Request) Response
-> Middleware h ts (Cookie e name val : ts)
cookieHandler
{-# INLINE optionalCookie #-}

-- | Trait for a cookie in HTTP responses
data SetCookie (e :: Existence) (name :: Symbol) = SetCookie

instance Trait (SetCookie Required name) Response where
  type Attribute (SetCookie Required name) Response = Cookie.SetCookie

instance Trait (SetCookie Optional name) Response where
  type Attribute (SetCookie Optional name) Response = Maybe Cookie.SetCookie

{- | Set a cookie value in a response.

 Example usage:

 > response' <- setCookie @"name" -< (response, cookie)
-}
setCookie ::
  forall name h ts.
  (Set h (SetCookie Required name) Response) =>
  h (Response `With` ts, Cookie.SetCookie) (Response `With` (SetCookie Required name : ts))
setCookie :: forall (name :: Symbol) (h :: * -> * -> *) (ts :: [*]).
Set h (SetCookie 'Required name) Response =>
h (With Response ts, SetCookie)
  (With Response (SetCookie 'Required name : ts))
setCookie = SetCookie 'Required name
-> h (With Response ts,
      Attribute (SetCookie 'Required name) Response)
     (With Response (SetCookie 'Required name : ts))
forall t (ts :: [*]) (h :: * -> * -> *) a.
Set h t a =>
t -> h (With a ts, Attribute t a) (With a (t : ts))
plant SetCookie 'Required name
forall (e :: Existence) (name :: Symbol). SetCookie e name
SetCookie
{-# INLINE setCookie #-}

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

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

 Example usage:

 > response' <- setOptionalCookie @"name" -< (response, cookie)
-}
setOptionalCookie ::
  forall name h ts.
  (Set h (SetCookie Optional name) Response) =>
  h (Response `With` ts, Maybe Cookie.SetCookie) (Response `With` (SetCookie Optional name : ts))
setOptionalCookie :: forall (name :: Symbol) (h :: * -> * -> *) (ts :: [*]).
Set h (SetCookie 'Optional name) Response =>
h (With Response ts, Maybe SetCookie)
  (With Response (SetCookie 'Optional name : ts))
setOptionalCookie = SetCookie 'Optional name
-> h (With Response ts,
      Attribute (SetCookie 'Optional name) Response)
     (With Response (SetCookie 'Optional name : ts))
forall t (ts :: [*]) (h :: * -> * -> *) a.
Set h t a =>
t -> h (With a ts, Attribute t a) (With a (t : ts))
plant SetCookie 'Optional name
forall (e :: Existence) (name :: Symbol). SetCookie e name
SetCookie
{-# INLINE setOptionalCookie #-}