diff --git a/Network/HTTP/Client/Body.hs b/Network/HTTP/Client/Body.hs --- a/Network/HTTP/Client/Body.hs +++ b/Network/HTTP/Client/Body.hs @@ -132,10 +132,10 @@ , brComplete = fmap (== -1) $ readIORef icount } -makeChunkedReader :: Bool -- ^ send headers +makeChunkedReader :: Bool -- ^ raw -> Connection -> IO BodyReader -makeChunkedReader sendHeaders conn@Connection {..} = do +makeChunkedReader raw conn@Connection {..} = do icount <- newIORef 0 return $! BodyReader { brRead = go icount @@ -146,21 +146,25 @@ where go icount = do count0 <- readIORef icount - count <- + (rawCount, count) <- if count0 == 0 then readHeader - else return count0 + else return (empty, count0) if count <= 0 then do writeIORef icount (-1) - return empty + return $ if count /= (-1) && raw then rawCount else empty else do - (bs, count') <- sendChunk count + (bs, count') <- readChunk count writeIORef icount count' - return bs + return $ appendHeader rawCount bs - sendChunk 0 = return (empty, 0) - sendChunk remainder = do + appendHeader + | raw = S.append + | otherwise = flip const + + readChunk 0 = return (empty, 0) + readChunk remainder = do bs <- connectionRead when (S.null bs) $ throwIO InvalidChunkHeaders case compare remainder $ S.length bs of @@ -168,11 +172,15 @@ let (x, y) = S.splitAt remainder bs assert (not $ S.null y) $ connectionUnread y requireNewline - return (x, 0) + done x EQ -> do requireNewline - return (bs, 0) + done bs GT -> return (bs, remainder - S.length bs) + where + done x + | raw = return (x `S.append` "\r\n", 0) + | otherwise = return (x, 0) requireNewline = do bs <- connectionReadLine conn @@ -182,7 +190,7 @@ bs <- connectionReadLine conn case parseHex bs of Nothing -> throwIO InvalidChunkHeaders - Just hex -> return hex + Just hex -> return (bs `S.append` "\r\n", hex) parseHex bs0 = case uncons bs0 of diff --git a/Network/HTTP/Client/Core.hs b/Network/HTTP/Client/Core.hs --- a/Network/HTTP/Client/Core.hs +++ b/Network/HTTP/Client/Core.hs @@ -130,6 +130,11 @@ -- This function automatically performs any necessary redirects, as specified -- by the 'redirectCount' setting. -- +-- When implementing a (reverse) proxy using this function or relating +-- functions, it's wise to remove Transfer-Encoding:, Content-Length:, +-- Content-Encoding: and Accept-Encoding: from request and response +-- headers to be relayed. +-- -- Since 0.1.0 responseOpen :: Request -> Manager -> IO (Response BodyReader) responseOpen req0 manager = mWrapIOException manager $ do diff --git a/Network/HTTP/Client/Manager.hs b/Network/HTTP/Client/Manager.hs --- a/Network/HTTP/Client/Manager.hs +++ b/Network/HTTP/Client/Manager.hs @@ -330,7 +330,7 @@ | S8.null h = throwIO $ InvalidDestinationHost h | otherwise = getManagedConn m (ConnKey connKeyHost connport (secure req)) $ - go connaddr connhost connport + wrapConnectExc $ go connaddr connhost connport where h = host req (useProxy, connhost, connport) = getConnDest req @@ -338,6 +338,10 @@ case (hostAddress req, useProxy) of (Just ha, False) -> (Just ha, HostAddress ha) _ -> (Nothing, HostName $ T.pack connhost) + + wrapConnectExc = handle $ \e -> + throwIO $ FailedConnectionException2 connhost connport (secure req) + (toException (e :: IOException)) go = case (secure req, useProxy) of (False, _) -> mRawConnection m diff --git a/Network/HTTP/Client/Response.hs b/Network/HTTP/Client/Response.hs --- a/Network/HTTP/Client/Response.hs +++ b/Network/HTTP/Client/Response.hs @@ -9,10 +9,9 @@ ) where import Control.Arrow (first) -import Control.Monad (liftM) +import Control.Monad (liftM, (>=>)) import Control.Exception (throwIO) -import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 @@ -97,11 +96,7 @@ let timeout' = case timeout'' of Nothing -> id - Just useconds -> \ma -> do - x <- timeout useconds ma - case x of - Nothing -> liftIO $ throwIO ResponseTimeout - Just y -> return y + Just t -> timeout t >=> maybe responseTimeout return StatusHeaders s version hs <- timeout' $ parseStatusHeaders conn let mcl = lookup "content-length" hs >>= readDec . S8.unpack @@ -137,3 +132,5 @@ , responseCookieJar = def , responseClose' = ResponseClose (cleanup False) } + where + responseTimeout = throwIO ResponseTimeout diff --git a/Network/HTTP/Client/Types.hs b/Network/HTTP/Client/Types.hs --- a/Network/HTTP/Client/Types.hs +++ b/Network/HTTP/Client/Types.hs @@ -87,6 +87,7 @@ | OverlongHeaders | ResponseTimeout | FailedConnectionException String Int -- ^ host/port + | FailedConnectionException2 String Int Bool SomeException -- ^ host/port/secure | ExpectedBlankAfter100Continue | InvalidStatusLine S.ByteString | InvalidHeader S.ByteString diff --git a/http-client.cabal b/http-client.cabal --- a/http-client.cabal +++ b/http-client.cabal @@ -1,5 +1,5 @@ name: http-client -version: 0.3.0.2 +version: 0.3.1 synopsis: An HTTP client engine, intended as a base layer for more user-friendly packages. description: This codebase has been refactored from http-conduit. homepage: https://github.com/snoyberg/http-client @@ -76,3 +76,4 @@ , base64-bytestring , zlib , async + , streaming-commons >= 0.1.1 diff --git a/test/Network/HTTP/Client/BodySpec.hs b/test/Network/HTTP/Client/BodySpec.hs --- a/test/Network/HTTP/Client/BodySpec.hs +++ b/test/Network/HTTP/Client/BodySpec.hs @@ -38,6 +38,33 @@ S.concat input' `shouldBe` "not consumed" complete2 <- brComplete reader complete2 `shouldBe` True + it "chunked, raw" $ do + (conn, _, input) <- dummyConnection + [ "5\r\nhello\r\n6\r\n world\r\n0\r\nnot consumed" + ] + reader <- makeChunkedReader True conn + complete1 <- brComplete reader + complete1 `shouldBe` False + body <- brConsume reader + S.concat body `shouldBe` "5\r\nhello\r\n6\r\n world\r\n0\r\n" + input' <- input + S.concat input' `shouldBe` "not consumed" + complete2 <- brComplete reader + complete2 `shouldBe` True + + it "chunked, pieces, raw" $ do + (conn, _, input) <- dummyConnection $ map S.singleton $ S.unpack + "5\r\nhello\r\n6\r\n world\r\n0\r\nnot consumed" + reader <- makeChunkedReader True conn + complete1 <- brComplete reader + complete1 `shouldBe` False + body <- brConsume reader + S.concat body `shouldBe` "5\r\nhello\r\n6\r\n world\r\n0\r\n" + input' <- input + S.concat input' `shouldBe` "not consumed" + complete2 <- brComplete reader + complete2 `shouldBe` True + it "length, single" $ do (conn, _, input) <- dummyConnection [ "hello world done" diff --git a/test/Network/HTTP/ClientSpec.hs b/test/Network/HTTP/ClientSpec.hs --- a/test/Network/HTTP/ClientSpec.hs +++ b/test/Network/HTTP/ClientSpec.hs @@ -11,25 +11,26 @@ import Network.Socket (accept, sClose) import Network.Socket.ByteString (recv, sendAll) import Test.Hspec +import qualified Data.Streaming.Network as N main :: IO () main = hspec spec redirectServer :: (Int -> IO a) -> IO a -redirectServer inner = do - let port = 23456 - bracket (listenOn $ PortNumber $ fromIntegral port) sClose $ \listener -> do - withAsync (forker listener) $ \_ -> inner port +redirectServer inner = bracket + (N.bindRandomPortTCP "*4") + (sClose . snd) + $ \(port, lsocket) -> withAsync + (N.runTCPServer (N.serverSettingsTCPSocket lsocket) app) + (const $ inner port) where - forker listener = forever $ do - (socket, _) <- accept listener - _ <- forkIO $ forever $ do - sendAll socket "HTTP/1.1 301 Redirect\r\nLocation: /\r\ncontent-length: 5\r\n\r\n" + app ad = do + forkIO $ forever $ N.appRead ad + forever $ do + N.appWrite ad "HTTP/1.1 301 Redirect\r\nLocation: /\r\ncontent-length: 5\r\n\r\n" threadDelay 10000 - sendAll socket "hello\r\n" + N.appWrite ad "hello\r\n" threadDelay 10000 - _ <- forkIO $ forever $ recv socket 4096 - return () spec :: Spec spec = describe "Client" $ do @@ -63,4 +64,13 @@ httpLbs req man `shouldThrow` \e -> case e of StatusCodeException{} -> True + _ -> False + it "connecting to missing server gives nice error message" $ do + (port, socket) <- N.bindRandomPortTCP "*4" + sClose socket + req <- parseUrl $ "http://127.0.0.1:" ++ show port + withManager defaultManagerSettings $ \man -> + httpLbs req man `shouldThrow` \e -> + case e of + FailedConnectionException2 "127.0.0.1" port' False _ -> port == port' _ -> False