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