diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,9 @@ +## 0.4.6 + +Add `onRequestBodyException` to `Request` to allow for recovering from +exceptions when sending the request. Most useful for servers which terminate +the connection after sending a response body without flushing the request body. + ## 0.4.5 Add `openSocketConnectionSize` and increase default chunk size to 8192. diff --git a/Network/HTTP/Client/Request.hs b/Network/HTTP/Client/Request.hs --- a/Network/HTTP/Client/Request.hs +++ b/Network/HTTP/Client/Request.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -42,7 +43,8 @@ import Network.URI (URI (..), URIAuth (..), parseURI, relativeTo, escapeURIString, isAllowedInURI) import Control.Monad.IO.Class (liftIO) -import Control.Exception (Exception, toException, throw, throwIO) +import Control.Exception (Exception, toException, throw, throwIO, IOException) +import qualified Control.Exception as E import qualified Data.CaseInsensitive as CI import qualified Data.ByteString.Base64 as B64 @@ -53,6 +55,7 @@ import System.Timeout (timeout) import Data.Time.Clock import Control.Monad.Catch (MonadThrow, throwM) +import Data.IORef -- | Convert a URL into a 'Request'. -- @@ -205,6 +208,10 @@ else return (Just remainingTime, res) , cookieJar = Just def , requestVersion = W.http11 + , onRequestBodyException = \se -> + case E.fromException se of + Just (_ :: IOException) -> return () + Nothing -> throwIO se } instance IsString Request where @@ -286,18 +293,33 @@ requestBuilder req Connection {..} = bodySource where + checkBadSend f = f `E.catch` onRequestBodyException req + writeBuilder = toByteStringIO connectionWrite (contentLength, bodySource) = case requestBody req of - RequestBodyLBS lbs -> (Just $ L.length lbs, writeBuilder $ builder `mappend` fromLazyByteString lbs) - RequestBodyBS bs -> (Just $ fromIntegral $ S.length bs, writeBuilder $ builder `mappend` fromByteString bs) - RequestBodyBuilder i b -> (Just $ i, writeBuilder $ builder `mappend` b) + RequestBodyLBS lbs -> (Just $ L.length lbs, + checkBadSend $ writeBuilder + $ builder `mappend` fromLazyByteString lbs) + RequestBodyBS bs -> (Just $ fromIntegral $ S.length bs, + checkBadSend $ writeBuilder + $ builder `mappend` fromByteString bs) + RequestBodyBuilder i b -> (Just i, + checkBadSend $ writeBuilder $ builder `mappend` b) -- See https://github.com/snoyberg/http-client/issues/74 for usage -- of flush here. - RequestBodyStream i stream -> (Just i, writeBuilder (builder `mappend` flush) >> writeStream False stream) - RequestBodyStreamChunked stream -> (Nothing, writeBuilder (builder `mappend` flush) >> writeStream True stream) + RequestBodyStream i stream -> (Just i, do + -- Don't check for a bad send on the headers themselves. + -- Ideally, we'd do the same thing for the other request body + -- types, but it would also introduce a performance hit since + -- we couldn't merge request headers and bodies together. + writeBuilder (builder `mappend` flush) + checkBadSend $ writeStream False stream) + RequestBodyStreamChunked stream -> (Nothing, do + writeBuilder (builder `mappend` flush) + checkBadSend $ writeStream True stream) writeStream isChunked withStream = withStream loop 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 @@ -397,6 +397,13 @@ -- Default: HTTP 1.1 -- -- Since 0.4.3 + + , onRequestBodyException :: SomeException -> IO () + -- ^ How to deal with exceptions thrown while sending the request. + -- + -- Default: ignore @IOException@s, rethrow all other exceptions. + -- + -- Since: 0.4.6 } deriving T.Typeable 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.4.5 +version: 0.4.6 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 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 @@ -1,18 +1,21 @@ {-# LANGUAGE OverloadedStrings #-} module Network.HTTP.ClientSpec where +import Blaze.ByteString.Builder (fromByteString) import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.Async (withAsync) import Control.Exception (bracket) import Control.Monad (forever, replicateM_) +import Data.Monoid (mappend) import Network (PortID (PortNumber), listenOn, withSocketsDo) import Network.HTTP.Client -import Network.HTTP.Types (status200) +import Network.HTTP.Types (status200, status413) import Network.Socket (accept, sClose) import Network.Socket.ByteString (recv, sendAll) import Test.Hspec import qualified Data.Streaming.Network as N import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L import Data.ByteString.Lazy.Char8 () -- orphan instance main :: IO () @@ -53,6 +56,24 @@ ] threadDelay 10000 +earlyClose413 :: (Int -> IO a) -> IO a +earlyClose413 inner = bracket + (N.bindRandomPortTCP "*4") + (sClose . snd) + $ \(port, lsocket) -> withAsync + (N.runTCPServer (N.serverSettingsTCPSocket lsocket) app) + (const $ inner port) + where + app ad = do + let readHeaders front = do + newBS <- N.appRead ad + let bs = S.append front newBS + if "\r\n\r\n" `S.isInfixOf` bs + then return () + else readHeaders bs + readHeaders S.empty + N.appWrite ad "HTTP/1.1 413 Too Large\r\ncontent-length: 7\r\n\r\ngoodbye" + spec :: Spec spec = describe "Client" $ do it "works" $ withSocketsDo $ do @@ -111,3 +132,14 @@ withManager settings $ \man -> do res <- httpLbs "http://httpbin.org:1234" man responseStatus res `shouldBe` status200 + + it "early close on a 413" $ earlyClose413 $ \port' -> do + withManager defaultManagerSettings $ \man -> do + res <- flip httpLbs man "http://localhost" + { port = port' + , checkStatus = \_ _ _ -> Nothing + , requestBody = RequestBodyStreamChunked + ($ return (S.replicate 100000 65)) + } + responseBody res `shouldBe` "goodbye" + responseStatus res `shouldBe` status413