http-conduit 1.2.5 → 1.2.6

raw patch · 8 files changed

+514/−273 lines, 8 filesdep +mtldep +network-conduitPVP ok

version bump matches the API change (PVP)

Dependencies added: mtl, network-conduit

API changes (from Hackage documentation)

Files

• Network/HTTP/Conduit.hs +2/−0
• Network/HTTP/Conduit/Browser.hs +196/−0
• Network/HTTP/Conduit/Cookies.hs +262/−12
• Network/HTTP/Conduit/Cookies/Internal.hs +0/−247
• Network/HTTP/Conduit/Request.hs +3/−5
• Network/HTTP/Conduit/Response.hs +25/−6
• http-conduit.cabal +4/−2
• test/main.hs +22/−1

@@ -93,6 +93,8 @@     , destroyCookieJar     , updateCookieJar     , receiveSetCookie+    , generateCookie+    , insertCheckedCookie     , insertCookiesIntoRequest     , computeCookieString     , evictExpiredCookies

@@ -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}

@@ -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)

@@ -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)

@@ -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))

@@ -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     }

@@ -1,5 +1,5 @@ name:            http-conduit-version:         1.2.5+version:         1.2.6 license:         BSD3 license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -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

@@ -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"