diff --git a/Network/HTTP/Conduit.hs b/Network/HTTP/Conduit.hs --- a/Network/HTTP/Conduit.hs +++ b/Network/HTTP/Conduit.hs @@ -23,8 +23,8 @@ -- > main = do -- > request <- parseUrl "http://google.com/" -- > withManager $ \manager -> do --- > Response _ _ bsrc <- http request manager --- > bsrc C.$$ sinkFile "google.html" +-- > Response _ _ src <- http request manager +-- > src C.$$ sinkFile "google.html" -- -- The following headers are automatically set by this module, and should not -- be added to 'requestHeaders': @@ -128,6 +128,7 @@ import Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.Conduit as C +import qualified Data.Conduit.Internal as CI import Data.Conduit.Blaze (builderToByteString) import Data.Conduit (MonadResource) import Control.Exception.Lifted (try, SomeException) @@ -172,7 +173,7 @@ case checkStatus req0 status hs of Nothing -> return res Just exc -> do - C.sourceClose body + CI.pipeClose body liftIO $ throwIO exc where go 0 _ _ = liftIO $ throwIO TooManyRedirects @@ -193,7 +194,7 @@ -> m (Response (C.Source m S.ByteString)) httpRaw req m = do (connRelease, ci, isManaged) <- getConn req m - bsrc <- C.bufferSource $ connSource ci + let src = connSource ci ex <- try $ requestBuilder req C.$$ builderToByteString C.=$ connSink ci case (ex :: Either SomeException (), isManaged) of -- Connection was reused, and might be been closed. Try again @@ -204,7 +205,7 @@ (Left e, Fresh) -> liftIO $ throwIO e -- Everything went ok, so the connection is good. If any exceptions get -- thrown in the rest of the code, just throw them as normal. - (Right (), _) -> getResponse connRelease req bsrc + (Right (), _) -> getResponse connRelease req src -- | Download the specified 'Request', returning the results as a 'Response'. -- diff --git a/Network/HTTP/Conduit/Chunk.hs b/Network/HTTP/Conduit/Chunk.hs --- a/Network/HTTP/Conduit/Chunk.hs +++ b/Network/HTTP/Conduit/Chunk.hs @@ -78,4 +78,4 @@ where conduit = C.NeedInput push close push xs = C.HaveOutput conduit (return ()) (chunkedTransferEncoding xs) - close = C.Open C.Closed (return ()) chunkedTransferTerminator + close = C.HaveOutput (return ()) (return ()) chunkedTransferTerminator diff --git a/Network/HTTP/Conduit/ConnInfo.hs b/Network/HTTP/Conduit/ConnInfo.hs --- a/Network/HTTP/Conduit/ConnInfo.hs +++ b/Network/HTTP/Conduit/ConnInfo.hs @@ -57,21 +57,23 @@ connSink :: C.MonadResource m => ConnInfo -> C.Sink ByteString m () connSink ConnInfo { connWrite = write } = - C.Processing push close + C.NeedInput push close where - push bss = C.SinkM $ liftIO (write bss) >> return (C.Processing push close) + push bss = C.PipeM + (liftIO (write bss) >> return (C.NeedInput push close)) + (return ()) close = return () connSource :: C.MonadResource m => ConnInfo -> C.Source m ByteString connSource ConnInfo { connRead = read' } = src where - src = C.SourceM pull close + src = C.PipeM pull close pull = do bs <- liftIO read' if S.null bs - then return C.Closed - else return $ C.Open src close bs + then return (return ()) + else return $ C.HaveOutput src close bs close = return () #if DEBUG 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 @@ -36,6 +36,8 @@ import Network.HTTP.Conduit.Parser import Network.HTTP.Conduit.Chunk +import Data.Void (absurd) + -- | A simple representation of the HTTP response created by 'lbsConsumer'. data Response body = Response { responseStatus :: W.Status @@ -113,22 +115,25 @@ => Int -> C.Sink S8.ByteString m a -> C.Sink S8.ByteString m a -checkHeaderLength len C.Processing{} - | len <= 0 = C.SinkM $ liftIO $ throwIO OverlongHeaders -checkHeaderLength len (C.Processing pushI closeI) = C.Processing +checkHeaderLength len C.NeedInput{} + | len <= 0 = + let x = liftIO $ throwIO OverlongHeaders + in C.PipeM x x +checkHeaderLength len (C.NeedInput pushI closeI) = C.NeedInput (\bs -> checkHeaderLength (len - S8.length bs) (pushI bs)) closeI -checkHeaderLength len (C.SinkM msink) = C.SinkM $ liftM (checkHeaderLength len) msink +checkHeaderLength len (C.PipeM msink close) = C.PipeM (liftM (checkHeaderLength len) msink) close checkHeaderLength _ s@C.Done{} = s +checkHeaderLength _ (C.HaveOutput _ _ o) = absurd o getResponse :: MonadResource m => ConnRelease m -> Request m - -> C.BufferedSource m S8.ByteString + -> C.Source m S8.ByteString -> m (Response (C.Source m S8.ByteString)) -getResponse connRelease req@(Request {..}) bsrc = do - ((vbs, sc, sm), hs) <- bsrc C.$$ checkHeaderLength 4096 sinkHeaders +getResponse connRelease req@(Request {..}) src1 = do + (src2, ((vbs, sc, sm), hs)) <- src1 C.$$+ checkHeaderLength 4096 sinkHeaders let version = if vbs == "1.1" then W.http11 else W.http10 let s = W.Status sc sm let hs' = map (first CI.mk) hs @@ -145,18 +150,18 @@ cleanup True return mempty else do - let bsrc' = + let src3 = if ("transfer-encoding", "chunked") `elem` hs' - then bsrc C.$= chunkedConduit rawBody + then src2 C.$= chunkedConduit rawBody else case mcl of - Just len -> bsrc C.$= CB.isolate len - Nothing -> C.unbufferSource bsrc - let bsrc'' = + Just len -> src2 C.$= CB.isolate len + Nothing -> src2 + let src4 = if needsGunzip req hs' - then bsrc' C.$= CZ.ungzip - else bsrc' - return $ addCleanup cleanup bsrc'' + then src3 C.$= CZ.ungzip + else src3 + return $ addCleanup cleanup src4 return $ Response s version hs' body @@ -166,13 +171,16 @@ => (Bool -> m ()) -> C.Source m a -> C.Source m a -addCleanup cleanup C.Closed = C.SourceM - (cleanup True >> return C.Closed) +addCleanup cleanup (C.Done leftover ()) = C.PipeM + (cleanup True >> return (C.Done leftover ())) (cleanup True) -addCleanup cleanup (C.Open src close x) = C.Open +addCleanup cleanup (C.HaveOutput src close x) = C.HaveOutput (addCleanup cleanup src) (cleanup False >> close) x -addCleanup cleanup (C.SourceM msrc close) = C.SourceM +addCleanup cleanup (C.PipeM msrc close) = C.PipeM (liftM (addCleanup cleanup) msrc) (cleanup False >> close) +addCleanup cleanup (C.NeedInput p c) = C.NeedInput + (addCleanup cleanup . p) + (addCleanup cleanup c) 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.3.0.1 +version: 1.4.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -20,13 +20,13 @@ library build-depends: base >= 4 && < 5 , bytestring >= 0.9.1.4 && < 0.10 - , transformers >= 0.2 && < 0.3 + , transformers >= 0.2 && < 0.4 , failure >= 0.1 , resourcet >= 0.3 && < 0.4 - , conduit >= 0.3 && < 0.4 - , zlib-conduit >= 0.3 && < 0.4 - , blaze-builder-conduit >= 0.3 && < 0.4 - , attoparsec-conduit >= 0.3 && < 0.4 + , conduit >= 0.4 && < 0.5 + , zlib-conduit >= 0.4 && < 0.5 + , blaze-builder-conduit >= 0.4 && < 0.5 + , attoparsec-conduit >= 0.4 && < 0.5 , attoparsec >= 0.8.0.2 && < 0.11 , utf8-string >= 0.3.4 && < 0.4 , blaze-builder >= 0.2.1 && < 0.4 @@ -40,13 +40,14 @@ , case-insensitive >= 0.2 , base64-bytestring >= 0.1 && < 0.2 , asn1-data >= 0.5.1 && < 0.7 - , data-default >= 0.3 && < 0.4 + , data-default >= 0.3 && < 0.5 , text , transformers-base >= 0.4 && < 0.5 , lifted-base >= 0.1 && < 0.2 , socks >= 0.4 && < 0.5 , time , cookie >= 0.4 && < 0.5 + , void >= 0.5.5 && < 0.6 , regex-compat , mtl if flag(network-bytestring) @@ -111,6 +112,7 @@ , regex-compat , network-conduit , resourcet + , void source-repository head type: git diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -17,11 +17,10 @@ import Control.Monad.Trans.Resource (register) import Control.Monad.IO.Class (liftIO) import Data.ByteString.UTF8 (fromString) -import Data.Conduit.List (sourceList, sinkNull) +import Data.Conduit.List (sourceList) import Data.CaseInsensitive (mk) import Data.List (partition) import qualified Data.Conduit.List as CL -import qualified Data.Conduit.Binary as CB app :: Application app req = @@ -38,12 +37,12 @@ describe "simpleHttp" $ do it "gets homepage" $ do tid <- forkIO $ run 3000 app - lbs <- simpleHttp "http://localhost:3000/" + lbs <- simpleHttp "http://127.0.0.1:3000/" killThread tid lbs @?= "homepage" it "throws exception on 404" $ do tid <- forkIO $ run 3001 app - elbs <- try $ simpleHttp "http://localhost:3001/404" + elbs <- try $ simpleHttp "http://127.0.0.1:3001/404" killThread tid case elbs of Left (_ :: SomeException) -> return () @@ -51,7 +50,7 @@ describe "httpLbs" $ do it "preserves 'set-cookie' headers" $ do tid <- forkIO $ run 3010 app - request <- parseUrl "http://localhost:3010/cookies" + request <- parseUrl "http://127.0.0.1:3010/cookies" withManager $ \manager -> do Response _ _ headers _ <- httpLbs request manager let setCookie = mk (fromString "Set-Cookie") @@ -65,8 +64,8 @@ tid2 <- forkIO $ run 3003 app threadDelay 1000 withManager $ \manager -> do - let Just req1 = parseUrl "http://localhost:3002/" - let Just req2 = parseUrl "http://localhost:3003/" + let Just req1 = parseUrl "http://127.0.0.1:3002/" + let Just req2 = parseUrl "http://127.0.0.1:3003/" _res1a <- http req1 manager _res1b <- http req1 manager _res2 <- http req2 manager @@ -80,7 +79,7 @@ threadDelay 1000 withManager $ \manager -> do _ <- register $ killThread tid1 - let Just req1 = parseUrl "http://localhost:3004/" + let Just req1 = parseUrl "http://127.0.0.1:3004/" res1 <- try $ http req1 manager case res1 of Left e -> liftIO $ show (e :: SomeException) @?= show OverlongHeaders @@ -90,7 +89,7 @@ threadDelay 1000 withManager $ \manager -> do _ <- register $ killThread tid1 - let Just req1 = parseUrl "http://localhost:3005/" + let Just req1 = parseUrl "http://127.0.0.1:3005/" _ <- httpLbs req1 manager return ()