{-# 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
    , isPotentiallyTrustworthyOrigin
    , 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 qualified Data.IP as IP
import Text.Read (readMaybe)

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

-- | Algorithm described in \"Secure Contexts\", Section 3.1, \"Is origin potentially trustworthy?\"
--
-- Note per RFC6265 section 5.4 user agent is free to define the meaning of "secure" protocol.
--
-- See:
-- https://w3c.github.io/webappsec-secure-contexts/#is-origin-trustworthy
isPotentiallyTrustworthyOrigin :: Bool          -- ^ True if HTTPS
                               -> BS.ByteString -- ^ Host
                               -> Bool          -- ^ Whether or not the origin is potentially trustworthy
isPotentiallyTrustworthyOrigin :: Bool -> ByteString -> Bool
isPotentiallyTrustworthyOrigin Bool
secure ByteString
host
  | Bool
secure = Bool
True             -- step 3
  | Bool
isLoopbackAddr4 = Bool
True    -- step 4, part 1
  | Bool
isLoopbackAddr6 = Bool
True    -- step 4, part 2
  | Bool
isLoopbackHostname = Bool
True -- step 5
  | Bool
otherwise = Bool
False
  where isLoopbackHostname :: Bool
isLoopbackHostname =
               ByteString
host ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"localhost"
            Bool -> Bool -> Bool
|| ByteString
host ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"localhost."
            Bool -> Bool -> Bool
|| ByteString -> ByteString -> Bool
BS.isSuffixOf ByteString
".localhost" ByteString
host
            Bool -> Bool -> Bool
|| ByteString -> ByteString -> Bool
BS.isSuffixOf ByteString
".localhost." ByteString
host
        isLoopbackAddr4 :: Bool
isLoopbackAddr4 =
          (IPv4 -> [Int]) -> Maybe IPv4 -> Maybe [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
1 ([Int] -> [Int]) -> (IPv4 -> [Int]) -> IPv4 -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IPv4 -> [Int]
IP.fromIPv4) (String -> Maybe IPv4
forall a. Read a => String -> Maybe a
readMaybe (ByteString -> String
S8.unpack ByteString
host)) Maybe [Int] -> Maybe [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== [Int] -> Maybe [Int]
forall a. a -> Maybe a
Just [Int
127]
        isLoopbackAddr6 :: Bool
isLoopbackAddr6 =
          (IPv6 -> HostAddress6) -> Maybe IPv6 -> Maybe HostAddress6
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IPv6 -> HostAddress6
IP.toHostAddress6 Maybe IPv6
maddr6 Maybe HostAddress6 -> Maybe HostAddress6 -> Bool
forall a. Eq a => a -> a -> Bool
== HostAddress6 -> Maybe HostAddress6
forall a. a -> Maybe a
Just (Word32
0, Word32
0, Word32
0, Word32
1)
        maddr6 :: Maybe IPv6
maddr6 = do
          (Char
c1, ByteString
rest1) <- ByteString -> Maybe (Char, ByteString)
S8.uncons ByteString
host
          (ByteString
rest2, Char
c2) <- ByteString -> Maybe (ByteString, Char)
S8.unsnoc ByteString
rest1
          case [Char
c1, Char
c2] of
            String
"[]" -> String -> Maybe IPv6
forall a. Read a => String -> Maybe a
readMaybe (ByteString -> String
S8.unpack ByteString
rest2)
            String
_ -> Maybe IPv6
forall a. Maybe a
Nothing

-- | 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 = Bool -> ByteString -> Bool
isPotentiallyTrustworthyOrigin (Request -> Bool
Req.secure Request
request) (Request -> ByteString
Req.host 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)