{-# OPTIONS_GHC -Wno-orphans #-}

-- | Server implementation of the `Cookie` and `SetCookie` traits.
module WebGear.Server.Trait.Cookie () where

import Control.Arrow (arr, returnA, (>>>))
import Data.ByteString (ByteString)
import Data.ByteString.Conversion (toByteString')
import Data.Proxy (Proxy (Proxy))
import Data.String (fromString)
import Data.Text (Text)
import GHC.TypeLits (KnownSymbol, symbolVal)
import Network.HTTP.Types (Header, ResponseHeaders)
import qualified Web.Cookie as Cookie
import Web.HttpApiData (FromHttpApiData, parseHeader)
import WebGear.Core.Modifiers
import WebGear.Core.Request (Request, requestHeader)
import WebGear.Core.Response (Response (..))
import WebGear.Core.Trait (Get (..), Set (..), With, unwitness)
import WebGear.Core.Trait.Cookie (Cookie (..), CookieNotFound (..), CookieParseError (..), SetCookie (..))
import WebGear.Server.Handler (ServerHandler)

instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (Cookie Required name val) Request where
  {-# INLINE getTrait #-}
  getTrait ::
    Cookie Required name val ->
    ServerHandler m (Request `With` ts) (Either (Either CookieNotFound CookieParseError) val)
  getTrait :: forall (ts :: [*]).
Cookie 'Required name val
-> ServerHandler
     m
     (With Request ts)
     (Either (Either CookieNotFound CookieParseError) val)
getTrait Cookie 'Required name val
Cookie = forall (m :: * -> *) (name :: Symbol) val (ts :: [*]).
(Monad m, KnownSymbol name, FromHttpApiData val) =>
Proxy name
-> ServerHandler m (With Request ts) (Maybe (Either Text val))
extractCookie (forall {k} (t :: k). Proxy t
Proxy @name) forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall {b}.
Maybe (Either Text b)
-> Either (Either CookieNotFound CookieParseError) b
f
    where
      f :: Maybe (Either Text b)
-> Either (Either CookieNotFound CookieParseError) b
f = \case
        Maybe (Either Text b)
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left CookieNotFound
CookieNotFound
        Just (Left Text
e) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> CookieParseError
CookieParseError Text
e
        Just (Right b
x) -> forall a b. b -> Either a b
Right b
x

instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (Cookie Optional name val) Request where
  {-# INLINE getTrait #-}
  getTrait ::
    Cookie Optional name val ->
    ServerHandler m (Request `With` ts) (Either CookieParseError (Maybe val))
  getTrait :: forall (ts :: [*]).
Cookie 'Optional name val
-> ServerHandler
     m (With Request ts) (Either CookieParseError (Maybe val))
getTrait Cookie 'Optional name val
Cookie = forall (m :: * -> *) (name :: Symbol) val (ts :: [*]).
(Monad m, KnownSymbol name, FromHttpApiData val) =>
Proxy name
-> ServerHandler m (With Request ts) (Maybe (Either Text val))
extractCookie (forall {k} (t :: k). Proxy t
Proxy @name) forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall {a}.
Maybe (Either Text a) -> Either CookieParseError (Maybe a)
f
    where
      f :: Maybe (Either Text a) -> Either CookieParseError (Maybe a)
f = \case
        Maybe (Either Text a)
Nothing -> forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
        Just (Left Text
e) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> CookieParseError
CookieParseError Text
e
        Just (Right a
x) -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
x

extractCookie ::
  (Monad m, KnownSymbol name, FromHttpApiData val) =>
  Proxy name ->
  ServerHandler m (Request `With` ts) (Maybe (Either Text val))
extractCookie :: forall (m :: * -> *) (name :: Symbol) val (ts :: [*]).
(Monad m, KnownSymbol name, FromHttpApiData val) =>
Proxy name
-> ServerHandler m (With Request ts) (Maybe (Either Text val))
extractCookie Proxy name
proxy = proc With Request ts
req -> do
  let ByteString
cookieName :: ByteString = forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy name
proxy

      lookupCookie :: Maybe ByteString
      lookupCookie :: Maybe ByteString
lookupCookie = do
        ByteString
hdr <- HeaderName -> Request -> Maybe ByteString
requestHeader HeaderName
"Cookie" (forall a (ts :: [*]). With a ts -> a
unwitness With Request ts
req)
        let Cookies
cookies :: Cookie.Cookies = ByteString -> Cookies
Cookie.parseCookies ByteString
hdr
        forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
cookieName Cookies
cookies

  forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
lookupCookie

instance (Monad m, KnownSymbol name) => Set (ServerHandler m) (SetCookie Required name) Response where
  {-# INLINE setTrait #-}
  setTrait ::
    SetCookie Required name ->
    (Response `With` ts -> Response -> Cookie.SetCookie -> Response `With` (SetCookie Required name : ts)) ->
    ServerHandler m (Response `With` ts, Cookie.SetCookie) (Response `With` (SetCookie Required name : ts))
  setTrait :: forall (ts :: [*]).
SetCookie 'Required name
-> (With Response ts
    -> Response
    -> SetCookie
    -> With Response (SetCookie 'Required name : ts))
-> ServerHandler
     m
     (With Response ts, SetCookie)
     (With Response (SetCookie 'Required name : ts))
setTrait SetCookie 'Required name
SetCookie With Response ts
-> Response
-> SetCookie
-> With Response (SetCookie 'Required name : ts)
f = proc (With Response ts
l, SetCookie
cookie) -> do
    let ByteString
cookieName :: ByteString = forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @name
        response :: Response
response@Response{ResponseHeaders
Status
ResponseBody
responseStatus :: Response -> Status
responseHeaders :: Response -> ResponseHeaders
responseBody :: Response -> ResponseBody
responseBody :: ResponseBody
responseHeaders :: ResponseHeaders
responseStatus :: Status
..} = forall a (ts :: [*]). With a ts -> a
unwitness With Response ts
l
        response' :: Response
response' = Response
response{responseHeaders :: ResponseHeaders
responseHeaders = (HeaderName
"Set-Cookie", ByteString -> SetCookie -> ByteString
cookieToBS ByteString
cookieName SetCookie
cookie) forall a. a -> [a] -> [a]
: ResponseHeaders
responseHeaders}
    forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< With Response ts
-> Response
-> SetCookie
-> With Response (SetCookie 'Required name : ts)
f With Response ts
l Response
response' SetCookie
cookie

instance (Monad m, KnownSymbol name) => Set (ServerHandler m) (SetCookie Optional name) Response where
  {-# INLINE setTrait #-}
  -- If the optional value is 'Nothing', the cookie is removed from the response
  setTrait ::
    SetCookie Optional name ->
    (Response `With` ts -> Response -> Maybe Cookie.SetCookie -> Response `With` (SetCookie Optional name : ts)) ->
    ServerHandler m (Response `With` ts, Maybe Cookie.SetCookie) (Response `With` (SetCookie Optional name : ts))
  setTrait :: forall (ts :: [*]).
SetCookie 'Optional name
-> (With Response ts
    -> Response
    -> Maybe SetCookie
    -> With Response (SetCookie 'Optional name : ts))
-> ServerHandler
     m
     (With Response ts, Maybe SetCookie)
     (With Response (SetCookie 'Optional name : ts))
setTrait SetCookie 'Optional name
SetCookie With Response ts
-> Response
-> Maybe SetCookie
-> With Response (SetCookie 'Optional name : ts)
f = proc (With Response ts
l, Maybe SetCookie
maybeCookie) -> do
    let ByteString
cookieName :: ByteString = forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @name
        response :: Response
response@Response{ResponseHeaders
Status
ResponseBody
responseBody :: ResponseBody
responseHeaders :: ResponseHeaders
responseStatus :: Status
responseStatus :: Response -> Status
responseHeaders :: Response -> ResponseHeaders
responseBody :: Response -> ResponseBody
..} = forall a (ts :: [*]). With a ts -> a
unwitness With Response ts
l
        response' :: Response
response' = Response
response{responseHeaders :: ResponseHeaders
responseHeaders = ByteString -> Maybe SetCookie -> ResponseHeaders -> ResponseHeaders
alterCookie ByteString
cookieName Maybe SetCookie
maybeCookie ResponseHeaders
responseHeaders}
    forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< With Response ts
-> Response
-> Maybe SetCookie
-> With Response (SetCookie 'Optional name : ts)
f With Response ts
l Response
response' Maybe SetCookie
maybeCookie

alterCookie :: ByteString -> Maybe Cookie.SetCookie -> ResponseHeaders -> ResponseHeaders
alterCookie :: ByteString -> Maybe SetCookie -> ResponseHeaders -> ResponseHeaders
alterCookie ByteString
name (Just SetCookie
cookie) ResponseHeaders
hdrs = (HeaderName
"Set-Cookie", ByteString -> SetCookie -> ByteString
cookieToBS ByteString
name SetCookie
cookie) forall a. a -> [a] -> [a]
: ResponseHeaders
hdrs
alterCookie ByteString
name Maybe SetCookie
Nothing ResponseHeaders
hdrs = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header -> Bool
isMatchingCookie) ResponseHeaders
hdrs
  where
    isMatchingCookie :: Header -> Bool
    isMatchingCookie :: Header -> Bool
isMatchingCookie (HeaderName
hdrName, ByteString
hdrVal) =
      (HeaderName
hdrName forall a. Eq a => a -> a -> Bool
== HeaderName
"Set-Cookie")
        Bool -> Bool -> Bool
&& (ByteString
name forall a. Eq a => a -> a -> Bool
== SetCookie -> ByteString
Cookie.setCookieName (ByteString -> SetCookie
Cookie.parseSetCookie ByteString
hdrVal))

cookieToBS :: ByteString -> Cookie.SetCookie -> ByteString
cookieToBS :: ByteString -> SetCookie -> ByteString
cookieToBS ByteString
name SetCookie
cookie =
  forall a. ToByteString a => a -> ByteString
toByteString'
    forall a b. (a -> b) -> a -> b
$ SetCookie -> Builder
Cookie.renderSetCookie
    forall a b. (a -> b) -> a -> b
$ SetCookie
cookie{setCookieName :: ByteString
Cookie.setCookieName = ByteString
name}