{-# LANGUAGE CPP, DeriveDataTypeable #-}

-- http://tools.ietf.org/html/rfc2109
module Happstack.Server.Internal.Cookie
    ( Cookie(..)
    , CookieLife(..)
    , SameSite(..)
    , calcLife
    , mkCookie
    , mkCookieHeader
    , getCookies
    , getCookie
    , getCookies'
    , getCookie'
    , parseCookies
    , cookiesParser
    )
    where

import Control.Monad
import Control.Monad.Fail (MonadFail)
import qualified Data.ByteString.Char8 as C
import Data.Char             (chr, toLower)
import Data.Data             (Data, Typeable)
import Data.List             ((\\), intersperse)
import Data.Time.Clock       (UTCTime, addUTCTime, diffUTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Happstack.Server.Internal.Clock (getApproximateUTCTime)
import Network.URI           (escapeURIString)
import Text.ParserCombinators.Parsec hiding (token)

#if MIN_VERSION_time(1,5,0)
import Data.Time.Format (formatTime, defaultTimeLocale)
#else
import Data.Time.Format (formatTime)
import System.Locale    (defaultTimeLocale)
#endif

-- | a type for HTTP cookies. Usually created using 'mkCookie'.
data Cookie = Cookie
    { Cookie -> [Char]
cookieVersion :: String
    , Cookie -> [Char]
cookiePath    :: String
    , Cookie -> [Char]
cookieDomain  :: String
    , Cookie -> [Char]
cookieName    :: String
    , Cookie -> [Char]
cookieValue   :: String
    , Cookie -> Bool
secure        :: Bool
    , Cookie -> Bool
httpOnly      :: Bool
    , Cookie -> SameSite
sameSite      :: SameSite
    , Cookie -> Bool
partitioned   :: Bool
    } deriving(Int -> Cookie -> ShowS
[Cookie] -> ShowS
Cookie -> [Char]
(Int -> Cookie -> ShowS)
-> (Cookie -> [Char]) -> ([Cookie] -> ShowS) -> Show Cookie
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Cookie -> ShowS
showsPrec :: Int -> Cookie -> ShowS
$cshow :: Cookie -> [Char]
show :: Cookie -> [Char]
$cshowList :: [Cookie] -> ShowS
showList :: [Cookie] -> ShowS
Show,Cookie -> Cookie -> Bool
(Cookie -> Cookie -> Bool)
-> (Cookie -> Cookie -> Bool) -> Eq Cookie
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Cookie -> Cookie -> Bool
== :: Cookie -> Cookie -> Bool
$c/= :: Cookie -> Cookie -> Bool
/= :: Cookie -> Cookie -> Bool
Eq,ReadPrec [Cookie]
ReadPrec Cookie
Int -> ReadS Cookie
ReadS [Cookie]
(Int -> ReadS Cookie)
-> ReadS [Cookie]
-> ReadPrec Cookie
-> ReadPrec [Cookie]
-> Read Cookie
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Cookie
readsPrec :: Int -> ReadS Cookie
$creadList :: ReadS [Cookie]
readList :: ReadS [Cookie]
$creadPrec :: ReadPrec Cookie
readPrec :: ReadPrec Cookie
$creadListPrec :: ReadPrec [Cookie]
readListPrec :: ReadPrec [Cookie]
Read,Typeable,Typeable Cookie
Typeable Cookie =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> Cookie -> c Cookie)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c Cookie)
-> (Cookie -> Constr)
-> (Cookie -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c Cookie))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Cookie))
-> ((forall b. Data b => b -> b) -> Cookie -> Cookie)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> Cookie -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> Cookie -> r)
-> (forall u. (forall d. Data d => d -> u) -> Cookie -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> Cookie -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> Cookie -> m Cookie)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Cookie -> m Cookie)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Cookie -> m Cookie)
-> Data Cookie
Cookie -> Constr
Cookie -> DataType
(forall b. Data b => b -> b) -> Cookie -> Cookie
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Cookie -> u
forall u. (forall d. Data d => d -> u) -> Cookie -> [u]
forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Cookie -> r
forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Cookie -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Cookie -> m Cookie
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Cookie -> m Cookie
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Cookie
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Cookie -> c Cookie
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Cookie)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Cookie)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Cookie -> c Cookie
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Cookie -> c Cookie
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Cookie
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Cookie
$ctoConstr :: Cookie -> Constr
toConstr :: Cookie -> Constr
$cdataTypeOf :: Cookie -> DataType
dataTypeOf :: Cookie -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Cookie)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Cookie)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Cookie)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Cookie)
$cgmapT :: (forall b. Data b => b -> b) -> Cookie -> Cookie
gmapT :: (forall b. Data b => b -> b) -> Cookie -> Cookie
$cgmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Cookie -> r
gmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Cookie -> r
$cgmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Cookie -> r
gmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Cookie -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Cookie -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> Cookie -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Cookie -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Cookie -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Cookie -> m Cookie
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Cookie -> m Cookie
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Cookie -> m Cookie
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Cookie -> m Cookie
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Cookie -> m Cookie
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Cookie -> m Cookie
Data)

-- | Specify the lifetime of a cookie.
--
-- Note that we always set the max-age and expires headers because
-- internet explorer does not honor max-age. You can specific 'MaxAge'
-- or 'Expires' and the other will be calculated for you. Choose which
-- ever one makes your life easiest.
--
data CookieLife
    = Session         -- ^ session cookie - expires when browser is closed
    | MaxAge Int      -- ^ life time of cookie in seconds
    | Expires UTCTime -- ^ cookie expiration date
    | Expired         -- ^ cookie already expired
      deriving (CookieLife -> CookieLife -> Bool
(CookieLife -> CookieLife -> Bool)
-> (CookieLife -> CookieLife -> Bool) -> Eq CookieLife
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CookieLife -> CookieLife -> Bool
== :: CookieLife -> CookieLife -> Bool
$c/= :: CookieLife -> CookieLife -> Bool
/= :: CookieLife -> CookieLife -> Bool
Eq, Eq CookieLife
Eq CookieLife =>
(CookieLife -> CookieLife -> Ordering)
-> (CookieLife -> CookieLife -> Bool)
-> (CookieLife -> CookieLife -> Bool)
-> (CookieLife -> CookieLife -> Bool)
-> (CookieLife -> CookieLife -> Bool)
-> (CookieLife -> CookieLife -> CookieLife)
-> (CookieLife -> CookieLife -> CookieLife)
-> Ord CookieLife
CookieLife -> CookieLife -> Bool
CookieLife -> CookieLife -> Ordering
CookieLife -> CookieLife -> CookieLife
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CookieLife -> CookieLife -> Ordering
compare :: CookieLife -> CookieLife -> Ordering
$c< :: CookieLife -> CookieLife -> Bool
< :: CookieLife -> CookieLife -> Bool
$c<= :: CookieLife -> CookieLife -> Bool
<= :: CookieLife -> CookieLife -> Bool
$c> :: CookieLife -> CookieLife -> Bool
> :: CookieLife -> CookieLife -> Bool
$c>= :: CookieLife -> CookieLife -> Bool
>= :: CookieLife -> CookieLife -> Bool
$cmax :: CookieLife -> CookieLife -> CookieLife
max :: CookieLife -> CookieLife -> CookieLife
$cmin :: CookieLife -> CookieLife -> CookieLife
min :: CookieLife -> CookieLife -> CookieLife
Ord, ReadPrec [CookieLife]
ReadPrec CookieLife
Int -> ReadS CookieLife
ReadS [CookieLife]
(Int -> ReadS CookieLife)
-> ReadS [CookieLife]
-> ReadPrec CookieLife
-> ReadPrec [CookieLife]
-> Read CookieLife
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS CookieLife
readsPrec :: Int -> ReadS CookieLife
$creadList :: ReadS [CookieLife]
readList :: ReadS [CookieLife]
$creadPrec :: ReadPrec CookieLife
readPrec :: ReadPrec CookieLife
$creadListPrec :: ReadPrec [CookieLife]
readListPrec :: ReadPrec [CookieLife]
Read, Int -> CookieLife -> ShowS
[CookieLife] -> ShowS
CookieLife -> [Char]
(Int -> CookieLife -> ShowS)
-> (CookieLife -> [Char])
-> ([CookieLife] -> ShowS)
-> Show CookieLife
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CookieLife -> ShowS
showsPrec :: Int -> CookieLife -> ShowS
$cshow :: CookieLife -> [Char]
show :: CookieLife -> [Char]
$cshowList :: [CookieLife] -> ShowS
showList :: [CookieLife] -> ShowS
Show, Typeable)

-- | Options for specifying third party cookie behaviour.
--
-- Note that most or all web clients require the cookie to be secure if "none" is
-- specified.
data SameSite
    = SameSiteLax
    -- ^ The cookie is sent in first party contexts as well as linked requests initiated
    -- from other contexts.
    | SameSiteStrict
    -- ^ The cookie is sent in first party contexts only.
    | SameSiteNone
    -- ^ The cookie is sent in first as well as third party contexts if the cookie is
    -- secure.
    | SameSiteNoValue
    -- ^ The default; used if you do not wish a SameSite attribute present at all.
      deriving (SameSite -> SameSite -> Bool
(SameSite -> SameSite -> Bool)
-> (SameSite -> SameSite -> Bool) -> Eq SameSite
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SameSite -> SameSite -> Bool
== :: SameSite -> SameSite -> Bool
$c/= :: SameSite -> SameSite -> Bool
/= :: SameSite -> SameSite -> Bool
Eq, Eq SameSite
Eq SameSite =>
(SameSite -> SameSite -> Ordering)
-> (SameSite -> SameSite -> Bool)
-> (SameSite -> SameSite -> Bool)
-> (SameSite -> SameSite -> Bool)
-> (SameSite -> SameSite -> Bool)
-> (SameSite -> SameSite -> SameSite)
-> (SameSite -> SameSite -> SameSite)
-> Ord SameSite
SameSite -> SameSite -> Bool
SameSite -> SameSite -> Ordering
SameSite -> SameSite -> SameSite
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SameSite -> SameSite -> Ordering
compare :: SameSite -> SameSite -> Ordering
$c< :: SameSite -> SameSite -> Bool
< :: SameSite -> SameSite -> Bool
$c<= :: SameSite -> SameSite -> Bool
<= :: SameSite -> SameSite -> Bool
$c> :: SameSite -> SameSite -> Bool
> :: SameSite -> SameSite -> Bool
$c>= :: SameSite -> SameSite -> Bool
>= :: SameSite -> SameSite -> Bool
$cmax :: SameSite -> SameSite -> SameSite
max :: SameSite -> SameSite -> SameSite
$cmin :: SameSite -> SameSite -> SameSite
min :: SameSite -> SameSite -> SameSite
Ord, Typeable, Typeable SameSite
Typeable SameSite =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> SameSite -> c SameSite)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c SameSite)
-> (SameSite -> Constr)
-> (SameSite -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c SameSite))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c SameSite))
-> ((forall b. Data b => b -> b) -> SameSite -> SameSite)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> SameSite -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> SameSite -> r)
-> (forall u. (forall d. Data d => d -> u) -> SameSite -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> SameSite -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> SameSite -> m SameSite)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> SameSite -> m SameSite)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> SameSite -> m SameSite)
-> Data SameSite
SameSite -> Constr
SameSite -> DataType
(forall b. Data b => b -> b) -> SameSite -> SameSite
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> SameSite -> u
forall u. (forall d. Data d => d -> u) -> SameSite -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SameSite -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> SameSite -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> SameSite -> m SameSite
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> SameSite -> m SameSite
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SameSite
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SameSite -> c SameSite
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c SameSite)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c SameSite)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SameSite -> c SameSite
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SameSite -> c SameSite
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SameSite
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SameSite
$ctoConstr :: SameSite -> Constr
toConstr :: SameSite -> Constr
$cdataTypeOf :: SameSite -> DataType
dataTypeOf :: SameSite -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c SameSite)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c SameSite)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c SameSite)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c SameSite)
$cgmapT :: (forall b. Data b => b -> b) -> SameSite -> SameSite
gmapT :: (forall b. Data b => b -> b) -> SameSite -> SameSite
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SameSite -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SameSite -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> SameSite -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> SameSite -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> SameSite -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> SameSite -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> SameSite -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> SameSite -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> SameSite -> m SameSite
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> SameSite -> m SameSite
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> SameSite -> m SameSite
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> SameSite -> m SameSite
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> SameSite -> m SameSite
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> SameSite -> m SameSite
Data, Int -> SameSite -> ShowS
[SameSite] -> ShowS
SameSite -> [Char]
(Int -> SameSite -> ShowS)
-> (SameSite -> [Char]) -> ([SameSite] -> ShowS) -> Show SameSite
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SameSite -> ShowS
showsPrec :: Int -> SameSite -> ShowS
$cshow :: SameSite -> [Char]
show :: SameSite -> [Char]
$cshowList :: [SameSite] -> ShowS
showList :: [SameSite] -> ShowS
Show, ReadPrec [SameSite]
ReadPrec SameSite
Int -> ReadS SameSite
ReadS [SameSite]
(Int -> ReadS SameSite)
-> ReadS [SameSite]
-> ReadPrec SameSite
-> ReadPrec [SameSite]
-> Read SameSite
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS SameSite
readsPrec :: Int -> ReadS SameSite
$creadList :: ReadS [SameSite]
readList :: ReadS [SameSite]
$creadPrec :: ReadPrec SameSite
readPrec :: ReadPrec SameSite
$creadListPrec :: ReadPrec [SameSite]
readListPrec :: ReadPrec [SameSite]
Read)

displaySameSite :: SameSite -> String
displaySameSite :: SameSite -> [Char]
displaySameSite SameSite
ss =
  case SameSite
ss of
    SameSite
SameSiteLax     -> [Char]
"SameSite=Lax"
    SameSite
SameSiteStrict  -> [Char]
"SameSite=Strict"
    SameSite
SameSiteNone    -> [Char]
"SameSite=None"
    SameSite
SameSiteNoValue -> [Char]
""

-- convert 'CookieLife' to the argument needed for calling 'mkCookieHeader'
calcLife :: CookieLife -> IO (Maybe (Int, UTCTime))
calcLife :: CookieLife -> IO (Maybe (Int, UTCTime))
calcLife CookieLife
Session = Maybe (Int, UTCTime) -> IO (Maybe (Int, UTCTime))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Int, UTCTime)
forall a. Maybe a
Nothing
calcLife (MaxAge Int
s) =
          do UTCTime
now <- IO UTCTime
getApproximateUTCTime
             Maybe (Int, UTCTime) -> IO (Maybe (Int, UTCTime))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int, UTCTime) -> Maybe (Int, UTCTime)
forall a. a -> Maybe a
Just (Int
s, NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s) UTCTime
now))
calcLife (Expires UTCTime
expirationDate) =
          do UTCTime
now <- IO UTCTime
getApproximateUTCTime
             Maybe (Int, UTCTime) -> IO (Maybe (Int, UTCTime))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Int, UTCTime) -> IO (Maybe (Int, UTCTime)))
-> Maybe (Int, UTCTime) -> IO (Maybe (Int, UTCTime))
forall a b. (a -> b) -> a -> b
$ (Int, UTCTime) -> Maybe (Int, UTCTime)
forall a. a -> Maybe a
Just (NominalDiffTime -> Int
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round  (NominalDiffTime -> Int) -> NominalDiffTime -> Int
forall a b. (a -> b) -> a -> b
$ UTCTime
expirationDate UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
now, UTCTime
expirationDate)
calcLife CookieLife
Expired =
          Maybe (Int, UTCTime) -> IO (Maybe (Int, UTCTime))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Int, UTCTime) -> IO (Maybe (Int, UTCTime)))
-> Maybe (Int, UTCTime) -> IO (Maybe (Int, UTCTime))
forall a b. (a -> b) -> a -> b
$ (Int, UTCTime) -> Maybe (Int, UTCTime)
forall a. a -> Maybe a
Just (Int
0, NominalDiffTime -> UTCTime
posixSecondsToUTCTime NominalDiffTime
0)


-- | Creates a cookie with a default version of 1, empty domain, a
-- path of "/", secure == False, httpOnly == False and
-- sameSite == SameSiteNoValue and partitioned = False
--
-- see also: 'addCookie'
mkCookie :: String  -- ^ cookie name
         -> String  -- ^ cookie value
         -> Cookie
mkCookie :: [Char] -> [Char] -> Cookie
mkCookie [Char]
key [Char]
val = [Char]
-> [Char]
-> [Char]
-> [Char]
-> [Char]
-> Bool
-> Bool
-> SameSite
-> Bool
-> Cookie
Cookie [Char]
"1" [Char]
"/" [Char]
"" [Char]
key [Char]
val Bool
False Bool
False SameSite
SameSiteNoValue Bool
False

-- | Set a Cookie in the Result.
-- The values are escaped as per RFC 2109, but some browsers may
-- have buggy support for cookies containing e.g. @\'\"\'@ or @\' \'@.
--
-- Also, it seems that chrome, safari, and other webkit browsers do
-- not like cookies which have double quotes around the domain and
-- reject/ignore the cookie. So, we no longer quote the domain.
--
-- internet explorer does not honor the max-age directive so we set
-- both max-age and expires.
--
-- See 'CookieLife' and 'calcLife' for a convenient way of calculating
-- the first argument to this function.
mkCookieHeader :: Maybe (Int, UTCTime) -> Cookie -> String
mkCookieHeader :: Maybe (Int, UTCTime) -> Cookie -> [Char]
mkCookieHeader Maybe (Int, UTCTime)
mLife Cookie
cookie =
  let
    l :: [([Char], [Char])]
l =
      [ (,) [Char]
"Domain="  (Cookie -> [Char]
cookieDomain Cookie
cookie)
      , (,) [Char]
"Max-Age=" ([Char]
-> ((Int, UTCTime) -> [Char]) -> Maybe (Int, UTCTime) -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" (Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [Char])
-> ((Int, UTCTime) -> Int) -> (Int, UTCTime) -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> ((Int, UTCTime) -> Int) -> (Int, UTCTime) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, UTCTime) -> Int
forall a b. (a, b) -> a
fst) Maybe (Int, UTCTime)
mLife)
      , (,) [Char]
"expires=" ([Char]
-> ((Int, UTCTime) -> [Char]) -> Maybe (Int, UTCTime) -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" (UTCTime -> [Char]
formatTime'  (UTCTime -> [Char])
-> ((Int, UTCTime) -> UTCTime) -> (Int, UTCTime) -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, UTCTime) -> UTCTime
forall a b. (a, b) -> b
snd) Maybe (Int, UTCTime)
mLife)
      , (,) [Char]
"Path="    (Cookie -> [Char]
cookiePath Cookie
cookie)
      , (,) [Char]
"Version=" ((Cookie -> [Char]) -> [Char]
s Cookie -> [Char]
cookieVersion)
      ]
    formatTime' :: UTCTime -> [Char]
formatTime' =
      TimeLocale -> [Char] -> UTCTime -> [Char]
forall t. FormatTime t => TimeLocale -> [Char] -> t -> [Char]
formatTime TimeLocale
defaultTimeLocale [Char]
"%a, %d-%b-%Y %X GMT"
    encode :: ShowS
encode =
      (Char -> Bool) -> ShowS
escapeURIString
        (\Char
c -> Char
c Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char
'A'..Char
'Z'] [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'a'..Char
'z'] [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'0'..Char
'9'] [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"-_.~"))
    s :: (Cookie -> [Char]) -> [Char]
s Cookie -> [Char]
f | Cookie -> [Char]
f Cookie
cookie [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"" = [Char]
""
        | Bool
otherwise      = Char
'\"' Char -> ShowS
forall a. a -> [a] -> [a]
: (ShowS
encode ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Cookie -> [Char]
f Cookie
cookie) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\""
  in
    [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
intersperse [Char]
";" ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$
         (Cookie -> [Char]
cookieName Cookie
cookie[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
"="[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++(Cookie -> [Char]) -> [Char]
s Cookie -> [Char]
cookieValue)[Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:[ ([Char]
k[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
v) | ([Char]
k,[Char]
v) <- [([Char], [Char])]
l, [Char]
"" [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
v ]
      [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ (if Cookie -> Bool
secure   Cookie
cookie then [[Char]
"Secure"]   else [])
      [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ (if Cookie -> Bool
httpOnly Cookie
cookie then [[Char]
"HttpOnly"] else [])
      [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ (if Cookie -> SameSite
sameSite Cookie
cookie SameSite -> SameSite -> Bool
forall a. Eq a => a -> a -> Bool
/= SameSite
SameSiteNoValue
          then [SameSite -> [Char]
displaySameSite (SameSite -> [Char]) -> (Cookie -> SameSite) -> Cookie -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cookie -> SameSite
sameSite (Cookie -> [Char]) -> Cookie -> [Char]
forall a b. (a -> b) -> a -> b
$ Cookie
cookie] else [])
      [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ (if Cookie -> Bool
partitioned Cookie
cookie then [[Char]
"Partitioned"] else [])

-- | Not an supported api.  Takes a cookie header and returns
-- either a String error message or an array of parsed cookies
parseCookies :: String -> Either String [Cookie]
parseCookies :: [Char] -> Either [Char] [Cookie]
parseCookies [Char]
str = (ParseError -> Either [Char] [Cookie])
-> ([Cookie] -> Either [Char] [Cookie])
-> Either ParseError [Cookie]
-> Either [Char] [Cookie]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> Either [Char] [Cookie]
forall a b. a -> Either a b
Left ([Char] -> Either [Char] [Cookie])
-> (ParseError -> [Char]) -> ParseError -> Either [Char] [Cookie]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> [Char]
forall a. Show a => a -> [Char]
show) [Cookie] -> Either [Char] [Cookie]
forall a b. b -> Either a b
Right (Either ParseError [Cookie] -> Either [Char] [Cookie])
-> Either ParseError [Cookie] -> Either [Char] [Cookie]
forall a b. (a -> b) -> a -> b
$ Parsec [Char] () [Cookie]
-> [Char] -> [Char] -> Either ParseError [Cookie]
forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
parse Parsec [Char] () [Cookie]
forall st. GenParser Char st [Cookie]
cookiesParser [Char]
str [Char]
str

-- | not a supported api.  A parser for RFC 2109 cookies
cookiesParser :: GenParser Char st [Cookie]
cookiesParser :: forall st. GenParser Char st [Cookie]
cookiesParser = ParsecT [Char] st Identity [Cookie]
forall st. GenParser Char st [Cookie]
cookies
    where -- Parsers based on RFC 2109
          cookies :: ParsecT [Char] u Identity [Cookie]
cookies = do
            ParsecT [Char] u Identity ()
forall {u}. ParsecT [Char] u Identity ()
ws
            [Char]
ver<-[Char]
-> ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option [Char]
"" (ParsecT [Char] u Identity [Char]
 -> ParsecT [Char] u Identity [Char])
-> ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall a b. (a -> b) -> a -> b
$ ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT [Char] u Identity [Char]
forall {u}. ParsecT [Char] u Identity [Char]
cookie_version ParsecT [Char] u Identity [Char]
-> ([Char] -> ParsecT [Char] u Identity [Char])
-> ParsecT [Char] u Identity [Char]
forall a b.
ParsecT [Char] u Identity a
-> (a -> ParsecT [Char] u Identity b)
-> ParsecT [Char] u Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\[Char]
x -> ParsecT [Char] u Identity ()
forall {u}. ParsecT [Char] u Identity ()
cookieSep ParsecT [Char] u Identity ()
-> ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall a b.
ParsecT [Char] u Identity a
-> ParsecT [Char] u Identity b -> ParsecT [Char] u Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> ParsecT [Char] u Identity [Char]
forall a. a -> ParsecT [Char] u Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
x))
            [Cookie]
cookieList<-([Char] -> ParsecT [Char] u Identity Cookie
forall {u}. [Char] -> ParsecT [Char] u Identity Cookie
cookie_value [Char]
ver) ParsecT [Char] u Identity Cookie
-> ParsecT [Char] u Identity ()
-> ParsecT [Char] u Identity [Cookie]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
`sepBy1` ParsecT [Char] u Identity () -> ParsecT [Char] u Identity ()
forall tok st a. GenParser tok st a -> GenParser tok st a
try ParsecT [Char] u Identity ()
forall {u}. ParsecT [Char] u Identity ()
cookieSep
            ParsecT [Char] u Identity ()
forall {u}. ParsecT [Char] u Identity ()
ws
            ParsecT [Char] u Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
            [Cookie] -> ParsecT [Char] u Identity [Cookie]
forall a. a -> ParsecT [Char] u Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [Cookie]
cookieList
          cookie_value :: [Char] -> ParsecT [Char] u Identity Cookie
cookie_value [Char]
ver = do
            [Char]
name<-ParsecT [Char] u Identity [Char]
forall {u}. ParsecT [Char] u Identity [Char]
name_parser
            ParsecT [Char] u Identity ()
forall {u}. ParsecT [Char] u Identity ()
cookieEq
            [Char]
val<-ParsecT [Char] u Identity [Char]
forall {u}. ParsecT [Char] u Identity [Char]
value
            [Char]
path<-[Char]
-> ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option [Char]
"" (ParsecT [Char] u Identity [Char]
 -> ParsecT [Char] u Identity [Char])
-> ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall a b. (a -> b) -> a -> b
$ ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT [Char] u Identity ()
forall {u}. ParsecT [Char] u Identity ()
cookieSep ParsecT [Char] u Identity ()
-> ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall a b.
ParsecT [Char] u Identity a
-> ParsecT [Char] u Identity b -> ParsecT [Char] u Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT [Char] u Identity [Char]
forall {u}. ParsecT [Char] u Identity [Char]
cookie_path)
            [Char]
domain<-[Char]
-> ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option [Char]
"" (ParsecT [Char] u Identity [Char]
 -> ParsecT [Char] u Identity [Char])
-> ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall a b. (a -> b) -> a -> b
$ ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT [Char] u Identity ()
forall {u}. ParsecT [Char] u Identity ()
cookieSep ParsecT [Char] u Identity ()
-> ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall a b.
ParsecT [Char] u Identity a
-> ParsecT [Char] u Identity b -> ParsecT [Char] u Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT [Char] u Identity [Char]
forall {u}. ParsecT [Char] u Identity [Char]
cookie_domain)
            Cookie -> ParsecT [Char] u Identity Cookie
forall a. a -> ParsecT [Char] u Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Cookie -> ParsecT [Char] u Identity Cookie)
-> Cookie -> ParsecT [Char] u Identity Cookie
forall a b. (a -> b) -> a -> b
$ [Char]
-> [Char]
-> [Char]
-> [Char]
-> [Char]
-> Bool
-> Bool
-> SameSite
-> Bool
-> Cookie
Cookie [Char]
ver [Char]
path [Char]
domain (ShowS
low [Char]
name) [Char]
val Bool
False Bool
False SameSite
SameSiteNoValue Bool
False
          cookie_version :: ParsecT [Char] u Identity [Char]
cookie_version = [Char] -> ParsecT [Char] u Identity [Char]
forall {u}. [Char] -> ParsecT [Char] u Identity [Char]
cookie_special [Char]
"$Version"
          cookie_path :: ParsecT [Char] u Identity [Char]
cookie_path = [Char] -> ParsecT [Char] u Identity [Char]
forall {u}. [Char] -> ParsecT [Char] u Identity [Char]
cookie_special [Char]
"$Path"
          cookie_domain :: ParsecT [Char] u Identity [Char]
cookie_domain = [Char] -> ParsecT [Char] u Identity [Char]
forall {u}. [Char] -> ParsecT [Char] u Identity [Char]
cookie_special [Char]
"$Domain"
          cookie_special :: [Char] -> ParsecT [Char] u Identity [Char]
cookie_special [Char]
s = do
            ParsecT [Char] u Identity [Char] -> ParsecT [Char] u Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT [Char] u Identity [Char] -> ParsecT [Char] u Identity ())
-> ParsecT [Char] u Identity [Char] -> ParsecT [Char] u Identity ()
forall a b. (a -> b) -> a -> b
$ [Char] -> ParsecT [Char] u Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
s
            ParsecT [Char] u Identity ()
forall {u}. ParsecT [Char] u Identity ()
cookieEq
            ParsecT [Char] u Identity [Char]
forall {u}. ParsecT [Char] u Identity [Char]
value
          cookieSep :: ParsecT [Char] u Identity ()
cookieSep = ParsecT [Char] u Identity ()
forall {u}. ParsecT [Char] u Identity ()
ws ParsecT [Char] u Identity ()
-> ParsecT [Char] u Identity Char -> ParsecT [Char] u Identity Char
forall a b.
ParsecT [Char] u Identity a
-> ParsecT [Char] u Identity b -> ParsecT [Char] u Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> ParsecT [Char] u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
",;" ParsecT [Char] u Identity Char
-> ParsecT [Char] u Identity () -> ParsecT [Char] u Identity ()
forall a b.
ParsecT [Char] u Identity a
-> ParsecT [Char] u Identity b -> ParsecT [Char] u Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT [Char] u Identity ()
forall {u}. ParsecT [Char] u Identity ()
ws
          cookieEq :: ParsecT [Char] u Identity ()
cookieEq = ParsecT [Char] u Identity ()
forall {u}. ParsecT [Char] u Identity ()
ws ParsecT [Char] u Identity ()
-> ParsecT [Char] u Identity Char -> ParsecT [Char] u Identity Char
forall a b.
ParsecT [Char] u Identity a
-> ParsecT [Char] u Identity b -> ParsecT [Char] u Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ParsecT [Char] u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'=' ParsecT [Char] u Identity Char
-> ParsecT [Char] u Identity () -> ParsecT [Char] u Identity ()
forall a b.
ParsecT [Char] u Identity a
-> ParsecT [Char] u Identity b -> ParsecT [Char] u Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT [Char] u Identity ()
forall {u}. ParsecT [Char] u Identity ()
ws
          ws :: ParsecT [Char] u Identity ()
ws = ParsecT [Char] u Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
          value :: ParsecT [Char] u Identity [Char]
value         = ParsecT [Char] u Identity [Char]
forall {u}. ParsecT [Char] u Identity [Char]
word
          word :: ParsecT [Char] u Identity [Char]
word          = ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try ParsecT [Char] u Identity [Char]
forall {u}. ParsecT [Char] u Identity [Char]
quoted_string ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try ParsecT [Char] u Identity [Char]
forall {u}. ParsecT [Char] u Identity [Char]
incomp_token ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> [Char] -> ParsecT [Char] u Identity [Char]
forall a. a -> ParsecT [Char] u Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
""

          -- Parsers based on RFC 2068
          quoted_string :: ParsecT [Char] u Identity [Char]
quoted_string = do
            ParsecT [Char] u Identity Char -> ParsecT [Char] u Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT [Char] u Identity Char -> ParsecT [Char] u Identity ())
-> ParsecT [Char] u Identity Char -> ParsecT [Char] u Identity ()
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT [Char] u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"'
            [Char]
r <-ParsecT [Char] u Identity Char -> ParsecT [Char] u Identity [Char]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ((ParsecT [Char] u Identity Char -> ParsecT [Char] u Identity Char
forall tok st a. GenParser tok st a -> GenParser tok st a
try ParsecT [Char] u Identity Char
forall {u}. ParsecT [Char] u Identity Char
quotedPair) ParsecT [Char] u Identity Char
-> ParsecT [Char] u Identity Char -> ParsecT [Char] u Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ([Char] -> ParsecT [Char] u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
qdtext))
            ParsecT [Char] u Identity Char -> ParsecT [Char] u Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT [Char] u Identity Char -> ParsecT [Char] u Identity ())
-> ParsecT [Char] u Identity Char -> ParsecT [Char] u Identity ()
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT [Char] u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"'
            [Char] -> ParsecT [Char] u Identity [Char]
forall a. a -> ParsecT [Char] u Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
r

          -- Custom parsers, incompatible with RFC 2068, but more forgiving ;)
          incomp_token :: ParsecT [Char] u Identity [Char]
incomp_token  = ParsecT [Char] u Identity Char -> ParsecT [Char] u Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT [Char] u Identity Char
 -> ParsecT [Char] u Identity [Char])
-> ParsecT [Char] u Identity Char
-> ParsecT [Char] u Identity [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> ParsecT [Char] u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf (([Char]
chars [Char] -> ShowS
forall a. Eq a => [a] -> [a] -> [a]
\\ [Char]
ctl) [Char] -> ShowS
forall a. Eq a => [a] -> [a] -> [a]
\\ [Char]
" \t\";")
          name_parser :: ParsecT [Char] u Identity [Char]
name_parser   = ParsecT [Char] u Identity Char -> ParsecT [Char] u Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT [Char] u Identity Char
 -> ParsecT [Char] u Identity [Char])
-> ParsecT [Char] u Identity Char
-> ParsecT [Char] u Identity [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> ParsecT [Char] u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf (([Char]
chars [Char] -> ShowS
forall a. Eq a => [a] -> [a] -> [a]
\\ [Char]
ctl) [Char] -> ShowS
forall a. Eq a => [a] -> [a] -> [a]
\\ [Char]
"= ;,")

          -- Primitives from RFC 2068
          ctl :: [Char]
ctl           = (Int -> Char) -> [Int] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
chr (Int
127Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int
0..Int
31])
          chars :: [Char]
chars         = (Int -> Char) -> [Int] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
chr [Int
0..Int
127]
          octet :: [Char]
octet         = (Int -> Char) -> [Int] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
chr [Int
0..Int
255]
          text :: [Char]
text          = [Char]
octet [Char] -> ShowS
forall a. Eq a => [a] -> [a] -> [a]
\\ [Char]
ctl
          qdtext :: [Char]
qdtext        = [Char]
text [Char] -> ShowS
forall a. Eq a => [a] -> [a] -> [a]
\\ [Char]
"\""
          quotedPair :: ParsecT [Char] u Identity Char
quotedPair    = Char -> ParsecT [Char] u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\\' ParsecT [Char] u Identity Char
-> ParsecT [Char] u Identity Char -> ParsecT [Char] u Identity Char
forall a b.
ParsecT [Char] u Identity a
-> ParsecT [Char] u Identity b -> ParsecT [Char] u Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT [Char] u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar

-- | Get all cookies from the HTTP request. The cookies are ordered per RFC from
-- the most specific to the least specific. Multiple cookies with the same
-- name are allowed to exist.
getCookies :: MonadFail m => C.ByteString -> m [Cookie]
getCookies :: forall (m :: * -> *). MonadFail m => ByteString -> m [Cookie]
getCookies ByteString
h = ByteString -> m (Either [Char] [Cookie])
forall (m :: * -> *).
Monad m =>
ByteString -> m (Either [Char] [Cookie])
getCookies' ByteString
h m (Either [Char] [Cookie])
-> (Either [Char] [Cookie] -> m [Cookie]) -> m [Cookie]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=  ([Char] -> m [Cookie])
-> ([Cookie] -> m [Cookie]) -> Either [Char] [Cookie] -> m [Cookie]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> m [Cookie]
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail([Char] -> m [Cookie]) -> ShowS -> [Char] -> m [Cookie]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"Cookie parsing failed!"[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++)) [Cookie] -> m [Cookie]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Get the most specific cookie with the given name. Fails if there is no such
-- cookie or if the browser did not escape cookies in a proper fashion.
-- Browser support for escaping cookies properly is very diverse.
getCookie :: MonadFail m => String -> C.ByteString -> m Cookie
getCookie :: forall (m :: * -> *).
MonadFail m =>
[Char] -> ByteString -> m Cookie
getCookie [Char]
s ByteString
h = [Char] -> ByteString -> m (Either [Char] Cookie)
forall (m :: * -> *).
Monad m =>
[Char] -> ByteString -> m (Either [Char] Cookie)
getCookie' [Char]
s ByteString
h m (Either [Char] Cookie)
-> (Either [Char] Cookie -> m Cookie) -> m Cookie
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([Char] -> m Cookie)
-> (Cookie -> m Cookie) -> Either [Char] Cookie -> m Cookie
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (m Cookie -> [Char] -> m Cookie
forall a b. a -> b -> a
const (m Cookie -> [Char] -> m Cookie) -> m Cookie -> [Char] -> m Cookie
forall a b. (a -> b) -> a -> b
$ [Char] -> m Cookie
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"getCookie: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> [Char]
show [Char]
s)) Cookie -> m Cookie
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return

getCookies' :: Monad m => C.ByteString -> m (Either String [Cookie])
getCookies' :: forall (m :: * -> *).
Monad m =>
ByteString -> m (Either [Char] [Cookie])
getCookies' ByteString
header | ByteString -> Bool
C.null ByteString
header = Either [Char] [Cookie] -> m (Either [Char] [Cookie])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] [Cookie] -> m (Either [Char] [Cookie]))
-> Either [Char] [Cookie] -> m (Either [Char] [Cookie])
forall a b. (a -> b) -> a -> b
$ [Cookie] -> Either [Char] [Cookie]
forall a b. b -> Either a b
Right []
                   | Bool
otherwise     = Either [Char] [Cookie] -> m (Either [Char] [Cookie])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] [Cookie] -> m (Either [Char] [Cookie]))
-> Either [Char] [Cookie] -> m (Either [Char] [Cookie])
forall a b. (a -> b) -> a -> b
$ [Char] -> Either [Char] [Cookie]
parseCookies (ByteString -> [Char]
C.unpack ByteString
header)

getCookie' :: Monad m => String -> C.ByteString -> m (Either String Cookie)
getCookie' :: forall (m :: * -> *).
Monad m =>
[Char] -> ByteString -> m (Either [Char] Cookie)
getCookie' [Char]
s ByteString
h = do
    Either [Char] [Cookie]
cs <- ByteString -> m (Either [Char] [Cookie])
forall (m :: * -> *).
Monad m =>
ByteString -> m (Either [Char] [Cookie])
getCookies' ByteString
h
    Either [Char] Cookie -> m (Either [Char] Cookie)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] Cookie -> m (Either [Char] Cookie))
-> Either [Char] Cookie -> m (Either [Char] Cookie)
forall a b. (a -> b) -> a -> b
$ do -- Either
       [Cookie]
cooks <- Either [Char] [Cookie]
cs
       case (Cookie -> Bool) -> [Cookie] -> [Cookie]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Cookie
x->[Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
(==)  (ShowS
low [Char]
s)  (Cookie -> [Char]
cookieName Cookie
x) ) [Cookie]
cooks of
            [] -> [Char] -> Either [Char] Cookie
forall a b. a -> Either a b
Left [Char]
"No cookie found"
            [Cookie]
f -> Cookie -> Either [Char] Cookie
forall a. a -> Either [Char] a
forall (m :: * -> *) a. Monad m => a -> m a
return (Cookie -> Either [Char] Cookie) -> Cookie -> Either [Char] Cookie
forall a b. (a -> b) -> a -> b
$ [Cookie] -> Cookie
forall a. HasCallStack => [a] -> a
head [Cookie]
f

low :: String -> String
low :: ShowS
low = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower