1{-# LANGUAGE OverloadedStrings #-}
2-- | This module implements the algorithms described in RFC 6265 for the Network.HTTP.Conduit library.
3module Network.HTTP.Client.Cookies
4    ( updateCookieJar
5    , receiveSetCookie
6    , generateCookie
7    , insertCheckedCookie
8    , insertCookiesIntoRequest
9    , computeCookieString
10    , evictExpiredCookies
11    , createCookieJar
12    , destroyCookieJar
13    , pathMatches
14    , removeExistingCookieFromCookieJar
15    , domainMatches
16    , isIpAddress
17    , defaultPath
18    ) where
19
20import qualified Data.ByteString as BS
21import qualified Data.ByteString.Char8 as S8
22import Data.Maybe
23import qualified Data.List as L
24import Data.Time.Clock
25import Data.Time.Calendar
26import Web.Cookie
27import qualified Data.CaseInsensitive as CI
28import Blaze.ByteString.Builder
29import qualified Network.PublicSuffixList.Lookup as PSL
30import Data.Text.Encoding (decodeUtf8With)
31import Data.Text.Encoding.Error (lenientDecode)
32
33import Network.HTTP.Client.Types as Req
34
35slash :: Integral a => a
36slash = 47 -- '/'
37
38isIpAddress :: BS.ByteString -> Bool
39isIpAddress =
40    go (4 :: Int)
41  where
42    go 0 bs = BS.null bs
43    go rest bs =
44        case S8.readInt x of
45            Just (i, x') | BS.null x' && i >= 0 && i < 256 -> go (rest - 1) y
46            _ -> False
47      where
48        (x, y') = BS.break (== 46) bs -- period
49        y = BS.drop 1 y'
50
51-- | This corresponds to the subcomponent algorithm entitled \"Domain Matching\" detailed
52-- in section 5.1.3
53domainMatches :: BS.ByteString -- ^ Domain to test
54              -> BS.ByteString -- ^ Domain from a cookie
55              -> Bool
56domainMatches string' domainString'
57  | string == domainString = True
58  | BS.length string < BS.length domainString + 1 = False
59  | domainString `BS.isSuffixOf` string && BS.singleton (BS.last difference) == "." && not (isIpAddress string) = True
60  | otherwise = False
61  where difference = BS.take (BS.length string - BS.length domainString) string
62        string = CI.foldCase string'
63        domainString = CI.foldCase domainString'
64
65-- | This corresponds to the subcomponent algorithm entitled \"Paths\" detailed
66-- in section 5.1.4
67defaultPath :: Req.Request   -> BS.ByteString
68defaultPath req
69  | BS.null uri_path = "/"
70  | BS.singleton (BS.head uri_path) /= "/" = "/"
71  | BS.count slash uri_path <= 1 = "/"
72  | otherwise = BS.reverse $ BS.tail $ BS.dropWhile (/= slash) $ BS.reverse uri_path
73  where uri_path = Req.path req
74
75-- | This corresponds to the subcomponent algorithm entitled \"Path-Match\" detailed
76-- in section 5.1.4
77pathMatches :: BS.ByteString -> BS.ByteString -> Bool
78pathMatches requestPath cookiePath
79  | cookiePath == path' = True
80  | cookiePath `BS.isPrefixOf` path' && BS.singleton (BS.last cookiePath) == "/" = True
81  | cookiePath `BS.isPrefixOf` path' && BS.singleton (BS.head remainder)  == "/" = True
82  | otherwise = False
83  where remainder = BS.drop (BS.length cookiePath) requestPath
84        path' = case S8.uncons requestPath of
85                 Just ('/', _) -> requestPath
86                 _             -> '/' `S8.cons` requestPath
87
88createCookieJar :: [Cookie] -> CookieJar
89createCookieJar = CJ
90
91destroyCookieJar :: CookieJar -> [Cookie]
92destroyCookieJar = expose
93
94insertIntoCookieJar :: Cookie -> CookieJar -> CookieJar
95insertIntoCookieJar cookie cookie_jar' = CJ $ cookie : cookie_jar
96  where cookie_jar = expose cookie_jar'
97
98removeExistingCookieFromCookieJar :: Cookie -> CookieJar -> (Maybe Cookie, CookieJar)
99removeExistingCookieFromCookieJar cookie cookie_jar' = (mc, CJ lc)
100  where (mc, lc) = removeExistingCookieFromCookieJarHelper cookie (expose cookie_jar')
101        removeExistingCookieFromCookieJarHelper _ [] = (Nothing, [])
102        removeExistingCookieFromCookieJarHelper c (c' : cs)
103          | c `equivCookie` c' = (Just c', cs)
104          | otherwise = (cookie', c' : cookie_jar'')
105          where (cookie', cookie_jar'') = removeExistingCookieFromCookieJarHelper c cs
106
107-- | Are we configured to reject cookies for domains such as \"com\"?
108rejectPublicSuffixes :: Bool
109rejectPublicSuffixes = True
110
111isPublicSuffix :: BS.ByteString -> Bool
112isPublicSuffix = PSL.isSuffix . decodeUtf8With lenientDecode
113
114-- | This corresponds to the eviction algorithm described in Section 5.3 \"Storage Model\"
115evictExpiredCookies :: CookieJar  -- ^ Input cookie jar
116                    -> UTCTime    -- ^ Value that should be used as \"now\"
117                    -> CookieJar  -- ^ Filtered cookie jar
118evictExpiredCookies cookie_jar' now = CJ $ filter (\ cookie -> cookie_expiry_time cookie >= now) $ expose cookie_jar'
119
120-- | This applies the 'computeCookieString' to a given Request
121insertCookiesIntoRequest :: Req.Request                 -- ^ The request to insert into
122                         -> CookieJar                   -- ^ Current cookie jar
123                         -> UTCTime                     -- ^ Value that should be used as \"now\"
124                         -> (Req.Request, CookieJar)    -- ^ (Output request, Updated cookie jar (last-access-time is updated))
125insertCookiesIntoRequest request cookie_jar now
126  | BS.null cookie_string = (request, cookie_jar')
127  | otherwise = (request {Req.requestHeaders = cookie_header : purgedHeaders}, cookie_jar')
128  where purgedHeaders = L.deleteBy (\ (a, _) (b, _) -> a == b) (CI.mk $ "Cookie", BS.empty) $ Req.requestHeaders request
129        (cookie_string, cookie_jar') = computeCookieString request cookie_jar now True
130        cookie_header = (CI.mk $ "Cookie", cookie_string)
131
132-- | This corresponds to the algorithm described in Section 5.4 \"The Cookie Header\"
133computeCookieString :: Req.Request           -- ^ Input request
134                    -> CookieJar             -- ^ Current cookie jar
135                    -> UTCTime               -- ^ Value that should be used as \"now\"
136                    -> Bool                  -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that)
137                    -> (BS.ByteString, CookieJar)  -- ^ (Contents of a \"Cookie\" header, Updated cookie jar (last-access-time is updated))
138computeCookieString request cookie_jar now is_http_api = (output_line, cookie_jar')
139  where matching_cookie cookie = condition1 && condition2 && condition3 && condition4
140          where condition1
141                  | cookie_host_only cookie = CI.foldCase (Req.host request) == CI.foldCase (cookie_domain cookie)
142                  | otherwise = domainMatches (Req.host request) (cookie_domain cookie)
143                condition2 = pathMatches (Req.path request) (cookie_path cookie)
144                condition3
145                  | not (cookie_secure_only cookie) = True
146                  | otherwise = Req.secure request
147                condition4
148                  | not (cookie_http_only cookie) = True
149                  | otherwise = is_http_api
150        matching_cookies = filter matching_cookie $ expose cookie_jar
151        output_cookies =  map (\ c -> (cookie_name c, cookie_value c)) $ L.sortBy compareCookies matching_cookies
152        output_line = toByteString $ renderCookies $ output_cookies
153        folding_function cookie_jar'' cookie = case removeExistingCookieFromCookieJar cookie cookie_jar'' of
154          (Just c, cookie_jar''') -> insertIntoCookieJar (c {cookie_last_access_time = now}) cookie_jar'''
155          (Nothing, cookie_jar''') -> cookie_jar'''
156        cookie_jar' = foldl folding_function cookie_jar matching_cookies
157
158-- | This applies 'receiveSetCookie' to a given Response
159updateCookieJar :: Response a                   -- ^ Response received from server
160                -> Request                      -- ^ Request which generated the response
161                -> UTCTime                      -- ^ Value that should be used as \"now\"
162                -> CookieJar                    -- ^ Current cookie jar
163                -> (CookieJar, Response a)      -- ^ (Updated cookie jar with cookies from the Response, The response stripped of any \"Set-Cookie\" header)
164updateCookieJar response request now cookie_jar = (cookie_jar', response { responseHeaders = other_headers })
165  where (set_cookie_headers, other_headers) = L.partition ((== (CI.mk $ "Set-Cookie")) . fst) $ responseHeaders response
166        set_cookie_data = map snd set_cookie_headers
167        set_cookies = map parseSetCookie set_cookie_data
168        cookie_jar' = foldl (\ cj sc -> receiveSetCookie sc request now True cj) cookie_jar set_cookies
169
170-- | This corresponds to the algorithm described in Section 5.3 \"Storage Model\"
171-- This function consists of calling 'generateCookie' followed by 'insertCheckedCookie'.
172-- Use this function if you plan to do both in a row.
173-- 'generateCookie' and 'insertCheckedCookie' are only provided for more fine-grained control.
174receiveSetCookie :: SetCookie      -- ^ The 'SetCookie' the cookie jar is receiving
175                 -> Req.Request    -- ^ The request that originated the response that yielded the 'SetCookie'
176                 -> UTCTime        -- ^ Value that should be used as \"now\"
177                 -> Bool           -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that)
178                 -> CookieJar      -- ^ Input cookie jar to modify
179                 -> CookieJar      -- ^ Updated cookie jar
180receiveSetCookie set_cookie request now is_http_api cookie_jar = case (do
181  cookie <- generateCookie set_cookie request now is_http_api
182  return $ insertCheckedCookie cookie cookie_jar is_http_api) of
183  Just cj -> cj
184  Nothing -> cookie_jar
185
186-- | Insert a cookie created by generateCookie into the cookie jar (or not if it shouldn't be allowed in)
187insertCheckedCookie :: Cookie    -- ^ The 'SetCookie' the cookie jar is receiving
188                    -> CookieJar -- ^ Input cookie jar to modify
189                    -> Bool      -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that)
190                    -> CookieJar -- ^ Updated (or not) cookie jar
191insertCheckedCookie c cookie_jar is_http_api = case (do
192  (cookie_jar', cookie') <- existanceTest c cookie_jar
193  return $ insertIntoCookieJar cookie' cookie_jar') of
194  Just cj -> cj
195  Nothing -> cookie_jar
196  where existanceTest cookie cookie_jar' = existanceTestHelper cookie $ removeExistingCookieFromCookieJar cookie cookie_jar'
197        existanceTestHelper new_cookie (Just old_cookie, cookie_jar')
198          | not is_http_api && cookie_http_only old_cookie = Nothing
199          | otherwise = return (cookie_jar', new_cookie {cookie_creation_time = cookie_creation_time old_cookie})
200        existanceTestHelper new_cookie (Nothing, cookie_jar') = return (cookie_jar', new_cookie)
201
202-- | Turn a SetCookie into a Cookie, if it is valid
203generateCookie :: SetCookie      -- ^ The 'SetCookie' we are encountering
204               -> Req.Request    -- ^ The request that originated the response that yielded the 'SetCookie'
205               -> UTCTime        -- ^ Value that should be used as \"now\"
206               -> Bool           -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that)
207               -> Maybe Cookie   -- ^ The optional output cookie
208generateCookie set_cookie request now is_http_api = do
209          domain_sanitized <- sanitizeDomain $ step4 (setCookieDomain set_cookie)
210          domain_intermediate <- step5 domain_sanitized
211          (domain_final, host_only') <- step6 domain_intermediate
212          http_only' <- step10
213          return $ Cookie { cookie_name = setCookieName set_cookie
214                          , cookie_value = setCookieValue set_cookie
215                          , cookie_expiry_time = getExpiryTime (setCookieExpires set_cookie) (setCookieMaxAge set_cookie)
216                          , cookie_domain = domain_final
217                          , cookie_path = getPath $ setCookiePath set_cookie
218                          , cookie_creation_time = now
219                          , cookie_last_access_time = now
220                          , cookie_persistent = getPersistent
221                          , cookie_host_only = host_only'
222                          , cookie_secure_only = setCookieSecure set_cookie
223                          , cookie_http_only = http_only'
224                          }
225  where sanitizeDomain domain'
226          | has_a_character && BS.singleton (BS.last domain') == "." = Nothing
227          | has_a_character && BS.singleton (BS.head domain') == "." = Just $ BS.tail domain'
228          | otherwise = Just $ domain'
229          where has_a_character = not (BS.null domain')
230        step4 (Just set_cookie_domain) = set_cookie_domain
231        step4 Nothing = BS.empty
232        step5 domain'
233          | firstCondition && domain' == (Req.host request) = return BS.empty
234          | firstCondition = Nothing
235          | otherwise = return domain'
236          where firstCondition = rejectPublicSuffixes && has_a_character && isPublicSuffix domain'
237                has_a_character = not (BS.null domain')
238        step6 domain'
239          | firstCondition && not (domainMatches (Req.host request) domain') = Nothing
240          | firstCondition = return (domain', False)
241          | otherwise = return (Req.host request, True)
242          where firstCondition = not $ BS.null domain'
243        step10
244          | not is_http_api && setCookieHttpOnly set_cookie = Nothing
245          | otherwise = return $ setCookieHttpOnly set_cookie
246        getExpiryTime :: Maybe UTCTime -> Maybe DiffTime -> UTCTime
247        getExpiryTime _ (Just t) = (fromRational $ toRational t) `addUTCTime` now
248        getExpiryTime (Just t) Nothing = t
249        getExpiryTime Nothing Nothing = UTCTime (365000 `addDays` utctDay now) (secondsToDiffTime 0)
250        getPath (Just p) = p
251        getPath Nothing = defaultPath request
252        getPersistent = isJust (setCookieExpires set_cookie) || isJust (setCookieMaxAge set_cookie)
253