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