diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +## 0.4.10 + +* Expect: 100-continue [#114](https://github.com/snoyberg/http-client/pull/114) + ## 0.4.9 * Add RequestBody smart constructors `streamFile` and `streamFileObserved`, the latter with accompanying type `StreamFileStatus`. 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 @@ -89,9 +89,9 @@ -- connections after accepting the request headers, so we need to check for -- exceptions in both. ex <- try $ do - requestBuilder req ci + cont <- requestBuilder req ci - getResponse connRelease timeout' req ci + getResponse connRelease timeout' req ci cont case (ex, isManaged) of -- Connection was reused, and might have been closed. Try again diff --git a/Network/HTTP/Client/Headers.hs b/Network/HTTP/Client/Headers.hs --- a/Network/HTTP/Client/Headers.hs +++ b/Network/HTTP/Client/Headers.hs @@ -13,6 +13,7 @@ import qualified Data.CaseInsensitive as CI import Network.HTTP.Client.Connection import Network.HTTP.Client.Types +import Network.HTTP.Client.Util (timeout) import Network.HTTP.Types import Data.Word (Word8) @@ -24,22 +25,38 @@ charPeriod = 46 -parseStatusHeaders :: Connection -> IO StatusHeaders -parseStatusHeaders conn = do - (status, version) <- getStatusLine - headers <- parseHeaders 0 id - return $! StatusHeaders status version headers +parseStatusHeaders :: Connection -> Maybe Int -> Maybe (IO ()) -> IO StatusHeaders +parseStatusHeaders conn timeout' cont + | Just k <- cont = getStatusExpectContinue k + | otherwise = getStatus where - getStatusLine = do + withTimeout = case timeout' of + Nothing -> id + Just t -> timeout t >=> maybe (throwIO ResponseTimeout) return + + getStatus = withTimeout next + where + next = nextStatusHeaders >>= maybe next return + + getStatusExpectContinue sendBody = do + status <- withTimeout nextStatusHeaders + case status of + Just s -> return s + Nothing -> sendBody >> getStatus + + nextStatusHeaders = do + (s, v) <- nextStatusLine + if statusCode s == 100 + then connectionDropTillBlankLine conn >> return Nothing + else Just . StatusHeaders s v <$> parseHeaders 0 id + + nextStatusLine :: IO (Status, HttpVersion) + nextStatusLine = do -- Ensure that there is some data coming in. If not, we want to signal -- this as a connection problem and not a protocol problem. bs <- connectionRead conn when (S.null bs) $ throwIO NoResponseDataReceived - - status@(code, _) <- connectionReadLineWith conn bs >>= parseStatus 3 - if code == status100 - then connectionDropTillBlankLine conn >> getStatusLine - else return status + connectionReadLineWith conn bs >>= parseStatus 3 parseStatus :: Int -> S.ByteString -> IO (Status, HttpVersion) parseStatus i bs | S.null bs && i > 0 = connectionReadLine conn >>= parseStatus (i - 1) 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 @@ -420,7 +420,7 @@ , " HTTP/1.1\r\n\r\n" ] parse conn = do - sh@(StatusHeaders status _ _) <- parseStatusHeaders conn + sh@(StatusHeaders status _ _) <- parseStatusHeaders conn Nothing Nothing unless (status == status200) $ throwIO $ ProxyConnectException ultHost ultPort $ Left $ S8.pack $ show sh in mTlsProxyConnection m connstr parse (S8.unpack ultHost) 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 @@ -64,7 +64,6 @@ import System.IO (withBinaryFile, hTell, hFileSize, Handle, IOMode (ReadMode)) - -- | Convert a URL into a 'Request'. -- -- This defaults some of the values in 'Request', such as setting 'method' to @@ -297,37 +296,51 @@ && ("content-encoding", "gzip") `elem` hs' && decompress req (fromMaybe "" $ lookup "content-type" hs') -requestBuilder :: Request -> Connection -> IO () -requestBuilder req Connection {..} = - bodySource +requestBuilder :: Request -> Connection -> IO (Maybe (IO ())) +requestBuilder req Connection {..} + | expectContinue = flushHeaders >> return (Just (checkBadSend sendLater)) + | otherwise = sendNow >> return Nothing where - checkBadSend f = f `E.catch` onRequestBodyException req - - writeBuilder = toByteStringIO connectionWrite + expectContinue = Just "100-continue" == lookup "Expect" (requestHeaders req) + checkBadSend f = f `E.catch` onRequestBodyException req + writeBuilder = toByteStringIO connectionWrite + writeHeadersWith = writeBuilder . (builder `mappend`) + flushHeaders = writeHeadersWith flush - (contentLength, bodySource) = + (contentLength, sendNow, sendLater) = case requestBody req of - 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) + RequestBodyLBS lbs -> + let body = fromLazyByteString lbs + now = checkBadSend $ writeHeadersWith body + later = writeBuilder body + in (Just (L.length lbs), now, later) + RequestBodyBS bs -> + let body = fromByteString bs + now = checkBadSend $ writeHeadersWith body + later = writeBuilder body + in (Just (fromIntegral $ S.length bs), now, later) + + RequestBodyBuilder len body -> + let now = checkBadSend $ writeHeadersWith body + later = writeBuilder body + in (Just len, now, later) + -- See https://github.com/snoyberg/http-client/issues/74 for usage -- of flush here. - 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) + RequestBodyStream len stream -> + let body = writeStream False stream + -- 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. + now = flushHeaders >> checkBadSend body + in (Just len, now, body) + + RequestBodyStreamChunked stream -> + let body = writeStream True stream + now = flushHeaders >> checkBadSend body + in (Nothing, now, body) writeStream isChunked withStream = withStream loop 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 @@ -87,13 +87,10 @@ -> Maybe Int -> Request -> Connection + -> Maybe (IO ()) -- ^ Action to run in case of a '100 Continue'. -> IO (Response BodyReader) -getResponse connRelease timeout'' req@(Request {..}) conn = do - let timeout' = - case timeout'' of - Nothing -> id - Just t -> timeout t >=> maybe (throwIO ResponseTimeout) return - StatusHeaders s version hs <- timeout' $ parseStatusHeaders conn +getResponse connRelease timeout' req@(Request {..}) conn cont = do + StatusHeaders s version hs <- parseStatusHeaders conn timeout' cont let mcl = lookup "content-length" hs >>= readDec . S8.unpack isChunked = ("transfer-encoding", "chunked") `elem` hs 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.9 +version: 0.4.10 synopsis: An HTTP client engine, intended as a base layer for more user-friendly packages. description: Hackage documentation generation is not reliable. For up to date documentation, please see: . homepage: https://github.com/snoyberg/http-client diff --git a/test-nonet/Network/HTTP/Client/HeadersSpec.hs b/test-nonet/Network/HTTP/Client/HeadersSpec.hs --- a/test-nonet/Network/HTTP/Client/HeadersSpec.hs +++ b/test-nonet/Network/HTTP/Client/HeadersSpec.hs @@ -20,8 +20,43 @@ , "\nignored" ] (connection, _, _) <- dummyConnection input - statusHeaders <- parseStatusHeaders connection + statusHeaders <- parseStatusHeaders connection Nothing Nothing statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) [ ("foo", "bar") , ("baz", "bin") ] + + it "Expect: 100-continue (success)" $ do + let input = + [ "HTTP/1.1 100 Continue\r\n\r\n" + , "HTTP/1.1 200 OK\r\n" + , "foo: bar\r\n\r\n" + ] + (conn, out, _) <- dummyConnection input + let sendBody = connectionWrite conn "data" + statusHeaders <- parseStatusHeaders conn Nothing (Just sendBody) + statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) [ ("foo", "bar") ] + out >>= (`shouldBe` ["data"]) + + it "Expect: 100-continue (failure)" $ do + let input = + [ "HTTP/1.1 417 Expectation Failed\r\n\r\n" + ] + (conn, out, _) <- dummyConnection input + let sendBody = connectionWrite conn "data" + statusHeaders <- parseStatusHeaders conn Nothing (Just sendBody) + statusHeaders `shouldBe` StatusHeaders status417 (HttpVersion 1 1) [] + out >>= (`shouldBe` []) + + it "100 Continue without expectation is OK" $ do + let input = + [ "HTTP/1.1 100 Continue\r\n\r\n" + , "HTTP/1.1 200 OK\r\n" + , "foo: bar\r\n\r\n" + , "result" + ] + (conn, out, inp) <- dummyConnection input + statusHeaders <- parseStatusHeaders conn Nothing Nothing + statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) [ ("foo", "bar") ] + out >>= (`shouldBe` []) + inp >>= (`shouldBe` ["result"]) diff --git a/test-nonet/Network/HTTP/Client/RequestSpec.hs b/test-nonet/Network/HTTP/Client/RequestSpec.hs --- a/test-nonet/Network/HTTP/Client/RequestSpec.hs +++ b/test-nonet/Network/HTTP/Client/RequestSpec.hs @@ -1,28 +1,85 @@ {-# LANGUAGE OverloadedStrings #-} module Network.HTTP.Client.RequestSpec where +import Blaze.ByteString.Builder (fromByteString) import Control.Applicative ((<$>)) -import Control.Monad (join) -import Data.Maybe (isJust) -import Test.Hspec +import Control.Monad (join, forM_) +import Data.IORef +import Data.Maybe (isJust, fromMaybe) import Network.HTTP.Client (parseUrl, requestHeaders, applyBasicProxyAuth) -import Control.Monad (forM_) +import Network.HTTP.Client.Internal +import Test.Hspec spec :: Spec spec = do - describe "case insensitive scheme" $ do - forM_ ["http://example.com", "httP://example.com", "HttP://example.com", "HttPs://example.com"] $ \url -> - it url $ case parseUrl url of - Nothing -> error "failed" - Just _ -> return () :: IO () - forM_ ["ftp://example.com"] $ \url -> - it url $ case parseUrl url of - Nothing -> return () :: IO () - Just req -> error $ show req - describe "applyBasicProxyAuth" $ do - let request = applyBasicProxyAuth "user" "pass" <$> parseUrl "http://example.org" - field = join $ lookup "Proxy-Authorization" . requestHeaders <$> request - it "Should add a proxy-authorization header" $ do - field `shouldSatisfy` isJust - it "Should add a proxy-authorization header with the specified username and password." $ do - field `shouldBe` Just "Basic dXNlcjpwYXNz" + describe "case insensitive scheme" $ do + forM_ ["http://example.com", "httP://example.com", "HttP://example.com", "HttPs://example.com"] $ \url -> + it url $ case parseUrl url of + Nothing -> error "failed" + Just _ -> return () :: IO () + forM_ ["ftp://example.com"] $ \url -> + it url $ case parseUrl url of + Nothing -> return () :: IO () + Just req -> error $ show req + + describe "applyBasicProxyAuth" $ do + let request = applyBasicProxyAuth "user" "pass" <$> parseUrl "http://example.org" + field = join $ lookup "Proxy-Authorization" . requestHeaders <$> request + it "Should add a proxy-authorization header" $ do + field `shouldSatisfy` isJust + it "Should add a proxy-authorization header with the specified username and password." $ do + field `shouldBe` Just "Basic dXNlcjpwYXNz" + + describe "requestBuilder" $ do + it "sends the full request, combining headers and body in the non-streaming case" $ do + let Just req = parseUrl "http://localhost" + let req' = req { method = "PUT", path = "foo" } + (conn, out, _) <- dummyConnection [] + forM_ (bodies `zip` out1) $ \(b, o) -> do + cont <- requestBuilder (req' { requestBody = b } ) conn + (const "" <$> cont) `shouldBe` Nothing + out >>= (`shouldBe` o) + + it "sends only headers and returns an action for the body on 'Expect: 100-continue'" $ do + let Just req = parseUrl "http://localhost" + let req' = req { requestHeaders = [("Expect", "100-continue")] + , method = "PUT" + , path = "foo" + } + (conn, out, _) <- dummyConnection [] + forM_ (bodies `zip` out2) $ \(b, (h, o)) -> do + cont <- requestBuilder (req' { requestBody = b } ) conn + out >>= (`shouldBe` [h, ""]) + fromMaybe (return ()) cont + out >>= (`shouldBe` o) + where + bodies = [ RequestBodyBS "data" + , RequestBodyLBS "data" + , RequestBodyBuilder 4 (fromByteString "data") + , RequestBodyStream 4 (popper ["data"] >>=) + , RequestBodyStreamChunked (popper ["data"] >>=) + ] + + out1 = [ [nonChunked <> "\r\ndata"] + , [nonChunked <> "\r\ndata"] + , [nonChunked <> "\r\ndata"] + , [nonChunked <> "\r\n", "", "data"] + , [chunked <> "\r\n", "", "4\r\n","data","\r\n","0\r\n\r\n"] + ] + + out2 = [ (nonChunked <> "Expect: 100-continue\r\n\r\n", ["data"]) + , (nonChunked <> "Expect: 100-continue\r\n\r\n", ["data"]) + , (nonChunked <> "Expect: 100-continue\r\n\r\n", ["data"]) + , (nonChunked <> "Expect: 100-continue\r\n\r\n", ["data"]) + , (chunked <> "Expect: 100-continue\r\n\r\n", ["4\r\n","data","\r\n","0\r\n\r\n"]) + ] + + nonChunked = "PUT /foo HTTP/1.1\r\nHost: localhost\r\nAccept-Encoding: gzip\r\nContent-Length: 4\r\n" + chunked = "PUT /foo HTTP/1.1\r\nHost: localhost\r\nAccept-Encoding: gzip\r\nTransfer-Encoding: chunked\r\n" + + popper dat = do + r <- newIORef dat + return . atomicModifyIORef' r $ \xs -> + case xs of + (x:xs') -> (xs', x) + [] -> ([], "") diff --git a/test-nonet/Network/HTTP/Client/ResponseSpec.hs b/test-nonet/Network/HTTP/Client/ResponseSpec.hs --- a/test-nonet/Network/HTTP/Client/ResponseSpec.hs +++ b/test-nonet/Network/HTTP/Client/ResponseSpec.hs @@ -16,7 +16,7 @@ spec :: Spec spec = describe "ResponseSpec" $ do - let getResponse' conn = getResponse (const $ return ()) Nothing req conn + let getResponse' conn = getResponse (const $ return ()) Nothing req conn Nothing Just req = parseUrl "http://localhost" it "basic" $ do (conn, _, _) <- dummyConnection