diff --git a/Network/HTTP/Conduit.hs b/Network/HTTP/Conduit.hs --- a/Network/HTTP/Conduit.hs +++ b/Network/HTTP/Conduit.hs @@ -93,6 +93,8 @@ , destroyCookieJar , updateCookieJar , receiveSetCookie + , generateCookie + , insertCheckedCookie , insertCookiesIntoRequest , computeCookieString , evictExpiredCookies diff --git a/Network/HTTP/Conduit/Browser.hs b/Network/HTTP/Conduit/Browser.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Conduit/Browser.hs @@ -0,0 +1,196 @@ +module Network.HTTP.Conduit.Browser + ( BrowserState + , BrowserAction + , browse + , makeRequest + , defaultState + , getBrowserState + , setBrowserState + , withBrowserState + , getMaxRedirects + , setMaxRedirects + , getMaxRetryCount + , setMaxRetryCount + , getAuthorities + , setAuthorities + , getCookieFilter + , setCookieFilter + , getCookieJar + , setCookieJar + , getCurrentProxy + , setCurrentProxy + , getUserAgent + , setUserAgent + , getManager + , setManager + ) + where + +import qualified Data.ByteString as BS +import Control.Monad.State +import Control.Exception +import qualified Control.Exception.Lifted as LE +import Control.Monad.Trans.Resource +import Data.Conduit +import Prelude hiding (catch) +import qualified Network.HTTP.Types as HT +import Data.Time.Clock (getCurrentTime, UTCTime) +import Data.CaseInsensitive (mk) +import Data.ByteString.UTF8 (fromString) +import Data.List (partition) +import Web.Cookie (parseSetCookie) +import Data.Default (def) +import Data.Maybe (catMaybes) + +import Network.HTTP.Conduit.Cookies hiding (updateCookieJar) +import Network.HTTP.Conduit.Request +import Network.HTTP.Conduit.Response +import Network.HTTP.Conduit.Manager +import qualified Network.HTTP.Conduit as HC + +data BrowserState = BrowserState + { maxRedirects :: Int + , maxRetryCount :: Int + , authorities :: Request IO -> Maybe (BS.ByteString, BS.ByteString) + , cookieFilter :: Request IO -> Cookie -> IO Bool + , cookieJar :: CookieJar + , currentProxy :: Maybe Proxy + , userAgent :: BS.ByteString + , manager :: Manager + } + +defaultState :: Manager -> BrowserState +defaultState m = BrowserState { maxRedirects = 10 + , maxRetryCount = 1 + , authorities = \ _ -> Nothing + , cookieFilter = \ _ _ -> return True + , cookieJar = def + , currentProxy = Nothing + , userAgent = fromString "http-conduit" + , manager = m + } + +type BrowserAction = StateT BrowserState (ResourceT IO) + +-- | Do the browser action with the given manager +browse :: Manager -> BrowserAction a -> ResourceT IO a +browse m act = evalStateT act (defaultState m) + +-- | Make a request, using all the state in the current BrowserState +makeRequest :: Request IO -> BrowserAction (Response (Source IO BS.ByteString)) +makeRequest request = do + BrowserState + { maxRetryCount = max_retry_count + , currentProxy = current_proxy + , userAgent = user_agent + } <- get + retryHelper (applyUserAgent user_agent $ + request { redirectCount = 0 + , proxy = current_proxy + , checkStatus = \ _ _ -> Nothing + }) max_retry_count Nothing + where retryHelper request' retry_count e + | retry_count == 0 = case e of + Just e' -> throw e' + Nothing -> throw TooManyRedirects + | otherwise = do + BrowserState {maxRedirects = max_redirects} <- get + resp <- LE.catch (runRedirectionChain request' max_redirects) + (\ e' -> retryHelper request' (retry_count - 1) (Just (e' :: HttpException))) + let code = HT.statusCode $ HC.statusCode resp + if code < 200 || code >= 300 + then retryHelper request' (retry_count - 1) (Just $ HC.StatusCodeException (HC.statusCode resp) (HC.responseHeaders resp)) + else return resp + runRedirectionChain request' redirect_count + | redirect_count == 0 = throw TooManyRedirects + | otherwise = do + s@(BrowserState { manager = manager' + , authorities = auths + , cookieJar = cookie_jar + , cookieFilter = cookie_filter + }) <- get + now <- liftIO getCurrentTime + let (request'', cookie_jar') = insertCookiesIntoRequest + (applyAuthorities auths request') + (evictExpiredCookies cookie_jar now) now + res <- lift $ HC.http request'' manager' + (cookie_jar'', response) <- liftIO $ updateCookieJar res request'' now cookie_jar' cookie_filter + put $ s {cookieJar = cookie_jar''} + let code = HT.statusCode (HC.statusCode response) + if code >= 300 && code < 400 + then runRedirectionChain (case HC.getRedirectedRequest request'' (responseHeaders response) code of + Just a -> a + Nothing -> throw HC.UnparseableRedirect) (redirect_count - 1) + else return res + applyAuthorities auths request' = case auths request' of + Just (user, pass) -> applyBasicAuth user pass request' + Nothing -> request' + applyUserAgent ua request' = request' {requestHeaders = (k, ua) : hs} + where hs = filter ((/= k) . fst) $ requestHeaders request' + k = mk $ fromString "User-Agent" + +updateCookieJar :: Response a -> Request IO -> UTCTime -> CookieJar -> (Request IO -> Cookie -> IO Bool) -> IO (CookieJar, Response a) +updateCookieJar response request' now cookie_jar cookie_filter = do + filtered_cookies <- filterM (cookie_filter request') $ catMaybes $ map (\ sc -> generateCookie sc request' now True) set_cookies + return (cookieJar' filtered_cookies, response {HC.responseHeaders = other_headers}) + where (set_cookie_headers, other_headers) = partition ((== (mk $ fromString "Set-Cookie")) . fst) $ HC.responseHeaders response + set_cookie_data = map snd set_cookie_headers + set_cookies = map parseSetCookie set_cookie_data + cookieJar' = foldl (\ cj c -> insertCheckedCookie c cj True) cookie_jar + +-- | You can save and restore the state at will +getBrowserState :: BrowserAction BrowserState +getBrowserState = get +setBrowserState :: BrowserState -> BrowserAction () +setBrowserState = put +withBrowserState :: BrowserState -> BrowserAction a -> BrowserAction a +withBrowserState s a = do + current <- get + put s + out <- a + put current + return out + +-- | The number of redirects to allow +getMaxRedirects :: BrowserAction Int +getMaxRedirects = get >>= \ a -> return $ maxRedirects a +setMaxRedirects :: Int -> BrowserAction () +setMaxRedirects b = get >>= \ a -> put a {maxRedirects = b} +-- | The number of times to retry a failed connection +getMaxRetryCount :: BrowserAction Int +getMaxRetryCount = get >>= \ a -> return $ maxRetryCount a +setMaxRetryCount :: Int -> BrowserAction () +setMaxRetryCount b = get >>= \ a -> put a {maxRetryCount = b} +-- | A user-provided function that provides optional authorities. +-- This function gets run on all requests before they get sent out. +-- The output of this function is applied to the request. +getAuthorities :: BrowserAction (Request IO -> Maybe (BS.ByteString, BS.ByteString)) +getAuthorities = get >>= \ a -> return $ authorities a +setAuthorities :: (Request IO -> Maybe (BS.ByteString, BS.ByteString)) -> BrowserAction () +setAuthorities b = get >>= \ a -> put a {authorities = b} +-- | Each new Set-Cookie the browser encounters will pass through this filter. +-- Only cookies that pass the filter (and are already valid) will be allowed into the cookie jar +getCookieFilter :: BrowserAction (Request IO -> Cookie -> IO Bool) +getCookieFilter = get >>= \ a -> return $ cookieFilter a +setCookieFilter :: (Request IO -> Cookie -> IO Bool) -> BrowserAction () +setCookieFilter b = get >>= \ a -> put a {cookieFilter = b} +-- | All the cookies! +getCookieJar :: BrowserAction CookieJar +getCookieJar = get >>= \ a -> return $ cookieJar a +setCookieJar :: CookieJar -> BrowserAction () +setCookieJar b = get >>= \ a -> put a {cookieJar = b} +-- | An optional proxy to send all requests through +getCurrentProxy :: BrowserAction (Maybe Proxy) +getCurrentProxy = get >>= \ a -> return $ currentProxy a +setCurrentProxy :: Maybe Proxy -> BrowserAction () +setCurrentProxy b = get >>= \ a -> put a {currentProxy = b} +-- | What string to report our user-agent as +getUserAgent :: BrowserAction BS.ByteString +getUserAgent = get >>= \ a -> return $ userAgent a +setUserAgent :: BS.ByteString -> BrowserAction () +setUserAgent b = get >>= \ a -> put a {userAgent = b} +-- | The active manager, managing the connection pool +getManager :: BrowserAction Manager +getManager = get >>= \ a -> return $ manager a +setManager :: Manager -> BrowserAction () +setManager b = get >>= \ a -> put a {manager = b} diff --git a/Network/HTTP/Conduit/Cookies.hs b/Network/HTTP/Conduit/Cookies.hs --- a/Network/HTTP/Conduit/Cookies.hs +++ b/Network/HTTP/Conduit/Cookies.hs @@ -1,14 +1,264 @@ -- | This module implements the algorithms described in RFC 6265 for the Network.HTTP.Conduit library. -module Network.HTTP.Conduit.Cookies - ( Cookie(..) - , CookieJar - , createCookieJar - , destroyCookieJar - , updateCookieJar - , receiveSetCookie - , insertCookiesIntoRequest - , computeCookieString - , evictExpiredCookies - ) where +module Network.HTTP.Conduit.Cookies where -import Network.HTTP.Conduit.Cookies.Internal +import qualified Network.HTTP.Types as W +import qualified Data.ByteString as BS +import qualified Data.ByteString.UTF8 as U +import Text.Regex +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 Data.Default + +import qualified Network.HTTP.Conduit.Request as Req +import qualified Network.HTTP.Conduit.Response as Res + +slash :: Integral a => a +slash = 47 -- '/' + +isIpAddress :: W.Ascii -> Bool +isIpAddress a = case strs of + Just strs' -> helper strs' + Nothing -> False + where s = U.toString a + regex = mkRegex "^([0-9]{1,3})\\.([0-9]{1,3})\\.([0-9]{1,3})\\.([0-9]{1,3})$" + strs = matchRegex regex s + helper l = length l == 4 && all helper2 l + helper2 v = (read v :: Int) >= 0 && (read v :: Int) < 256 + +-- | This corresponds to the subcomponent algorithm entitled \"Domain Matching\" detailed +-- in section 5.1.3 +domainMatches :: W.Ascii -> W.Ascii -> Bool +domainMatches string domainString + | string == domainString = True + | BS.length string < BS.length domainString + 1 = False + | domainString `BS.isSuffixOf` string && BS.singleton (BS.last difference) == U.fromString "." && not (isIpAddress string) = True + | otherwise = False + where difference = BS.take (BS.length string - BS.length domainString) string + +-- | This corresponds to the subcomponent algorithm entitled \"Paths\" detailed +-- in section 5.1.4 +defaultPath :: Req.Request m -> W.Ascii +defaultPath req + | BS.null uri_path = U.fromString "/" + | BS.singleton (BS.head uri_path) /= U.fromString "/" = U.fromString "/" + | BS.count slash uri_path <= 1 = U.fromString "/" + | otherwise = BS.reverse $ BS.tail $ BS.dropWhile (/= slash) $ BS.reverse uri_path + where uri_path = Req.path req + +-- | This corresponds to the subcomponent algorithm entitled \"Path-Match\" detailed +-- in section 5.1.4 +pathMatches :: W.Ascii -> W.Ascii -> Bool +pathMatches requestPath cookiePath + | cookiePath == requestPath = True + | cookiePath `BS.isPrefixOf` requestPath && BS.singleton (BS.last cookiePath) == U.fromString "/" = True + | cookiePath `BS.isPrefixOf` requestPath && BS.singleton (BS.head remainder) == U.fromString "/" = True + | otherwise = False + where remainder = BS.drop (BS.length cookiePath) requestPath + +-- This corresponds to the description of a cookie detailed in Section 5.3 \"Storage Model\" +data Cookie = Cookie + { cookie_name :: W.Ascii + , cookie_value :: W.Ascii + , cookie_expiry_time :: UTCTime + , cookie_domain :: W.Ascii + , cookie_path :: W.Ascii + , cookie_creation_time :: UTCTime + , cookie_last_access_time :: UTCTime + , cookie_persistent :: Bool + , cookie_host_only :: Bool + , cookie_secure_only :: Bool + , cookie_http_only :: Bool + } + deriving (Show) +-- This corresponds to step 11 of the algorithm described in Section 5.3 \"Storage Model\" +instance Eq Cookie where + (==) a b = name_matches && domain_matches && path_matches + where name_matches = cookie_name a == cookie_name b + domain_matches = cookie_domain a == cookie_domain b + path_matches = cookie_path a == cookie_path b +instance Ord Cookie where + compare c1 c2 + | BS.length (cookie_path c1) > BS.length (cookie_path c2) = LT + | BS.length (cookie_path c1) < BS.length (cookie_path c2) = GT + | cookie_creation_time c1 > cookie_creation_time c2 = GT + | otherwise = LT + +newtype CookieJar = CJ { expose :: [Cookie] } + +-- | empty cookie jar +instance Default CookieJar where + def = CJ [] + +instance Eq CookieJar where + (==) cj1 cj2 = (L.sort $ expose cj1) == (L.sort $ expose cj2) + +instance Show CookieJar where + show = show . expose + +createCookieJar :: [Cookie] -> CookieJar +createCookieJar = CJ + +destroyCookieJar :: CookieJar -> [Cookie] +destroyCookieJar = expose + +insertIntoCookieJar :: Cookie -> CookieJar -> CookieJar +insertIntoCookieJar cookie cookie_jar' = CJ $ cookie : cookie_jar + where cookie_jar = expose cookie_jar' + +removeExistingCookieFromCookieJar :: Cookie -> CookieJar -> (Maybe Cookie, CookieJar) +removeExistingCookieFromCookieJar cookie cookie_jar' = (mc, CJ lc) + where (mc, lc) = removeExistingCookieFromCookieJarHelper cookie (expose cookie_jar') + removeExistingCookieFromCookieJarHelper _ [] = (Nothing, []) + removeExistingCookieFromCookieJarHelper c (c' : cs) + | c == c' = (Just c', cs) + | otherwise = (cookie', c' : cookie_jar'') + where (cookie', cookie_jar'') = removeExistingCookieFromCookieJarHelper c cs + +-- | Are we configured to reject cookies for domains such as \"com\"? +rejectPublicSuffixes :: Bool +rejectPublicSuffixes = True + +isPublicSuffix :: W.Ascii -> Bool +isPublicSuffix _ = False + +-- | 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 cookie_jar' now = CJ $ filter (\ cookie -> cookie_expiry_time cookie >= now) $ expose cookie_jar' + +-- | This applies the 'computeCookieString' to a given Request +insertCookiesIntoRequest :: Req.Request m -- ^ The request to insert into + -> CookieJar -- ^ Current cookie jar + -> UTCTime -- ^ Value that should be used as \"now\" + -> (Req.Request m, CookieJar) -- ^ (Ouptut request, Updated cookie jar (last-access-time is updated)) +insertCookiesIntoRequest request cookie_jar now = (request {Req.requestHeaders = cookie_header : purgedHeaders}, cookie_jar') + where purgedHeaders = L.deleteBy (\ (a, _) (b, _) -> a == b) (CI.mk $ U.fromString "Cookie", BS.empty) $ Req.requestHeaders request + (cookie_string, cookie_jar') = computeCookieString request cookie_jar now True + cookie_header = (CI.mk $ U.fromString "Cookie", cookie_string) + +-- | This corresponds to the algorithm described in Section 5.4 \"The Cookie Header\" +computeCookieString :: Req.Request m -- ^ 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) + -> (W.Ascii, CookieJar) -- ^ (Contents of a \"Cookie\" header, Updated cookie jar (last-access-time is updated)) +computeCookieString request cookie_jar now is_http_api = (output_line, cookie_jar') + where matching_cookie cookie = condition1 && condition2 && condition3 && condition4 + where condition1 + | cookie_host_only cookie = Req.host request == cookie_domain cookie + | otherwise = domainMatches (Req.host request) (cookie_domain cookie) + condition2 = pathMatches (Req.path request) (cookie_path cookie) + condition3 + | not (cookie_secure_only cookie) = True + | otherwise = Req.secure request + condition4 + | not (cookie_http_only cookie) = True + | otherwise = is_http_api + matching_cookies = filter matching_cookie $ expose cookie_jar + output_cookies = map (\ c -> (cookie_name c, cookie_value c)) $ L.sort matching_cookies + output_line = toByteString $ renderCookies $ output_cookies + folding_function cookie_jar'' cookie = case removeExistingCookieFromCookieJar cookie cookie_jar'' of + (Just c, cookie_jar''') -> insertIntoCookieJar (c {cookie_last_access_time = now}) cookie_jar''' + (Nothing, cookie_jar''') -> cookie_jar''' + cookie_jar' = foldl folding_function cookie_jar matching_cookies + +-- | This applies 'receiveSetCookie' to a given Response +updateCookieJar :: Res.Response a -- ^ Response received from server + -> Req.Request m -- ^ Request which generated the response + -> UTCTime -- ^ Value that should be used as \"now\" + -> CookieJar -- ^ Current cookie jar + -> (CookieJar, Res.Response a) -- ^ (Updated cookie jar with cookies from the Response, The response stripped of any \"Set-Cookie\" header) +updateCookieJar response request now cookie_jar = (cookie_jar', response {Res.responseHeaders = other_headers}) + where (set_cookie_headers, other_headers) = L.partition ((== (CI.mk $ U.fromString "Set-Cookie")) . fst) $ Res.responseHeaders response + set_cookie_data = map snd set_cookie_headers + set_cookies = map parseSetCookie set_cookie_data + cookie_jar' = foldl (\ cj sc -> receiveSetCookie sc request now True cj) cookie_jar 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 m -- ^ 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 set_cookie request now is_http_api cookie_jar = case (do + cookie <- generateCookie set_cookie request now is_http_api + return $ insertCheckedCookie cookie cookie_jar is_http_api) of + Just cj -> cj + Nothing -> 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 c cookie_jar is_http_api = case (do + (cookie_jar', cookie') <- existanceTest c cookie_jar + return $ insertIntoCookieJar cookie' cookie_jar') of + Just cj -> cj + Nothing -> cookie_jar + where existanceTest cookie cookie_jar' = existanceTestHelper cookie $ removeExistingCookieFromCookieJar cookie cookie_jar' + existanceTestHelper new_cookie (Just old_cookie, cookie_jar') + | not is_http_api && cookie_http_only old_cookie = Nothing + | otherwise = return (cookie_jar', new_cookie {cookie_creation_time = cookie_creation_time old_cookie}) + existanceTestHelper new_cookie (Nothing, cookie_jar') = return (cookie_jar', new_cookie) + +-- | Turn a SetCookie into a Cookie, if it is valid +generateCookie :: SetCookie -- ^ The 'SetCookie' we are encountering + -> Req.Request m -- ^ 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 set_cookie request now is_http_api = do + domain_sanitized <- sanitizeDomain $ step4 (setCookieDomain set_cookie) + domain_intermediate <- step5 domain_sanitized + (domain_final, host_only') <- step6 domain_intermediate + http_only' <- step10 + return $ Cookie { cookie_name = setCookieName set_cookie + , cookie_value = setCookieValue set_cookie + , cookie_expiry_time = getExpiryTime (setCookieExpires set_cookie) (setCookieMaxAge set_cookie) + , cookie_domain = domain_final + , cookie_path = getPath $ setCookiePath set_cookie + , cookie_creation_time = now + , cookie_last_access_time = now + , cookie_persistent = getPersistent + , cookie_host_only = host_only' + , cookie_secure_only = setCookieSecure set_cookie + , cookie_http_only = http_only' + } + where sanitizeDomain domain' + | has_a_character && BS.singleton (BS.last domain') == U.fromString "." = Nothing + | has_a_character && BS.singleton (BS.head domain') == U.fromString "." = Just $ BS.tail domain' + | otherwise = Just $ domain' + where has_a_character = not (BS.null domain') + step4 (Just set_cookie_domain) = set_cookie_domain + step4 Nothing = BS.empty + step5 domain' + | firstCondition && domain' == (Req.host request) = return BS.empty + | firstCondition = Nothing + | otherwise = return domain' + where firstCondition = rejectPublicSuffixes && isPublicSuffix domain' + step6 domain' + | firstCondition && not (domainMatches (Req.host request) domain') = Nothing + | firstCondition = return (domain', False) + | otherwise = return (Req.host request, True) + where firstCondition = not $ BS.null domain' + step10 + | not is_http_api && setCookieHttpOnly set_cookie = Nothing + | otherwise = return $ setCookieHttpOnly set_cookie + getExpiryTime :: Maybe UTCTime -> Maybe DiffTime -> UTCTime + getExpiryTime _ (Just t) = (fromRational $ toRational t) `addUTCTime` now + getExpiryTime (Just t) Nothing = t + getExpiryTime Nothing Nothing= UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 0) + getPath (Just p) = p + getPath Nothing = defaultPath request + getPersistent = isJust (setCookieExpires set_cookie) || isJust (setCookieMaxAge set_cookie) diff --git a/Network/HTTP/Conduit/Cookies/Internal.hs b/Network/HTTP/Conduit/Cookies/Internal.hs deleted file mode 100644 --- a/Network/HTTP/Conduit/Cookies/Internal.hs +++ /dev/null @@ -1,247 +0,0 @@ --- | This module implements the algorithms described in RFC 6265 for the Network.HTTP.Conduit library. -module Network.HTTP.Conduit.Cookies.Internal where - -import qualified Network.HTTP.Types as W -import qualified Data.ByteString as BS -import qualified Data.ByteString.UTF8 as U -import Text.Regex -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 Data.Default - -import qualified Network.HTTP.Conduit.Request as Req -import qualified Network.HTTP.Conduit.Response as Res - -slash :: Integral a => a -slash = 47 -- '/' - -isIpAddress :: W.Ascii -> Bool -isIpAddress a = case strs of - Just strs' -> helper strs' - Nothing -> False - where s = U.toString a - regex = mkRegex "^([0-9]{1,3})\\.([0-9]{1,3})\\.([0-9]{1,3})\\.([0-9]{1,3})$" - strs = matchRegex regex s - helper l = length l == 4 && all helper2 l - helper2 v = (read v :: Int) >= 0 && (read v :: Int) < 256 - --- | This corresponds to the subcomponent algorithm entitled \"Domain Matching\" detailed --- in section 5.1.3 -domainMatches :: W.Ascii -> W.Ascii -> Bool -domainMatches string domainString - | string == domainString = True - | BS.length string < BS.length domainString + 1 = False - | domainString `BS.isSuffixOf` string && BS.singleton (BS.last difference) == U.fromString "." && not (isIpAddress string) = True - | otherwise = False - where difference = BS.take (BS.length string - BS.length domainString) string - --- | This corresponds to the subcomponent algorithm entitled \"Paths\" detailed --- in section 5.1.4 -defaultPath :: Req.Request m -> W.Ascii -defaultPath req - | BS.null uri_path = U.fromString "/" - | BS.singleton (BS.head uri_path) /= U.fromString "/" = U.fromString "/" - | BS.count slash uri_path <= 1 = U.fromString "/" - | otherwise = BS.reverse $ BS.tail $ BS.dropWhile (/= slash) $ BS.reverse uri_path - where uri_path = Req.path req - --- | This corresponds to the subcomponent algorithm entitled \"Path-Match\" detailed --- in section 5.1.4 -pathMatches :: W.Ascii -> W.Ascii -> Bool -pathMatches requestPath cookiePath - | cookiePath == requestPath = True - | cookiePath `BS.isPrefixOf` requestPath && BS.singleton (BS.last cookiePath) == U.fromString "/" = True - | cookiePath `BS.isPrefixOf` requestPath && BS.singleton (BS.head remainder) == U.fromString "/" = True - | otherwise = False - where remainder = BS.drop (BS.length cookiePath) requestPath - --- This corresponds to the description of a cookie detailed in Section 5.3 \"Storage Model\" -data Cookie = Cookie - { cookie_name :: W.Ascii - , cookie_value :: W.Ascii - , cookie_expiry_time :: UTCTime - , cookie_domain :: W.Ascii - , cookie_path :: W.Ascii - , cookie_creation_time :: UTCTime - , cookie_last_access_time :: UTCTime - , cookie_persistent :: Bool - , cookie_host_only :: Bool - , cookie_secure_only :: Bool - , cookie_http_only :: Bool - } - deriving (Show) --- This corresponds to step 11 of the algorithm described in Section 5.3 \"Storage Model\" -instance Eq Cookie where - (==) a b = name_matches && domain_matches && path_matches - where name_matches = cookie_name a == cookie_name b - domain_matches = cookie_domain a == cookie_domain b - path_matches = cookie_path a == cookie_path b -instance Ord Cookie where - compare c1 c2 - | BS.length (cookie_path c1) > BS.length (cookie_path c2) = LT - | BS.length (cookie_path c1) < BS.length (cookie_path c2) = GT - | cookie_creation_time c1 > cookie_creation_time c2 = GT - | otherwise = LT - -newtype CookieJar = CJ { expose :: [Cookie] } - --- | empty cookie jar -instance Default CookieJar where - def = CJ [] - -instance Eq CookieJar where - (==) cj1 cj2 = (L.sort $ expose cj1) == (L.sort $ expose cj2) - -instance Show CookieJar where - show = show . expose - -createCookieJar :: [Cookie] -> CookieJar -createCookieJar = CJ - -destroyCookieJar :: CookieJar -> [Cookie] -destroyCookieJar = expose - -insertIntoCookieJar :: Cookie -> CookieJar -> CookieJar -insertIntoCookieJar cookie cookie_jar' = CJ $ cookie : cookie_jar - where cookie_jar = expose cookie_jar' - -removeExistingCookieFromCookieJar :: Cookie -> CookieJar -> (Maybe Cookie, CookieJar) -removeExistingCookieFromCookieJar cookie cookie_jar' = (mc, CJ lc) - where (mc, lc) = removeExistingCookieFromCookieJarHelper cookie (expose cookie_jar') - removeExistingCookieFromCookieJarHelper _ [] = (Nothing, []) - removeExistingCookieFromCookieJarHelper c (c' : cs) - | c == c' = (Just c', cs) - | otherwise = (cookie', c' : cookie_jar'') - where (cookie', cookie_jar'') = removeExistingCookieFromCookieJarHelper c cs - --- | Are we configured to reject cookies for domains such as \"com\"? -rejectPublicSuffixes :: Bool -rejectPublicSuffixes = True - -isPublicSuffix :: W.Ascii -> Bool -isPublicSuffix _ = False - --- | 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 cookie_jar' now = CJ $ filter (\ cookie -> cookie_expiry_time cookie >= now) $ expose cookie_jar' - --- | This applies the 'computeCookieString' to a given Request -insertCookiesIntoRequest :: Req.Request m -- ^ The request to insert into - -> CookieJar -- ^ Current cookie jar - -> UTCTime -- ^ Value that should be used as \"now\" - -> (Req.Request m, CookieJar) -- ^ (Ouptut request, Updated cookie jar (last-access-time is updated)) -insertCookiesIntoRequest request cookie_jar now = (request {Req.requestHeaders = cookie_header : purgedHeaders}, cookie_jar') - where purgedHeaders = L.deleteBy (\ (a, _) (b, _) -> a == b) (CI.mk $ U.fromString "Cookie", BS.empty) $ Req.requestHeaders request - (cookie_string, cookie_jar') = computeCookieString request cookie_jar now True - cookie_header = (CI.mk $ U.fromString "Cookie", cookie_string) - --- | This corresponds to the algorithm described in Section 5.4 \"The Cookie Header\" -computeCookieString :: Req.Request m -- ^ 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) - -> (W.Ascii, CookieJar) -- ^ (Contents of a \"Cookie\" header, Updated cookie jar (last-access-time is updated)) -computeCookieString request cookie_jar now is_http_api = (output_line, cookie_jar') - where matching_cookie cookie = condition1 && condition2 && condition3 && condition4 - where condition1 - | cookie_host_only cookie = Req.host request == cookie_domain cookie - | otherwise = domainMatches (Req.host request) (cookie_domain cookie) - condition2 = pathMatches (Req.path request) (cookie_path cookie) - condition3 - | not (cookie_secure_only cookie) = True - | otherwise = Req.secure request - condition4 - | not (cookie_http_only cookie) = True - | otherwise = is_http_api - matching_cookies = filter matching_cookie $ expose cookie_jar - output_cookies = map (\ c -> (cookie_name c, cookie_value c)) $ L.sort matching_cookies - output_line = toByteString $ renderCookies $ output_cookies - folding_function cookie_jar'' cookie = case removeExistingCookieFromCookieJar cookie cookie_jar'' of - (Just c, cookie_jar''') -> insertIntoCookieJar (c {cookie_last_access_time = now}) cookie_jar''' - (Nothing, cookie_jar''') -> cookie_jar''' - cookie_jar' = foldl folding_function cookie_jar matching_cookies - --- | This applies 'receiveSetCookie' to a given Response -updateCookieJar :: Res.Response a -- ^ Response received from server - -> Req.Request m -- ^ Request which generated the response - -> UTCTime -- ^ Value that should be used as \"now\" - -> CookieJar -- ^ Current cookie jar - -> (CookieJar, Res.Response a) -- ^ (Updated cookie jar with cookies from the Response, The response stripped of any \"Set-Cookie\" header) -updateCookieJar response request now cookie_jar = (cookie_jar', response {Res.responseHeaders = other_headers}) - where (set_cookie_headers, other_headers) = L.partition ((== (CI.mk $ U.fromString "Set-Cookie")) . fst) $ Res.responseHeaders response - set_cookie_data = map snd set_cookie_headers - set_cookies = map parseSetCookie set_cookie_data - cookie_jar' = foldl (\ cj sc -> receiveSetCookie sc request now True cj) cookie_jar set_cookies - --- | This corresponds to the algorithm described in Section 5.3 \"Storage Model\" -receiveSetCookie :: SetCookie -- ^ The 'SetCookie' the cookie jar is receiving - -> Req.Request m -- ^ 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 set_cookie request now is_http_api cookie_jar = case result of - Nothing -> cookie_jar - Just cookie_jar' -> cookie_jar' - where result :: Maybe CookieJar - result = do - cookie <- generateCookie - (cookie_jar', cookie') <- existanceTest cookie cookie_jar - return $ insertIntoCookieJar cookie' cookie_jar' - generateCookie :: Maybe Cookie - generateCookie = do - domain_sanitized <- sanitizeDomain $ step4 (setCookieDomain set_cookie) - domain_intermediate <- step5 domain_sanitized - (domain_final, host_only') <- step6 domain_intermediate - http_only' <- step10 - return $ Cookie { cookie_name = setCookieName set_cookie - , cookie_value = setCookieValue set_cookie - , cookie_expiry_time = getExpiryTime (setCookieExpires set_cookie) (setCookieMaxAge set_cookie) - , cookie_domain = domain_final - , cookie_path = getPath $ setCookiePath set_cookie - , cookie_creation_time = now - , cookie_last_access_time = now - , cookie_persistent = getPersistent - , cookie_host_only = host_only' - , cookie_secure_only = setCookieSecure set_cookie - , cookie_http_only = http_only' - } - sanitizeDomain domain' - | has_a_character && BS.singleton (BS.last domain') == U.fromString "." = Nothing - | has_a_character && BS.singleton (BS.head domain') == U.fromString "." = Just $ BS.tail domain' - | otherwise = Just $ domain' - where has_a_character = not (BS.null domain') - step4 (Just set_cookie_domain) = set_cookie_domain - step4 Nothing = BS.empty - step5 domain' - | firstCondition && domain' == (Req.host request) = return BS.empty - | firstCondition = Nothing - | otherwise = return domain' - where firstCondition = rejectPublicSuffixes && isPublicSuffix domain' - step6 domain' - | firstCondition && not (domainMatches (Req.host request) domain') = Nothing - | firstCondition = return (domain', False) - | otherwise = return (Req.host request, True) - where firstCondition = not $ BS.null domain' - step10 - | not is_http_api && setCookieHttpOnly set_cookie = Nothing - | otherwise = return $ setCookieHttpOnly set_cookie - getExpiryTime :: Maybe UTCTime -> Maybe DiffTime -> UTCTime - getExpiryTime _ (Just t) = (fromRational $ toRational t) `addUTCTime` now - getExpiryTime (Just t) Nothing = t - getExpiryTime Nothing Nothing= UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 0) - getPath (Just p) = p - getPath Nothing = defaultPath request - getPersistent = isJust (setCookieExpires set_cookie) || isJust (setCookieMaxAge set_cookie) - existanceTest cookie cookie_jar' = existanceTestHelper cookie $ removeExistingCookieFromCookieJar cookie cookie_jar' - existanceTestHelper new_cookie (Just old_cookie, cookie_jar') - | not is_http_api && cookie_http_only old_cookie = Nothing - | otherwise = return (cookie_jar', new_cookie {cookie_creation_time = cookie_creation_time old_cookie}) - existanceTestHelper new_cookie (Nothing, cookie_jar') = return (cookie_jar', new_cookie) diff --git a/Network/HTTP/Conduit/Request.hs b/Network/HTTP/Conduit/Request.hs --- a/Network/HTTP/Conduit/Request.hs +++ b/Network/HTTP/Conduit/Request.hs @@ -214,8 +214,11 @@ data HttpException = StatusCodeException W.Status W.ResponseHeaders | InvalidUrlException String String | TooManyRedirects + | UnparseableRedirect + | TooManyRetries | HttpParserException String | HandshakeFailed + | OverlongHeaders deriving (Show, Typeable) instance Exception HttpException @@ -311,11 +314,6 @@ builder = fromByteString (method req) <> fromByteString " " - <> (case proxy req of - Just{} -> - fromByteString (if secure req then "https://" else "http://") - <> fromByteString hh - Nothing -> mempty) <> (case S8.uncons $ path req of Just ('/', _) -> fromByteString $ path req _ -> fromByteString "/" <> fromByteString (path req)) diff --git a/Network/HTTP/Conduit/Response.hs b/Network/HTTP/Conduit/Response.hs --- a/Network/HTTP/Conduit/Response.hs +++ b/Network/HTTP/Conduit/Response.hs @@ -13,6 +13,9 @@ import Data.Typeable (Typeable) import Data.Monoid (mempty) +import Control.Exception (throwIO) +import Control.Monad.IO.Class (liftIO) + import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L @@ -104,26 +107,42 @@ { responseBody = L.fromChunks bss } +checkHeaderLength :: ResourceIO m => Int -> C.Sink S8.ByteString m a -> C.Sink S8.ByteString m a +checkHeaderLength len0 (C.SinkData pushI0 closeI0) = + C.SinkData (push len0 pushI0) closeI0 + where + push len pushI bs = do + res <- pushI bs + case res of + C.Processing pushI' close + | len' <= 0 -> liftIO $ throwIO OverlongHeaders + | otherwise -> return $ C.Processing + (push len' pushI') close + C.Done a b -> return $ C.Done a b + where + len' = len - S8.length bs +checkHeaderLength _ _ = error "checkHeaderLength" + getResponse :: ResourceIO m => ConnRelease m -> Request m -> C.BufferedSource m S8.ByteString -> ResourceT m (Response (C.Source m S8.ByteString)) getResponse connRelease req@(Request {..}) bsrc = do - ((_, sc, sm), hs) <- bsrc C.$$ sinkHeaders + ((_, sc, sm), hs) <- bsrc C.$$ checkHeaderLength 4096 sinkHeaders let s = W.Status sc sm let hs' = map (first CI.mk) hs let mcl = lookup "content-length" hs' >>= readDec . S8.unpack -- should we put this connection back into the connection manager? let toPut = Just "close" /= lookup "connection" hs' - let cleanup = connRelease $ if toPut then Reuse else DontReuse + let cleanup bodyConsumed = connRelease $ if toPut && bodyConsumed then Reuse else DontReuse -- RFC 2616 section 4.4_1 defines responses that must not include a body body <- if hasNoBody method sc || mcl == Just 0 then do - cleanup + cleanup True return mempty else do let bsrc' = @@ -144,18 +163,18 @@ -- | Add some cleanup code to the given 'C.Source'. General purpose -- function, could be included in conduit itself. addCleanup :: C.ResourceIO m - => ResourceT m () + => (Bool -> ResourceT m ()) -> C.Source m a -> C.Source m a addCleanup cleanup src = src { C.sourcePull = do res <- C.sourcePull src case res of - C.Closed -> cleanup >> return C.Closed + C.Closed -> cleanup True >> return C.Closed C.Open src' val -> return $ C.Open (addCleanup cleanup src') val , C.sourceClose = do C.sourceClose src - cleanup + cleanup False } diff --git a/http-conduit.cabal b/http-conduit.cabal --- a/http-conduit.cabal +++ b/http-conduit.cabal @@ -1,5 +1,5 @@ name: http-conduit -version: 1.2.5 +version: 1.2.6 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -47,12 +47,14 @@ , time , cookie >= 0.4 && < 0.5 , regex-compat + , mtl if flag(network-bytestring) build-depends: network >= 2.2.1 && < 2.2.3 , network-bytestring >= 0.1.3 && < 0.1.4 else build-depends: network >= 2.3 && < 2.4 exposed-modules: Network.HTTP.Conduit + Network.HTTP.Conduit.Browser other-modules: Network.HTTP.Conduit.Parser Network.HTTP.Conduit.ConnInfo Network.HTTP.Conduit.Request @@ -61,7 +63,6 @@ Network.HTTP.Conduit.Chunk Network.HTTP.Conduit.Response Network.HTTP.Conduit.Cookies - Network.HTTP.Conduit.Cookies.Internal ghc-options: -Wall test-suite test @@ -106,6 +107,7 @@ , http-types , cookie , regex-compat + , network-conduit source-repository head type: git diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -8,9 +8,14 @@ import Network.HTTP.Conduit import Control.Concurrent (forkIO, killThread) import Network.HTTP.Types -import Control.Exception (try, SomeException) +import Control.Exception.Lifted (try, SomeException) import Network.HTTP.Conduit.ConnInfo import CookieTest (cookieTest) +import Data.Conduit.Network (runTCPServer, ServerSettings (..)) +import Data.Conduit (($$)) +import Control.Monad.Trans.Resource (register) +import Control.Monad.IO.Class (liftIO) +import Data.Conduit.List (sourceList) app :: Application app req = @@ -49,3 +54,19 @@ requireAllSocketsClosed killThread tid2 killThread tid1 + describe "DOS protection" $ do + it "overlong headers" $ do + tid1 <- forkIO overLongHeaders + withManager $ \manager -> do + _ <- register $ killThread tid1 + let Just req1 = parseUrl "http://localhost:3004/" + res1 <- try $ http req1 manager + case res1 of + Left e -> liftIO $ show (e :: SomeException) @?= show OverlongHeaders + _ -> error "Shouldn't have worked" + +overLongHeaders :: IO () +overLongHeaders = runTCPServer (ServerSettings 3004 Nothing) $ \_ sink -> + src $$ sink + where + src = sourceList $ "HTTP/1.0 200 OK\r\nfoo: " : repeat "bar"