summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMichaelSnoyman <>2018-01-16 15:44:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-01-16 15:44:00 (GMT)
commit54941b227a01db140b75115a4a220af093566556 (patch)
tree26758a32d0ce2f9dda8d104357f36d00b8ab89bd
parent23f62319d6d33fa5b7ab5609eb53d4163b57c040 (diff)
version 2.3.02.3.0
-rw-r--r--ChangeLog.md11
-rw-r--r--Network/HTTP/Client/Conduit.hs39
-rw-r--r--Network/HTTP/Conduit.hs55
-rw-r--r--Network/HTTP/Simple.hs54
-rw-r--r--http-conduit.cabal17
-rw-r--r--test/main.hs349
6 files changed, 250 insertions, 275 deletions
diff --git a/ChangeLog.md b/ChangeLog.md
index dfc8eba..ba19222 100644
--- 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
index d8da489..1aca0a5 100644
--- a/Network/HTTP/Client/Conduit.hs
+++ b/Network/HTTP/Client/Conduit.hs
@@ -19,8 +19,6 @@ module Network.HTTP.Client.Conduit
-- * Manager helpers
, defaultManagerSettings
, newManager
- , withManager
- , withManagerSettings
, newManagerSettings
-- * General HTTP client interface
, module Network.HTTP.Client
@@ -33,21 +31,20 @@ module Network.HTTP.Client.Conduit
) 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 @@ import Network.HTTP.Client.TLS (tlsManagerSettings)
--
-- * 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 @@ newManager = newManagerSettings defaultManagerSettings
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 @@ responseClose = liftIO . H.responseClose
bodyReaderSource :: MonadIO m
=> H.BodyReader
- -> Producer m ByteString
+ -> ConduitM i ByteString m ()
bodyReaderSource br =
loop
where
@@ -142,13 +127,13 @@ bodyReaderSource br =
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
index 978807e..34f46f9 100644
--- a/Network/HTTP/Conduit.hs
+++ b/Network/HTTP/Conduit.hs
@@ -181,11 +181,8 @@ module Network.HTTP.Conduit
, Manager
, newManager
, closeManager
- , withManager
- , withManagerSettings
-- ** Settings
, ManagerSettings
- , conduitManagerSettings
, tlsManagerSettings
, mkManagerSettings
, managerConnCount
@@ -225,13 +222,12 @@ module Network.HTTP.Conduit
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 @@ simpleHttp url = liftIO $ do
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 @@ lbsResponse res = do
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 @@ srcToPopper src f = runResourceT $ do
| 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
index 22a0927..18789a7 100644
--- a/Network/HTTP/Simple.hs
+++ b/Network/HTTP/Simple.hs
@@ -79,7 +79,7 @@ import qualified Network.HTTP.Client.Internal as HI
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 qualified Data.Traversable as T
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 @@ instance Exception JSONException
-- | 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 @@ httpSource req withRes = do
-- 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 @@ setRequestHeader name vals req =
++ (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 @@ setRequestBodyLBS = setRequestBody . H.RequestBodyLBS
--
-- @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 @@ setRequestBodyFile = setRequestBody . HI.RequestBodyIO . H.streamFile
-- | 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
index e753c4a..c9f42ac 100644
--- 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 <michael@snoyman.com>
@@ -25,16 +25,17 @@ library
, 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 @@ test-suite test
, 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
index 38b617e..599b76c 100644
--- a/test/main.hs
+++ b/test/main.hs
@@ -12,15 +12,15 @@ import Network.HTTP.Client (streamFile)
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 @@ import Data.Conduit.Network (runTCPServer, serverSettings, HostPreference (..),
#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 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)
+import Control.Monad.Trans.Resource (runResourceT)
past :: UTCTime
past = UTCTime (ModifiedJulianDay 56200) (secondsToDiffTime 0)
@@ -122,7 +115,7 @@ getPort = do
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 @@ main = do
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 @@ main = do
{ 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 @@ main = do
--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 @@ main = do
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 @@ main = do
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 @@ main = do
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 @@ main = do
, (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 @@ main = do
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
-
- 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"
- ]
+ 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"
+ ]
withCApp :: (Data.Conduit.Network.AppData -> IO ()) -> (Int -> IO ()) -> IO ()
withCApp app' f = do
@@ -509,14 +508,14 @@ withCApp app' f = do
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 @@ redir =
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 @@ wrongLength =
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