{-# LANGUAGE OverloadedStrings #-}
-- | This module implements the algorithms described in RFC 6265 for the Network.HTTP.Conduit library.
module Network.HTTP.Client.Cookies
    ( updateCookieJar
    , receiveSetCookie
    , generateCookie
    , insertCheckedCookie
    , insertCookiesIntoRequest
    , computeCookieString
    , evictExpiredCookies
    , createCookieJar
    , destroyCookieJar
    , pathMatches
    , removeExistingCookieFromCookieJar
    , domainMatches
    , isIpAddress
    , defaultPath
    ) where

import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as S8
import Data.Maybe
import qualified Data.List as L
import Data.Time.Clock
import Data.Time.Calendar
import Web.Cookie
import qualified Data.CaseInsensitive as CI
import Blaze.ByteString.Builder
import qualified Network.PublicSuffixList.Lookup as PSL
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)

import Network.HTTP.Client.Types as Req

slash :: Integral a => a
slash :: a
slash = a
47 -- '/'

isIpAddress :: BS.ByteString -> Bool
isIpAddress :: ByteString -> Bool
isIpAddress =
    Int -> ByteString -> Bool
forall t. (Eq t, Num t) => t -> ByteString -> Bool
go (Int
4 :: Int)
  where
    go :: t -> ByteString -> Bool
go t
0 ByteString
bs = ByteString -> Bool
BS.null ByteString
bs
    go t
rest ByteString
bs =
        case ByteString -> Maybe (Int, ByteString)
S8.readInt ByteString
x of
            Just (Int
i, ByteString
x') | ByteString -> Bool
BS.null ByteString
x' Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
256 -> t -> ByteString -> Bool
go (t
rest t -> t -> t
forall a. Num a => a -> a -> a
- t
1) ByteString
y
            Maybe (Int, ByteString)
_ -> Bool
False
      where
        (ByteString
x, ByteString
y') = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
BS.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
46) ByteString
bs -- period
        y :: ByteString
y = Int -> ByteString -> ByteString
BS.drop Int
1 ByteString
y'

-- | This corresponds to the subcomponent algorithm entitled \"Domain Matching\" detailed
-- in section 5.1.3
domainMatches :: BS.ByteString -- ^ Domain to test
              -> BS.ByteString -- ^ Domain from a cookie
              -> Bool
domainMatches :: ByteString -> ByteString -> Bool
domainMatches ByteString
string' ByteString
domainString'
  | ByteString
string ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
domainString = Bool
True
  | ByteString -> Int
BS.length ByteString
string Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< ByteString -> Int
BS.length ByteString
domainString Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 = Bool
False
  | ByteString
domainString ByteString -> ByteString -> Bool
`BS.isSuffixOf` ByteString
string Bool -> Bool -> Bool
&& Word8 -> ByteString
BS.singleton (ByteString -> Word8
BS.last ByteString
difference) ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"." Bool -> Bool -> Bool
&& Bool -> Bool
not (ByteString -> Bool
isIpAddress ByteString
string) = Bool
True
  | Bool
otherwise = Bool
False
  where difference :: ByteString
difference = Int -> ByteString -> ByteString
BS.take (ByteString -> Int
BS.length ByteString
string Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
BS.length ByteString
domainString) ByteString
string
        string :: ByteString
string = ByteString -> ByteString
forall s. FoldCase s => s -> s
CI.foldCase ByteString
string'
        domainString :: ByteString
domainString = ByteString -> ByteString
forall s. FoldCase s => s -> s
CI.foldCase ByteString
domainString'

-- | This corresponds to the subcomponent algorithm entitled \"Paths\" detailed
-- in section 5.1.4
defaultPath :: Req.Request   -> BS.ByteString
defaultPath :: Request -> ByteString
defaultPath Request
req
  | ByteString -> Bool
BS.null ByteString
uri_path = ByteString
"/"
  | Word8 -> ByteString
BS.singleton (ByteString -> Word8
BS.head ByteString
uri_path) ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"/" = ByteString
"/"
  | Word8 -> ByteString -> Int
BS.count Word8
forall a. Integral a => a
slash ByteString
uri_path Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 = ByteString
"/"
  | Bool
otherwise = ByteString -> ByteString
BS.reverse (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.tail (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ (Word8 -> Bool) -> ByteString -> ByteString
BS.dropWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
forall a. Integral a => a
slash) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.reverse ByteString
uri_path
  where uri_path :: ByteString
uri_path = Request -> ByteString
Req.path Request
req

-- | This corresponds to the subcomponent algorithm entitled \"Path-Match\" detailed
-- in section 5.1.4
pathMatches :: BS.ByteString -> BS.ByteString -> Bool
pathMatches :: ByteString -> ByteString -> Bool
pathMatches ByteString
requestPath ByteString
cookiePath
  | ByteString
cookiePath ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
path' = Bool
True
  | ByteString
cookiePath ByteString -> ByteString -> Bool
`BS.isPrefixOf` ByteString
path' Bool -> Bool -> Bool
&& Word8 -> ByteString
BS.singleton (ByteString -> Word8
BS.last ByteString
cookiePath) ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"/" = Bool
True
  | ByteString
cookiePath ByteString -> ByteString -> Bool
`BS.isPrefixOf` ByteString
path' Bool -> Bool -> Bool
&& Word8 -> ByteString
BS.singleton (ByteString -> Word8
BS.head ByteString
remainder)  ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"/" = Bool
True
  | Bool
otherwise = Bool
False
  where remainder :: ByteString
remainder = Int -> ByteString -> ByteString
BS.drop (ByteString -> Int
BS.length ByteString
cookiePath) ByteString
requestPath
        path' :: ByteString
path' = case ByteString -> Maybe (Char, ByteString)
S8.uncons ByteString
requestPath of
                 Just (Char
'/', ByteString
_) -> ByteString
requestPath
                 Maybe (Char, ByteString)
_             -> Char
'/' Char -> ByteString -> ByteString
`S8.cons` ByteString
requestPath

createCookieJar :: [Cookie] -> CookieJar
createCookieJar :: [Cookie] -> CookieJar
createCookieJar = [Cookie] -> CookieJar
CJ

destroyCookieJar :: CookieJar -> [Cookie]
destroyCookieJar :: CookieJar -> [Cookie]
destroyCookieJar = CookieJar -> [Cookie]
expose

insertIntoCookieJar :: Cookie -> CookieJar -> CookieJar
insertIntoCookieJar :: Cookie -> CookieJar -> CookieJar
insertIntoCookieJar Cookie
cookie CookieJar
cookie_jar' = [Cookie] -> CookieJar
CJ ([Cookie] -> CookieJar) -> [Cookie] -> CookieJar
forall a b. (a -> b) -> a -> b
$ Cookie
cookie Cookie -> [Cookie] -> [Cookie]
forall a. a -> [a] -> [a]
: [Cookie]
cookie_jar
  where cookie_jar :: [Cookie]
cookie_jar = CookieJar -> [Cookie]
expose CookieJar
cookie_jar'

removeExistingCookieFromCookieJar :: Cookie -> CookieJar -> (Maybe Cookie, CookieJar)
removeExistingCookieFromCookieJar :: Cookie -> CookieJar -> (Maybe Cookie, CookieJar)
removeExistingCookieFromCookieJar Cookie
cookie CookieJar
cookie_jar' = (Maybe Cookie
mc, [Cookie] -> CookieJar
CJ [Cookie]
lc)
  where (Maybe Cookie
mc, [Cookie]
lc) = Cookie -> [Cookie] -> (Maybe Cookie, [Cookie])
removeExistingCookieFromCookieJarHelper Cookie
cookie (CookieJar -> [Cookie]
expose CookieJar
cookie_jar')
        removeExistingCookieFromCookieJarHelper :: Cookie -> [Cookie] -> (Maybe Cookie, [Cookie])
removeExistingCookieFromCookieJarHelper Cookie
_ [] = (Maybe Cookie
forall a. Maybe a
Nothing, [])
        removeExistingCookieFromCookieJarHelper Cookie
c (Cookie
c' : [Cookie]
cs)
          | Cookie
c Cookie -> Cookie -> Bool
`equivCookie` Cookie
c' = (Cookie -> Maybe Cookie
forall a. a -> Maybe a
Just Cookie
c', [Cookie]
cs)
          | Bool
otherwise = (Maybe Cookie
cookie', Cookie
c' Cookie -> [Cookie] -> [Cookie]
forall a. a -> [a] -> [a]
: [Cookie]
cookie_jar'')
          where (Maybe Cookie
cookie', [Cookie]
cookie_jar'') = Cookie -> [Cookie] -> (Maybe Cookie, [Cookie])
removeExistingCookieFromCookieJarHelper Cookie
c [Cookie]
cs

-- | Are we configured to reject cookies for domains such as \"com\"?
rejectPublicSuffixes :: Bool
rejectPublicSuffixes :: Bool
rejectPublicSuffixes = Bool
True

isPublicSuffix :: BS.ByteString -> Bool
isPublicSuffix :: ByteString -> Bool
isPublicSuffix = Text -> Bool
PSL.isSuffix (Text -> Bool) -> (ByteString -> Text) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode

-- | This corresponds to the eviction algorithm described in Section 5.3 \"Storage Model\"
evictExpiredCookies :: CookieJar  -- ^ Input cookie jar
                    -> UTCTime    -- ^ Value that should be used as \"now\"
                    -> CookieJar  -- ^ Filtered cookie jar
evictExpiredCookies :: CookieJar -> UTCTime -> CookieJar
evictExpiredCookies CookieJar
cookie_jar' UTCTime
now = [Cookie] -> CookieJar
CJ ([Cookie] -> CookieJar) -> [Cookie] -> CookieJar
forall a b. (a -> b) -> a -> b
$ (Cookie -> Bool) -> [Cookie] -> [Cookie]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ Cookie
cookie -> Cookie -> UTCTime
cookie_expiry_time Cookie
cookie UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= UTCTime
now) ([Cookie] -> [Cookie]) -> [Cookie] -> [Cookie]
forall a b. (a -> b) -> a -> b
$ CookieJar -> [Cookie]
expose CookieJar
cookie_jar'

-- | This applies the 'computeCookieString' to a given Request
insertCookiesIntoRequest :: Req.Request                 -- ^ The request to insert into
                         -> CookieJar                   -- ^ Current cookie jar
                         -> UTCTime                     -- ^ Value that should be used as \"now\"
                         -> (Req.Request, CookieJar)    -- ^ (Output request, Updated cookie jar (last-access-time is updated))
insertCookiesIntoRequest :: Request -> CookieJar -> UTCTime -> (Request, CookieJar)
insertCookiesIntoRequest Request
request CookieJar
cookie_jar UTCTime
now
  | ByteString -> Bool
BS.null ByteString
cookie_string = (Request
request, CookieJar
cookie_jar')
  | Bool
otherwise = (Request
request {requestHeaders :: RequestHeaders
Req.requestHeaders = (CI ByteString, ByteString)
cookie_header (CI ByteString, ByteString) -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
: RequestHeaders
purgedHeaders}, CookieJar
cookie_jar')
  where purgedHeaders :: RequestHeaders
purgedHeaders = ((CI ByteString, ByteString)
 -> (CI ByteString, ByteString) -> Bool)
-> (CI ByteString, ByteString) -> RequestHeaders -> RequestHeaders
forall a. (a -> a -> Bool) -> a -> [a] -> [a]
L.deleteBy (\ (CI ByteString
a, ByteString
_) (CI ByteString
b, ByteString
_) -> CI ByteString
a CI ByteString -> CI ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== CI ByteString
b) (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> CI ByteString) -> ByteString -> CI ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
"Cookie", ByteString
BS.empty) (RequestHeaders -> RequestHeaders)
-> RequestHeaders -> RequestHeaders
forall a b. (a -> b) -> a -> b
$ Request -> RequestHeaders
Req.requestHeaders Request
request
        (ByteString
cookie_string, CookieJar
cookie_jar') = Request -> CookieJar -> UTCTime -> Bool -> (ByteString, CookieJar)
computeCookieString Request
request CookieJar
cookie_jar UTCTime
now Bool
True
        cookie_header :: (CI ByteString, ByteString)
cookie_header = (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> CI ByteString) -> ByteString -> CI ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
"Cookie", ByteString
cookie_string)

-- | This corresponds to the algorithm described in Section 5.4 \"The Cookie Header\"
computeCookieString :: Req.Request           -- ^ Input request
                    -> CookieJar             -- ^ Current cookie jar
                    -> UTCTime               -- ^ Value that should be used as \"now\"
                    -> Bool                  -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that)
                    -> (BS.ByteString, CookieJar)  -- ^ (Contents of a \"Cookie\" header, Updated cookie jar (last-access-time is updated))
computeCookieString :: Request -> CookieJar -> UTCTime -> Bool -> (ByteString, CookieJar)
computeCookieString Request
request CookieJar
cookie_jar UTCTime
now Bool
is_http_api = (ByteString
output_line, CookieJar
cookie_jar')
  where matching_cookie :: Cookie -> Bool
matching_cookie Cookie
cookie = Bool
condition1 Bool -> Bool -> Bool
&& Bool
condition2 Bool -> Bool -> Bool
&& Bool
condition3 Bool -> Bool -> Bool
&& Bool
condition4
          where condition1 :: Bool
condition1
                  | Cookie -> Bool
cookie_host_only Cookie
cookie = ByteString -> ByteString
forall s. FoldCase s => s -> s
CI.foldCase (Request -> ByteString
Req.host Request
request) ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> ByteString
forall s. FoldCase s => s -> s
CI.foldCase (Cookie -> ByteString
cookie_domain Cookie
cookie)
                  | Bool
otherwise = ByteString -> ByteString -> Bool
domainMatches (Request -> ByteString
Req.host Request
request) (Cookie -> ByteString
cookie_domain Cookie
cookie)
                condition2 :: Bool
condition2 = ByteString -> ByteString -> Bool
pathMatches (Request -> ByteString
Req.path Request
request) (Cookie -> ByteString
cookie_path Cookie
cookie)
                condition3 :: Bool
condition3
                  | Bool -> Bool
not (Cookie -> Bool
cookie_secure_only Cookie
cookie) = Bool
True
                  | Bool
otherwise = Request -> Bool
Req.secure Request
request
                condition4 :: Bool
condition4
                  | Bool -> Bool
not (Cookie -> Bool
cookie_http_only Cookie
cookie) = Bool
True
                  | Bool
otherwise = Bool
is_http_api
        matching_cookies :: [Cookie]
matching_cookies = (Cookie -> Bool) -> [Cookie] -> [Cookie]
forall a. (a -> Bool) -> [a] -> [a]
filter Cookie -> Bool
matching_cookie ([Cookie] -> [Cookie]) -> [Cookie] -> [Cookie]
forall a b. (a -> b) -> a -> b
$ CookieJar -> [Cookie]
expose CookieJar
cookie_jar
        output_cookies :: [(ByteString, ByteString)]
output_cookies =  (Cookie -> (ByteString, ByteString))
-> [Cookie] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (\ Cookie
c -> (Cookie -> ByteString
cookie_name Cookie
c, Cookie -> ByteString
cookie_value Cookie
c)) ([Cookie] -> [(ByteString, ByteString)])
-> [Cookie] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ (Cookie -> Cookie -> Ordering) -> [Cookie] -> [Cookie]
forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy Cookie -> Cookie -> Ordering
compareCookies [Cookie]
matching_cookies
        output_line :: ByteString
output_line = Builder -> ByteString
toByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ [(ByteString, ByteString)] -> Builder
renderCookies ([(ByteString, ByteString)] -> Builder)
-> [(ByteString, ByteString)] -> Builder
forall a b. (a -> b) -> a -> b
$ [(ByteString, ByteString)]
output_cookies
        folding_function :: CookieJar -> Cookie -> CookieJar
folding_function CookieJar
cookie_jar'' Cookie
cookie = case Cookie -> CookieJar -> (Maybe Cookie, CookieJar)
removeExistingCookieFromCookieJar Cookie
cookie CookieJar
cookie_jar'' of
          (Just Cookie
c, CookieJar
cookie_jar''') -> Cookie -> CookieJar -> CookieJar
insertIntoCookieJar (Cookie
c {cookie_last_access_time :: UTCTime
cookie_last_access_time = UTCTime
now}) CookieJar
cookie_jar'''
          (Maybe Cookie
Nothing, CookieJar
cookie_jar''') -> CookieJar
cookie_jar'''
        cookie_jar' :: CookieJar
cookie_jar' = (CookieJar -> Cookie -> CookieJar)
-> CookieJar -> [Cookie] -> CookieJar
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl CookieJar -> Cookie -> CookieJar
folding_function CookieJar
cookie_jar [Cookie]
matching_cookies

-- | This applies 'receiveSetCookie' to a given Response
updateCookieJar :: Response a                   -- ^ Response received from server
                -> Request                      -- ^ Request which generated the response
                -> UTCTime                      -- ^ Value that should be used as \"now\"
                -> CookieJar                    -- ^ Current cookie jar
                -> (CookieJar, Response a)      -- ^ (Updated cookie jar with cookies from the Response, The response stripped of any \"Set-Cookie\" header)
updateCookieJar :: Response a
-> Request -> UTCTime -> CookieJar -> (CookieJar, Response a)
updateCookieJar Response a
response Request
request UTCTime
now CookieJar
cookie_jar = (CookieJar
cookie_jar', Response a
response { responseHeaders :: RequestHeaders
responseHeaders = RequestHeaders
other_headers })
  where (RequestHeaders
set_cookie_headers, RequestHeaders
other_headers) = ((CI ByteString, ByteString) -> Bool)
-> RequestHeaders -> (RequestHeaders, RequestHeaders)
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition ((CI ByteString -> CI ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> CI ByteString) -> ByteString -> CI ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
"Set-Cookie")) (CI ByteString -> Bool)
-> ((CI ByteString, ByteString) -> CI ByteString)
-> (CI ByteString, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CI ByteString, ByteString) -> CI ByteString
forall a b. (a, b) -> a
fst) (RequestHeaders -> (RequestHeaders, RequestHeaders))
-> RequestHeaders -> (RequestHeaders, RequestHeaders)
forall a b. (a -> b) -> a -> b
$ Response a -> RequestHeaders
forall body. Response body -> RequestHeaders
responseHeaders Response a
response
        set_cookie_data :: [ByteString]
set_cookie_data = ((CI ByteString, ByteString) -> ByteString)
-> RequestHeaders -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (CI ByteString, ByteString) -> ByteString
forall a b. (a, b) -> b
snd RequestHeaders
set_cookie_headers
        set_cookies :: [SetCookie]
set_cookies = (ByteString -> SetCookie) -> [ByteString] -> [SetCookie]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> SetCookie
parseSetCookie [ByteString]
set_cookie_data
        cookie_jar' :: CookieJar
cookie_jar' = (CookieJar -> SetCookie -> CookieJar)
-> CookieJar -> [SetCookie] -> CookieJar
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ CookieJar
cj SetCookie
sc -> SetCookie -> Request -> UTCTime -> Bool -> CookieJar -> CookieJar
receiveSetCookie SetCookie
sc Request
request UTCTime
now Bool
True CookieJar
cj) CookieJar
cookie_jar [SetCookie]
set_cookies

-- | This corresponds to the algorithm described in Section 5.3 \"Storage Model\"
-- This function consists of calling 'generateCookie' followed by 'insertCheckedCookie'.
-- Use this function if you plan to do both in a row.
-- 'generateCookie' and 'insertCheckedCookie' are only provided for more fine-grained control.
receiveSetCookie :: SetCookie      -- ^ The 'SetCookie' the cookie jar is receiving
                 -> Req.Request    -- ^ The request that originated the response that yielded the 'SetCookie'
                 -> UTCTime        -- ^ Value that should be used as \"now\"
                 -> Bool           -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that)
                 -> CookieJar      -- ^ Input cookie jar to modify
                 -> CookieJar      -- ^ Updated cookie jar
receiveSetCookie :: SetCookie -> Request -> UTCTime -> Bool -> CookieJar -> CookieJar
receiveSetCookie SetCookie
set_cookie Request
request UTCTime
now Bool
is_http_api CookieJar
cookie_jar = case (do
  Cookie
cookie <- SetCookie -> Request -> UTCTime -> Bool -> Maybe Cookie
generateCookie SetCookie
set_cookie Request
request UTCTime
now Bool
is_http_api
  CookieJar -> Maybe CookieJar
forall (m :: * -> *) a. Monad m => a -> m a
return (CookieJar -> Maybe CookieJar) -> CookieJar -> Maybe CookieJar
forall a b. (a -> b) -> a -> b
$ Cookie -> CookieJar -> Bool -> CookieJar
insertCheckedCookie Cookie
cookie CookieJar
cookie_jar Bool
is_http_api) of
  Just CookieJar
cj -> CookieJar
cj
  Maybe CookieJar
Nothing -> CookieJar
cookie_jar

-- | Insert a cookie created by generateCookie into the cookie jar (or not if it shouldn't be allowed in)
insertCheckedCookie :: Cookie    -- ^ The 'SetCookie' the cookie jar is receiving
                    -> CookieJar -- ^ Input cookie jar to modify
                    -> Bool      -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that)
                    -> CookieJar -- ^ Updated (or not) cookie jar
insertCheckedCookie :: Cookie -> CookieJar -> Bool -> CookieJar
insertCheckedCookie Cookie
c CookieJar
cookie_jar Bool
is_http_api = case (do
  (CookieJar
cookie_jar', Cookie
cookie') <- Cookie -> CookieJar -> Maybe (CookieJar, Cookie)
existanceTest Cookie
c CookieJar
cookie_jar
  CookieJar -> Maybe CookieJar
forall (m :: * -> *) a. Monad m => a -> m a
return (CookieJar -> Maybe CookieJar) -> CookieJar -> Maybe CookieJar
forall a b. (a -> b) -> a -> b
$ Cookie -> CookieJar -> CookieJar
insertIntoCookieJar Cookie
cookie' CookieJar
cookie_jar') of
  Just CookieJar
cj -> CookieJar
cj
  Maybe CookieJar
Nothing -> CookieJar
cookie_jar
  where existanceTest :: Cookie -> CookieJar -> Maybe (CookieJar, Cookie)
existanceTest Cookie
cookie CookieJar
cookie_jar' = Cookie -> (Maybe Cookie, CookieJar) -> Maybe (CookieJar, Cookie)
forall a. Cookie -> (Maybe Cookie, a) -> Maybe (a, Cookie)
existanceTestHelper Cookie
cookie ((Maybe Cookie, CookieJar) -> Maybe (CookieJar, Cookie))
-> (Maybe Cookie, CookieJar) -> Maybe (CookieJar, Cookie)
forall a b. (a -> b) -> a -> b
$ Cookie -> CookieJar -> (Maybe Cookie, CookieJar)
removeExistingCookieFromCookieJar Cookie
cookie CookieJar
cookie_jar'
        existanceTestHelper :: Cookie -> (Maybe Cookie, a) -> Maybe (a, Cookie)
existanceTestHelper Cookie
new_cookie (Just Cookie
old_cookie, a
cookie_jar')
          | Bool -> Bool
not Bool
is_http_api Bool -> Bool -> Bool
&& Cookie -> Bool
cookie_http_only Cookie
old_cookie = Maybe (a, Cookie)
forall a. Maybe a
Nothing
          | Bool
otherwise = (a, Cookie) -> Maybe (a, Cookie)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
cookie_jar', Cookie
new_cookie {cookie_creation_time :: UTCTime
cookie_creation_time = Cookie -> UTCTime
cookie_creation_time Cookie
old_cookie})
        existanceTestHelper Cookie
new_cookie (Maybe Cookie
Nothing, a
cookie_jar') = (a, Cookie) -> Maybe (a, Cookie)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
cookie_jar', Cookie
new_cookie)

-- | Turn a SetCookie into a Cookie, if it is valid
generateCookie :: SetCookie      -- ^ The 'SetCookie' we are encountering
               -> Req.Request    -- ^ The request that originated the response that yielded the 'SetCookie'
               -> UTCTime        -- ^ Value that should be used as \"now\"
               -> Bool           -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that)
               -> Maybe Cookie   -- ^ The optional output cookie
generateCookie :: SetCookie -> Request -> UTCTime -> Bool -> Maybe Cookie
generateCookie SetCookie
set_cookie Request
request UTCTime
now Bool
is_http_api = do
          ByteString
domain_sanitized <- ByteString -> Maybe ByteString
sanitizeDomain (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Maybe ByteString -> ByteString
step4 (SetCookie -> Maybe ByteString
setCookieDomain SetCookie
set_cookie)
          ByteString
domain_intermediate <- ByteString -> Maybe ByteString
step5 ByteString
domain_sanitized
          (ByteString
domain_final, Bool
host_only') <- ByteString -> Maybe (ByteString, Bool)
step6 ByteString
domain_intermediate
          Bool
http_only' <- Maybe Bool
step10
          Cookie -> Maybe Cookie
forall (m :: * -> *) a. Monad m => a -> m a
return (Cookie -> Maybe Cookie) -> Cookie -> Maybe Cookie
forall a b. (a -> b) -> a -> b
$ Cookie :: ByteString
-> ByteString
-> UTCTime
-> ByteString
-> ByteString
-> UTCTime
-> UTCTime
-> Bool
-> Bool
-> Bool
-> Bool
-> Cookie
Cookie { cookie_name :: ByteString
cookie_name = SetCookie -> ByteString
setCookieName SetCookie
set_cookie
                          , cookie_value :: ByteString
cookie_value = SetCookie -> ByteString
setCookieValue SetCookie
set_cookie
                          , cookie_expiry_time :: UTCTime
cookie_expiry_time = Maybe UTCTime -> Maybe DiffTime -> UTCTime
getExpiryTime (SetCookie -> Maybe UTCTime
setCookieExpires SetCookie
set_cookie) (SetCookie -> Maybe DiffTime
setCookieMaxAge SetCookie
set_cookie)
                          , cookie_domain :: ByteString
cookie_domain = ByteString
domain_final
                          , cookie_path :: ByteString
cookie_path = Maybe ByteString -> ByteString
getPath (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ SetCookie -> Maybe ByteString
setCookiePath SetCookie
set_cookie
                          , cookie_creation_time :: UTCTime
cookie_creation_time = UTCTime
now
                          , cookie_last_access_time :: UTCTime
cookie_last_access_time = UTCTime
now
                          , cookie_persistent :: Bool
cookie_persistent = Bool
getPersistent
                          , cookie_host_only :: Bool
cookie_host_only = Bool
host_only'
                          , cookie_secure_only :: Bool
cookie_secure_only = SetCookie -> Bool
setCookieSecure SetCookie
set_cookie
                          , cookie_http_only :: Bool
cookie_http_only = Bool
http_only'
                          }
  where sanitizeDomain :: ByteString -> Maybe ByteString
sanitizeDomain ByteString
domain'
          | Bool
has_a_character Bool -> Bool -> Bool
&& Word8 -> ByteString
BS.singleton (ByteString -> Word8
BS.last ByteString
domain') ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"." = Maybe ByteString
forall a. Maybe a
Nothing
          | Bool
has_a_character Bool -> Bool -> Bool
&& Word8 -> ByteString
BS.singleton (ByteString -> Word8
BS.head ByteString
domain') ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"." = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.tail ByteString
domain'
          | Bool
otherwise = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
domain'
          where has_a_character :: Bool
has_a_character = Bool -> Bool
not (ByteString -> Bool
BS.null ByteString
domain')
        step4 :: Maybe ByteString -> ByteString
step4 (Just ByteString
set_cookie_domain) = ByteString
set_cookie_domain
        step4 Maybe ByteString
Nothing = ByteString
BS.empty
        step5 :: ByteString -> Maybe ByteString
step5 ByteString
domain'
          | Bool
firstCondition Bool -> Bool -> Bool
&& ByteString
domain' ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== (Request -> ByteString
Req.host Request
request) = ByteString -> Maybe ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
BS.empty
          | Bool
firstCondition = Maybe ByteString
forall a. Maybe a
Nothing
          | Bool
otherwise = ByteString -> Maybe ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
domain'
          where firstCondition :: Bool
firstCondition = Bool
rejectPublicSuffixes Bool -> Bool -> Bool
&& Bool
has_a_character Bool -> Bool -> Bool
&& ByteString -> Bool
isPublicSuffix ByteString
domain'
                has_a_character :: Bool
has_a_character = Bool -> Bool
not (ByteString -> Bool
BS.null ByteString
domain')
        step6 :: ByteString -> Maybe (ByteString, Bool)
step6 ByteString
domain'
          | Bool
firstCondition Bool -> Bool -> Bool
&& Bool -> Bool
not (ByteString -> ByteString -> Bool
domainMatches (Request -> ByteString
Req.host Request
request) ByteString
domain') = Maybe (ByteString, Bool)
forall a. Maybe a
Nothing
          | Bool
firstCondition = (ByteString, Bool) -> Maybe (ByteString, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
domain', Bool
False)
          | Bool
otherwise = (ByteString, Bool) -> Maybe (ByteString, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Request -> ByteString
Req.host Request
request, Bool
True)
          where firstCondition :: Bool
firstCondition = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> Bool
BS.null ByteString
domain'
        step10 :: Maybe Bool
step10
          | Bool -> Bool
not Bool
is_http_api Bool -> Bool -> Bool
&& SetCookie -> Bool
setCookieHttpOnly SetCookie
set_cookie = Maybe Bool
forall a. Maybe a
Nothing
          | Bool
otherwise = Bool -> Maybe Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ SetCookie -> Bool
setCookieHttpOnly SetCookie
set_cookie
        getExpiryTime :: Maybe UTCTime -> Maybe DiffTime -> UTCTime
        getExpiryTime :: Maybe UTCTime -> Maybe DiffTime -> UTCTime
getExpiryTime Maybe UTCTime
_ (Just DiffTime
t) = (Rational -> NominalDiffTime
forall a. Fractional a => Rational -> a
fromRational (Rational -> NominalDiffTime) -> Rational -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ DiffTime -> Rational
forall a. Real a => a -> Rational
toRational DiffTime
t) NominalDiffTime -> UTCTime -> UTCTime
`addUTCTime` UTCTime
now
        getExpiryTime (Just UTCTime
t) Maybe DiffTime
Nothing = UTCTime
t
        getExpiryTime Maybe UTCTime
Nothing Maybe DiffTime
Nothing = Day -> DiffTime -> UTCTime
UTCTime (Integer
365000 Integer -> Day -> Day
`addDays` UTCTime -> Day
utctDay UTCTime
now) (Integer -> DiffTime
secondsToDiffTime Integer
0)
        getPath :: Maybe ByteString -> ByteString
getPath (Just ByteString
p) = ByteString
p
        getPath Maybe ByteString
Nothing = Request -> ByteString
defaultPath Request
request
        getPersistent :: Bool
getPersistent = Maybe UTCTime -> Bool
forall a. Maybe a -> Bool
isJust (SetCookie -> Maybe UTCTime
setCookieExpires SetCookie
set_cookie) Bool -> Bool -> Bool
|| Maybe DiffTime -> Bool
forall a. Maybe a -> Bool
isJust (SetCookie -> Maybe DiffTime
setCookieMaxAge SetCookie
set_cookie)