diff --git a/Network/HTTP/Conduit.hs b/Network/HTTP/Conduit.hs --- a/Network/HTTP/Conduit.hs +++ b/Network/HTTP/Conduit.hs @@ -68,6 +68,7 @@ , requestHeaders , requestBody , proxy + , socksProxy , rawBody , decompress , redirectCount @@ -88,6 +89,7 @@ , applyBasicAuth , addProxy , lbsResponse + , getRedirectedRequest -- * Decompression predicates , alwaysDecompress , browserDecompress @@ -103,7 +105,6 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Char8 as S8 import qualified Network.HTTP.Types as W import Data.Default (def) @@ -154,46 +155,15 @@ case checkStatus req0 status hs of Nothing -> return res Just exc -> do - body' <- C.prepareSource body - C.sourceClose body' + C.sourceClose body liftBase $ throwIO exc where go 0 _ = liftBase $ throwIO TooManyRedirects go count req = do - res@(Response (W.Status code _) hs _) <- httpRaw req manager - case (300 <= code && code < 400, lookup "location" hs) of - (True, Just l'') -> do - -- Prepend scheme, host and port if missing - let l' = - case S8.uncons l'' of - Just ('/', _) -> concat - [ "http" - , if secure req then "s" else "" - , "://" - , S8.unpack $ host req - , ":" - , show $ port req - , S8.unpack l'' - ] - _ -> S8.unpack l'' - l <- liftBase $ parseUrl l' - let req' = req - { host = host l - , port = port l - , secure = secure l - , path = path l - , queryString = queryString l - , method = - -- According to the spec, this should *only* be for - -- status code 303. However, almost all clients - -- mistakenly implement it for 302 as well. So we - -- have to be wrong like everyone else... - if code == 302 || code == 303 - then "GET" - else method l - } - go (count - 1) req' - _ -> return res + res <- httpRaw req manager + case getRedirectedRequest req (responseHeaders res) (W.statusCode (statusCode res)) of + Just req' -> go (count - 1) req' + Nothing -> return res -- | Get a 'Response' without any redirect following. httpRaw 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 @@ -44,7 +44,7 @@ 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 (NeedHeader f', C.Producing $ front []) + A.Partial f' -> return $ C.StateProducing (NeedHeader f') $ front [] A.Fail _ contexts msg -> lift $ C.resourceThrow $ ParseError contexts msg push front (Isolate i) x = do let (a, b) = S.splitAt i x @@ -54,10 +54,9 @@ (front . (a:)) (NeedNewline $ A.parse newline) b - else assert (S.null b) $ return - ( Isolate i' - , C.Producing (front [a]) - ) + 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 @@ -67,16 +66,18 @@ (front . addHeader) (NeedHeader $ A.parse parseChunkHeader) x' - A.Partial f' -> return (NeedNewline f', C.Producing $ front []) + A.Partial f' -> return $ C.StateProducing (NeedNewline f') $ front [] A.Fail _ contexts msg -> lift $ C.resourceThrow $ 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 (Complete, C.Finished lo $ front end) + return $ C.StateFinished lo $ front end close _ = return [] chunkIt :: C.Resource m => C.Conduit Blaze.Builder m Blaze.Builder -chunkIt = C.Conduit $ return $ C.PreparedConduit - { C.conduitPush = \xs -> return $ C.Producing [chunkedTransferEncoding xs] - , C.conduitClose = return [chunkedTransferTerminator] - } +chunkIt = + conduit + where + conduit = C.Conduit push close + push xs = return $ C.Producing conduit [chunkedTransferEncoding xs] + close = 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 @@ -28,9 +28,11 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L +import Network (PortID(..)) import Network.Socket (Socket, sClose) import Network.Socket.ByteString (recv, sendAll) import qualified Network.Socket as NS +import Network.Socks5 (socksConnectWith, SocksConf) import Network.TLS import Network.TLS.Extra (ciphersuite_all) @@ -54,20 +56,23 @@ } connSink :: C.ResourceIO m => ConnInfo -> C.Sink ByteString m () -connSink ConnInfo { connWrite = write } = C.Sink $ return $ C.SinkData - { C.sinkPush = \bss -> liftBase (write bss) >> return C.Processing - , C.sinkClose = return () - } +connSink ConnInfo { connWrite = write } = + C.SinkData push close + where + push bss = liftBase (write bss) >> return (C.Processing push close) + close = return () connSource :: C.ResourceIO m => ConnInfo -> C.Source m ByteString -connSource ConnInfo { connRead = read' } = C.Source $ return $ C.PreparedSource - { C.sourcePull = do +connSource ConnInfo { connRead = read' } = + src + where + src = C.Source pull close + pull = do bs <- liftBase read' if S.null bs then return C.Closed - else return $ C.Open bs - , C.sourceClose = return () - } + else return $ C.Open src bs + close = return () #if DEBUG allOpenSockets :: I.IORef (Int, IntMap.IntMap String) @@ -151,8 +156,10 @@ -- least on tls-0.8.4 it's guaranteed to always -- return a lazy bytestring with a single chunk. -getSocket :: String -> Int -> IO NS.Socket -getSocket host' port' = do +getSocket :: String -> Int -> Maybe SocksConf -> IO NS.Socket +getSocket host' port' (Just socksConf) = do + socksConnectWith socksConf host' (PortNumber $ fromIntegral port') +getSocket host' port' Nothing = do let hints = NS.defaultHints { NS.addrFlags = [NS.AI_ADDRCONFIG] , NS.addrSocketType = NS.Stream diff --git a/Network/HTTP/Conduit/Manager.hs b/Network/HTTP/Conduit/Manager.hs --- a/Network/HTTP/Conduit/Manager.hs +++ b/Network/HTTP/Conduit/Manager.hs @@ -18,7 +18,7 @@ import Prelude hiding (catch) import Data.Monoid (mappend) -import System.IO (hClose, hFlush) +import System.IO (hClose, hFlush, IOMode(..)) import qualified Data.IORef as I import qualified Data.Map as Map @@ -42,7 +42,8 @@ import Control.Concurrent (forkIO, threadDelay) import Data.Time (UTCTime, getCurrentTime, addUTCTime) -import Network (connectTo, PortID (PortNumber)) +import Network (connectTo, PortID (PortNumber), HostName) +import Network.Socket (socketToHandle) import Data.Certificate.X509 (X509, encodeCertificate) import qualified Network.HTTP.Types as W @@ -52,8 +53,10 @@ import Network.HTTP.Conduit.Util (hGetSome) import Network.HTTP.Conduit.Parser (parserHeadersFromByteString) import Network.HTTP.Conduit.Request +import Network.Socks5 (SocksConf, socksConnectWith) import Data.Default import Data.Maybe (mapMaybe) +import System.IO (Handle) -- | Settings for a @Manager@. Please use the 'def' function and then modify -- individual settings. @@ -238,10 +241,11 @@ => Manager -> String -> Int + -> Maybe SocksConf -- ^ optional socks proxy -> ResourceT m (ConnRelease m, ConnInfo, ManagedConn) -getSocketConn man host' port' = +getSocketConn man host' port' socksProxy' = getManagedConn man (ConnKey (T.pack host') port' False) $ - getSocket host' port' >>= socketConn desc + getSocket host' port' socksProxy' >>= socketConn desc where desc = socketDesc host' port' "unsecured" @@ -253,10 +257,11 @@ -> Manager -> String -- ^ host -> Int -- ^ port + -> Maybe SocksConf -- ^ optional socks proxy -> ResourceT m (ConnRelease m, ConnInfo, ManagedConn) -getSslConn checkCert man host' port' = +getSslConn checkCert man host' port' socksProxy' = getManagedConn man (ConnKey (T.pack host') port' True) $ - (connectTo host' (PortNumber $ fromIntegral port') >>= sslClientConn desc checkCert) + (connectionTo host' (PortNumber $ fromIntegral port') socksProxy' >>= sslClientConn desc checkCert) where desc = socketDesc host' port' "secured" @@ -268,14 +273,15 @@ -> Manager -> String -- ^ Proxy host -> Int -- ^ Proxy port + -> Maybe SocksConf -- ^ optional SOCKS proxy -> ResourceT m (ConnRelease m, ConnInfo, ManagedConn) -getSslProxyConn checkCert thost tport man phost pport = +getSslProxyConn checkCert thost tport man phost pport socksProxy' = getManagedConn man (ConnKey (T.pack phost) pport True) $ doConnect >>= sslClientConn desc checkCert where desc = socketDesc phost pport "secured-proxy" doConnect = do - h <- connectTo phost (PortNumber $ fromIntegral pport) + h <- connectionTo phost (PortNumber $ fromIntegral pport) socksProxy' L.hPutStr h $ Blaze.toLazyByteString connectRequest hFlush h r <- hGetSome h 2048 @@ -350,7 +356,7 @@ -> Manager -> ResourceT m (ConnRelease m, ConnInfo, ManagedConn) getConn req m = - go m connhost connport + go m connhost connport (socksProxy req) where h = host req (useProxy, connhost, connport) = @@ -400,3 +406,8 @@ case Map.lookup host' cache of Nothing -> Map.singleton encoded expire Just m -> Map.insert encoded expire m + +connectionTo :: HostName -> PortID -> Maybe SocksConf -> IO Handle +connectionTo host' port' Nothing = connectTo host' port' +connectionTo host' port' (Just socksConf) = + socksConnectWith socksConf host' port' >>= flip socketToHandle ReadWriteMode 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 @@ -36,6 +36,7 @@ import qualified Data.ByteString.Lazy as L import qualified Network.HTTP.Types as W +import Network.Socks5 (SocksConf) import Control.Exception (Exception, SomeException, toException) import Control.Failure (Failure (failure)) @@ -72,6 +73,8 @@ , 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. @@ -165,6 +168,7 @@ , requestBody = RequestBodyLBS L.empty , method = "GET" , proxy = Nothing + , socksProxy = Nothing , rawBody = False , decompress = browserDecompress , redirectCount = 10 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 @@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} module Network.HTTP.Conduit.Response ( Response (..) + , getRedirectedRequest , getResponse , lbsResponse ) where @@ -43,6 +44,54 @@ instance Functor Response where fmap f (Response status headers body) = Response status 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' +-- if the code is not a 3xx, there is no 'location' header included, or if the +-- redirected response couldn't be parsed with 'parseUrl'. +-- +-- If a user of this library wants to know the url chain that results from a +-- 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']) +-- > (\ (StatusCodeException status headers) -> do +-- > l <- myHttp (fromJust $ nextRequest status headers) man +-- > return $ req' : l) +-- > where req' = req { redirectCount = 0 } +-- > nextRequest status headers = getRedirectedRequest req' headers $ W.statusCode status +getRedirectedRequest :: Request m -> W.ResponseHeaders -> Int -> Maybe (Request m) +getRedirectedRequest req hs code + | 300 <= code && code < 400 = do + l' <- lookup "location" hs + l <- parseUrl $ case S8.uncons l' of + Just ('/', _) -> concat + [ "http" + , if secure req then "s" else "" + , "://" + , S8.unpack $ host req + , ":" + , show $ port req + , S8.unpack l' + ] + _ -> S8.unpack l' + return req + { host = host l + , port = port l + , secure = secure l + , path = path l + , queryString = queryString l + , method = + -- According to the spec, this should *only* be for + -- status code 303. However, almost all clients + -- mistakenly implement it for 302 as well. So we + -- have to be wrong like everyone else... + if code == 302 || code == 303 + then "GET" + else method l + } + | otherwise = Nothing + -- | Convert a 'Response' that has a 'C.Source' body to one with a lazy -- 'L.ByteString' body. lbsResponse :: C.Resource m @@ -98,16 +147,15 @@ => ResourceT m () -> C.Source m a -> C.Source m a -addCleanup cleanup (C.Source msrc) = C.Source $ do - src <- msrc - return C.PreparedSource - { C.sourcePull = do - res <- C.sourcePull src - case res of - C.Closed -> cleanup - C.Open _ -> return () - return res - , C.sourceClose = do - C.sourceClose src - cleanup - } +addCleanup cleanup src = src + { C.sourcePull = do + res <- C.sourcePull src + case res of + C.Closed -> cleanup >> return C.Closed + C.Open src' val -> return $ C.Open + (addCleanup cleanup src') + val + , C.sourceClose = do + C.sourceClose src + cleanup + } 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.2.0 +version: 1.2.1 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -22,10 +22,10 @@ , bytestring >= 0.9.1.4 && < 0.10 , transformers >= 0.2 && < 0.3 , failure >= 0.1 - , conduit >= 0.1 - , zlib-conduit >= 0.0 && < 0.1 - , blaze-builder-conduit >= 0.0 && < 0.1 - , attoparsec-conduit >= 0.0 && < 0.1 + , conduit >= 0.2 + , zlib-conduit >= 0.2 && < 0.3 + , blaze-builder-conduit >= 0.2 && < 0.3 + , attoparsec-conduit >= 0.2 && < 0.3 , attoparsec >= 0.8.0.2 && < 0.11 , utf8-string >= 0.3.4 && < 0.4 , blaze-builder >= 0.2.1 && < 0.4 @@ -43,6 +43,7 @@ , text , transformers-base >= 0.4 && < 0.5 , lifted-base >= 0.1 && < 0.2 + , socks >= 0.4 && < 0.5 , time if flag(network-bytestring) build-depends: network >= 2.2.1 && < 2.2.3 @@ -96,6 +97,7 @@ , network , wai , warp + , socks , http-types source-repository head