http-conduit 2.1.11 → 2.2.0
raw patch · 7 files changed
+77/−69 lines, 7 filesdep ~aesondep ~http-clientdep ~http-client-tls
Dependency ranges changed: aeson, http-client, http-client-tls, resourcet
Files
- ChangeLog.md +4/−0
- Network/HTTP/Client/Conduit.hs +0/−1
- Network/HTTP/Conduit.hs +10/−5
- Network/HTTP/Simple.hs +1/−9
- http-conduit.cabal +3/−3
- test/CookieTest.hs +2/−3
- test/main.hs +57/−48
ChangeLog.md view
@@ -1,3 +1,7 @@+## 2.2.0++* Upgrade to http-client 0.5+ ## 2.1.11 * Switch to non-throwing behavior in `Network.HTTP.Simple` [#193](https://github.com/snoyberg/http-client/issues/193)
Network/HTTP/Client/Conduit.hs view
@@ -49,7 +49,6 @@ newManager, responseClose, responseOpen, withManager, withResponse, BodyReader, brRead, brConsume, httpNoBody)-import Network.HTTP.Client (HasHttpManager(..)) import qualified Network.HTTP.Client as H import Network.HTTP.Client.TLS (tlsManagerSettings)
Network/HTTP/Conduit.hs view
@@ -169,11 +169,10 @@ , rawBody , decompress , redirectCount- , checkStatus+ , checkResponse , responseTimeout , cookieJar , requestVersion- , getConnectionWrapper , HCC.setQueryString -- *** Request body , requestBodySource@@ -201,6 +200,11 @@ , managerConnCount , managerResponseTimeout , managerTlsConnection+ -- ** Response timeout+ , HC.ResponseTimeout+ , HC.responseTimeoutMicro+ , HC.responseTimeoutNone+ , HC.responseTimeoutDefault -- * Cookies , Cookie(..) , CookieJar@@ -225,6 +229,7 @@ , urlEncodedBody -- * Exceptions , HttpException (..)+ , HCC.HttpExceptionContent (..) ) where import qualified Data.ByteString as S@@ -234,12 +239,12 @@ import qualified Data.Conduit.List as CL import Data.IORef (readIORef, writeIORef, newIORef) import Data.Int (Int64)-import Control.Applicative ((<$>))-import Control.Exception.Lifted (bracket)+import Control.Applicative as A ((<$>)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Resource import qualified Network.HTTP.Client as Client (httpLbs, responseOpen, responseClose)+import qualified Network.HTTP.Client as HC import qualified Network.HTTP.Client.Conduit as HCC import Network.HTTP.Client.Internal (createCookieJar, destroyCookieJar)@@ -303,7 +308,7 @@ simpleHttp url = liftIO $ do man <- newManager tlsManagerSettings req <- liftIO $ parseUrlThrow url- responseBody <$> httpLbs (setConnectionClose req) man+ responseBody A.<$> httpLbs (setConnectionClose req) man conduitManagerSettings :: ManagerSettings conduitManagerSettings = tlsManagerSettings
Network/HTTP/Simple.hs view
@@ -54,7 +54,7 @@ , setRequestBodyFile , setRequestBodyURLEncoded -- ** Special fields- , setRequestIgnoreStatus+ , H.setRequestIgnoreStatus , setRequestBasicAuth , setRequestManager , setRequestProxy@@ -86,7 +86,6 @@ import qualified Data.Conduit as C import qualified Data.Conduit.Attoparsec as C import qualified Control.Monad.Catch as Catch-import Data.Default.Class (def) import qualified Network.HTTP.Types as H import Data.Int (Int64) @@ -298,13 +297,6 @@ -- @since 2.1.10 setRequestBodyURLEncoded :: [(S.ByteString, S.ByteString)] -> H.Request -> H.Request setRequestBodyURLEncoded = H.urlEncodedBody---- | Modify the request so that non-2XX status codes do not generate a runtime--- exception.------ @since 2.1.10-setRequestIgnoreStatus :: H.Request -> H.Request-setRequestIgnoreStatus req = req { H.checkStatus = \_ _ _ -> Nothing } -- | Set basic auth with the given username and password --
http-conduit.cabal view
@@ -1,5 +1,5 @@ name: http-conduit-version: 2.1.11+version: 2.2.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -30,12 +30,11 @@ , conduit-extra >= 1.1.5 , http-types >= 0.7 , lifted-base >= 0.1- , http-client >= 0.4.30 && < 0.5+ , http-client >= 0.5 && < 0.6 , http-client-tls >= 0.2.4 , monad-control , mtl , exceptions >= 0.6- , data-default-class exposed-modules: Network.HTTP.Conduit Network.HTTP.Client.Conduit Network.HTTP.Simple@@ -76,6 +75,7 @@ , streaming-commons , aeson , temporary+ , resourcet source-repository head type: git
test/CookieTest.hs view
@@ -8,14 +8,13 @@ import qualified Network.HTTP.Conduit as HC import Data.ByteString.UTF8 import Data.Monoid-import Data.Maybe import Data.Time.Clock import Data.Time.Calendar import qualified Data.CaseInsensitive as CI import Web.Cookie default_request :: HC.Request-default_request = fromJust $ HC.parseUrl "http://www.google.com/"+default_request = HC.parseRequest_ "http://www.google.com/" default_cookie :: Cookie default_cookie = Cookie { cookie_name = fromString "name"@@ -444,7 +443,7 @@ testMonoidPreferRecent :: IO () testMonoidPreferRecent = assertEqual "Monoid prefers more recent cookies"- (cct $ createCookieJar [c2]) (cct $ createCookieJar [c1] `mappend` createCookieJar [c2])+ (cct $ createCookieJar [c2]) (cct $ createCookieJar [c1] `Data.Monoid.mappend` createCookieJar [c2]) where c1 = default_cookie {cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1)} c2 = default_cookie {cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 2)} cct cj = cookie_creation_time $ head $ destroyCookieJar cj
test/main.hs view
@@ -12,7 +12,7 @@ import System.IO.Temp (withSystemTempFile) import qualified Network.Wai as Wai import Network.Wai.Handler.Warp (runSettings, defaultSettings, setPort, setBeforeMainLoop, Settings, setTimeout)-import Network.HTTP.Conduit hiding (port)+import Network.HTTP.Conduit hiding (port, withManager, withManagerSettings) import qualified Network.HTTP.Conduit as NHC import Network.HTTP.Client.MultipartFormData import Control.Concurrent (forkIO, killThread, putMVar, takeMVar, newEmptyMVar, threadDelay)@@ -25,7 +25,7 @@ import qualified Network.BSD import CookieTest (cookieTest) #if MIN_VERSION_conduit(1,1,0)-import Data.Conduit.Network (runTCPServer, serverSettings, HostPreference (..), appSink, appSource, ServerSettings)+import Data.Conduit.Network (runTCPServer, serverSettings, appSink, appSource, ServerSettings) import Data.Streaming.Network (bindPortTCP, setAfterBind) #define bindPort bindPortTCP #else@@ -53,7 +53,16 @@ import Data.Default.Class (def) import qualified Data.Aeson as A import qualified Network.HTTP.Simple as Simple+import Data.Monoid (mempty)+import Control.Monad.Trans.Resource (ResourceT, runResourceT) +-- I'm too lazy to rewrite code below+withManager :: (Manager -> ResourceT IO a) -> IO a+withManager = withManagerSettings tlsManagerSettings++withManagerSettings :: ManagerSettings -> (Manager -> ResourceT IO a) -> IO a+withManagerSettings set f = newManager set >>= (runResourceT . f)+ past :: UTCTime past = UTCTime (ModifiedJulianDay 56200) (secondsToDiffTime 0) @@ -174,49 +183,49 @@ it "throws exception on 404" $ withApp app $ \port -> do elbs <- try $ simpleHttp $ concat ["http://127.0.0.1:", show port, "/404"] case elbs of- Left (StatusCodeException _ _ _) -> return ()+ Left (HttpExceptionRequest _ StatusCodeException {}) -> return () _ -> error "Expected an exception" describe "httpLbs" $ do it "preserves 'set-cookie' headers" $ withApp app $ \port -> do- request <- parseUrl $ concat ["http://127.0.0.1:", show port, "/cookies"]+ request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/cookies"] withManager $ \manager -> do response <- httpLbs request manager let setCookie = mk (fromString "Set-Cookie") (setCookieHeaders, _) = partition ((== setCookie) . fst) (NHC.responseHeaders response) liftIO $ assertBool "response contains a 'set-cookie' header" $ length setCookieHeaders > 0 it "redirects set cookies" $ withApp app $ \port -> do- request <- parseUrl $ concat ["http://127.0.0.1:", show port, "/cookie_redir1"]+ request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/cookie_redir1"] withManager $ \manager -> do response <- httpLbs request manager liftIO $ (responseBody response) @?= "nom-nom-nom" it "user-defined cookie jar works" $ withApp app $ \port -> do- request <- parseUrl $ concat ["http://127.0.0.1:", show port, "/dump_cookies"]+ request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/dump_cookies"] withManager $ \manager -> do response <- httpLbs (request {redirectCount = 1, cookieJar = Just cookie_jar}) manager liftIO $ (responseBody response) @?= "key=value" it "user-defined cookie jar is not ignored when redirection is disabled" $ withApp app $ \port -> do- request <- parseUrl $ concat ["http://127.0.0.1:", show port, "/dump_cookies"]+ request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/dump_cookies"] withManager $ \manager -> do response <- httpLbs (request {redirectCount = 0, cookieJar = Just cookie_jar}) manager liftIO $ (responseBody response) @?= "key=value" it "cookie jar is available in response" $ withApp app $ \port -> do- request <- parseUrl $ concat ["http://127.0.0.1:", show port, "/cookies"]+ request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/cookies"] withManager $ \manager -> do- response <- httpLbs (request {cookieJar = Just def}) manager+ response <- httpLbs (request {cookieJar = Just Data.Monoid.mempty}) manager liftIO $ (length $ destroyCookieJar $ responseCookieJar response) @?= 1 it "Cookie header isn't touched when no cookie jar supplied" $ withApp app $ \port -> do- request <- parseUrl $ concat ["http://127.0.0.1:", show port, "/dump_cookies"]+ request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/dump_cookies"] withManager $ \manager -> do let request_headers = (mk "Cookie", "key2=value2") : filter ((/= mk "Cookie") . fst) (NHC.requestHeaders request) response <- httpLbs (request {NHC.requestHeaders = request_headers, cookieJar = Nothing}) manager liftIO $ (responseBody response) @?= "key2=value2" it "Response cookie jar is nothing when request cookie jar is nothing" $ withApp app $ \port -> do- request <- parseUrl $ concat ["http://127.0.0.1:", show port, "/cookies"]+ request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/cookies"] withManager $ \manager -> do response <- httpLbs (request {cookieJar = Nothing}) manager- liftIO $ (responseCookieJar response) @?= def+ liftIO $ (responseCookieJar response) @?= mempty it "TLS" $ withAppTls app $ \port -> do- request <- parseUrl $ "https://127.0.0.1:" ++ show port+ request <- parseUrlThrow $ "https://127.0.0.1:" ++ show port let set = mkManagerSettings def { settingDisableCertificateValidation = True@@ -228,8 +237,8 @@ it "closes all connections" $ withApp app $ \port1 -> withApp app $ \port2 -> do --FIXME clearSocketsList withManager $ \manager -> do- let Just req1 = parseUrl $ "http://127.0.0.1:" ++ show port1- let Just req2 = parseUrl $ "http://127.0.0.1:" ++ show port2+ let Just req1 = parseUrlThrow $ "http://127.0.0.1:" ++ show port1+ let Just req2 = parseUrlThrow $ "http://127.0.0.1:" ++ show port2 _res1a <- http req1 manager _res1b <- http req1 manager _res2 <- http req2 manager@@ -238,7 +247,7 @@ describe "http" $ do it "response body" $ withApp app $ \port -> do withManager $ \manager -> do- req <- liftIO $ parseUrl $ "http://127.0.0.1:" ++ show port+ req <- liftIO $ parseUrlThrow $ "http://127.0.0.1:" ++ show port res1 <- http req manager bss <- responseBody res1 $$+- CL.consume res2 <- httpLbs req manager@@ -246,21 +255,21 @@ describe "DOS protection" $ do it "overlong headers" $ overLongHeaders $ \port -> do withManager $ \manager -> do- let Just req1 = parseUrl $ "http://127.0.0.1:" ++ show port+ let Just req1 = parseUrlThrow $ "http://127.0.0.1:" ++ show port res1 <- try $ http req1 manager case res1 of- Left e -> liftIO $ show (e :: SomeException) @?= show OverlongHeaders+ Left e -> liftIO $ show (e :: SomeException) @?= show (HttpExceptionRequest req1 OverlongHeaders) _ -> error "Shouldn't have worked" it "not overlong headers" $ notOverLongHeaders $ \port -> do withManager $ \manager -> do- let Just req1 = parseUrl $ "http://127.0.0.1:" ++ show port+ let Just req1 = parseUrlThrow $ "http://127.0.0.1:" ++ show port _ <- httpLbs req1 manager return () describe "redirects" $ do it "doesn't double escape" $ redir $ \port -> do withManager $ \manager -> do let go (encoded, final) = do- let Just req1 = parseUrl $ concat ["http://127.0.0.1:", show port, "/redir/", encoded]+ let Just req1 = parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/redir/", encoded] res <- httpLbs req1 manager liftIO $ Network.HTTP.Conduit.responseStatus res @?= status200 liftIO $ responseBody res @?= L.fromChunks [TE.encodeUtf8 final]@@ -272,19 +281,19 @@ , ("hello%20world%3f%23", "hello world?#") ] it "TooManyRedirects: redirect request body is preserved" $ withApp app $ \port -> do- let Just req = parseUrl $ concat ["http://127.0.0.1:", show port, "/infredir/0"]+ let Just req = parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/infredir/0"] let go (res, i) = liftIO $ responseBody res @?= (L8.pack $ show i) E.catch (withManager $ \manager -> do void $ http req{redirectCount=5} manager) $ \e -> case e of- TooManyRedirects redirs ->+ HttpExceptionRequest _ (TooManyRedirects redirs) -> mapM_ go (zip redirs [5,4..0 :: Int]) _ -> error $ show e describe "chunked request body" $ do it "works" $ echo $ \port -> do withManager $ \manager -> do let go bss = do- let Just req1 = parseUrl $ "POST http://127.0.0.1:" ++ show port+ let Just req1 = parseUrlThrow $ "POST http://127.0.0.1:" ++ show port src = sourceList bss lbs = L.fromChunks bss res <- httpLbs req1@@ -299,7 +308,7 @@ ] describe "no status message" $ do it "works" $ noStatusMessage $ \port -> do- req <- parseUrl $ "http://127.0.0.1:" ++ show port+ req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port withManager $ \manager -> do res <- httpLbs req manager liftIO $ do@@ -308,49 +317,49 @@ describe "response body too short" $ do it "throws an exception" $ wrongLength $ \port -> do- req <- parseUrl $ "http://127.0.0.1:" ++ show port+ req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port withManager $ \manager -> do eres <- try $ httpLbs req manager liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres- `shouldBe` Left (show $ ResponseBodyTooShort 50 18)+ `shouldBe` Left (show $ HttpExceptionRequest req $ ResponseBodyTooShort 50 18) describe "chunked response body" $ do it "no chunk terminator" $ wrongLengthChunk1 $ \port -> do- req <- parseUrl $ "http://127.0.0.1:" ++ show port+ req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port withManager $ \manager -> do eres <- try $ httpLbs req manager liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres- `shouldBe` Left (show IncompleteHeaders)+ `shouldBe` Left (show (HttpExceptionRequest req IncompleteHeaders)) it "incomplete chunk" $ wrongLengthChunk2 $ \port -> do- req <- parseUrl $ "http://127.0.0.1:" ++ show port+ req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port withManager $ \manager -> do eres <- try $ httpLbs req manager liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres- `shouldBe` Left (show InvalidChunkHeaders)+ `shouldBe` Left (show (HttpExceptionRequest req InvalidChunkHeaders)) it "invalid chunk" $ invalidChunk $ \port -> do- req <- parseUrl $ "http://127.0.0.1:" ++ show port+ req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port withManager $ \manager -> do eres <- try $ httpLbs req manager liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres- `shouldBe` Left (show InvalidChunkHeaders)+ `shouldBe` Left (show (HttpExceptionRequest req InvalidChunkHeaders)) it "missing header" $ rawApp "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nabcd\r\n\r\n\r\n" $ \port -> do- req <- parseUrl $ "http://127.0.0.1:" ++ show port+ req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port withManager $ \manager -> do eres <- try $ httpLbs req manager liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres- `shouldBe` Left (show InvalidChunkHeaders)+ `shouldBe` Left (show (HttpExceptionRequest req InvalidChunkHeaders)) it "junk header" $ rawApp "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nabcd\r\njunk\r\n\r\n" $ \port -> do- req <- parseUrl $ "http://127.0.0.1:" ++ show port+ req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port withManager $ \manager -> do eres <- try $ httpLbs req manager liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres- `shouldBe` Left (show InvalidChunkHeaders)+ `shouldBe` Left (show (HttpExceptionRequest req InvalidChunkHeaders)) describe "redirect" $ do it "ignores large response bodies" $ do@@ -359,7 +368,7 @@ ["foo"] -> return $ responseLBS status200 [] "Hello World!" _ -> return $ responseSource status301 [("location", S8.pack $ "http://127.0.0.1:" ++ show port ++ "/foo")] $ forever $ yield $ Chunk $ fromByteString "hello\n" withApp' app' $ \port -> withManager $ \manager -> do- req <- liftIO $ parseUrl $ "http://127.0.0.1:" ++ show port+ req <- liftIO $ parseUrlThrow $ "http://127.0.0.1:" ++ show port res <- httpLbs req manager liftIO $ do Network.HTTP.Conduit.responseStatus res `shouldBe` status200@@ -392,7 +401,7 @@ _ <- appSource app' $$ await yield "HTTP/1.0 200 OK\r\n\r\nThis is it!" $$ appSink app' withCApp baseHTTP $ \port -> withManager $ \manager -> do- req <- liftIO $ parseUrl $ "http://127.0.0.1:" ++ show port+ req <- liftIO $ parseUrlThrow $ "http://127.0.0.1:" ++ show port res1 <- httpLbs req manager res2 <- httpLbs req manager liftIO $ res1 @?= res2@@ -400,33 +409,33 @@ describe "hostAddress" $ do it "overrides host" $ withApp app $ \port -> do entry <- Network.BSD.getHostByName "127.0.0.1"- req' <- parseUrl $ "http://example.com:" ++ show port+ req' <- parseUrlThrow $ "http://example.com:" ++ show port let req = req' { hostAddress = Just $ Network.BSD.hostAddress entry } res <- withManager $ httpLbs req responseBody res @?= "homepage for example.com" describe "managerResponseTimeout" $ do it "works" $ withApp app $ \port -> do- req1 <- parseUrl $ "http://localhost:" ++ show port- let req2 = req1 { responseTimeout = Just 5000000 }- withManagerSettings conduitManagerSettings { managerResponseTimeout = Just 1 } $ \man -> do+ req1 <- parseUrlThrow $ "http://localhost:" ++ show port+ let req2 = req1 { responseTimeout = responseTimeoutMicro 5000000 }+ withManagerSettings tlsManagerSettings { managerResponseTimeout = responseTimeoutMicro 1 } $ \man -> do eres1 <- try $ httpLbs req1 { NHC.path = "/delayed" } man case eres1 of- Left (FailedConnectionException _ _) -> return ()+ Left (HttpExceptionRequest _ ConnectionTimeout{}) -> return () _ -> error "Did not time out" _ <- httpLbs req2 man return () describe "delayed body" $ do it "works" $ withApp app $ \port -> do- req <- parseUrl $ "http://localhost:" ++ show port ++ "/delayed"+ req <- parseUrlThrow $ "http://localhost:" ++ show port ++ "/delayed" withManager $ \man -> do _ <- http req man return () it "reuse/connection close tries again" $ do withAppSettings (setTimeout 1) (const app) $ \port -> do- req <- parseUrl $ "http://localhost:" ++ show port+ req <- parseUrlThrow $ "http://localhost:" ++ show port withManager $ \man -> do res1 <- httpLbs req man liftIO $ threadDelay 3000000@@ -450,7 +459,7 @@ , ("noval", Nothing) ] withManager $ \man -> do- req <- parseUrl $ "http://localhost:" ++ show port+ req <- parseUrlThrow $ "http://localhost:" ++ show port _ <- httpLbs (setQueryString qs req) man return () res <- I.readIORef ref@@ -458,7 +467,7 @@ describe "Simple" $ do it "JSON" $ jsonApp $ \port -> do- req <- parseUrl $ "http://localhost:" ++ show port+ req <- parseUrlThrow $ "http://localhost:" ++ show port value <- Simple.httpJSON req responseBody value `shouldBe` jsonValue @@ -469,7 +478,7 @@ mapM_ (S.hPutStr tmph) bss hClose tmph - let Just req1 = parseUrl $ "POST http://127.0.0.1:" ++ show port+ let Just req1 = parseUrlThrow $ "POST http://127.0.0.1:" ++ show port lbs = L.fromChunks bss res <- httpLbs req1 { requestBody = RequestBodyIO (streamFile tmpfp)