diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,14 @@ +## 2.3.0 + +* conduit 1.3 support + * NOTE: Even for older versions of conduit, this includes dropping + support for finalizers +* `http` returns a `Source` instead of a `ResumableSource` (due to lack of + finalizers) +* Drop monad-control for unliftio +* Removed some deprecated functions: `withManager`, `withManagerSettings`, + `conduitManagerSettings` + ## 2.2.4 * Add `httpBS` to `Network.HTTP.Simple` 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 @@ -19,8 +19,6 @@ -- * Manager helpers , defaultManagerSettings , newManager - , withManager - , withManagerSettings , newManagerSettings -- * General HTTP client interface , module Network.HTTP.Client @@ -33,21 +31,20 @@ ) where import Control.Monad (unless) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Reader (MonadReader (..), ReaderT (..)) -import Control.Monad.Trans.Control (MonadBaseControl) +import Control.Monad.IO.Unlift (MonadIO, liftIO, MonadUnliftIO, withRunInIO) +import Control.Monad.Reader (MonadReader (..)) import Data.Acquire (Acquire, mkAcquire, with) import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L -import Data.Conduit (ConduitM, Producer, Source, - await, yield, ($$+), ($$++)) +import Data.Conduit (ConduitM, ($$+), + await, yield, ($$++)) import Data.Int (Int64) import Data.IORef (newIORef, readIORef, writeIORef) import Network.HTTP.Client hiding (closeManager, defaultManagerSettings, httpLbs, newManager, responseClose, - responseOpen, withManager, + responseOpen, withResponse, BodyReader, brRead, brConsume, httpNoBody) import qualified Network.HTTP.Client as H import Network.HTTP.Client.TLS (tlsManagerSettings) @@ -56,18 +53,18 @@ -- -- * Response body is represented as a @Producer@. -- --- * Generalized to any instance of @MonadBaseControl@, not just @IO@. +-- * Generalized to any instance of @MonadUnliftIO@, not just @IO@. -- -- * The @Manager@ is contained by a @MonadReader@ context. -- -- Since 2.1.0 -withResponse :: (MonadBaseControl IO m, MonadIO n, MonadReader env m, HasHttpManager env) +withResponse :: (MonadUnliftIO m, MonadIO n, MonadReader env m, HasHttpManager env) => Request -> (Response (ConduitM i ByteString n ()) -> m a) -> m a withResponse req f = do env <- ask - with (acquireResponse req env) f + withRunInIO $ \run -> with (acquireResponse req env) (run . f) -- | An @Acquire@ for getting a @Response@. -- @@ -100,18 +97,6 @@ newManagerSettings :: MonadIO m => ManagerSettings -> m Manager newManagerSettings = liftIO . H.newManager --- | Get a new manager with 'defaultManagerSettings' and construct a @ReaderT@ containing it. --- --- Since 2.1.0 -withManager :: MonadIO m => (ReaderT Manager m a) -> m a -withManager = withManagerSettings defaultManagerSettings - --- | Get a new manager with the given settings and construct a @ReaderT@ containing it. --- --- Since 2.1.0 -withManagerSettings :: MonadIO m => ManagerSettings -> (ReaderT Manager m a) -> m a -withManagerSettings settings (ReaderT inner) = newManagerSettings settings >>= inner - -- | Conduit-powered version of 'H.responseOpen'. -- -- See 'withResponse' for the differences with 'H.responseOpen'. @@ -132,7 +117,7 @@ bodyReaderSource :: MonadIO m => H.BodyReader - -> Producer m ByteString + -> ConduitM i ByteString m () bodyReaderSource br = loop where @@ -142,13 +127,13 @@ yield bs loop -requestBodySource :: Int64 -> Source IO ByteString -> RequestBody +requestBodySource :: Int64 -> ConduitM () ByteString IO () -> RequestBody requestBodySource size = RequestBodyStream size . srcToPopperIO -requestBodySourceChunked :: Source IO ByteString -> RequestBody +requestBodySourceChunked :: ConduitM () ByteString IO () -> RequestBody requestBodySourceChunked = RequestBodyStreamChunked . srcToPopperIO -srcToPopperIO :: Source IO ByteString -> GivesPopper () +srcToPopperIO :: ConduitM () ByteString IO () -> GivesPopper () srcToPopperIO src f = do (rsrc0, ()) <- src $$+ return () irsrc <- newIORef rsrc0 diff --git a/Network/HTTP/Conduit.hs b/Network/HTTP/Conduit.hs --- a/Network/HTTP/Conduit.hs +++ b/Network/HTTP/Conduit.hs @@ -181,11 +181,8 @@ , Manager , newManager , closeManager - , withManager - , withManagerSettings -- ** Settings , ManagerSettings - , conduitManagerSettings , tlsManagerSettings , mkManagerSettings , managerConnCount @@ -225,13 +222,12 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L -import Data.Conduit (ResumableSource, ($$+-), await, ($$++), ($$+), Source, addCleanup) -import qualified Data.Conduit.Internal as CI +import Data.Conduit import qualified Data.Conduit.List as CL import Data.IORef (readIORef, writeIORef, newIORef) import Data.Int (Int64) import Control.Applicative as A ((<$>)) -import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.IO.Unlift (MonadIO (liftIO)) import Control.Monad.Trans.Resource import qualified Network.HTTP.Client as Client (httpLbs, responseOpen, responseClose) @@ -301,31 +297,14 @@ req <- liftIO $ parseUrlThrow url responseBody A.<$> httpLbs (setConnectionClose req) man -conduitManagerSettings :: ManagerSettings -conduitManagerSettings = tlsManagerSettings -{-# DEPRECATED conduitManagerSettings "Use tlsManagerSettings" #-} - -withManager :: (MonadIO m, MonadBaseControl IO m) - => (Manager -> ResourceT m a) - -> m a -withManager = withManagerSettings tlsManagerSettings -{-# DEPRECATED withManager "Please use newManager tlsManagerSettings" #-} - -withManagerSettings :: (MonadIO m, MonadBaseControl IO m) - => ManagerSettings - -> (Manager -> ResourceT m a) - -> m a -withManagerSettings set f = liftIO (newManager set) >>= runResourceT . f -{-# DEPRECATED withManagerSettings "Please use newManager" #-} - setConnectionClose :: Request -> Request setConnectionClose req = req{requestHeaders = ("Connection", "close") : requestHeaders req} lbsResponse :: Monad m - => Response (ResumableSource m S.ByteString) + => Response (ConduitM () S.ByteString m ()) -> m (Response L.ByteString) lbsResponse res = do - bss <- responseBody res $$+- CL.consume + bss <- runConduit $ responseBody res .| CL.consume return res { responseBody = L.fromChunks bss } @@ -333,27 +312,21 @@ http :: MonadResource m => Request -> Manager - -> m (Response (ResumableSource m S.ByteString)) + -> m (Response (ConduitM i S.ByteString m ())) http req man = do (key, res) <- allocate (Client.responseOpen req man) Client.responseClose -#if MIN_VERSION_conduit(1, 2, 0) - let rsrc = CI.ResumableSource - (flip CI.unConduitM CI.Done $ addCleanup (const $ release key) $ HCC.bodyReaderSource $ responseBody res) - (release key) -#else - let rsrc = CI.ResumableSource - (addCleanup (const $ release key) $ HCC.bodyReaderSource $ responseBody res) - (release key) -#endif - return res { responseBody = rsrc } + return res { responseBody = do + HCC.bodyReaderSource $ responseBody res + release key + } -requestBodySource :: Int64 -> Source (ResourceT IO) S.ByteString -> RequestBody +requestBodySource :: Int64 -> ConduitM () S.ByteString (ResourceT IO) () -> RequestBody requestBodySource size = RequestBodyStream size . srcToPopper -requestBodySourceChunked :: Source (ResourceT IO) S.ByteString -> RequestBody +requestBodySourceChunked :: ConduitM () S.ByteString (ResourceT IO) () -> RequestBody requestBodySourceChunked = RequestBodyStreamChunked . srcToPopper -srcToPopper :: Source (ResourceT IO) S.ByteString -> HCC.GivesPopper () +srcToPopper :: ConduitM () S.ByteString (ResourceT IO) () -> HCC.GivesPopper () srcToPopper src f = runResourceT $ do (rsrc0, ()) <- src $$+ return () irsrc <- liftIO $ newIORef rsrc0 @@ -370,8 +343,8 @@ | otherwise -> return bs liftIO $ f popper -requestBodySourceIO :: Int64 -> Source IO S.ByteString -> RequestBody +requestBodySourceIO :: Int64 -> ConduitM () S.ByteString IO () -> RequestBody requestBodySourceIO = HCC.requestBodySource -requestBodySourceChunkedIO :: Source IO S.ByteString -> RequestBody +requestBodySourceChunkedIO :: ConduitM () S.ByteString IO () -> RequestBody requestBodySourceChunkedIO = HCC.requestBodySourceChunked diff --git a/Network/HTTP/Simple.hs b/Network/HTTP/Simple.hs --- a/Network/HTTP/Simple.hs +++ b/Network/HTTP/Simple.hs @@ -79,7 +79,7 @@ import qualified Network.HTTP.Client.TLS as H import Network.HTTP.Client.Conduit (bodyReaderSource) import qualified Network.HTTP.Client.Conduit as HC -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.IO.Unlift (MonadIO, liftIO, MonadUnliftIO, withRunInIO) import Data.Aeson (FromJSON (..), Value) import Data.Aeson.Parser (json') import qualified Data.Aeson.Types as A @@ -88,11 +88,13 @@ import Control.Exception (throwIO, Exception) import Data.Typeable (Typeable) import qualified Data.Conduit as C +import Data.Conduit (runConduit, (.|), ConduitM) import qualified Data.Conduit.Attoparsec as C -import qualified Control.Monad.Catch as Catch import qualified Network.HTTP.Types as H import Data.Int (Int64) import Control.Monad.Trans.Resource (MonadResource) +import qualified Control.Exception as E (bracket) +import Data.Void (Void) -- | Perform an HTTP request and return the body as a @ByteString@. -- @@ -161,17 +163,19 @@ -- | Perform an HTTP request and consume the body with the given 'C.Sink' -- -- @since 2.1.10 -httpSink :: (MonadIO m, Catch.MonadMask m) +httpSink :: MonadUnliftIO m => H.Request - -> (H.Response () -> C.Sink S.ByteString m a) + -> (H.Response () -> ConduitM S.ByteString Void m a) -> m a -httpSink req sink = do - man <- liftIO H.getGlobalManager - Catch.bracket - (liftIO $ H.responseOpen req man) - (liftIO . H.responseClose) - (\res -> bodyReaderSource (getResponseBody res) - C.$$ sink (fmap (const ()) res)) +httpSink req sink = withRunInIO $ \run -> do + man <- H.getGlobalManager + E.bracket + (H.responseOpen req man) + H.responseClose + $ \res -> run + $ runConduit + $ bodyReaderSource (getResponseBody res) + .| sink (fmap (const ()) res) -- | Perform an HTTP request, and get the response body as a Source. -- @@ -221,16 +225,16 @@ -- value. -- -- @since 2.2.3 -withResponse :: (MonadIO m, Catch.MonadMask m, MonadIO n) +withResponse :: (MonadUnliftIO m, MonadIO n) => H.Request -> (H.Response (C.ConduitM i S.ByteString n ()) -> m a) -> m a -withResponse req withRes = do - man <- liftIO H.getGlobalManager - Catch.bracket - (liftIO (H.responseOpen req man)) - (liftIO . H.responseClose) - (withRes . fmap bodyReaderSource) +withResponse req withRes = withRunInIO $ \run -> do + man <- H.getGlobalManager + E.bracket + (H.responseOpen req man) + H.responseClose + (run . withRes . fmap bodyReaderSource) -- | Alternate spelling of 'httpLBS' -- @@ -294,7 +298,11 @@ ++ (map (name, ) vals) } --- | Set the request headers, wiping out any previously set headers +-- | Set the request headers, wiping out __all__ previously set headers. This +-- means if you use 'setRequestHeaders' to set some headers and also use one of +-- the other setters that modifies the @content-type@ header (such as +-- 'setRequestBodyJSON'), be sure that 'setRequestHeaders' is evaluated +-- __first__. -- -- @since 2.1.10 setRequestHeaders :: [(H.HeaderName, S.ByteString)] -> H.Request -> H.Request @@ -355,7 +363,7 @@ -- -- @since 2.1.10 setRequestBodySource :: Int64 -- ^ length of source - -> C.Source IO S.ByteString + -> ConduitM () S.ByteString IO () -> H.Request -> H.Request setRequestBodySource len src req = req { H.requestBody = HC.requestBodySource len src } @@ -371,10 +379,8 @@ -- | Set the request body as URL encoded data -- --- /Note/: This will not modify the request method. For that, please use --- 'requestMethod'. You likely don't want the default of @GET@. --- --- This also sets the @content-type@ to @application/x-www-form-urlencoded@ +-- /Note/: This will change the request method to @POST@ and set the @content-type@ +-- to @application/x-www-form-urlencoded@ -- -- @since 2.1.10 setRequestBodyURLEncoded :: [(S.ByteString, S.ByteString)] -> H.Request -> H.Request 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.2.4 +version: 2.3.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -25,16 +25,17 @@ , aeson >= 0.8 , bytestring >= 0.9.1.4 , transformers >= 0.2 - , resourcet >= 1.1 && < 1.2 - , conduit >= 0.5.5 && < 1.3 - , conduit-extra >= 1.1.5 + , resourcet >= 1.1 + , conduit >= 1.2 + , conduit-extra >= 1.1 , http-types >= 0.7 - , lifted-base >= 0.1 , http-client >= 0.5 && < 0.6 , http-client-tls >= 0.3 && < 0.4 - , monad-control , mtl - , exceptions >= 0.6 + , unliftio-core + + if !impl(ghc>=7.9) + build-depends: void >= 0.5.5 exposed-modules: Network.HTTP.Conduit Network.HTTP.Client.Conduit Network.HTTP.Simple @@ -62,7 +63,7 @@ , conduit >= 1.1 , utf8-string , case-insensitive - , lifted-base + , unliftio , network , wai >= 3.0 && < 3.3 , warp >= 3.0.0.2 && < 3.3 diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -12,15 +12,15 @@ 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, withManager, withManagerSettings) +import Network.HTTP.Conduit hiding (port) import qualified Network.HTTP.Conduit as NHC import Network.HTTP.Client.MultipartFormData import Control.Concurrent (forkIO, killThread, putMVar, takeMVar, newEmptyMVar, threadDelay) import Network.HTTP.Types -import Control.Exception.Lifted (try, SomeException, bracket, onException, IOException) +import UnliftIO.Exception (try, SomeException, bracket, onException, IOException) import qualified Data.IORef as I import qualified Control.Exception as E (catch) -import Network.Socket (sClose) +import qualified Network.Socket as NS import qualified Network.BSD import CookieTest (cookieTest) #if MIN_VERSION_conduit(1,1,0) @@ -32,7 +32,7 @@ #endif import qualified Data.Conduit.Network import System.IO.Unsafe (unsafePerformIO) -import Data.Conduit (($$), ($$+-), yield, Flush (Chunk, Flush), await) +import Data.Conduit ((.|), yield, Flush (Chunk, Flush), await, runConduit) import Control.Monad (void, forever) import Control.Monad.IO.Class (liftIO) import Data.ByteString.UTF8 (fromString) @@ -53,14 +53,7 @@ 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) +import Control.Monad.Trans.Resource (runResourceT) past :: UTCTime past = UTCTime (ModifiedJulianDay 56200) (secondsToDiffTime 0) @@ -122,7 +115,7 @@ case esocket of Left (_ :: IOException) -> getPort Right socket -> do - sClose socket + NS.close socket return port withApp :: (Wai.Request -> IO Wai.Response) -> (Int -> IO ()) -> IO () @@ -187,42 +180,42 @@ describe "httpLbs" $ do it "preserves 'set-cookie' headers" $ withApp app $ \port -> do 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 + manager <- newManager tlsManagerSettings + response <- httpLbs request manager + let setCookie = mk (fromString "Set-Cookie") + (setCookieHeaders, _) = partition ((== setCookie) . fst) (NHC.responseHeaders response) + assertBool "response contains a 'set-cookie' header" $ length setCookieHeaders > 0 it "redirects set cookies" $ withApp app $ \port -> do 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" + manager <- newManager tlsManagerSettings + response <- httpLbs request manager + (responseBody response) @?= "nom-nom-nom" it "user-defined cookie jar works" $ withApp app $ \port -> do 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" + manager <- newManager tlsManagerSettings + response <- httpLbs (request {redirectCount = 1, cookieJar = Just cookie_jar}) manager + (responseBody response) @?= "key=value" it "user-defined cookie jar is not ignored when redirection is disabled" $ withApp app $ \port -> do 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" + manager <- newManager tlsManagerSettings + response <- httpLbs (request {redirectCount = 0, cookieJar = Just cookie_jar}) manager + (responseBody response) @?= "key=value" it "cookie jar is available in response" $ withApp app $ \port -> do request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/cookies"] - withManager $ \manager -> do - response <- httpLbs (request {cookieJar = Just Data.Monoid.mempty}) manager - liftIO $ (length $ destroyCookieJar $ responseCookieJar response) @?= 1 + manager <- newManager tlsManagerSettings + response <- httpLbs (request {cookieJar = Just Data.Monoid.mempty}) manager + (length $ destroyCookieJar $ responseCookieJar response) @?= 1 it "Cookie header isn't touched when no cookie jar supplied" $ withApp app $ \port -> do 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" + manager <- newManager tlsManagerSettings + let request_headers = (mk "Cookie", "key2=value2") : filter ((/= mk "Cookie") . fst) (NHC.requestHeaders request) + response <- httpLbs (request {NHC.requestHeaders = request_headers, cookieJar = Nothing}) manager + (responseBody response) @?= "key2=value2" it "Response cookie jar is nothing when request cookie jar is nothing" $ withApp app $ \port -> do request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/cookies"] - withManager $ \manager -> do - response <- httpLbs (request {cookieJar = Nothing}) manager - liftIO $ (responseCookieJar response) @?= mempty + manager <- newManager tlsManagerSettings + response <- httpLbs (request {cookieJar = Nothing}) manager + (responseCookieJar response) @?= mempty it "TLS" $ withAppTls app $ \port -> do request <- parseUrlThrow $ "https://127.0.0.1:" ++ show port let set = mkManagerSettings @@ -230,14 +223,16 @@ { settingDisableCertificateValidation = True } Nothing - response <- withManagerSettings set $ httpLbs request + manager <- newManager set + response <- httpLbs request manager responseBody response @?= "homepage" describe "manager" $ do it "closes all connections" $ withApp app $ \port1 -> withApp app $ \port2 -> do --FIXME clearSocketsList - withManager $ \manager -> do - let Just req1 = parseUrlThrow $ "http://127.0.0.1:" ++ show port1 - let Just req2 = parseUrlThrow $ "http://127.0.0.1:" ++ show port2 + manager <- newManager tlsManagerSettings + let Just req1 = parseUrlThrow $ "http://127.0.0.1:" ++ show port1 + let Just req2 = parseUrlThrow $ "http://127.0.0.1:" ++ show port2 + runResourceT $ do _res1a <- http req1 manager _res1b <- http req1 manager _res2 <- http req2 manager @@ -245,120 +240,122 @@ --FIXME requireAllSocketsClosed describe "http" $ do it "response body" $ withApp app $ \port -> do - withManager $ \manager -> do - req <- liftIO $ parseUrlThrow $ "http://127.0.0.1:" ++ show port + manager <- newManager tlsManagerSettings + req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port + runResourceT $ do res1 <- http req manager - bss <- responseBody res1 $$+- CL.consume + bss <- runConduit $ responseBody res1 .| CL.consume res2 <- httpLbs req manager liftIO $ L.fromChunks bss `shouldBe` responseBody res2 describe "DOS protection" $ do it "overlong headers" $ overLongHeaders $ \port -> do - withManager $ \manager -> do - 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 (HttpExceptionRequest req1 OverlongHeaders) - _ -> error "Shouldn't have worked" + manager <- newManager tlsManagerSettings + let Just req1 = parseUrlThrow $ "http://127.0.0.1:" ++ show port + res1 <- try $ runResourceT $ http req1 manager + case res1 of + Left e -> 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 = parseUrlThrow $ "http://127.0.0.1:" ++ show port - _ <- httpLbs req1 manager - return () + manager <- newManager tlsManagerSettings + 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 = 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] - mapM_ go - [ ("hello world%2F", "hello world/") - , ("%D7%A9%D7%9C%D7%95%D7%9D", "שלום") - , ("simple", "simple") - , ("hello%20world", "hello world") - , ("hello%20world%3f%23", "hello world?#") - ] + manager <- newManager tlsManagerSettings + let go (encoded, final) = do + 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] + mapM_ go + [ ("hello world%2F", "hello world/") + , ("%D7%A9%D7%9C%D7%95%D7%9D", "שלום") + , ("simple", "simple") + , ("hello%20world", "hello world") + , ("hello%20world%3f%23", "hello world?#") + ] it "TooManyRedirects: redirect request body is preserved" $ withApp app $ \port -> do 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 -> + manager <- newManager tlsManagerSettings + E.catch (void $ runResourceT $ http req{redirectCount=5} manager) + $ \e -> case e of 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 = parseUrlThrow $ "POST http://127.0.0.1:" ++ show port - src = sourceList bss - lbs = L.fromChunks bss - res <- httpLbs req1 - { requestBody = requestBodySourceChunked src - } manager - liftIO $ Network.HTTP.Conduit.responseStatus res @?= status200 - let ts = S.concat . L.toChunks - liftIO $ ts (responseBody res) @?= ts lbs - mapM_ go - [ ["hello", "world"] - , replicate 500 "foo\003\n\r" - ] + manager <- newManager tlsManagerSettings + let go bss = do + let Just req1 = parseUrlThrow $ "POST http://127.0.0.1:" ++ show port + src = sourceList bss + lbs = L.fromChunks bss + res <- httpLbs req1 + { requestBody = requestBodySourceChunked src + } manager + liftIO $ Network.HTTP.Conduit.responseStatus res @?= status200 + let ts = S.concat . L.toChunks + liftIO $ ts (responseBody res) @?= ts lbs + mapM_ go + [ ["hello", "world"] + , replicate 500 "foo\003\n\r" + ] describe "no status message" $ do it "works" $ noStatusMessage $ \port -> do req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port - withManager $ \manager -> do - res <- httpLbs req manager - liftIO $ do - Network.HTTP.Conduit.responseStatus res `shouldBe` status200 - responseBody res `shouldBe` "foo" + manager <- newManager tlsManagerSettings + res <- httpLbs req manager + liftIO $ do + Network.HTTP.Conduit.responseStatus res `shouldBe` status200 + responseBody res `shouldBe` "foo" describe "response body too short" $ do it "throws an exception" $ wrongLength $ \port -> do 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 $ HttpExceptionRequest req $ ResponseBodyTooShort 50 18) + manager <- newManager tlsManagerSettings + eres <- try $ httpLbs req manager + liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres + `shouldBe` Left (show $ HttpExceptionRequest req $ ResponseBodyTooShort 50 18) describe "chunked response body" $ do it "no chunk terminator" $ wrongLengthChunk1 $ \port -> do 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 (HttpExceptionRequest req IncompleteHeaders)) + manager <- newManager tlsManagerSettings + eres <- try $ httpLbs req manager + liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres + `shouldBe` Left (show (HttpExceptionRequest req IncompleteHeaders)) it "incomplete chunk" $ wrongLengthChunk2 $ \port -> do 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 (HttpExceptionRequest req InvalidChunkHeaders)) + manager <- newManager tlsManagerSettings + eres <- try $ httpLbs req manager + liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres + `shouldBe` Left (show (HttpExceptionRequest req InvalidChunkHeaders)) it "invalid chunk" $ invalidChunk $ \port -> do 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 (HttpExceptionRequest req InvalidChunkHeaders)) + manager <- newManager tlsManagerSettings + eres <- try $ httpLbs req manager + liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres + `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 <- 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 (HttpExceptionRequest req InvalidChunkHeaders)) + manager <- newManager tlsManagerSettings + eres <- try $ httpLbs req manager + liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres + `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 <- 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 (HttpExceptionRequest req InvalidChunkHeaders)) + manager <- newManager tlsManagerSettings + eres <- try $ httpLbs req manager + liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres + `shouldBe` Left (show (HttpExceptionRequest req InvalidChunkHeaders)) describe "redirect" $ do it "ignores large response bodies" $ do @@ -366,7 +363,8 @@ case pathInfo req of ["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 + manager <- newManager tlsManagerSettings + withApp' app' $ \port -> do req <- liftIO $ parseUrlThrow $ "http://127.0.0.1:" ++ show port res <- httpLbs req manager liftIO $ do @@ -397,9 +395,10 @@ describe "HTTP/1.0" $ do it "BaseHTTP" $ do let baseHTTP app' = do - _ <- appSource app' $$ await - yield "HTTP/1.0 200 OK\r\n\r\nThis is it!" $$ appSink app' - withCApp baseHTTP $ \port -> withManager $ \manager -> do + _ <- runConduit $ appSource app' .| await + runConduit $ yield "HTTP/1.0 200 OK\r\n\r\nThis is it!" .| appSink app' + manager <- newManager tlsManagerSettings + withCApp baseHTTP $ \port -> do req <- liftIO $ parseUrlThrow $ "http://127.0.0.1:" ++ show port res1 <- httpLbs req manager res2 <- httpLbs req manager @@ -410,41 +409,42 @@ entry <- Network.BSD.getHostByName "127.0.0.1" req' <- parseUrlThrow $ "http://example.com:" ++ show port let req = req' { hostAddress = Just $ Network.BSD.hostAddress entry } - res <- withManager $ httpLbs req + manager <- newManager tlsManagerSettings + res <- httpLbs req manager responseBody res @?= "homepage for example.com" describe "managerResponseTimeout" $ do it "works" $ withApp app $ \port -> 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 (HttpExceptionRequest _ ConnectionTimeout{}) -> return () - _ -> error "Did not time out" - _ <- httpLbs req2 man - return () + man <- newManager tlsManagerSettings { managerResponseTimeout = responseTimeoutMicro 1 } + eres1 <- try $ httpLbs req1 { NHC.path = "/delayed" } man + case eres1 of + Left (HttpExceptionRequest _ ConnectionTimeout{}) -> return () + _ -> error "Did not time out" + _ <- httpLbs req2 man + return () describe "delayed body" $ do it "works" $ withApp app $ \port -> do req <- parseUrlThrow $ "http://localhost:" ++ show port ++ "/delayed" - withManager $ \man -> do - _ <- http req man - return () + man <- newManager tlsManagerSettings + _ <- runResourceT $ http req man + return () it "reuse/connection close tries again" $ do withAppSettings (setTimeout 1) (const app) $ \port -> do req <- parseUrlThrow $ "http://localhost:" ++ show port - withManager $ \man -> do - res1 <- httpLbs req man - liftIO $ threadDelay 3000000 - res2 <- httpLbs req man - let f res = res - { NHC.responseHeaders = filter (not . isDate) (NHC.responseHeaders res) - } - isDate ("date", _) = True - isDate _ = False - liftIO $ f res2 `shouldBe` f res1 + man <- newManager tlsManagerSettings + res1 <- httpLbs req man + threadDelay 3000000 + res2 <- httpLbs req man + let f res = res + { NHC.responseHeaders = filter (not . isDate) (NHC.responseHeaders res) + } + isDate ("date", _) = True + isDate _ = False + f res2 `shouldBe` f res1 it "setQueryString" $ do ref <- I.newIORef undefined @@ -457,10 +457,9 @@ , (TE.encodeUtf8 "שלום", Just "hola") , ("noval", Nothing) ] - withManager $ \man -> do - req <- parseUrlThrow $ "http://localhost:" ++ show port - _ <- httpLbs (setQueryString qs req) man - return () + man <- newManager tlsManagerSettings + req <- parseUrlThrow $ "http://localhost:" ++ show port + _ <- httpLbs (setQueryString qs req) man res <- I.readIORef ref res `shouldBe` qs @@ -471,24 +470,24 @@ responseBody value `shouldBe` jsonValue it "RequestBodyIO" $ echo $ \port -> do - withManager $ \manager -> do - let go bss = withSystemTempFile "request-body-io" $ \tmpfp tmph -> do - liftIO $ do - mapM_ (S.hPutStr tmph) bss - hClose tmph + manager <- newManager tlsManagerSettings + let go bss = withSystemTempFile "request-body-io" $ \tmpfp tmph -> do + liftIO $ do + mapM_ (S.hPutStr tmph) bss + hClose tmph - let Just req1 = parseUrlThrow $ "POST http://127.0.0.1:" ++ show port - lbs = L.fromChunks bss - res <- httpLbs req1 - { requestBody = RequestBodyIO (streamFile tmpfp) - } manager - liftIO $ Network.HTTP.Conduit.responseStatus res @?= status200 - let ts = S.concat . L.toChunks - liftIO $ ts (responseBody res) @?= ts lbs - mapM_ go - [ ["hello", "world"] - , replicate 500 "foo\003\n\r" - ] + let Just req1 = parseUrlThrow $ "POST http://127.0.0.1:" ++ show port + lbs = L.fromChunks bss + res <- httpLbs req1 + { requestBody = RequestBodyIO (streamFile tmpfp) + } manager + liftIO $ Network.HTTP.Conduit.responseStatus res @?= status200 + let ts = S.concat . L.toChunks + liftIO $ ts (responseBody res) @?= ts lbs + mapM_ go + [ ["hello", "world"] + , replicate 500 "foo\003\n\r" + ] withCApp :: (Data.Conduit.Network.AppData -> IO ()) -> (Int -> IO ()) -> IO () withCApp app' f = do @@ -509,14 +508,14 @@ overLongHeaders :: (Int -> IO ()) -> IO () overLongHeaders = - withCApp $ \app' -> src $$ appSink app' + withCApp $ \app' -> runConduit $ src .| appSink app' where src = sourceList $ "HTTP/1.0 200 OK\r\nfoo: " : repeat "bar" notOverLongHeaders :: (Int -> IO ()) -> IO () notOverLongHeaders = withCApp $ \app' -> do - appSource app' $$ CL.drop 1 - src $$ appSink app' + runConduit $ appSource app' .| CL.drop 1 + runConduit $ src .| appSink app' where src = sourceList $ [S.concat $ "HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\nContent-Length: 16384\r\n\r\n" : ( take 16384 $ repeat "x")] @@ -556,20 +555,20 @@ echo :: (Int -> IO ()) -> IO () echo = withApp $ \req -> do - bss <- sourceRequestBody req $$ CL.consume + bss <- runConduit $ sourceRequestBody req .| CL.consume return $ responseLBS status200 [] $ L.fromChunks bss noStatusMessage :: (Int -> IO ()) -> IO () noStatusMessage = - withCApp $ \app' -> src $$ appSink app' + withCApp $ \app' -> runConduit $ src .| appSink app' where src = yield "HTTP/1.0 200\r\nContent-Length: 3\r\n\r\nfoo: barbazbin" wrongLength :: (Int -> IO ()) -> IO () wrongLength = withCApp $ \app' -> do - _ <- appSource app' $$ await - src $$ appSink app' + _ <- runConduit $ appSource app' .| await + runConduit $ src .| appSink app' where src = do yield "HTTP/1.0 200 OK\r\nContent-Length: 50\r\n\r\n" @@ -578,32 +577,32 @@ wrongLengthChunk1 :: (Int -> IO ()) -> IO () wrongLengthChunk1 = withCApp $ \app' -> do - _ <- appSource app' $$ await - src $$ appSink app' + _ <- runConduit $ appSource app' .| await + runConduit $ src .| appSink app' where src = yield "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nWiki\r\n" wrongLengthChunk2 :: (Int -> IO ()) -> IO () wrongLengthChunk2 = withCApp $ \app' -> do - _ <- appSource app' $$ await - src $$ appSink app' + _ <- runConduit $ appSource app' .| await + runConduit $ src .| appSink app' where src = yield "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nWiki\r\n5\r\npedia\r\nE\r\nin\r\n\r\nch\r\n" invalidChunk :: (Int -> IO ()) -> IO () invalidChunk = withCApp $ \app' -> do - _ <- appSource app' $$ await - src $$ appSink app' + _ <- runConduit $ appSource app' .| await + runConduit $ src .| appSink app' where src = yield "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nabcd\r\ngarbage\r\nef\r\n0\r\n\r\n" rawApp :: S8.ByteString -> (Int -> IO ()) -> IO () rawApp bs = withCApp $ \app' -> do - _ <- appSource app' $$ await - src $$ appSink app' + _ <- runConduit $ appSource app' .| await + runConduit $ src .| appSink app' where src = yield bs