http-conduit 2.2.4 → 2.3.9.1
raw patch · 8 files changed
Files
- ChangeLog.md +91/−0
- Network/HTTP/Client/Conduit.hs +32/−30
- Network/HTTP/Conduit.hs +34/−53
- Network/HTTP/Simple.hs +118/−30
- README.md +1/−1
- http-conduit.cabal +34/−18
- test/CookieTest.hs +38/−16
- test/main.hs +193/−183
ChangeLog.md view
@@ -1,3 +1,94 @@+# ChangeLog for http-conduit++## 2.3.9.1++* data-default-class -> data-default [#546](https://github.com/snoyberg/http-client/pull/546/files)++## 2.3.9++* Fix space leaks when closing responses [#539](https://github.com/snoyberg/http-client/pull/539)++## 2.3.8.3++* aeson 2.2 support [#512](https://github.com/snoyberg/http-client/pull/512)++## 2.3.8.2++* Add missing `crypton-connection` dependency++## 2.3.8.1++* Drop `connection` dependency++## 2.3.8++* Adds `setRequestBearerAuth` convenience function. Note that this is only available for `http-client` versions 0.7.6 or greater. [#457](https://github.com/snoyberg/http-client/pull/457/files)+* Adds a convenience function to set a request's response timeout [#456](https://github.com/snoyberg/http-client/pull/456)++## 2.3.7.4++* Introduces the `aeson` cabal file [#448](https://github.com/snoyberg/http-client/issues/448)++## 2.3.7.3++* Relax test suite version bounds++## 2.3.7.2++* Add the `network3` flag++## 2.3.7.1++* Properly skip whitespace after JSON body [#401](https://github.com/snoyberg/http-client/issues/401)++## 2.3.7++* Ensure entire JSON response body is consumed [#395](https://github.com/snoyberg/http-client/issues/395)++## 2.3.6.1++* Add back compatibility with older http-client version [#393](https://github.com/snoyberg/http-client/pull/393)++## 2.3.6++* Add `httpSource` to `Network.HTTP.Client.Conduit` [#390](https://github.com/snoyberg/http-client/pull/390).++## 2.3.5++* Adds `addToRequestQueryString` helper function++## 2.3.4++* Reexport RequestHeaders from Network.HTTP.Types (what was intended in last version)+* Fix mistake in ChangeLog++## 2.3.3++* Reexport Header, QueryItem and ResponseHeaders from Network.HTTP.Types+* Rewrite a type signature of setRequestHeaders with RequestHeaders++## 2.3.2++* Adds `parseRequestThrow`, `parseRequestThrow_`, and+ `setRequestCheckStatus` to `Network.HTTP.Simple`.+ See [#304](https://github.com/snoyberg/http-client/issues/304)++## 2.3.1++* Reexport Query from Network.HTTP.Types+* Rewrite a type signatures of getRequestQueryString and setRequestQueryString with Query++## 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`
Network/HTTP/Client/Conduit.hs view
@@ -1,6 +1,5 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-} -- | A new, experimental API to replace "Network.HTTP.Conduit". -- -- For most users, "Network.HTTP.Simple" is probably a better choice. For more@@ -16,11 +15,10 @@ , responseOpen , responseClose , acquireResponse+ , httpSource -- * Manager helpers , defaultManagerSettings , newManager- , withManager- , withManagerSettings , newManagerSettings -- * General HTTP client interface , module Network.HTTP.Client@@ -33,21 +31,21 @@ ) 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 (..), runReaderT)+import Control.Monad.Trans.Resource (MonadResource) 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, bracketP) 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 +54,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 +98,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 +118,7 @@ bodyReaderSource :: MonadIO m => H.BodyReader- -> Producer m ByteString+ -> ConduitM i ByteString m () bodyReaderSource br = loop where@@ -142,13 +128,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@@ -188,3 +174,19 @@ env <- ask let man = getHttpManager env liftIO $ H.httpNoBody req man++-- | Same as 'Network.HTTP.Simple.httpSource', but uses 'Manager'+-- from Reader environment instead of the global one.+--+-- Since 2.3.6+httpSource+ :: (MonadResource m, MonadIO n, MonadReader env m, HasHttpManager env)+ => Request+ -> (Response (ConduitM () ByteString n ()) -> ConduitM () r m ())+ -> ConduitM () r m ()+httpSource request withRes = do+ env <- ask+ bracketP+ (runReaderT (responseOpen request) env)+ responseClose+ withRes
Network/HTTP/Conduit.hs view
@@ -1,7 +1,6 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} -- | -- -- = Simpler API@@ -31,7 +30,7 @@ -- -- > import Data.Conduit.Binary (sinkFile) -- Exported from the package conduit-extra -- > import Network.HTTP.Conduit--- > import qualified Data.Conduit as C+-- > import Conduit (runConduit, (.|)) -- > import Control.Monad.Trans.Resource (runResourceT) -- > -- > main :: IO ()@@ -40,7 +39,7 @@ -- > manager <- newManager tlsManagerSettings -- > runResourceT $ do -- > response <- http request manager--- > responseBody response C.$$+- sinkFile "google.html"+-- > runConduit $ responseBody response .| sinkFile "google.html" -- -- The following headers are automatically set by this module, and should not -- be added to 'requestHeaders':@@ -160,6 +159,9 @@ , rawBody , decompress , redirectCount+#if MIN_VERSION_http_client(0,6,2)+ , shouldStripHeaderOnRedirect+#endif , checkResponse , responseTimeout , cookieJar@@ -177,15 +179,13 @@ , responseHeaders , responseBody , responseCookieJar+ , responseEarlyHints -- * Manager , Manager , newManager , closeManager- , withManager- , withManagerSettings -- ** Settings , ManagerSettings- , conduitManagerSettings , tlsManagerSettings , mkManagerSettings , managerConnCount@@ -225,16 +225,15 @@ 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)+import qualified Network.HTTP.Client as Client (httpLbs, responseOpen) import qualified Network.HTTP.Client as HC import qualified Network.HTTP.Client.Conduit as HCC import Network.HTTP.Client.Internal (createCookieJar,@@ -245,9 +244,8 @@ managerTlsConnection, newManager) import Network.HTTP.Client (parseUrl, parseUrlThrow, urlEncodedBody, applyBasicAuth, defaultRequest, parseRequest, parseRequest_)-import Network.HTTP.Client.Internal (addProxy, alwaysDecompress,- browserDecompress)-import Network.HTTP.Client.Internal (getRedirectedRequest)+import Network.HTTP.Client.Internal (ResponseClose (..), addProxy, alwaysDecompress,+ browserDecompress, getRedirectedRequest) import Network.HTTP.Client.TLS (mkManagerSettings, tlsManagerSettings) import Network.HTTP.Client.Internal (Cookie (..), CookieJar (..),@@ -301,31 +299,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 +314,27 @@ http :: MonadResource m => Request -> Manager- -> m (Response (ResumableSource m S.ByteString))-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 }+ -> m (Response (ConduitM i S.ByteString m ()))+http req man = resourceMask $ \_ -> do+ res <- liftIO $ Client.responseOpen req man+ -- Move the cleanup action for the response into `ResourceT` so+ -- that we can release it from the `ReleaseMap` as soon as the+ -- response is closed or the body is consumed.+ let ResponseClose cleanup = responseClose' res+ key <- register cleanup+ pure res { responseClose' = ResponseClose $ release key+ , 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 +351,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
Network/HTTP/Simple.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-}@@ -22,21 +23,32 @@ httpBS , httpLBS , httpNoBody+#ifdef VERSION_aeson , httpJSON , httpJSONEither+#endif , httpSink , httpSource , withResponse -- * Types+ , H.Header+ , H.Query+ , H.QueryItem , H.Request+ , H.RequestHeaders , H.Response+ , H.ResponseHeaders+#ifdef VERSION_aeson , JSONException (..)+#endif , H.HttpException (..) , H.Proxy (..) -- * Request constructions , H.defaultRequest , H.parseRequest , H.parseRequest_+ , parseRequestThrow+ , parseRequestThrow_ -- * Request lenses -- ** Basics , setRequestMethod@@ -50,18 +62,26 @@ , setRequestHeaders , setRequestQueryString , getRequestQueryString+ , addToRequestQueryString -- ** Request body , setRequestBody+#ifdef VERSION_aeson , setRequestBodyJSON+#endif , setRequestBodyLBS , setRequestBodySource , setRequestBodyFile , setRequestBodyURLEncoded -- ** Special fields , H.setRequestIgnoreStatus+ , H.setRequestCheckStatus , setRequestBasicAuth+#if MIN_VERSION_http_client(0,7,6)+ , setRequestBearerAuth+#endif , setRequestManager , setRequestProxy+ , setRequestResponseTimeout -- * Response lenses , getResponseStatus , getResponseStatusCode@@ -79,20 +99,29 @@ 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)++#ifdef VERSION_aeson import Data.Aeson (FromJSON (..), Value) import Data.Aeson.Parser (json') import qualified Data.Aeson.Types as A import qualified Data.Aeson as A+#endif+ import qualified Data.Traversable as T-import Control.Exception (throwIO, Exception)+import Control.Exception (throw, throwIO, Exception)+import Data.Monoid 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 Control.Monad.Trans.Resource (MonadResource, MonadThrow)+import qualified Control.Exception as E (bracket)+import Data.Void (Void)+import qualified Data.Attoparsec.ByteString as Atto+import qualified Data.Attoparsec.ByteString.Char8 as Atto8 -- | Perform an HTTP request and return the body as a @ByteString@. --@@ -122,9 +151,12 @@ man <- H.getGlobalManager H.httpNoBody req man +#ifdef VERSION_aeson -- | Perform an HTTP request and parse the body as JSON. In the event of an -- JSON parse errors, a 'JSONException' runtime exception will be thrown. --+-- NOTE: Depends on the @aeson@ cabal flag being enabled+-- -- @since 2.1.10 httpJSON :: (MonadIO m, FromJSON a) => H.Request -> m (H.Response a) httpJSON req = liftIO $ httpJSONEither req >>= T.mapM (either throwIO return)@@ -132,6 +164,8 @@ -- | Perform an HTTP request and parse the body as JSON. In the event of an -- JSON parse errors, a @Left@ value will be returned. --+-- NOTE: Depends on the @aeson@ cabal flag being enabled+-- -- @since 2.1.10 httpJSONEither :: (MonadIO m, FromJSON a) => H.Request@@ -140,7 +174,8 @@ where req' = addRequestHeader H.hAccept "application/json" req sink orig = fmap (\x -> fmap (const x) orig) $ do- eres1 <- C.sinkParserEither json'+ eres1 <- C.sinkParserEither (json' <* (Atto8.skipSpace *> Atto.endOfInput))+ case eres1 of Left e -> return $ Left $ JSONParseException req' orig e Right value ->@@ -151,27 +186,32 @@ -- | An exception that can occur when parsing JSON --+-- NOTE: Depends on the @aeson@ cabal flag being enabled+-- -- @since 2.1.10 data JSONException = JSONParseException H.Request (H.Response ()) C.ParseError | JSONConversionException H.Request (H.Response Value) String deriving (Show, Typeable) instance Exception JSONException+#endif -- | 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,17 +261,36 @@ -- 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) +-- | Same as 'parseRequest', except will throw an 'HttpException' in the+-- event of a non-2XX response. This uses 'throwErrorStatusCodes' to+-- implement 'checkResponse'.+--+-- Exactly the same as 'parseUrlThrow', but has a name that is more+-- consistent with the other parseRequest functions.+--+-- @since 2.3.2+parseRequestThrow :: MonadThrow m => String -> m HC.Request+parseRequestThrow = HC.parseUrlThrow++-- | Same as 'parseRequestThrow', but parse errors cause an impure+-- exception. Mostly useful for static strings which are known to be+-- correctly formatted.+--+-- @since 2.3.2+parseRequestThrow_ :: String -> HC.Request+parseRequestThrow_ = either throw id . HC.parseUrlThrow+ -- | Alternate spelling of 'httpLBS' -- -- @since 2.1.10@@ -294,24 +353,35 @@ ++ (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+setRequestHeaders :: H.RequestHeaders -> H.Request -> H.Request setRequestHeaders x req = req { H.requestHeaders = x } -- | Get the query string parameters -- -- @since 2.1.10-getRequestQueryString :: H.Request -> [(S.ByteString, Maybe S.ByteString)]+getRequestQueryString :: H.Request -> H.Query getRequestQueryString = H.parseQuery . H.queryString -- | Set the query string parameters -- -- @since 2.1.10-setRequestQueryString :: [(S.ByteString, Maybe S.ByteString)] -> H.Request -> H.Request+setRequestQueryString :: H.Query -> H.Request -> H.Request setRequestQueryString = H.setQueryString +-- | Add to the existing query string parameters.+--+-- @since 2.3.5+addToRequestQueryString :: H.Query -> H.Request -> H.Request+addToRequestQueryString additions req = setRequestQueryString q req+ where q = additions <> getRequestQueryString req+ -- | Set the request body to the given 'H.RequestBody'. You may want to -- consider using one of the convenience functions in the modules, e.g. -- 'requestBodyJSON'.@@ -323,6 +393,7 @@ setRequestBody :: H.RequestBody -> H.Request -> H.Request setRequestBody x req = req { H.requestBody = x } +#ifdef VERSION_aeson -- | Set the request body as a JSON value -- -- /Note/: This will not modify the request method. For that, please use@@ -330,6 +401,8 @@ -- -- This also sets the @Content-Type@ to @application/json; charset=utf-8@ --+-- NOTE: Depends on the @aeson@ cabal flag being enabled+-- -- @since 2.1.10 setRequestBodyJSON :: A.ToJSON a => a -> H.Request -> H.Request setRequestBodyJSON x req =@@ -338,6 +411,7 @@ : filter (\(y, _) -> y /= H.hContentType) (H.requestHeaders req) , H.requestBody = H.RequestBodyLBS $ A.encode x }+#endif -- | Set the request body as a lazy @ByteString@ --@@ -355,7 +429,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 +445,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@@ -389,6 +461,16 @@ -> H.Request setRequestBasicAuth = H.applyBasicAuth +#if MIN_VERSION_http_client(0,7,6)+-- | Set bearer auth with the given token+--+-- @since 2.3.8+setRequestBearerAuth :: S.ByteString -- ^ token+ -> H.Request+ -> H.Request+setRequestBearerAuth = H.applyBearerAuth+#endif+ -- | Instead of using the default global 'H.Manager', use the supplied -- @Manager@. --@@ -401,6 +483,12 @@ -- @since 2.1.10 setRequestProxy :: Maybe H.Proxy -> H.Request -> H.Request setRequestProxy x req = req { H.proxy = x }++-- | Set the maximum time to wait for a response+--+-- @since 2.3.8+setRequestResponseTimeout :: H.ResponseTimeout -> H.Request -> H.Request+setRequestResponseTimeout x req = req { H.responseTimeout = x } -- | Get the status of the response --
README.md view
@@ -5,6 +5,6 @@ streaming interface. Full tutorial docs are available at:-https://haskell-lang.org/library/http-client+https://github.com/snoyberg/http-client/blob/master/TUTORIAL.md The `Network.HTTP.Conduit.Browser` module has been moved to <http://hackage.haskell.org/package/http-conduit-browser/>
http-conduit.cabal view
@@ -1,5 +1,6 @@+cabal-version: >= 1.10 name: http-conduit-version: 2.2.4+version: 2.3.9.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -8,9 +9,8 @@ description: Hackage documentation generation is not reliable. For up to date documentation, please see: <http://www.stackage.org/package/http-conduit>. category: Web, Conduit stability: Stable-cabal-version: >= 1.8 build-type: Simple-homepage: http://www.yesodweb.com/book/http-conduit+homepage: https://github.com/snoyberg/http-client extra-source-files: test/main.hs , test/CookieTest.hs , multipart-example.bin@@ -20,27 +20,39 @@ , README.md , ChangeLog.md +flag aeson+ manual: True+ description: Enable the dependency on aeson+ default: True+ library- build-depends: base >= 4 && < 5- , aeson >= 0.8+ default-language: Haskell2010+ build-depends: base >= 4.10 && < 5+ , attoparsec , 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 >= 0.5.13 && < 0.8 , http-client-tls >= 0.3 && < 0.4- , monad-control , mtl- , exceptions >= 0.6+ , unliftio-core++ if flag(aeson)+ build-depends: aeson >= 0.8+ , attoparsec-aeson >= 2.1++ if !impl(ghc>=7.9)+ build-depends: void >= 0.5.5 exposed-modules: Network.HTTP.Conduit Network.HTTP.Client.Conduit Network.HTTP.Simple ghc-options: -Wall test-suite test+ default-language: Haskell2010 main-is: main.hs other-modules: CookieTest type: exitcode-stdio-1.0@@ -51,9 +63,10 @@ build-depends: base >= 4 && < 5 , HUnit , hspec >= 1.3- , data-default-class- , connection >= 0.2+ , data-default+ , crypton-connection , warp-tls+ , tls < 1.5 || >= 1.5.2 , time , blaze-builder , bytestring@@ -62,10 +75,9 @@ , conduit >= 1.1 , utf8-string , case-insensitive- , lifted-base- , network+ , unliftio , wai >= 3.0 && < 3.3- , warp >= 3.0.0.2 && < 3.3+ , warp >= 3.0.0.2 && < 3.4 , wai-conduit , http-types , cookie@@ -73,9 +85,13 @@ , http-conduit , conduit-extra , streaming-commons- , aeson , temporary , resourcet+ , network++ if flag(aeson)+ build-depends: aeson+ , attoparsec-aeson >= 2.1 source-repository head type: git
test/CookieTest.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wno-orphans #-}+ module CookieTest (cookieTest) where import Prelude hiding (exp)@@ -13,6 +15,25 @@ import qualified Data.CaseInsensitive as CI import Web.Cookie +-- We use these Eq instances here because they make sense and may be added to the library in+-- the future. We do not add them now because they would silently break the old Eq behavior,+-- which was `equivCookie`.+instance Eq Cookie where+ (==) = equalCookie++instance Eq CookieJar where+ (==) = equalCookieJar++instance Eq body => Eq (Response body) where+ resp == resp' = and+ [ responseStatus resp == responseStatus resp'+ , responseVersion resp == responseVersion resp'+ , responseHeaders resp == responseHeaders resp'+ , responseBody resp == responseBody resp'+ , responseCookieJar resp `equivCookieJar` responseCookieJar resp' -- !+ -- , responseClose -- !+ ]+ default_request :: HC.Request default_request = HC.parseRequest_ "http://www.google.com/" @@ -127,8 +148,8 @@ where cookie = default_cookie testCookieEqualityResiliance :: IO ()-testCookieEqualityResiliance = assertEqual "Cookies should still be equal if extra options are changed"- (default_cookie {cookie_persistent = True}) (default_cookie {cookie_host_only = True})+testCookieEqualityResiliance = assertBool "Cookies should still be equal if extra options are changed" $+ (default_cookie {cookie_persistent = True}) `equivCookie` (default_cookie {cookie_host_only = True}) testDomainChangesEquality :: IO () testDomainChangesEquality = assertBool "Changing the domain should make cookies not equal" $@@ -139,7 +160,7 @@ (Just default_cookie, createCookieJar []) (removeExistingCookieFromCookieJar default_cookie $ createCookieJar [default_cookie]) testRemoveNonexistantCookie :: IO ()-testRemoveNonexistantCookie = assertEqual "Removing a nonexistant cookie doesn't work"+testRemoveNonexistantCookie = assertEqual "Removing a nonexistent cookie doesn't work" (Nothing, createCookieJar [default_cookie]) (removeExistingCookieFromCookieJar (default_cookie {cookie_name = fromString "key2"}) $ createCookieJar [default_cookie]) testRemoveCorrectCookie :: IO ()@@ -228,8 +249,9 @@ where cookie_jar = createCookieJar [default_cookie {cookie_http_only = True}] testComputeCookieStringSort :: IO ()-testComputeCookieStringSort = assertEqual "Sorting works correctly"- (fromString "c1=v1;c3=v3;c4=v4;c2=v2", cookie_jar_out) format_output+testComputeCookieStringSort = do+ assertEqual "Sorting works correctly (computed string)" (fst format_output) (fromString "c1=v1;c3=v3;c4=v4;c2=v2")+ assertBool "Sorting works correctly (remaining jar)" $ (snd format_output) `equivCookieJar` cookie_jar_out where now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 11) cookie_jar = createCookieJar [ default_cookie { cookie_name = fromString "c1" , cookie_value = fromString "v1"@@ -289,8 +311,8 @@ fromString "otherkey=otherval")]} testReceiveSetCookie :: IO ()-testReceiveSetCookie = assertEqual "Receiving a Set-Cookie"- (createCookieJar [default_cookie]) (receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar [])+testReceiveSetCookie = assertBool "Receiving a Set-Cookie" $+ (createCookieJar [default_cookie]) `equivCookieJar` (receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar []) testReceiveSetCookieTrailingDot :: IO () testReceiveSetCookieTrailingDot = assertEqual "Receiving a Set-Cookie with a trailing domain dot"@@ -298,18 +320,18 @@ where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString "www.google.com."} testReceiveSetCookieLeadingDot :: IO ()-testReceiveSetCookieLeadingDot = assertEqual "Receiving a Set-Cookie with a leading domain dot"- (createCookieJar [default_cookie]) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar [])+testReceiveSetCookieLeadingDot = assertBool "Receiving a Set-Cookie with a leading domain dot" $+ (createCookieJar [default_cookie]) `equivCookieJar` (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString ".www.google.com"} testReceiveSetCookieNoDomain :: IO ()-testReceiveSetCookieNoDomain = assertEqual "Receiving cookie without domain"- (createCookieJar [default_cookie]) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar [])+testReceiveSetCookieNoDomain = assertBool "Receiving cookie without domain" $+ (createCookieJar [default_cookie]) `equivCookieJar` (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) where set_cookie = default_set_cookie {setCookieDomain = Nothing} testReceiveSetCookieEmptyDomain :: IO ()-testReceiveSetCookieEmptyDomain = assertEqual "Receiving cookie with empty domain"- (createCookieJar [default_cookie]) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar [])+testReceiveSetCookieEmptyDomain = assertBool "Receiving cookie with empty domain" $+ (createCookieJar [default_cookie]) `equivCookieJar` (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) where set_cookie = default_set_cookie {setCookieDomain = Just BS.empty} -- Can't test public suffixes until that module is written@@ -379,7 +401,7 @@ where set_cookie = default_set_cookie {setCookiePath = Just $ fromString "/a/path"} testReceiveSetCookieNoPath :: IO ()-testReceiveSetCookieNoPath = assertEqual "Path gets set correctly when nonexistant"+testReceiveSetCookieNoPath = assertEqual "Path gets set correctly when nonexistent" (fromString "/a/path/to") (cookie_path $ head $ destroyCookieJar $ receiveSetCookie set_cookie request default_time True $ createCookieJar []) where set_cookie = default_set_cookie {setCookiePath = Nothing} request = default_request {HC.path = fromString "/a/path/to/nowhere"}@@ -487,7 +509,7 @@ removeTests :: Spec removeTests = do it "Removing a cookie works" testRemoveCookie- it "Removing a nonexistant cookie doesn't work" testRemoveNonexistantCookie+ it "Removing a nonexistent cookie doesn't work" testRemoveNonexistantCookie it "Removing the correct cookie" testRemoveCorrectCookie evictionTests :: Spec@@ -528,7 +550,7 @@ it "Expiry gets set based on max age if no expiry is given" testReceiveSetCookieNoExpiry it "Expiry gets set based on given value if no max age is given" testReceiveSetCookieNoMaxAge it "Expiry gets set to a future date if no expiry and no max age are given" testReceiveSetCookieNoExpiryNoMaxAge- it "Path gets set correctly when nonexistant" testReceiveSetCookieNoPath+ it "Path gets set correctly when nonexistent" testReceiveSetCookieNoPath it "Path gets set correctly" testReceiveSetCookiePath it "Creation time gets set correctly" testReceiveSetCookieCreationTime it "Last access time gets set correctly" testReceiveSetCookieAccessTime
test/main.hs view
@@ -12,16 +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.BSD+import qualified Network.Socket as NS import CookieTest (cookieTest) #if MIN_VERSION_conduit(1,1,0) import Data.Conduit.Network (runTCPServer, serverSettings, appSink, appSource, ServerSettings)@@ -32,7 +31,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)@@ -49,18 +48,13 @@ import Data.Time.Calendar import qualified Network.Wai.Handler.WarpTLS as WT import Network.Connection (settingDisableCertificateValidation)-import Data.Default.Class (def)+import Data.Default (def)+#ifdef VERSION_aeson import qualified Data.Aeson as A+#endif 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 +116,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 +181,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 +224,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 +241,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 +364,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 +396,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@@ -407,44 +407,44 @@ describe "hostAddress" $ do it "overrides host" $ withApp app $ \port -> 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+ let req = req' { hostAddress = Just $ NS.tupleToHostAddress (127, 0, 0, 1) }+ 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,38 +457,43 @@ , (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 - describe "Simple" $ do- it "JSON" $ jsonApp $ \port -> do+#ifdef VERSION_aeson+ describe "Simple.JSON" $ do+ it "normal" $ jsonApp $ \port -> do req <- parseUrlThrow $ "http://localhost:" ++ show port value <- Simple.httpJSON req responseBody value `shouldBe` jsonValue+ it "trailing whitespace" $ jsonApp $ \port -> do+ req <- parseUrlThrow $ "http://localhost:" ++ show port ++ "/trailing"+ value <- Simple.httpJSON req+ responseBody value `shouldBe` jsonValue+#endif 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 +514,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 +561,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,44 +583,49 @@ 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 +#ifdef VERSION_aeson jsonApp :: (Int -> IO ()) -> IO ()-jsonApp = withApp $ \_req -> return $ responseLBS+jsonApp = withApp $ \req -> return $ responseLBS status200 [ ("Content-Type", "application/json")- ]- (A.encode jsonValue)+ ] $+ case pathInfo req of+ [] -> A.encode jsonValue+ ["trailing"] -> L.append (A.encode jsonValue) " \n\r\n\t "+ x -> error $ "unsupported: " ++ show x jsonValue :: A.Value jsonValue = A.object [ "name" A..= ("Alice" :: String) , "age" A..= (35 :: Int) ]+#endif