http-client 0.4.9 → 0.4.10
raw patch · 10 files changed
+192/−69 lines, 10 files
Files
- ChangeLog.md +4/−0
- Network/HTTP/Client/Core.hs +2/−2
- Network/HTTP/Client/Headers.hs +28/−11
- Network/HTTP/Client/Manager.hs +1/−1
- Network/HTTP/Client/Request.hs +39/−26
- Network/HTTP/Client/Response.hs +3/−6
- http-client.cabal +1/−1
- test-nonet/Network/HTTP/Client/HeadersSpec.hs +36/−1
- test-nonet/Network/HTTP/Client/RequestSpec.hs +77/−20
- test-nonet/Network/HTTP/Client/ResponseSpec.hs +1/−1
ChangeLog.md view
@@ -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`.
Network/HTTP/Client/Core.hs view
@@ -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
Network/HTTP/Client/Headers.hs view
@@ -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)
Network/HTTP/Client/Manager.hs view
@@ -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)
Network/HTTP/Client/Request.hs view
@@ -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
Network/HTTP/Client/Response.hs view
@@ -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
http-client.cabal view
@@ -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: <http://www.stackage.org/package/http-client>. homepage: https://github.com/snoyberg/http-client
test-nonet/Network/HTTP/Client/HeadersSpec.hs view
@@ -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"])
test-nonet/Network/HTTP/Client/RequestSpec.hs view
@@ -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 "<IO ()>" <$> 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)+ [] -> ([], "")
test-nonet/Network/HTTP/Client/ResponseSpec.hs view
@@ -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