diff --git a/Network/HTTP/Conduit.hs b/Network/HTTP/Conduit.hs --- a/Network/HTTP/Conduit.hs +++ b/Network/HTTP/Conduit.hs @@ -138,6 +138,7 @@ import Data.Default (def) import Control.Exception.Lifted (throwIO) +import Control.Monad ((<=<)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Control (MonadBaseControl) @@ -183,7 +184,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 @@ -191,14 +192,14 @@ final liftIO $ throwIO exc where - go 0 _ _ = liftIO $ throwIO TooManyRedirects - go count req'' cookie_jar'' = do + go (-1) _ _ ress = liftIO . throwIO . TooManyRedirects =<< mapM lbsResponse ress + go count req'' cookie_jar'' ress = do now <- liftIO getCurrentTime let (req', cookie_jar') = insertCookiesIntoRequest req'' (evictExpiredCookies cookie_jar'' now) now res <- httpRaw req' manager let (cookie_jar, _) = updateCookieJar res req' now cookie_jar' case getRedirectedRequest req' (responseHeaders res) (W.statusCode (responseStatus res)) of - Just req -> go (count - 1) req cookie_jar + Just req -> go (count - 1) req cookie_jar (res:ress) Nothing -> return res -- | Get a 'Response' without any redirect following. @@ -240,7 +241,7 @@ -- interleaved actions on the response body during download, you'll need to use -- 'http' directly. This function is defined as: -- --- @httpLbs = 'lbsResponse' . 'http'@ +-- @httpLbs = 'lbsResponse' <=< 'http'@ -- -- Even though the 'Response' contains a lazy bytestring, this -- function does /not/ utilize lazy I/O, and therefore the entire @@ -251,7 +252,7 @@ -- 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 = lbsResponse <=< http r -- | Download the specified URL, following any redirects, and -- return the response body. 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 @@ -3,6 +3,7 @@ , BrowserAction , browse , makeRequest + , makeRequestLbs , defaultState , getBrowserState , setBrowserState @@ -27,6 +28,7 @@ where import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as L import Control.Monad.State import Control.Exception import qualified Control.Exception.Lifted as LE @@ -91,18 +93,18 @@ where retryHelper request' retry_count e | retry_count == 0 = case e of Just e' -> throw e' - Nothing -> throw TooManyRedirects + Nothing -> throw TooManyRetries | otherwise = do BrowserState {maxRedirects = max_redirects} <- get - resp <- LE.catch (runRedirectionChain request' max_redirects) + resp <- LE.catch (if max_redirects==0 + then (\(_,a,_) -> a) `fmap` performRequest request' + else runRedirectionChain request' max_redirects []) (\ e' -> retryHelper request' (retry_count - 1) (Just (e' :: HttpException))) let code = HT.statusCode $ HC.responseStatus resp if code < 200 || code >= 300 then retryHelper request' (retry_count - 1) (Just $ HC.StatusCodeException (HC.responseStatus resp) (HC.responseHeaders resp)) else return resp - runRedirectionChain request' redirect_count - | redirect_count == 0 = throw TooManyRedirects - | otherwise = do + performRequest request' = do s@(BrowserState { manager = manager' , authorities = auths , cookieJar = cookie_jar @@ -115,11 +117,17 @@ res <- lift $ HC.http request'' manager' (cookie_jar'', response) <- liftIO $ updateCookieJar res request'' now cookie_jar' cookie_filter put $ s {cookieJar = cookie_jar''} + return (request'', res, response) + runRedirectionChain request' redirect_count ress + | redirect_count == (-1) = throw . TooManyRedirects =<< mapM (liftIO . runResourceT . lbsResponse) ress + | otherwise = do + (request'', res, response) <- performRequest request' let code = HT.statusCode (HC.responseStatus 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) + then do request''' <- case HC.getRedirectedRequest request'' (responseHeaders response) code of + Just a -> return a + Nothing -> throw . HC.UnparseableRedirect =<< (liftIO $ runResourceT $ lbsResponse response) + runRedirectionChain request''' (redirect_count - 1) (res:ress) else return res applyAuthorities auths request' = case auths request' of Just (user, pass) -> applyBasicAuth user pass request' @@ -127,6 +135,9 @@ applyUserAgent ua request' = request' {requestHeaders = (k, ua) : hs} where hs = filter ((/= k) . fst) $ requestHeaders request' k = mk $ fromString "User-Agent" + +makeRequestLbs :: Request (ResourceT IO) -> BrowserAction (Response L.ByteString) +makeRequestLbs = liftIO . runResourceT . lbsResponse <=< makeRequest updateCookieJar :: Response a -> Request (ResourceT IO) -> UTCTime -> CookieJar -> (Request (ResourceT IO) -> Cookie -> IO Bool) -> IO (CookieJar, Response a) updateCookieJar response request' now cookie_jar cookie_filter = do 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module Network.HTTP.Conduit.Request @@ -18,16 +17,13 @@ , requestBuilder ) where -import Data.Int (Int64) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isJust) import Data.Monoid (mempty, mappend) -import Data.Typeable (Typeable) import Data.Default (Default (def)) import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString) import Blaze.ByteString.Builder.Char8 (fromChar) -import qualified Blaze.ByteString.Builder as Blaze import qualified Data.Conduit as C import qualified Data.Conduit.List as CL @@ -37,115 +33,20 @@ import qualified Data.ByteString.Lazy as L import qualified Network.HTTP.Types as W -import Network.Socks5 (SocksConf) import Network.URI (URI (..), URIAuth (..), parseURI, relativeTo, escapeURIString, isAllowedInURI) -import Control.Exception (Exception, SomeException, toException) +import Control.Exception (Exception, toException) import Control.Failure (Failure (failure)) import Codec.Binary.UTF8.String (encodeString) import qualified Data.CaseInsensitive as CI import qualified Data.ByteString.Base64 as B64 +import Network.HTTP.Conduit.Types (Request (..), RequestBody (..), ContentType, Proxy (..), HttpException (..)) + import Network.HTTP.Conduit.Chunk (chunkIt) import Network.HTTP.Conduit.Util (readDec, (<>)) -type ContentType = S.ByteString --- | All information on how to connect to a host and what should be sent in the --- HTTP request. --- --- If you simply wish to download from a URL, see 'parseUrl'. --- --- The constructor for this data type is not exposed. Instead, you should use --- either the 'def' method to retrieve a default instance, or 'parseUrl' to --- construct from a URL, and then use the records below to make modifications. --- This approach allows http-conduit to add configuration options without --- breaking backwards compatibility. --- --- For example, to construct a POST request, you could do something like: --- --- > initReq <- parseUrl "http://www.example.com/path" --- > let req = initReq --- > { method = "POST" --- > } --- --- For more information, please see --- . -data Request m = Request - { method :: W.Method - -- ^ HTTP request method, eg GET, POST. - , secure :: Bool - -- ^ Whether to use HTTPS (ie, SSL). - , host :: S.ByteString - , port :: Int - , path :: S.ByteString - -- ^ Everything from the host to the query string. - , queryString :: S.ByteString - , requestHeaders :: W.RequestHeaders - -- ^ Custom HTTP request headers - -- - -- As already stated in the introduction, the Content-Length and Host - -- headers are set automatically by this module, and shall not be added to - -- requestHeaders. - -- - -- Moreover, the Accept-Encoding header is set implicitly to gzip for - -- convenience by default. This behaviour can be overridden if needed, by - -- setting the header explicitly to a different value. In order to omit the - -- Accept-Header altogether, set it to the empty string \"\". If you need an - -- empty Accept-Header (i.e. requesting the identity encoding), set it to a - -- non-empty white-space string, e.g. \" \". See RFC 2616 section 14.3 for - -- details about the semantics of the Accept-Header field. If you request a - -- content-encoding not supported by this module, you will have to decode - -- it yourself (see also the 'decompress' field). - -- - -- Note: Multiple header fields with the same field-name will result in - -- multiple header fields being sent and therefore it\'s the responsibility - -- of the client code to ensure that the rules from RFC 2616 section 4.2 - -- are honoured. - , requestBody :: RequestBody m - , proxy :: Maybe Proxy - -- ^ Optional HTTP proxy. - , socksProxy :: Maybe SocksConf - -- ^ Optional SOCKS proxy. - , rawBody :: Bool - -- ^ If @True@, a chunked and\/or gzipped body will not be - -- decoded. Use with caution. - , decompress :: ContentType -> Bool - -- ^ Predicate to specify whether gzipped data should be - -- decompressed on the fly (see 'alwaysDecompress' and - -- 'browserDecompress'). Default: browserDecompress. - , redirectCount :: Int - -- ^ How many redirects to follow when getting a resource. 0 means follow - -- no redirects. Default value: 10. - , checkStatus :: W.Status -> W.ResponseHeaders -> Maybe SomeException - -- ^ Check the status code. Note that this will run after all redirects are - -- performed. Default: return a @StatusCodeException@ on non-2XX responses. - } - --- | When using one of the --- 'RequestBodySource' \/ 'RequestBodySourceChunked' constructors, --- you must ensure --- that the 'Source' can be called multiple times. Usually this --- is not a problem. --- --- The 'RequestBodySourceChunked' will send a chunked request --- body, note that not all servers support this. Only use --- 'RequestBodySourceChunked' if you know the server you're --- sending to supports chunked request bodies. -data RequestBody m - = RequestBodyLBS L.ByteString - | RequestBodyBS S.ByteString - | RequestBodyBuilder Int64 Blaze.Builder - | RequestBodySource Int64 (C.Source m Blaze.Builder) - | RequestBodySourceChunked (C.Source m Blaze.Builder) - --- | Define a HTTP proxy, consisting of a hostname and port number. - -data Proxy = Proxy - { proxyHost :: S.ByteString -- ^ The host name of the HTTP proxy. - , proxyPort :: Int -- ^ The port number of the HTTP proxy. - } - -- | Convert a URL into a 'Request'. -- -- This defaults some of the values in 'Request', such as setting 'method' to @@ -246,17 +147,6 @@ else Just $ toException $ StatusCodeException s hs } -data HttpException = StatusCodeException W.Status W.ResponseHeaders - | InvalidUrlException String String - | TooManyRedirects - | UnparseableRedirect - | TooManyRetries - | HttpParserException String - | HandshakeFailed - | OverlongHeaders - deriving (Show, Typeable) -instance Exception HttpException - -- | Always decompress a compressed stream. alwaysDecompress :: ContentType -> Bool alwaysDecompress = const True @@ -332,6 +222,14 @@ | port req == 443 && secure req = host req | otherwise = host req <> S8.pack (':' : show (port req)) + requestProtocol + | secure req = fromByteString "https://" + | otherwise = fromByteString "http://" + + requestHostname + | isJust (proxy req) = requestProtocol <> fromByteString hh + | otherwise = mempty + contentLengthHeader (Just contentLength') = if method req `elem` ["GET", "HEAD"] && contentLength' == 0 then id @@ -356,6 +254,7 @@ builder = fromByteString (method req) <> fromByteString " " + <> requestHostname <> (case S8.uncons $ path req of Just ('/', _) -> fromByteString $ path req _ -> fromChar '/' <> fromByteString (path req)) 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,5 +1,4 @@ {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module Network.HTTP.Conduit.Response @@ -10,7 +9,6 @@ ) where import Control.Arrow (first) -import Data.Typeable (Typeable) import Control.Monad (liftM) import Control.Exception (throwIO) @@ -30,6 +28,8 @@ import qualified Network.HTTP.Types as W import Network.URI (parseURIReference) +import Network.HTTP.Conduit.Types (Response (..)) + import Network.HTTP.Conduit.Manager import Network.HTTP.Conduit.Request import Network.HTTP.Conduit.Util @@ -38,19 +38,6 @@ import Data.Void (Void, absurd) --- | A simple representation of the HTTP response created by 'lbsConsumer'. -data Response body = Response - { responseStatus :: W.Status - , responseVersion :: W.HttpVersion - , responseHeaders :: W.ResponseHeaders - , responseBody :: body - } - deriving (Show, Eq, Typeable) - --- | Since 1.1.2. -instance Functor Response where - fmap f (Response status v headers body) = Response status v headers (f body) - -- | 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 -- redirection, and the redirection code itself. This function returns 'Nothing' @@ -87,10 +74,9 @@ -- | Convert a 'Response' that has a 'Source' body to one with a lazy -- 'L.ByteString' body. lbsResponse :: Monad m - => m (Response (ResumableSource m S8.ByteString)) + => Response (ResumableSource m S8.ByteString) -> m (Response L.ByteString) -lbsResponse mres = do - res <- mres +lbsResponse res = do bss <- responseBody res $$+- CL.consume return res { responseBody = L.fromChunks bss diff --git a/Network/HTTP/Conduit/Types.hs b/Network/HTTP/Conduit/Types.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Conduit/Types.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module Network.HTTP.Conduit.Types + ( Request (..) + , RequestBody (..) + , ContentType + , Proxy (..) + , HttpException (..) + , Response (..) + ) where + +import Data.Int (Int64) +import Data.Typeable (Typeable) + +import qualified Blaze.ByteString.Builder as Blaze + +import qualified Data.Conduit as C + +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + +import qualified Network.HTTP.Types as W +import Network.Socks5 (SocksConf) + +import Control.Exception (Exception, SomeException) + +type ContentType = S.ByteString + +-- | All information on how to connect to a host and what should be sent in the +-- HTTP request. +-- +-- If you simply wish to download from a URL, see 'parseUrl'. +-- +-- The constructor for this data type is not exposed. Instead, you should use +-- either the 'def' method to retrieve a default instance, or 'parseUrl' to +-- construct from a URL, and then use the records below to make modifications. +-- This approach allows http-conduit to add configuration options without +-- breaking backwards compatibility. +-- +-- For example, to construct a POST request, you could do something like: +-- +-- > initReq <- parseUrl "http://www.example.com/path" +-- > let req = initReq +-- > { method = "POST" +-- > } +-- +-- For more information, please see +-- . +data Request m = Request + { method :: W.Method + -- ^ HTTP request method, eg GET, POST. + , secure :: Bool + -- ^ Whether to use HTTPS (ie, SSL). + , host :: S.ByteString + , port :: Int + , path :: S.ByteString + -- ^ Everything from the host to the query string. + , queryString :: S.ByteString + , requestHeaders :: W.RequestHeaders + -- ^ Custom HTTP request headers + -- + -- As already stated in the introduction, the Content-Length and Host + -- headers are set automatically by this module, and shall not be added to + -- requestHeaders. + -- + -- Moreover, the Accept-Encoding header is set implicitly to gzip for + -- convenience by default. This behaviour can be overridden if needed, by + -- setting the header explicitly to a different value. In order to omit the + -- Accept-Header altogether, set it to the empty string \"\". If you need an + -- empty Accept-Header (i.e. requesting the identity encoding), set it to a + -- non-empty white-space string, e.g. \" \". See RFC 2616 section 14.3 for + -- details about the semantics of the Accept-Header field. If you request a + -- content-encoding not supported by this module, you will have to decode + -- it yourself (see also the 'decompress' field). + -- + -- Note: Multiple header fields with the same field-name will result in + -- multiple header fields being sent and therefore it\'s the responsibility + -- of the client code to ensure that the rules from RFC 2616 section 4.2 + -- are honoured. + , requestBody :: RequestBody m + , proxy :: Maybe Proxy + -- ^ Optional HTTP proxy. + , socksProxy :: Maybe SocksConf + -- ^ Optional SOCKS proxy. + , rawBody :: Bool + -- ^ If @True@, a chunked and\/or gzipped body will not be + -- decoded. Use with caution. + , decompress :: ContentType -> Bool + -- ^ Predicate to specify whether gzipped data should be + -- decompressed on the fly (see 'alwaysDecompress' and + -- 'browserDecompress'). Default: browserDecompress. + , redirectCount :: Int + -- ^ How many redirects to follow when getting a resource. 0 means follow + -- no redirects. Default value: 10. + , checkStatus :: W.Status -> W.ResponseHeaders -> Maybe SomeException + -- ^ Check the status code. Note that this will run after all redirects are + -- performed. Default: return a @StatusCodeException@ on non-2XX responses. + } + +-- | When using one of the +-- 'RequestBodySource' \/ 'RequestBodySourceChunked' constructors, +-- you must ensure +-- that the 'Source' can be called multiple times. Usually this +-- is not a problem. +-- +-- The 'RequestBodySourceChunked' will send a chunked request +-- body, note that not all servers support this. Only use +-- 'RequestBodySourceChunked' if you know the server you're +-- sending to supports chunked request bodies. +data RequestBody m + = RequestBodyLBS L.ByteString + | RequestBodyBS S.ByteString + | RequestBodyBuilder Int64 Blaze.Builder + | RequestBodySource Int64 (C.Source m Blaze.Builder) + | RequestBodySourceChunked (C.Source m Blaze.Builder) + +-- | Define a HTTP proxy, consisting of a hostname and port number. + +data Proxy = Proxy + { proxyHost :: S.ByteString -- ^ The host name of the HTTP proxy. + , proxyPort :: Int -- ^ The port number of the HTTP proxy. + } + +data HttpException = StatusCodeException W.Status W.ResponseHeaders + | InvalidUrlException String String + | TooManyRedirects [Response L.ByteString] -- ^ List of encountered responses containing redirects in reverse chronological order; including last redirect, which triggered the exception and was not followed. + | UnparseableRedirect (Response L.ByteString) -- ^ Response containing unparseable redirect. + | TooManyRetries + | HttpParserException String + | HandshakeFailed + | OverlongHeaders + deriving (Show, Typeable) +instance Exception HttpException + +-- | A simple representation of the HTTP response created by 'lbsConsumer'. +data Response body = Response + { responseStatus :: W.Status + , responseVersion :: W.HttpVersion + , responseHeaders :: W.ResponseHeaders + , responseBody :: body + } + deriving (Show, Eq, Typeable) + +-- | Since 1.1.2. +instance Functor Response where + fmap f (Response status v headers body) = Response status v headers (f body) diff --git a/Network/HTTP/Conduit/Util.hs b/Network/HTTP/Conduit/Util.hs --- a/Network/HTTP/Conduit/Util.hs +++ b/Network/HTTP/Conduit/Util.hs @@ -15,7 +15,7 @@ import qualified Data.Text as T import qualified Data.Text.Read -#if MIN_VERSION_base(4,3,0) +#if 1 import Data.ByteString (hGetSome) #else import GHC.IO.Handle.Types 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.5.0.3 +version: 1.6.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -67,6 +67,7 @@ Network.HTTP.Conduit.Chunk Network.HTTP.Conduit.Response Network.HTTP.Conduit.Cookies + Network.HTTP.Conduit.Types ghc-options: -Wall test-suite test