diff --git a/Network/HTTP/Conduit.hs b/Network/HTTP/Conduit.hs --- a/Network/HTTP/Conduit.hs +++ b/Network/HTTP/Conduit.hs @@ -30,6 +30,7 @@ -- be added to 'requestHeaders': -- -- * Content-Length +-- * Transfer-Encoding -- -- Note: In previous versions, the Host header would be set by this module in -- all cases. Starting from 1.6.1, if a Host header is present in @@ -95,6 +96,7 @@ , redirectCount , checkStatus , responseTimeout + , getConnectionWrapper -- * Manager , Manager , newManager @@ -147,7 +149,7 @@ import qualified Network.HTTP.Types as W import Data.Default (def) -import Control.Exception.Lifted (throwIO) +import Control.Exception.Lifted (throwIO, handle) import Control.Monad ((<=<)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Resource @@ -187,6 +189,33 @@ -- You may also directly connect the returned 'C.Source' -- into a 'C.Sink', perhaps a file or another socket. -- +-- An important note: the response body returned by this function represents a +-- live HTTP connection. As such, if you do not use the response body, an open +-- socket will be retained until the containing @ResourceT@ block exits. If you +-- do not need the response body, it is recommended that you explicitly shut +-- down the connection immediately, using the pattern: +-- +-- > responseBody res $$+- return () +-- +-- As a more thorough example, consider the following program. Without the +-- explicit response body closing, the program will run out of file descriptors +-- around the 1000th request (depending on the operating system limits). +-- +-- > import Control.Monad (replicateM_) +-- > import Control.Monad.IO.Class (liftIO) +-- > import Data.Conduit (($$+-)) +-- > import Network (withSocketsDo) +-- > import Network.HTTP.Conduit +-- > +-- > main = withSocketsDo $ withManager $ \manager -> do +-- > req <- parseUrl "http://localhost/" +-- > mapM_ (worker manager req) [1..5000] +-- > +-- > worker manager req i = do +-- > res <- http req manager +-- > responseBody res $$+- return () -- The important line +-- > liftIO $ print (i, responseStatus res) +-- -- Note: Unlike previous versions, this function will perform redirects, as -- specified by the 'redirectCount' setting. http @@ -194,7 +223,7 @@ => Request m -> Manager -> m (Response (C.ResumableSource m S.ByteString)) -http req0 manager = do +http req0 manager = wrapIOException $ do res@(Response status _version hs body) <- if redirectCount req0 == 0 then httpRaw req0 manager @@ -236,7 +265,7 @@ -> Manager -> m (Response (C.ResumableSource m S.ByteString)) httpRaw req m = do - (connRelease, ci, isManaged) <- getConnectionWrapper + (timeout', (connRelease, ci, isManaged)) <- getConnectionWrapper req (responseTimeout req) (failedConnectionException req) @@ -249,7 +278,7 @@ -- exceptions in both. ex <- try' $ do requestBuilder req C.$$ builderToByteString C.=$ connSink ci - getResponse connRelease req src + getResponse connRelease timeout' req src case (ex, isManaged) of -- Connection was reused, and might be been closed. Try again @@ -283,7 +312,10 @@ -- Note: Unlike previous versions, this function will perform redirects, as -- specified by the 'redirectCount' setting. httpLbs :: (MonadBaseControl IO m, MonadResource m) => Request m -> Manager -> m (Response L.ByteString) -httpLbs r = lbsResponse <=< http r +httpLbs r = wrapIOException . (lbsResponse <=< http r) + +wrapIOException :: MonadBaseControl IO m => m a -> m a +wrapIOException = handle $ throwIO . InternalIOException -- | Download the specified URL, following any redirects, and -- return the response body. 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 @@ -12,7 +12,7 @@ import Blaze.ByteString.Builder.HTTP import qualified Blaze.ByteString.Builder as Blaze -import Data.Conduit hiding (Source, Sink, Conduit) +import Data.Conduit import qualified Data.Conduit.Binary as CB import Control.Monad (when, unless) @@ -20,7 +20,7 @@ chunkedConduit :: MonadThrow m => Bool -- ^ send the headers as well, necessary for a proxy - -> Pipe S.ByteString S.ByteString S.ByteString u m () + -> Conduit S.ByteString m S.ByteString chunkedConduit sendHeaders = do i <- getLen when sendHeaders $ yield $ S8.pack $ showHex i "\r\n" @@ -28,37 +28,36 @@ CB.isolate i CB.drop 2 chunkedConduit sendHeaders - -getLen :: Monad m => Pipe S.ByteString S.ByteString o u m Int -getLen = - start 0 where - start i = await >>= maybe (return i) (go i) + getLen = + start 0 + where + start i = await >>= maybe (return i) (go i) - go i bs = - case S.uncons bs of - Nothing -> start i - Just (w, bs') -> - case toI w of - Just i' -> go (i * 16 + i') bs' - Nothing -> do - stripNewLine bs - return i + go i bs = + case S.uncons bs of + Nothing -> start i + Just (w, bs') -> + case toI w of + Just i' -> go (i * 16 + i') bs' + Nothing -> do + stripNewLine bs + return i - stripNewLine bs = - case S.uncons $ S.dropWhile (/= 10) bs of - Just (10, bs') -> leftover bs' - Just _ -> assert False $ await >>= maybe (return ()) stripNewLine - Nothing -> await >>= maybe (return ()) stripNewLine + stripNewLine bs = + case S.uncons $ S.dropWhile (/= 10) bs of + Just (10, bs') -> leftover bs' + Just _ -> assert False $ await >>= maybe (return ()) stripNewLine + Nothing -> await >>= maybe (return ()) stripNewLine - toI w - | 48 <= w && w <= 57 = Just $ fromIntegral w - 48 - | 65 <= w && w <= 70 = Just $ fromIntegral w - 55 - | 97 <= w && w <= 102 = Just $ fromIntegral w - 87 - | otherwise = Nothing + toI w + | 48 <= w && w <= 57 = Just $ fromIntegral w - 48 + | 65 <= w && w <= 70 = Just $ fromIntegral w - 55 + | 97 <= w && w <= 102 = Just $ fromIntegral w - 87 + | otherwise = Nothing -chunkIt :: Monad m => Pipe l Blaze.Builder Blaze.Builder r m r +chunkIt :: Monad m => Conduit Blaze.Builder m Blaze.Builder chunkIt = - awaitE >>= either - (\u -> yield chunkedTransferTerminator >> return u) + await >>= maybe + (yield chunkedTransferTerminator) (\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 @@ -42,7 +42,7 @@ import Crypto.Random.AESCtr (makeSystem) -import Data.Conduit hiding (Source, Sink, Conduit) +import Data.Conduit #if DEBUG import qualified Data.IntMap as IntMap @@ -56,13 +56,13 @@ , connClose :: IO () } -connSink :: MonadResource m => ConnInfo -> Pipe l ByteString o r m r +connSink :: MonadResource m => ConnInfo -> Sink ByteString m () connSink ConnInfo { connWrite = write } = self where - self = awaitE >>= either return (\x -> liftIO (write x) >> self) + self = await >>= maybe (return ()) (\x -> liftIO (write x) >> self) -connSource :: MonadResource m => ConnInfo -> Pipe l i ByteString u m () +connSource :: MonadResource m => ConnInfo -> Source m ByteString connSource ConnInfo { connRead = read' } = self where 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 @@ -41,6 +41,7 @@ import qualified Network.HTTP.Types as W import Network.URI (URI (..), URIAuth (..), parseURI, relativeTo, escapeURIString, isAllowedInURI) +import Control.Monad.IO.Class (liftIO) import Control.Exception.Lifted (Exception, toException, throwIO) import Control.Failure (Failure (failure)) import Codec.Binary.UTF8.String (encodeString) @@ -52,6 +53,7 @@ import Network.HTTP.Conduit.Chunk (chunkIt) import Network.HTTP.Conduit.Util (readDec, (<>)) import System.Timeout.Lifted (timeout) +import Data.Time.Clock -- | Convert a URL into a 'Request'. -- @@ -116,6 +118,7 @@ , queryString = S8.pack $ uriQuery uri } where + failUri :: Failure HttpException m => String -> m a failUri = failure . InvalidUrlException (show uri) parseScheme URI{uriScheme = scheme} = @@ -136,6 +139,25 @@ False {- HTTP -} -> return 80 True {- HTTPS -} -> return 443 +instance Show (Request m) where + show x = unlines + [ "Request {" + , " host = " ++ show (host x) + , " port = " ++ show (port x) + , " secure = " ++ show (secure x) + , " clientCertificates = " ++ show (clientCertificates x) + , " requestHeaders = " ++ show (requestHeaders x) + , " path = " ++ show (path x) + , " queryString = " ++ show (queryString x) + , " requestBody = " ++ show (requestBody x) + , " method = " ++ show (method x) + , " proxy = " ++ show (proxy x) + , " rawBody = " ++ show (rawBody x) + , " redirectCount = " ++ show (redirectCount x) + , " responseTimeout = " ++ show (responseTimeout x) + , "}" + ] + instance Default (Request m) where def = Request { host = "localhost" @@ -159,12 +181,19 @@ , responseTimeout = Just 5000000 , getConnectionWrapper = \mtimeout exc f -> case mtimeout of - Nothing -> f + Nothing -> fmap ((,) Nothing) f Just timeout' -> do - mres <- timeout (timeout' `div` 2) f + before <- liftIO getCurrentTime + mres <- timeout timeout' f case mres of Nothing -> throwIO exc - Just res -> return res + Just res -> do + now <- liftIO getCurrentTime + let timeSpentMicro = diffUTCTime now before * 1000000 + remainingTime = round $ fromIntegral timeout' - timeSpentMicro + if remainingTime <= 0 + then throwIO exc + else return (Just remainingTime, res) } -- | Always decompress a compressed stream. 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 @@ -1,6 +1,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} module Network.HTTP.Conduit.Response ( Response (..) , getRedirectedRequest @@ -40,6 +41,9 @@ import Data.Void (Void, absurd) import System.Timeout.Lifted (timeout) +#if MIN_VERSION_conduit(1, 0, 0) +import Data.Conduit.Internal (ConduitM (..)) +#endif -- | If a request is a redirection (status code 3xx) this function will create -- a new request from the old request, the server headers returned with the @@ -103,19 +107,25 @@ getResponse :: (MonadResource m, MonadBaseControl IO m) => ConnRelease m + -> Maybe Int -> Request m -> Source m S8.ByteString -> m (Response (ResumableSource m S8.ByteString)) -getResponse connRelease req@(Request {..}) src1 = do +getResponse connRelease timeout'' req@(Request {..}) src1 = do let timeout' = - case responseTimeout of + case timeout'' of Nothing -> id Just useconds -> \ma -> do x <- timeout useconds ma case x of Nothing -> liftIO $ throwIO ResponseTimeout Just y -> return y - (src2, ((vbs, sc, sm), hs)) <- timeout' $ src1 $$+ checkHeaderLength 4096 sinkHeaders' + (src2, ((vbs, sc, sm), hs)) <- timeout' $ src1 $$+ +#if MIN_VERSION_conduit(1, 0, 0) + ConduitM (checkHeaderLength 4096 $ unConduitM sinkHeaders') +#else + (checkHeaderLength 4096 sinkHeaders') +#endif 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 diff --git a/Network/HTTP/Conduit/Types.hs b/Network/HTTP/Conduit/Types.hs --- a/Network/HTTP/Conduit/Types.hs +++ b/Network/HTTP/Conduit/Types.hs @@ -26,7 +26,7 @@ import qualified Network.HTTP.Types as W import Network.Socks5 (SocksConf) -import Control.Exception (Exception, SomeException) +import Control.Exception (Exception, SomeException, IOException) import Data.Certificate.X509 (X509) import Network.TLS (PrivateKey) @@ -115,16 +115,16 @@ => Maybe Int -> HttpException -> n (ConnRelease n, ConnInfo, ManagedConn) - -> n (ConnRelease n, ConnInfo, ManagedConn) + -> n (Maybe Int, (ConnRelease n, ConnInfo, ManagedConn)) -- ^ Wraps the calls for getting new connections. This can be useful for -- instituting some kind of timeouts. The first argument is the value of -- @responseTimeout@. Second argument is the exception to be thrown on -- failure. -- -- Default: If @responseTimeout@ is @Nothing@, does nothing. Otherwise, - -- institutes a timeout half of the length of @responseTimeout@. + -- institutes timeout, and returns remaining time for @responseTimeout@. -- - -- Since 1.8.6 + -- Exported since 1.8.8 } data ConnReuse = Reuse | DontReuse @@ -156,7 +156,7 @@ { proxyHost :: S.ByteString -- ^ The host name of the HTTP proxy. , proxyPort :: Int -- ^ The port number of the HTTP proxy. } - deriving (Show, Read, Eq, Typeable) + deriving (Show, Read, Eq, Ord, Typeable) data HttpException = StatusCodeException W.Status W.ResponseHeaders | InvalidUrlException String String @@ -171,6 +171,7 @@ | ExpectedBlankAfter100Continue | InvalidStatusLine S.ByteString | InvalidHeader S.ByteString + | InternalIOException IOException deriving (Show, Typeable) instance Exception HttpException 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.8.7.1 +version: 1.8.8 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -28,8 +28,8 @@ , transformers >= 0.2 , failure >= 0.1 , resourcet >= 0.3 && < 0.5 - , conduit >= 0.5.5 && < 0.6 - , zlib-conduit >= 0.5 && < 0.6 + , conduit >= 0.5.5 && < 1.1 + , zlib-conduit >= 0.5 && < 1.1 , blaze-builder-conduit >= 0.5 , attoparsec-conduit >= 0.5 , attoparsec >= 0.8.0.2