{-# LANGUAGE CPP, DeriveDataTypeable #-}

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

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

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

-- | a type for HTTP cookies. Usually created using 'mkCookie'.
data Cookie = Cookie
    { Cookie -> [Char]
cookieVersion :: String
    , Cookie -> [Char]
cookiePath    :: String
    , Cookie -> [Char]
cookieDomain  :: String
    , Cookie -> [Char]
cookieName    :: String
    , Cookie -> [Char]
cookieValue   :: String
    , Cookie -> Bool
secure        :: Bool
    , Cookie -> Bool
httpOnly      :: Bool
    , Cookie -> SameSite
sameSite      :: SameSite
    } deriving(Int -> Cookie -> ShowS
[Cookie] -> ShowS
Cookie -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Cookie] -> ShowS
$cshowList :: [Cookie] -> ShowS
show :: Cookie -> [Char]
$cshow :: Cookie -> [Char]
showsPrec :: Int -> Cookie -> ShowS
$cshowsPrec :: Int -> Cookie -> ShowS
Show,Cookie -> Cookie -> Bool
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]
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
Cookie -> DataType
Cookie -> Constr
(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)
gmapMo :: 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
gmapMp :: forall (m :: * -> *).
MonadPlus 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
gmapM :: forall (m :: * -> *).
Monad m =>
(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 :: forall u. Int -> (forall d. Data d => d -> u) -> Cookie -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Cookie -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> Cookie -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Cookie -> [u]
gmapQr :: 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
gmapQl :: forall r r'.
(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 (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(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 (t :: * -> *) (c :: * -> *).
Typeable t =>
(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 (c :: * -> *).
(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 (c :: * -> *).
(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
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
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
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
Ord, ReadPrec [CookieLife]
ReadPrec CookieLife
Int -> ReadS CookieLife
ReadS [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 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [CookieLife] -> ShowS
$cshowList :: [CookieLife] -> ShowS
show :: CookieLife -> [Char]
$cshow :: CookieLife -> [Char]
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
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
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
Ord, Typeable, Typeable SameSite
SameSite -> DataType
SameSite -> Constr
(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)
gmapMo :: 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
gmapMp :: forall (m :: * -> *).
MonadPlus 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
gmapM :: forall (m :: * -> *).
Monad m =>
(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 :: forall u. Int -> (forall d. Data d => d -> u) -> SameSite -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> SameSite -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> SameSite -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> SameSite -> [u]
gmapQr :: 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
gmapQl :: forall r r'.
(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 (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(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 (t :: * -> *) (c :: * -> *).
Typeable t =>
(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 (c :: * -> *).
(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 (c :: * -> *).
(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
Data, Int -> SameSite -> ShowS
[SameSite] -> ShowS
SameSite -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SameSite] -> ShowS
$cshowList :: [SameSite] -> ShowS
show :: SameSite -> [Char]
$cshow :: SameSite -> [Char]
showsPrec :: Int -> SameSite -> ShowS
$cshowsPrec :: Int -> SameSite -> ShowS
Show, ReadPrec [SameSite]
ReadPrec SameSite
Int -> ReadS SameSite
ReadS [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 -> [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 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
calcLife (MaxAge Int
s) =
          do UTCTime
now <- IO UTCTime
getApproximateUTCTime
             forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (Int
s, NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s) UTCTime
now))
calcLife (Expires UTCTime
expirationDate) =
          do UTCTime
now <- IO UTCTime
getApproximateUTCTime
             forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (forall a b. (RealFrac a, Integral b) => a -> b
round  forall a b. (a -> b) -> a -> b
$ UTCTime
expirationDate UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
now, UTCTime
expirationDate)
calcLife CookieLife
Expired =
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 :: [Char] -> [Char] -> Cookie
mkCookie [Char]
key [Char]
val = [Char]
-> [Char]
-> [Char]
-> [Char]
-> [Char]
-> Bool
-> Bool
-> SameSite
-> Cookie
Cookie [Char]
"1" [Char]
"/" [Char]
"" [Char]
key [Char]
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 -> [Char]
mkCookieHeader Maybe (Int, UTCTime)
mLife Cookie
cookie =
  let
    l :: [([Char], [Char])]
l =
      [ (,) [Char]
"Domain="  (Cookie -> [Char]
cookieDomain Cookie
cookie)
      , (,) [Char]
"Max-Age=" (forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" (forall a. Show a => a -> [Char]
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a
max Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) Maybe (Int, UTCTime)
mLife)
      , (,) [Char]
"expires=" (forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" (UTCTime -> [Char]
formatTime'  forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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' =
      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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char
'A'..Char
'Z'] forall a. [a] -> [a] -> [a]
++ [Char
'a'..Char
'z'] forall a. [a] -> [a] -> [a]
++ [Char
'0'..Char
'9'] forall a. [a] -> [a] -> [a]
++ [Char]
"-_.~"))
    s :: (Cookie -> [Char]) -> [Char]
s Cookie -> [Char]
f | Cookie -> [Char]
f Cookie
cookie forall a. Eq a => a -> a -> Bool
== [Char]
"" = [Char]
""
        | Bool
otherwise      = Char
'\"' forall a. a -> [a] -> [a]
: (ShowS
encode forall a b. (a -> b) -> a -> b
$ Cookie -> [Char]
f Cookie
cookie) forall a. [a] -> [a] -> [a]
++ [Char]
"\""
  in
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse [Char]
";" forall a b. (a -> b) -> a -> b
$
         (Cookie -> [Char]
cookieName Cookie
cookieforall a. [a] -> [a] -> [a]
++[Char]
"="forall a. [a] -> [a] -> [a]
++(Cookie -> [Char]) -> [Char]
s Cookie -> [Char]
cookieValue)forall a. a -> [a] -> [a]
:[ ([Char]
kforall a. [a] -> [a] -> [a]
++[Char]
v) | ([Char]
k,[Char]
v) <- [([Char], [Char])]
l, [Char]
"" forall a. Eq a => a -> a -> Bool
/= [Char]
v ]
      forall a. [a] -> [a] -> [a]
++ (if Cookie -> Bool
secure   Cookie
cookie then [[Char]
"Secure"]   else [])
      forall a. [a] -> [a] -> [a]
++ (if Cookie -> Bool
httpOnly Cookie
cookie then [[Char]
"HttpOnly"] else [])
      forall a. [a] -> [a] -> [a]
++ (if Cookie -> SameSite
sameSite Cookie
cookie forall a. Eq a => a -> a -> Bool
/= SameSite
SameSiteNoValue
          then [SameSite -> [Char]
displaySameSite forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cookie -> SameSite
sameSite 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 :: [Char] -> Either [Char] [Cookie]
parseCookies [Char]
str = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
parse 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 = forall st. GenParser Char st [Cookie]
cookies
    where -- Parsers based on RFC 2109
          cookies :: ParsecT [Char] u Identity [Cookie]
cookies = do
            forall {u}. ParsecT [Char] u Identity ()
ws
            [Char]
ver<-forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option [Char]
"" forall a b. (a -> b) -> a -> b
$ forall tok st a. GenParser tok st a -> GenParser tok st a
try (forall {u}. ParsecT [Char] u Identity [Char]
cookie_version forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\[Char]
x -> forall {u}. ParsecT [Char] u Identity ()
cookieSep forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
x))
            [Cookie]
cookieList<-(forall {u}. [Char] -> ParsecT [Char] u Identity Cookie
cookie_value [Char]
ver) 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` forall tok st a. GenParser tok st a -> GenParser tok st a
try forall {u}. ParsecT [Char] u Identity ()
cookieSep
            forall {u}. ParsecT [Char] u Identity ()
ws
            forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
            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<-forall {u}. ParsecT [Char] u Identity [Char]
name_parser
            forall {u}. ParsecT [Char] u Identity ()
cookieEq
            [Char]
val<-forall {u}. ParsecT [Char] u Identity [Char]
value
            [Char]
path<-forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option [Char]
"" forall a b. (a -> b) -> a -> b
$ forall tok st a. GenParser tok st a -> GenParser tok st a
try (forall {u}. ParsecT [Char] u Identity ()
cookieSep forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall {u}. ParsecT [Char] u Identity [Char]
cookie_path)
            [Char]
domain<-forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option [Char]
"" forall a b. (a -> b) -> a -> b
$ forall tok st a. GenParser tok st a -> GenParser tok st a
try (forall {u}. ParsecT [Char] u Identity ()
cookieSep forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall {u}. ParsecT [Char] u Identity [Char]
cookie_domain)
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char]
-> [Char]
-> [Char]
-> [Char]
-> [Char]
-> Bool
-> Bool
-> SameSite
-> Cookie
Cookie [Char]
ver [Char]
path [Char]
domain (ShowS
low [Char]
name) [Char]
val Bool
False Bool
False SameSite
SameSiteNoValue
          cookie_version :: ParsecT [Char] u Identity [Char]
cookie_version = forall {u}. [Char] -> ParsecT [Char] u Identity [Char]
cookie_special [Char]
"$Version"
          cookie_path :: ParsecT [Char] u Identity [Char]
cookie_path = forall {u}. [Char] -> ParsecT [Char] u Identity [Char]
cookie_special [Char]
"$Path"
          cookie_domain :: ParsecT [Char] u Identity [Char]
cookie_domain = 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
            forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
s
            forall {u}. ParsecT [Char] u Identity ()
cookieEq
            forall {u}. ParsecT [Char] u Identity [Char]
value
          cookieSep :: ParsecT [Char] u Identity ()
cookieSep = forall {u}. ParsecT [Char] u Identity ()
ws forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
",;" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall {u}. ParsecT [Char] u Identity ()
ws
          cookieEq :: ParsecT [Char] u Identity ()
cookieEq = forall {u}. ParsecT [Char] u Identity ()
ws forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'=' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall {u}. ParsecT [Char] u Identity ()
ws
          ws :: ParsecT [Char] u Identity ()
ws = forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
          value :: ParsecT [Char] u Identity [Char]
value         = forall {u}. ParsecT [Char] u Identity [Char]
word
          word :: ParsecT [Char] u Identity [Char]
word          = forall tok st a. GenParser tok st a -> GenParser tok st a
try forall {u}. ParsecT [Char] u Identity [Char]
quoted_string forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall tok st a. GenParser tok st a -> GenParser tok st a
try forall {u}. ParsecT [Char] u Identity [Char]
incomp_token forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m 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
            forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"'
            [Char]
r <-forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ((forall tok st a. GenParser tok st a -> GenParser tok st a
try forall {u}. ParsecT [Char] u Identity Char
quotedPair) forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
qdtext))
            forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"'
            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  = forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf (([Char]
chars forall a. Eq a => [a] -> [a] -> [a]
\\ [Char]
ctl) forall a. Eq a => [a] -> [a] -> [a]
\\ [Char]
" \t\";")
          name_parser :: ParsecT [Char] u Identity [Char]
name_parser   = forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf (([Char]
chars forall a. Eq a => [a] -> [a] -> [a]
\\ [Char]
ctl) forall a. Eq a => [a] -> [a] -> [a]
\\ [Char]
"= ;,")

          -- Primitives from RFC 2068
          ctl :: [Char]
ctl           = forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
chr (Int
127forall a. a -> [a] -> [a]
:[Int
0..Int
31])
          chars :: [Char]
chars         = forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
chr [Int
0..Int
127]
          octet :: [Char]
octet         = forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
chr [Int
0..Int
255]
          text :: [Char]
text          = [Char]
octet forall a. Eq a => [a] -> [a] -> [a]
\\ [Char]
ctl
          qdtext :: [Char]
qdtext        = [Char]
text forall a. Eq a => [a] -> [a] -> [a]
\\ [Char]
"\""
          quotedPair :: ParsecT [Char] u Identity Char
quotedPair    = forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\\' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 = forall (m :: * -> *).
Monad m =>
ByteString -> m (Either [Char] [Cookie])
getCookies' ByteString
h forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
failforall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"Cookie parsing failed!"forall a. [a] -> [a] -> [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 = forall (m :: * -> *).
Monad m =>
[Char] -> ByteString -> m (Either [Char] Cookie)
getCookie' [Char]
s ByteString
h forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"getCookie: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
s)) 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 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right []
                   | Bool
otherwise     = forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall (m :: * -> *).
Monad m =>
ByteString -> m (Either [Char] [Cookie])
getCookies' ByteString
h
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do -- Either
       [Cookie]
cooks <- Either [Char] [Cookie]
cs
       case forall a. (a -> Bool) -> [a] -> [a]
filter (\Cookie
x->forall a. Eq a => a -> a -> Bool
(==)  (ShowS
low [Char]
s)  (Cookie -> [Char]
cookieName Cookie
x) ) [Cookie]
cooks of
            [] -> forall a b. a -> Either a b
Left [Char]
"No cookie found"
            [Cookie]
f -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [Cookie]
f

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