{-# 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)
import Data.List             ((\\), intersperse)
import Data.Time.Clock       (UTCTime, addUTCTime, diffUTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Time.Format      (formatTime, defaultTimeLocale)
import Happstack.Server.Internal.Clock (getApproximateUTCTime)
import Network.URI           (escapeURIString)
import Text.ParserCombinators.Parsec hiding (token)




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

-- | 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 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 u (m :: * -> *) a. 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 u (m :: * -> *) a. 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