diff --git a/Network/HTTP/Conduit.hs b/Network/HTTP/Conduit.hs --- a/Network/HTTP/Conduit.hs +++ b/Network/HTTP/Conduit.hs @@ -180,7 +180,7 @@ :: (MonadResource m, MonadBaseControl IO m) => Request m -> Manager - -> m (Response (C.Source m S.ByteString)) + -> m (Response (C.ResumableSource m S.ByteString)) http req0 manager = do res@(Response status _version hs body) <- if redirectCount req0 == 0 @@ -189,7 +189,8 @@ case checkStatus req0 status hs of Nothing -> return res Just exc -> do - CI.runFinalize $ CI.pipeClose body + let CI.ResumableSource _ final = body + final liftIO $ throwIO exc where go 0 _ _ = liftIO $ throwIO TooManyRedirects @@ -207,7 +208,7 @@ :: (MonadBaseControl IO m, MonadResource m) => Request m -> Manager - -> m (Response (C.Source m S.ByteString)) + -> m (Response (C.ResumableSource m S.ByteString)) httpRaw req m = do (connRelease, ci, isManaged) <- getConn req m let src = connSource ci diff --git a/Network/HTTP/Conduit/Browser.hs b/Network/HTTP/Conduit/Browser.hs --- a/Network/HTTP/Conduit/Browser.hs +++ b/Network/HTTP/Conduit/Browser.hs @@ -76,7 +76,7 @@ browse m act = evalStateT act (defaultState m) -- | Make a request, using all the state in the current BrowserState -makeRequest :: Request (ResourceT IO) -> BrowserAction (Response (Source (ResourceT IO) BS.ByteString)) +makeRequest :: Request (ResourceT IO) -> BrowserAction (Response (ResumableSource (ResourceT IO) BS.ByteString)) makeRequest request = do BrowserState { maxRetryCount = max_retry_count 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 @@ -4,7 +4,6 @@ , chunkIt ) where -import Control.Exception (assert) import Numeric (showHex) import qualified Data.ByteString as S @@ -15,67 +14,35 @@ import qualified Data.Attoparsec.ByteString as A -import qualified Data.Conduit as C -import Data.Conduit.Attoparsec (ParseError (ParseError)) +import Data.Conduit hiding (Source, Sink, Conduit) +import qualified Data.Conduit.Binary as CB +import Data.Conduit.Attoparsec (ParseError (ParseError), Position (..)) import Network.HTTP.Conduit.Parser - - -data CState = NeedHeader (S.ByteString -> A.Result Int) - | Isolate Int - | NeedNewline (S.ByteString -> A.Result ()) - | Complete +import Control.Monad (when, unless) +import Control.Monad.Trans.Class (lift) -chunkedConduit :: C.MonadThrow m +chunkedConduit :: MonadThrow m => Bool -- ^ send the headers as well, necessary for a proxy - -> C.Conduit S.ByteString m S.ByteString -chunkedConduit sendHeaders = C.conduitState - (NeedHeader $ A.parse parseChunkHeader) - (push id) - close + -> Pipe S.ByteString S.ByteString S.ByteString u m () +chunkedConduit sendHeaders = + await >>= maybe (return ()) (needHeader $ A.parse parseChunkHeader) where - push front (NeedHeader f) x = + needHeader f x = case f x of A.Done x' i - | i == 0 -> push front Complete x' + | i == 0 -> unless (S.null x') (leftover x') >> complete | otherwise -> do let header = S8.pack $ showHex i "\r\n" - let addHeader = if sendHeaders then (header:) else id - push (front . addHeader) (Isolate i) x' - A.Partial f' -> return $ C.StateProducing (NeedHeader f') $ front [] - A.Fail _ contexts msg -> C.monadThrow $ ParseError contexts msg - push front (Isolate i) x = do - let (a, b) = S.splitAt i x - i' = i - S.length a - if i' == 0 - then push - (front . (a:)) - (NeedNewline $ A.parse newline) - b - else assert (S.null b) $ return $ C.StateProducing - (Isolate i') - (front [a]) - push front (NeedNewline f) x = - case f x of - A.Done x' () -> do - let header = S8.pack "\r\n" - let addHeader = if sendHeaders then (header:) else id - push - (front . addHeader) - (NeedHeader $ A.parse parseChunkHeader) - x' - A.Partial f' -> return $ C.StateProducing (NeedNewline f') $ front [] - A.Fail _ contexts msg -> C.monadThrow $ ParseError contexts msg - push front Complete leftover = do - let end = if sendHeaders then [S8.pack "0\r\n"] else [] - lo = if S.null leftover then Nothing else Just leftover - return $ C.StateFinished lo $ front end - close _ = return [] + when sendHeaders $ yield header + unless (S.null x') $ leftover x' + CB.isolate i + A.Partial f' -> await >>= maybe (return ()) (needHeader f') + A.Fail _ contexts msg -> lift $ monadThrow $ ParseError contexts msg $ Position 0 0 + complete = when sendHeaders $ yield $ S8.pack "0\r\n" -chunkIt :: Monad m => C.Conduit Blaze.Builder m Blaze.Builder +chunkIt :: Monad m => Pipe l Blaze.Builder Blaze.Builder r m r chunkIt = - conduit - where - conduit = C.NeedInput push close - push xs = C.HaveOutput conduit (return ()) (chunkedTransferEncoding xs) - close = C.HaveOutput (return ()) (return ()) chunkedTransferTerminator + awaitE >>= either + (\u -> yield chunkedTransferTerminator >> return u) + (\x -> yield (chunkedTransferEncoding x) >> chunkIt) 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 @@ -41,7 +41,7 @@ import Crypto.Random.AESCtr (makeSystem) -import qualified Data.Conduit as C +import Data.Conduit hiding (Source, Sink, Conduit) #if DEBUG import qualified Data.IntMap as IntMap @@ -55,26 +55,21 @@ , connClose :: IO () } -connSink :: C.MonadResource m => ConnInfo -> C.Sink ByteString m () +connSink :: MonadResource m => ConnInfo -> Pipe l ByteString o r m r connSink ConnInfo { connWrite = write } = - C.NeedInput push close + self where - push bss = C.PipeM - (liftIO (write bss) >> return (C.NeedInput push close)) - (return ()) - close = return () + self = awaitE >>= either return (\x -> liftIO (write x) >> self) -connSource :: C.MonadResource m => ConnInfo -> C.Source m ByteString +connSource :: MonadResource m => ConnInfo -> Pipe l i ByteString u m () connSource ConnInfo { connRead = read' } = - src + self where - src = C.PipeM pull close - pull = do + self = do bs <- liftIO read' if S.null bs - then return (return ()) - else return $ C.HaveOutput src close bs - close = return () + then return () + else yield bs >> self #if DEBUG allOpenSockets :: I.IORef (Int, IntMap.IntMap String) 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 @@ -11,7 +11,6 @@ import Control.Arrow (first) import Data.Typeable (Typeable) -import Data.Monoid (mempty) import Control.Monad (liftM) import Control.Exception (throwIO) @@ -22,13 +21,11 @@ import qualified Data.CaseInsensitive as CI -import Control.Monad.Trans.Resource (MonadResource) -import Control.Monad.Trans.Class (lift) -import qualified Data.Conduit as C +import Data.Conduit hiding (Sink, Conduit) +import Data.Conduit.Internal (ResumableSource (..), Pipe (..)) import qualified Data.Conduit.Zlib as CZ import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL -import qualified Data.Conduit.Internal import qualified Network.HTTP.Types as W import Network.URI (parseURIReference) @@ -39,7 +36,7 @@ import Network.HTTP.Conduit.Parser import Network.HTTP.Conduit.Chunk -import Data.Void (absurd) +import Data.Void (Void, absurd) -- | A simple representation of the HTTP response created by 'lbsConsumer'. data Response body = Response @@ -64,7 +61,7 @@ -- specific request, that user has to re-implement the redirect-following logic -- themselves. An example of that might look like this: -- --- > myHttp req man = E.catch (C.runResourceT $ http req' man >> return [req']) +-- > myHttp req man = E.catch (runResourceT $ http req' man >> return [req']) -- > (\ (StatusCodeException status headers) -> do -- > l <- myHttp (fromJust $ nextRequest status headers) man -- > return $ req' : l) @@ -87,41 +84,41 @@ else req' | otherwise = Nothing --- | Convert a 'Response' that has a 'C.Source' body to one with a lazy +-- | Convert a 'Response' that has a 'Source' body to one with a lazy -- 'L.ByteString' body. lbsResponse :: Monad m - => m (Response (C.Source m S8.ByteString)) + => m (Response (ResumableSource m S8.ByteString)) -> m (Response L.ByteString) lbsResponse mres = do res <- mres - bss <- responseBody res C.$$ CL.consume + bss <- responseBody res $$+- CL.consume return res { responseBody = L.fromChunks bss } +-- | This function can\'t be a Conduit, since it would lose leftovers. checkHeaderLength :: MonadResource m => Int - -> C.Sink S8.ByteString m a - -> C.Sink S8.ByteString m a -checkHeaderLength len C.NeedInput{} - | len <= 0 = - let x = liftIO $ throwIO OverlongHeaders - in C.PipeM x (lift x) -checkHeaderLength len (C.NeedInput pushI closeI) = C.NeedInput + -> Pipe S8.ByteString S8.ByteString Void u m r + -> Pipe S8.ByteString S8.ByteString Void u m r +checkHeaderLength len NeedInput{} + | len <= 0 = liftIO $ throwIO OverlongHeaders +checkHeaderLength len (NeedInput pushI closeI) = NeedInput (\bs -> checkHeaderLength (len - S8.length bs) (pushI bs)) closeI -checkHeaderLength len (C.PipeM msink close) = C.PipeM (liftM (checkHeaderLength len) msink) close -checkHeaderLength _ s@C.Done{} = s -checkHeaderLength _ (C.HaveOutput _ _ o) = absurd o +checkHeaderLength len (PipeM msink) = PipeM (liftM (checkHeaderLength len) msink) +checkHeaderLength _ s@Done{} = s +checkHeaderLength _ (HaveOutput _ _ o) = absurd o +checkHeaderLength len (Leftover p i) = Leftover (checkHeaderLength len p) i getResponse :: MonadResource m => ConnRelease m -> Request m - -> C.Source m S8.ByteString - -> m (Response (C.Source m S8.ByteString)) + -> Source m S8.ByteString + -> m (Response (ResumableSource m S8.ByteString)) getResponse connRelease req@(Request {..}) src1 = do - (src2, ((vbs, sc, sm), hs)) <- src1 C.$$+ checkHeaderLength 4096 sinkHeaders + (src2, ((vbs, sc, sm), hs)) <- src1 $$+ 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 @@ -136,19 +133,23 @@ if hasNoBody method sc || mcl == Just 0 then do cleanup True - return mempty + (rsrc, ()) <- return () $$+ return () + return rsrc else do let src3 = if ("transfer-encoding", "chunked") `elem` hs' - then src2 C.$= chunkedConduit rawBody + then fmapResume ($= chunkedConduit rawBody) src2 else case mcl of - Just len -> src2 C.$= CB.isolate len + Just len -> fmapResume ($= CB.isolate len) src2 Nothing -> src2 let src4 = if needsGunzip req hs' - then src3 C.$= CZ.ungzip + then fmapResume ($= CZ.ungzip) src3 else src3 - return $ Data.Conduit.Internal.addCleanup cleanup src4 + return $ addCleanup' cleanup src4 return $ Response s version hs' body + where + fmapResume f (ResumableSource src m) = ResumableSource (f src) m + addCleanup' f (ResumableSource src m) = ResumableSource (addCleanup f src) (m >> f 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.4.1.10 +version: 1.5.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -23,10 +23,10 @@ , transformers >= 0.2 && < 0.4 , failure >= 0.1 , resourcet >= 0.3 && < 0.4 - , conduit >= 0.4.1 && < 0.5 - , zlib-conduit >= 0.4 && < 0.5 - , blaze-builder-conduit >= 0.4 && < 0.5 - , attoparsec-conduit >= 0.4 && < 0.5 + , conduit >= 0.5 && < 0.6 + , zlib-conduit >= 0.5 && < 0.6 + , blaze-builder-conduit >= 0.5 && < 0.6 + , attoparsec-conduit >= 0.5 && < 0.6 , attoparsec >= 0.8.0.2 && < 0.11 , utf8-string >= 0.3.4 && < 0.4 , blaze-builder >= 0.2.1 && < 0.4 @@ -40,7 +40,7 @@ , case-insensitive >= 0.2 , base64-bytestring >= 0.1 && < 0.2 , asn1-data >= 0.5.1 && < 0.7 - , data-default >= 0.3 && < 0.5 + , data-default , text , transformers-base >= 0.4 && < 0.5 , lifted-base >= 0.1 && < 0.2