{-# LANGUAGE OverloadedStrings #-}
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
y :: ByteString
y = Int -> ByteString -> ByteString
BS.drop Int
1 ByteString
y'
domainMatches :: BS.ByteString
-> BS.ByteString
-> 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'
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
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
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
isPotentiallyTrustworthyOrigin :: Bool
-> BS.ByteString
-> Bool
isPotentiallyTrustworthyOrigin :: Bool -> ByteString -> Bool
isPotentiallyTrustworthyOrigin Bool
secure ByteString
host
| Bool
secure = Bool
True
| Bool
isLoopbackAddr4 = Bool
True
| Bool
isLoopbackAddr6 = Bool
True
| Bool
isLoopbackHostname = Bool
True
| 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
evictExpiredCookies :: CookieJar
-> UTCTime
-> CookieJar
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'
insertCookiesIntoRequest :: Req.Request
-> CookieJar
-> UTCTime
-> (Req.Request, CookieJar)
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)
computeCookieString :: Req.Request
-> CookieJar
-> UTCTime
-> Bool
-> (BS.ByteString, CookieJar)
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
updateCookieJar :: Response a
-> Request
-> UTCTime
-> CookieJar
-> (CookieJar, Response a)
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
receiveSetCookie :: SetCookie
-> Req.Request
-> UTCTime
-> Bool
-> CookieJar
-> CookieJar
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
insertCheckedCookie :: Cookie
-> CookieJar
-> Bool
-> CookieJar
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)
generateCookie :: SetCookie
-> Req.Request
-> UTCTime
-> Bool
-> Maybe 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)