{-# 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 -> String
cookieVersion :: String
    , Cookie -> String
cookiePath    :: String
    , Cookie -> String
cookieDomain  :: String
    , Cookie -> String
cookieName    :: String
    , Cookie -> String
cookieValue   :: String
    , Cookie -> Bool
secure        :: Bool
    , Cookie -> Bool
httpOnly      :: Bool
    , Cookie -> SameSite
sameSite      :: SameSite
    } deriving(Int -> Cookie -> ShowS
[Cookie] -> ShowS
Cookie -> String
(Int -> Cookie -> ShowS)
-> (Cookie -> String) -> ([Cookie] -> ShowS) -> Show Cookie
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Cookie] -> ShowS
$cshowList :: [Cookie] -> ShowS
show :: Cookie -> String
$cshow :: Cookie -> String
showsPrec :: Int -> Cookie -> ShowS
$cshowsPrec :: Int -> Cookie -> ShowS
Show,Cookie -> Cookie -> Bool
(Cookie -> Cookie -> Bool)
-> (Cookie -> Cookie -> Bool) -> Eq Cookie
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cookie -> Cookie -> Bool
$c/= :: Cookie -> Cookie -> Bool
== :: Cookie -> Cookie -> Bool
$c== :: 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
readListPrec :: ReadPrec [Cookie]
$creadListPrec :: ReadPrec [Cookie]
readPrec :: ReadPrec Cookie
$creadPrec :: ReadPrec Cookie
readList :: ReadS [Cookie]
$creadList :: ReadS [Cookie]
readsPrec :: Int -> ReadS Cookie
$creadsPrec :: Int -> ReadS Cookie
Read,Typeable,Typeable Cookie
DataType
Constr
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 -> DataType
Cookie -> Constr
(forall b. Data b => b -> b) -> Cookie -> Cookie
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Cookie -> c Cookie
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c 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)
$cCookie :: Constr
$tCookie :: DataType
gmapMo :: (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
gmapMp :: (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
gmapM :: (forall d. Data d => d -> m d) -> Cookie -> m Cookie
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Cookie -> m Cookie
gmapQi :: Int -> (forall d. Data d => d -> u) -> Cookie -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Cookie -> u
gmapQ :: (forall d. Data d => d -> u) -> Cookie -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Cookie -> [u]
gmapQr :: (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
gmapQl :: (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Cookie -> r
$cgmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Cookie -> r
gmapT :: (forall b. Data b => b -> b) -> Cookie -> Cookie
$cgmapT :: (forall b. Data b => b -> b) -> Cookie -> Cookie
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Cookie)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Cookie)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c Cookie)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Cookie)
dataTypeOf :: Cookie -> DataType
$cdataTypeOf :: Cookie -> DataType
toConstr :: Cookie -> Constr
$ctoConstr :: Cookie -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Cookie
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Cookie
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Cookie -> c Cookie
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Cookie -> c Cookie
$cp1Data :: Typeable 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
/= :: CookieLife -> CookieLife -> Bool
$c/= :: CookieLife -> CookieLife -> Bool
== :: CookieLife -> CookieLife -> Bool
$c== :: 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
min :: CookieLife -> CookieLife -> CookieLife
$cmin :: CookieLife -> CookieLife -> CookieLife
max :: CookieLife -> CookieLife -> CookieLife
$cmax :: CookieLife -> CookieLife -> CookieLife
>= :: CookieLife -> CookieLife -> Bool
$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
compare :: CookieLife -> CookieLife -> Ordering
$ccompare :: CookieLife -> CookieLife -> Ordering
$cp1Ord :: Eq 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
readListPrec :: ReadPrec [CookieLife]
$creadListPrec :: ReadPrec [CookieLife]
readPrec :: ReadPrec CookieLife
$creadPrec :: ReadPrec CookieLife
readList :: ReadS [CookieLife]
$creadList :: ReadS [CookieLife]
readsPrec :: Int -> ReadS CookieLife
$creadsPrec :: Int -> ReadS CookieLife
Read, Int -> CookieLife -> ShowS
[CookieLife] -> ShowS
CookieLife -> String
(Int -> CookieLife -> ShowS)
-> (CookieLife -> String)
-> ([CookieLife] -> ShowS)
-> Show CookieLife
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CookieLife] -> ShowS
$cshowList :: [CookieLife] -> ShowS
show :: CookieLife -> String
$cshow :: CookieLife -> String
showsPrec :: Int -> CookieLife -> ShowS
$cshowsPrec :: Int -> 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
/= :: SameSite -> SameSite -> Bool
$c/= :: SameSite -> SameSite -> Bool
== :: SameSite -> SameSite -> Bool
$c== :: 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
min :: SameSite -> SameSite -> SameSite
$cmin :: SameSite -> SameSite -> SameSite
max :: SameSite -> SameSite -> SameSite
$cmax :: SameSite -> SameSite -> SameSite
>= :: SameSite -> SameSite -> Bool
$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
compare :: SameSite -> SameSite -> Ordering
$ccompare :: SameSite -> SameSite -> Ordering
$cp1Ord :: Eq SameSite
Ord, Typeable, Typeable SameSite
DataType
Constr
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 -> DataType
SameSite -> Constr
(forall b. Data b => b -> b) -> SameSite -> SameSite
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SameSite -> c SameSite
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c 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)
$cSameSiteNoValue :: Constr
$cSameSiteNone :: Constr
$cSameSiteStrict :: Constr
$cSameSiteLax :: Constr
$tSameSite :: DataType
gmapMo :: (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
gmapMp :: (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
gmapM :: (forall d. Data d => d -> m d) -> SameSite -> m SameSite
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> SameSite -> m SameSite
gmapQi :: Int -> (forall d. Data d => d -> u) -> SameSite -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> SameSite -> u
gmapQ :: (forall d. Data d => d -> u) -> SameSite -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> SameSite -> [u]
gmapQr :: (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
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SameSite -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SameSite -> r
gmapT :: (forall b. Data b => b -> b) -> SameSite -> SameSite
$cgmapT :: (forall b. Data b => b -> b) -> SameSite -> SameSite
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c SameSite)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c SameSite)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c SameSite)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c SameSite)
dataTypeOf :: SameSite -> DataType
$cdataTypeOf :: SameSite -> DataType
toConstr :: SameSite -> Constr
$ctoConstr :: SameSite -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SameSite
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SameSite
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SameSite -> c SameSite
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SameSite -> c SameSite
$cp1Data :: Typeable SameSite
Data, Int -> SameSite -> ShowS
[SameSite] -> ShowS
SameSite -> String
(Int -> SameSite -> ShowS)
-> (SameSite -> String) -> ([SameSite] -> ShowS) -> Show SameSite
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SameSite] -> ShowS
$cshowList :: [SameSite] -> ShowS
show :: SameSite -> String
$cshow :: SameSite -> String
showsPrec :: Int -> SameSite -> ShowS
$cshowsPrec :: Int -> 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
readListPrec :: ReadPrec [SameSite]
$creadListPrec :: ReadPrec [SameSite]
readPrec :: ReadPrec SameSite
$creadPrec :: ReadPrec SameSite
readList :: ReadS [SameSite]
$creadList :: ReadS [SameSite]
readsPrec :: Int -> ReadS SameSite
$creadsPrec :: Int -> ReadS SameSite
Read)

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

-- 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 (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 (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 (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 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 (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
--
-- see also: 'addCookie'
mkCookie :: String  -- ^ cookie name
         -> String  -- ^ cookie value
         -> Cookie
mkCookie :: String -> String -> Cookie
mkCookie String
key String
val = String
-> String
-> String
-> String
-> String
-> Bool
-> Bool
-> SameSite
-> Cookie
Cookie String
"1" String
"/" String
"" String
key String
val Bool
False Bool
False SameSite
SameSiteNoValue

-- | 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 -> String
mkCookieHeader Maybe (Int, UTCTime)
mLife Cookie
cookie =
  let
    l :: [(String, String)]
l =
      [ (,) String
"Domain="  (Cookie -> String
cookieDomain Cookie
cookie)
      , (,) String
"Max-Age=" (String
-> ((Int, UTCTime) -> String) -> Maybe (Int, UTCTime) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (Int -> String
forall a. Show a => a -> String
show (Int -> String)
-> ((Int, UTCTime) -> Int) -> (Int, UTCTime) -> String
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)
      , (,) String
"expires=" (String
-> ((Int, UTCTime) -> String) -> Maybe (Int, UTCTime) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (UTCTime -> String
formatTime'  (UTCTime -> String)
-> ((Int, UTCTime) -> UTCTime) -> (Int, UTCTime) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, UTCTime) -> UTCTime
forall a b. (a, b) -> b
snd) Maybe (Int, UTCTime)
mLife)
      , (,) String
"Path="    (Cookie -> String
cookiePath Cookie
cookie)
      , (,) String
"Version=" ((Cookie -> String) -> String
s Cookie -> String
cookieVersion)
      ]
    formatTime' :: UTCTime -> String
formatTime' =
      TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%a, %d-%b-%Y %X GMT"
    encode :: ShowS
encode =
      (Char -> Bool) -> ShowS
escapeURIString
        (\Char
c -> Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char
'A'..Char
'Z'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'a'..Char
'z'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'0'..Char
'9'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-_.~"))
    s :: (Cookie -> String) -> String
s Cookie -> String
f | Cookie -> String
f Cookie
cookie String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" = String
""
        | Bool
otherwise      = Char
'\"' Char -> ShowS
forall a. a -> [a] -> [a]
: (ShowS
encode ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Cookie -> String
f Cookie
cookie) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\""
  in
    [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
";" ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
         (Cookie -> String
cookieName Cookie
cookieString -> ShowS
forall a. [a] -> [a] -> [a]
++String
"="String -> ShowS
forall a. [a] -> [a] -> [a]
++(Cookie -> String) -> String
s Cookie -> String
cookieValue)String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[ (String
kString -> ShowS
forall a. [a] -> [a] -> [a]
++String
v) | (String
k,String
v) <- [(String, String)]
l, String
"" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
v ]
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (if Cookie -> Bool
secure   Cookie
cookie then [String
"Secure"]   else [])
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (if Cookie -> Bool
httpOnly Cookie
cookie then [String
"HttpOnly"] else [])
      [String] -> [String] -> [String]
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 -> String
displaySameSite (SameSite -> String) -> (Cookie -> SameSite) -> Cookie -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cookie -> SameSite
sameSite (Cookie -> String) -> Cookie -> String
forall a b. (a -> b) -> a -> b
$ Cookie
cookie] 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 :: String -> Either String [Cookie]
parseCookies String
str = (ParseError -> Either String [Cookie])
-> ([Cookie] -> Either String [Cookie])
-> Either ParseError [Cookie]
-> Either String [Cookie]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Either String [Cookie]
forall a b. a -> Either a b
Left (String -> Either String [Cookie])
-> (ParseError -> String) -> ParseError -> Either String [Cookie]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> String
forall a. Show a => a -> String
show) [Cookie] -> Either String [Cookie]
forall a b. b -> Either a b
Right (Either ParseError [Cookie] -> Either String [Cookie])
-> Either ParseError [Cookie] -> Either String [Cookie]
forall a b. (a -> b) -> a -> b
$ Parsec String () [Cookie]
-> String -> String -> Either ParseError [Cookie]
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parsec String () [Cookie]
forall st. GenParser Char st [Cookie]
cookiesParser String
str String
str

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

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

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

          -- Primitives from RFC 2068
          ctl :: String
ctl           = (Int -> Char) -> [Int] -> String
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 :: String
chars         = (Int -> Char) -> [Int] -> String
forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
chr [Int
0..Int
127]
          octet :: String
octet         = (Int -> Char) -> [Int] -> String
forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
chr [Int
0..Int
255]
          text :: String
text          = String
octet String -> ShowS
forall a. Eq a => [a] -> [a] -> [a]
\\ String
ctl
          qdtext :: String
qdtext        = String
text String -> ShowS
forall a. Eq a => [a] -> [a] -> [a]
\\ String
"\""
          quotedPair :: ParsecT String u Identity Char
quotedPair    = Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\\' ParsecT String u Identity Char
-> ParsecT String u Identity Char -> ParsecT String u Identity Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String 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 :: ByteString -> m [Cookie]
getCookies ByteString
h = ByteString -> m (Either String [Cookie])
forall (m :: * -> *).
Monad m =>
ByteString -> m (Either String [Cookie])
getCookies' ByteString
h m (Either String [Cookie])
-> (Either String [Cookie] -> m [Cookie]) -> m [Cookie]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=  (String -> m [Cookie])
-> ([Cookie] -> m [Cookie]) -> Either String [Cookie] -> m [Cookie]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> m [Cookie]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail(String -> m [Cookie]) -> ShowS -> String -> m [Cookie]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Cookie parsing failed!"String -> ShowS
forall a. [a] -> [a] -> [a]
++)) [Cookie] -> m [Cookie]
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 :: String -> ByteString -> m Cookie
getCookie String
s ByteString
h = String -> ByteString -> m (Either String Cookie)
forall (m :: * -> *).
Monad m =>
String -> ByteString -> m (Either String Cookie)
getCookie' String
s ByteString
h m (Either String Cookie)
-> (Either String Cookie -> m Cookie) -> m Cookie
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> m Cookie)
-> (Cookie -> m Cookie) -> Either String Cookie -> m Cookie
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (m Cookie -> String -> m Cookie
forall a b. a -> b -> a
const (m Cookie -> String -> m Cookie) -> m Cookie -> String -> m Cookie
forall a b. (a -> b) -> a -> b
$ String -> m Cookie
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"getCookie: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
s)) Cookie -> m Cookie
forall (m :: * -> *) a. Monad m => a -> m a
return

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

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