http-conduit 1.8.4.5 → 1.8.5
raw patch · 5 files changed
+110/−34 lines, 5 files
Files
- Network/HTTP/Conduit.hs +16/−28
- Network/HTTP/Conduit/Internal.hs +54/−0
- Network/HTTP/Conduit/Request.hs +2/−0
- http-conduit.cabal +1/−1
- test/main.hs +37/−5
Network/HTTP/Conduit.hs view
@@ -140,7 +140,6 @@ ) where import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import qualified Network.HTTP.Types as W@@ -149,15 +148,15 @@ import Control.Exception.Lifted (throwIO) import Control.Monad ((<=<)) import Control.Monad.IO.Class (MonadIO (liftIO))-import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Monad.Trans.Resource+import Control.Monad.Trans.State (get, put, evalStateT)+import Control.Monad.Trans (lift) import Control.Exception (fromException, toException) import qualified Data.Conduit as C import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.Internal as CI-import Data.Conduit.List (sinkNull) import Data.Conduit.Blaze (builderToByteString)-import Data.Conduit (MonadResource) import Control.Exception.Lifted (try, SomeException) import Data.Time.Clock@@ -167,6 +166,7 @@ import Network.HTTP.Conduit.Manager import Network.HTTP.Conduit.ConnInfo import Network.HTTP.Conduit.Cookies+import Network.HTTP.Conduit.Internal (httpRedirect) -- | The most low-level function for initiating an HTTP request. --@@ -196,7 +196,7 @@ res@(Response status _version hs body) <- if redirectCount req0 == 0 then httpRaw req0 manager- else go (redirectCount req0) req0 def []+ else go (redirectCount req0) req0 def case checkStatus req0 status hs of Nothing -> return res Just exc -> do@@ -212,32 +212,20 @@ return exc liftIO $ throwIO exc' where- go (-1) _ _ ress = liftIO . throwIO . TooManyRedirects =<< mapM lbsResponse ress- go count req'' cookie_jar'' ress = do+ go count req''' cookie_jar''' = (`evalStateT` cookie_jar''') $+ httpRedirect+ count+ (\req'' -> do+ cookie_jar'' <- get now <- liftIO getCurrentTime let (req', cookie_jar') = insertCookiesIntoRequest req'' (evictExpiredCookies cookie_jar'' now) now- res <- httpRaw req' manager+ res <- lift $ httpRaw req' manager let (cookie_jar, _) = updateCookieJar res req' now cookie_jar'- case getRedirectedRequest req' (responseHeaders res) (W.statusCode (responseStatus res)) of- Just req -> do- -- Allow the original connection to return to the- -- connection pool immediately by flushing the body.- -- If the response body is too large, don't flush, but- -- instead just close the connection.- let maxFlush = 1024- readMay bs =- case S8.readInt bs of- Just (i, bs') | S.null bs' -> Just i- _ -> Nothing- sink =- case lookup "content-length" (responseHeaders res) >>= readMay of- Just i | i > maxFlush -> return ()- _ -> CB.isolate maxFlush C.=$ sinkNull- responseBody res C.$$+- sink-- -- And now perform the actual redirect- go (count - 1) req cookie_jar (res:ress)- Nothing -> return res+ put cookie_jar+ let mreq = getRedirectedRequest req' (responseHeaders res) (W.statusCode (responseStatus res))+ return (res, mreq))+ lift+ req''' -- | Get a 'Response' without any redirect following. httpRaw
Network/HTTP/Conduit/Internal.hs view
@@ -1,5 +1,59 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-} module Network.HTTP.Conduit.Internal ( module Network.HTTP.Conduit.Parser+ , getUri+ , setUri+ , setUriRelative+ , httpRedirect ) where import Network.HTTP.Conduit.Parser++import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8++import Control.Exception.Lifted (throwIO)+import Control.Monad.Trans.Resource++import qualified Data.Conduit as C+import qualified Data.Conduit.Binary as CB+import Data.Conduit.List (sinkNull)++import Network.HTTP.Conduit.Request+import Network.HTTP.Conduit.Response++-- | Redirect loop+httpRedirect+ :: (MonadBaseControl IO m, MonadResource m, Monad m1)+ => Int -- ^ 'redirectCount'+ -> (Request m1 -> m (Response (C.ResumableSource m1 S.ByteString), Maybe (Request m1))) -- ^ function which performs a request and returns a response, and possibly another request if there's a redirect.+ -> (forall a. m1 a -> m a) -- ^ 'liftResourceT'+ -> Request m1+ -> m (Response (C.ResumableSource m1 S.ByteString))+httpRedirect count0 http' lift' req0 = go count0 req0 []+ where+ go (-1) _ ress = throwIO . TooManyRedirects =<< lift' (mapM lbsResponse ress)+ go count req' ress = do+ (res, mreq) <- http' req'+ case mreq of+ Just req -> do+ -- Allow the original connection to return to the+ -- connection pool immediately by flushing the body.+ -- If the response body is too large, don't flush, but+ -- instead just close the connection.+ let maxFlush = 1024+ readMay bs =+ case S8.readInt bs of+ Just (i, bs') | S.null bs' -> Just i+ _ -> Nothing+ sink =+ case lookup "content-length" (responseHeaders res) >>= readMay of+ Just i | i > maxFlush -> return ()+ _ -> CB.isolate maxFlush C.=$ sinkNull+ lift' $ responseBody res C.$$+- sink++ -- And now perform the actual redirect+ go (count - 1) req (res:ress)+ Nothing -> return res
Network/HTTP/Conduit/Request.hs view
@@ -11,6 +11,8 @@ , Proxy (..) , parseUrl , setUriRelative+ , getUri+ , setUri , browserDecompress , HttpException (..) , alwaysDecompress
http-conduit.cabal view
@@ -1,5 +1,5 @@ name: http-conduit-version: 1.8.4.5+version: 1.8.5 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>
test/main.hs view
@@ -3,28 +3,31 @@ import Test.Hspec import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy.Char8 as L8 import Test.HUnit import Network.Wai hiding (requestBody)-import qualified Network.Wai+import qualified Network.Wai as Wai import Network.Wai.Handler.Warp (run) import Network.HTTP.Conduit import Data.ByteString.Base64 (encode) import Control.Concurrent (forkIO, killThread, threadDelay) import Network.HTTP.Types import Control.Exception.Lifted (try, SomeException)+import qualified Control.Exception as E (catch) import Network.HTTP.Conduit.ConnInfo import Network (withSocketsDo) import CookieTest (cookieTest) import Data.Conduit.Network (runTCPServer, serverSettings, HostPreference (HostAny), appSink, appSource) import Data.Conduit (($$), yield, Flush (Chunk))+import Control.Monad (void, forever) import Control.Monad.Trans.Resource (register) import Control.Monad.IO.Class (liftIO)-import Control.Monad (forever) import Data.ByteString.UTF8 (fromString) import Data.Conduit.List (sourceList) import Data.CaseInsensitive (mk)-import Data.List (partition)+import Data.List (partition, lookup) import qualified Data.Conduit.List as CL+import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.ByteString.Lazy as L import Blaze.ByteString.Builder (fromByteString)@@ -34,6 +37,21 @@ case pathInfo req of [] -> return $ responseLBS status200 [] "homepage" ["cookies"] -> return $ responseLBS status200 [tastyCookie] "cookies"+ ["cookie_redir1"] -> return $ responseLBS status303 [tastyCookie, (hLocation, "/checkcookie")] ""+ ["checkcookie"] -> return $ case lookup hCookie $ Wai.requestHeaders req of+ Just "flavor=chocolate-chip" -> responseLBS status200 [] "nom-nom-nom"+ _ -> responseLBS status412 [] "Baaaw where's my chocolate?"+ ["infredir", i'] ->+ let i = read $ T.unpack i'+ in return $ responseLBS status303+ [(hLocation, S.append "/infredir/" $ S8.pack $ show $ i+1)]+ (L8.pack $ show i)+ ["infredirrepeat", i'] ->+ let i = read $ T.unpack i'+ in return $ responseLBS status303+ [(hLocation, S.append "/infredirrepeat/" $ S8.pack $ show $ i+1)+ ,(hContentLength, "2048")]+ (L8.pack $ take 2048 $ unwords $ repeat $ show i) _ -> return $ responseLBS status404 [] "not found" where tastyCookie = (mk (fromString "Set-Cookie"), fromString "flavor=chocolate-chip;")@@ -67,6 +85,13 @@ (setCookieHeaders, _) = partition ((== setCookie) . fst) headers liftIO $ assertBool "response contains a 'set-cookie' header" $ length setCookieHeaders > 0 killThread tid+ it "redirects set cookies" $ do+ tid <- forkIO $ run 13010 app+ request <- parseUrl "http://127.0.0.1:13010/cookie_redir1"+ withManager $ \manager -> do+ _ <- register $ killThread tid+ Response _ _ _ body <- httpLbs request manager+ liftIO $ body @?= "nom-nom-nom" describe "manager" $ do it "closes all connections" $ do clearSocketsList@@ -120,7 +145,14 @@ , ("hello%20world", "hello world") , ("hello%20world%3f%23", "hello world?#") ]-+ it "TooManyRedirects: redirect request body is preserved" $ do+ tid <- forkIO $ run 13009 app+ let Just req = parseUrl "http://127.0.0.1:13009/infredir/0"+ let go (res, i) = liftIO $ responseBody res @?= (L8.pack $ show i)+ E.catch (withManager $ \manager -> do+ void $ register $ killThread tid+ void $ http req{redirectCount=5} manager) $+ \(TooManyRedirects redirs) -> mapM_ go (zip redirs [5,4..0]) describe "chunked request body" $ do it "works" $ do tid <- forkIO echo@@ -218,7 +250,7 @@ echo :: IO () echo = run 13007 $ \req -> do- bss <- Network.Wai.requestBody req $$ CL.consume+ bss <- Wai.requestBody req $$ CL.consume return $ responseLBS status200 [] $ L.fromChunks bss noStatusMessage :: IO ()