{-# 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.Binary.Builder (toLazyByteString)
import Data.ByteString (ByteString)
import Data.ByteString.Lazy (toStrict)
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 = Proxy name
-> ServerHandler m (With Request ts) (Maybe (Either Text val))
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
forall (t :: Symbol). Proxy t
Proxy @name) ServerHandler m (With Request ts) (Maybe (Either Text val))
-> ServerHandler
     m
     (Maybe (Either Text val))
     (Either (Either CookieNotFound CookieParseError) val)
-> ServerHandler
     m
     (With Request ts)
     (Either (Either CookieNotFound CookieParseError) val)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Maybe (Either Text val)
 -> Either (Either CookieNotFound CookieParseError) val)
-> ServerHandler
     m
     (Maybe (Either Text val))
     (Either (Either CookieNotFound CookieParseError) val)
forall b c. (b -> c) -> ServerHandler m b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr Maybe (Either Text val)
-> Either (Either CookieNotFound CookieParseError) val
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 -> Either CookieNotFound CookieParseError
-> Either (Either CookieNotFound CookieParseError) b
forall a b. a -> Either a b
Left (Either CookieNotFound CookieParseError
 -> Either (Either CookieNotFound CookieParseError) b)
-> Either CookieNotFound CookieParseError
-> Either (Either CookieNotFound CookieParseError) b
forall a b. (a -> b) -> a -> b
$ CookieNotFound -> Either CookieNotFound CookieParseError
forall a b. a -> Either a b
Left CookieNotFound
CookieNotFound
        Just (Left Text
e) -> Either CookieNotFound CookieParseError
-> Either (Either CookieNotFound CookieParseError) b
forall a b. a -> Either a b
Left (Either CookieNotFound CookieParseError
 -> Either (Either CookieNotFound CookieParseError) b)
-> Either CookieNotFound CookieParseError
-> Either (Either CookieNotFound CookieParseError) b
forall a b. (a -> b) -> a -> b
$ CookieParseError -> Either CookieNotFound CookieParseError
forall a b. b -> Either a b
Right (CookieParseError -> Either CookieNotFound CookieParseError)
-> CookieParseError -> Either CookieNotFound CookieParseError
forall a b. (a -> b) -> a -> b
$ Text -> CookieParseError
CookieParseError Text
e
        Just (Right b
x) -> b -> Either (Either CookieNotFound CookieParseError) b
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 = Proxy name
-> ServerHandler m (With Request ts) (Maybe (Either Text val))
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
forall (t :: Symbol). Proxy t
Proxy @name) ServerHandler m (With Request ts) (Maybe (Either Text val))
-> ServerHandler
     m (Maybe (Either Text val)) (Either CookieParseError (Maybe val))
-> ServerHandler
     m (With Request ts) (Either CookieParseError (Maybe val))
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Maybe (Either Text val) -> Either CookieParseError (Maybe val))
-> ServerHandler
     m (Maybe (Either Text val)) (Either CookieParseError (Maybe val))
forall b c. (b -> c) -> ServerHandler m b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr Maybe (Either Text val) -> Either CookieParseError (Maybe val)
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 -> Maybe a -> Either CookieParseError (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing
        Just (Left Text
e) -> CookieParseError -> Either CookieParseError (Maybe a)
forall a b. a -> Either a b
Left (CookieParseError -> Either CookieParseError (Maybe a))
-> CookieParseError -> Either CookieParseError (Maybe a)
forall a b. (a -> b) -> a -> b
$ Text -> CookieParseError
CookieParseError Text
e
        Just (Right a
x) -> Maybe a -> Either CookieParseError (Maybe a)
forall a b. b -> Either a b
Right (Maybe a -> Either CookieParseError (Maybe a))
-> Maybe a -> Either CookieParseError (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
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 = String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Proxy name -> String
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" (With Request ts -> Request
forall a (ts :: [*]). With a ts -> a
unwitness With Request ts
req)
        let Cookies
cookies :: Cookie.Cookies = ByteString -> Cookies
Cookie.parseCookies ByteString
hdr
        ByteString -> Cookies -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
cookieName Cookies
cookies

  ServerHandler m (Maybe (Either Text val)) (Maybe (Either Text val))
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< ByteString -> Either Text val
forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader (ByteString -> Either Text val)
-> Maybe ByteString -> Maybe (Either Text val)
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 = String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy name -> String) -> Proxy name -> String
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name
        response :: Response
response = With Response ts -> Response
forall a (ts :: [*]). With a ts -> a
unwitness With Response ts
l
        response' :: Response
response' =
          case Response
response of
            Response Status
status ResponseHeaders
hdrs ResponseBody
body -> Status -> ResponseHeaders -> ResponseBody -> Response
Response Status
status ((HeaderName
"Set-Cookie", ByteString -> SetCookie -> ByteString
cookieToBS ByteString
cookieName SetCookie
cookie) Header -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: ResponseHeaders
hdrs) ResponseBody
body
            Response
_ -> Response
response
    ServerHandler
  m
  (With Response (SetCookie 'Required name : ts))
  (With Response (SetCookie 'Required name : ts))
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 = String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy name -> String) -> Proxy name -> String
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name
        response :: Response
response = With Response ts -> Response
forall a (ts :: [*]). With a ts -> a
unwitness With Response ts
l
        response' :: Response
response' =
          case Response
response of
            Response Status
status ResponseHeaders
hdrs ResponseBody
body -> Status -> ResponseHeaders -> ResponseBody -> Response
Response Status
status (ByteString -> Maybe SetCookie -> ResponseHeaders -> ResponseHeaders
alterCookie ByteString
cookieName Maybe SetCookie
maybeCookie ResponseHeaders
hdrs) ResponseBody
body
            Response
_ -> Response
response
    ServerHandler
  m
  (With Response (SetCookie 'Optional name : ts))
  (With Response (SetCookie 'Optional name : ts))
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) Header -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: ResponseHeaders
hdrs
alterCookie ByteString
name Maybe SetCookie
Nothing ResponseHeaders
hdrs = (Header -> Bool) -> ResponseHeaders -> ResponseHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Header -> Bool) -> Header -> Bool
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 HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
"Set-Cookie")
        Bool -> Bool -> Bool
&& (ByteString
name ByteString -> ByteString -> Bool
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 =
  ByteString -> ByteString
toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
    Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$
      SetCookie -> Builder
Cookie.renderSetCookie (SetCookie -> Builder) -> SetCookie -> Builder
forall a b. (a -> b) -> a -> b
$
        SetCookie
cookie{Cookie.setCookieName = name}