diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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) diff --git a/Network/HTTP/Client/Conduit.hs b/Network/HTTP/Client/Conduit.hs --- a/Network/HTTP/Client/Conduit.hs +++ b/Network/HTTP/Client/Conduit.hs @@ -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) diff --git a/Network/HTTP/Conduit.hs b/Network/HTTP/Conduit.hs --- a/Network/HTTP/Conduit.hs +++ b/Network/HTTP/Conduit.hs @@ -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 diff --git a/Network/HTTP/Simple.hs b/Network/HTTP/Simple.hs --- a/Network/HTTP/Simple.hs +++ b/Network/HTTP/Simple.hs @@ -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 -- diff --git a/http-conduit.cabal b/http-conduit.cabal --- a/http-conduit.cabal +++ b/http-conduit.cabal @@ -1,5 +1,5 @@ name: http-conduit -version: 2.1.11 +version: 2.2.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -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 diff --git a/test/CookieTest.hs b/test/CookieTest.hs --- a/test/CookieTest.hs +++ b/test/CookieTest.hs @@ -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 diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -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)