diff --git a/Network/HTTP/Client/Conduit.hs b/Network/HTTP/Client/Conduit.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Client/Conduit.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +-- | A new, experimental API to replace "Network.HTTP.Conduit". +module Network.HTTP.Client.Conduit + ( -- * Conduit-specific interface + withResponse + , responseOpen + , responseClose + , acquireResponse + -- * Manager helpers + , defaultManagerSettings + , newManager + , withManager + , withManagerSettings + , newManagerSettings + , HasHttpManager (..) + -- * General HTTP client interface + , module Network.HTTP.Client + -- * Lower-level conduit functions + , requestBodySource + , requestBodySourceChunked + , bodyReaderSource + ) 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 Data.Acquire (Acquire, mkAcquire, with) +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import Data.Conduit (ConduitM, Producer, Source, + await, yield, ($$+), ($$++)) +import Data.Int (Int64) +import Data.IORef (newIORef, readIORef, writeIORef) +import Network.HTTP.Client hiding (closeManager, + defaultManagerSettings, httpLbs, + newManager, responseClose, + responseOpen, withManager, + withResponse, BodyReader, brRead, brConsume) +import qualified Network.HTTP.Client as H +import Network.HTTP.Client.TLS (tlsManagerSettings) + +-- | Conduit powered version of 'H.withResponse'. Differences are: +-- +-- * Response body is represented as a @Producer@. +-- +-- * Generalized to any instance of @MonadBaseControl@, 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) + => Request + -> (Response (ConduitM i ByteString n ()) -> m a) + -> m a +withResponse req f = do + env <- ask + with (acquireResponse req env) f + +-- | An @Acquire@ for getting a @Response@. +-- +-- Since 2.1.0 +acquireResponse :: (MonadIO n, MonadReader env m, HasHttpManager env) + => Request + -> m (Acquire (Response (ConduitM i ByteString n ()))) +acquireResponse req = do + env <- ask + let man = getHttpManager env + return $ do + res <- mkAcquire (H.responseOpen req man) H.responseClose + return $ fmap bodyReaderSource res + +-- | TLS-powered manager settings. +-- +-- Since 2.1.0 +defaultManagerSettings :: ManagerSettings +defaultManagerSettings = tlsManagerSettings + +-- | Get a new manager using 'defaultManagerSettings'. +-- +-- Since 2.1.0 +newManager :: MonadIO m => m Manager +newManager = newManagerSettings defaultManagerSettings + +-- | Get a new manager using the given settings. +-- +-- Since 2.1.0 +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'. +-- +-- Since 2.1.0 +responseOpen :: (MonadIO m, MonadIO n, MonadReader env m, HasHttpManager env) + => Request + -> m (Response (ConduitM i ByteString n ())) +responseOpen req = do + env <- ask + liftIO $ fmap bodyReaderSource `fmap` H.responseOpen req (getHttpManager env) + +-- | Generalized version of 'H.responseClose'. +-- +-- Since 2.1.0 +responseClose :: MonadIO m => Response body -> m () +responseClose = liftIO . H.responseClose + +class HasHttpManager a where + getHttpManager :: a -> Manager +instance HasHttpManager Manager where + getHttpManager = id + +bodyReaderSource :: MonadIO m + => H.BodyReader + -> Producer m ByteString +bodyReaderSource br = + loop + where + loop = do + bs <- liftIO $ H.brRead br + unless (S.null bs) $ do + yield bs + loop + +requestBodySource :: Int64 -> Source IO ByteString -> RequestBody +requestBodySource size = RequestBodyStream size . srcToPopperIO + +requestBodySourceChunked :: Source IO ByteString -> RequestBody +requestBodySourceChunked = RequestBodyStreamChunked . srcToPopperIO + +srcToPopperIO :: Source IO ByteString -> GivesPopper () +srcToPopperIO src f = do + (rsrc0, ()) <- src $$+ return () + irsrc <- newIORef rsrc0 + let popper :: IO ByteString + popper = do + rsrc <- readIORef irsrc + (rsrc', mres) <- rsrc $$++ await + writeIORef irsrc rsrc' + case mres of + Nothing -> return S.empty + Just bs + | S.null bs -> popper + | otherwise -> return bs + f popper diff --git a/Network/HTTP/Conduit.hs b/Network/HTTP/Conduit.hs --- a/Network/HTTP/Conduit.hs +++ b/Network/HTTP/Conduit.hs @@ -199,16 +199,18 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L -import Data.Conduit (ResumableSource, ($$+-)) +import Data.Conduit (ResumableSource, ($$+-), await, ($$++), ($$+), Source) +import qualified Data.Conduit.Internal as CI import qualified Data.Conduit.List as CL - +import Data.IORef (readIORef, writeIORef, newIORef) +import Data.Int (Int64) import Control.Applicative ((<$>)) import Control.Exception.Lifted (bracket) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Resource -import qualified Network.HTTP.Client as Client (httpLbs) -import Network.HTTP.Client.Conduit +import qualified Network.HTTP.Client as Client (httpLbs, responseOpen, responseClose) +import qualified Network.HTTP.Client.Conduit as HCC import Network.HTTP.Client.Internal (createCookieJar, destroyCookieJar) import Network.HTTP.Client.Internal (Manager, ManagerSettings, @@ -294,3 +296,43 @@ return res { responseBody = L.fromChunks bss } + +http :: MonadResource m + => Request + -> Manager + -> m (Response (ResumableSource m S.ByteString)) +http req man = do + (key, res) <- allocate (Client.responseOpen req man) Client.responseClose + let rsrc = CI.ResumableSource + (HCC.bodyReaderSource $ responseBody res) + (release key) + return res { responseBody = rsrc } + +requestBodySource :: Int64 -> Source (ResourceT IO) S.ByteString -> RequestBody +requestBodySource size = RequestBodyStream size . srcToPopper + +requestBodySourceChunked :: Source (ResourceT IO) S.ByteString -> RequestBody +requestBodySourceChunked = RequestBodyStreamChunked . srcToPopper + +srcToPopper :: Source (ResourceT IO) S.ByteString -> HCC.GivesPopper () +srcToPopper src f = runResourceT $ do + (rsrc0, ()) <- src $$+ return () + irsrc <- liftIO $ newIORef rsrc0 + is <- getInternalState + let popper :: IO S.ByteString + popper = do + rsrc <- readIORef irsrc + (rsrc', mres) <- runInternalState (rsrc $$++ await) is + writeIORef irsrc rsrc' + case mres of + Nothing -> return S.empty + Just bs + | S.null bs -> popper + | otherwise -> return bs + liftIO $ f popper + +requestBodySourceIO :: Int64 -> Source IO S.ByteString -> RequestBody +requestBodySourceIO = HCC.requestBodySource + +requestBodySourceChunkedIO :: Source IO S.ByteString -> RequestBody +requestBodySourceChunkedIO = HCC.requestBodySourceChunked diff --git a/http-conduit.cabal b/http-conduit.cabal --- a/http-conduit.cabal +++ b/http-conduit.cabal @@ -1,5 +1,5 @@ name: http-conduit -version: 2.0.0.10 +version: 2.1.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -9,8 +9,6 @@ This package uses conduit for parsing the actual contents of the HTTP connection. It also provides higher-level functions which allow you to avoid directly dealing with streaming data. See for more information. . The @Network.HTTP.Conduit.Browser@ module has been moved to - . - The @Network.HTTP.Conduit.MultipartFormData@ module has been moved to category: Web, Conduit stability: Stable cabal-version: >= 1.8 @@ -27,14 +25,16 @@ build-depends: base >= 4 && < 5 , bytestring >= 0.9.1.4 , transformers >= 0.2 - , resourcet >= 0.3 && < 0.5 - , conduit >= 0.5.5 && < 1.1 + , resourcet >= 1.1 && < 1.2 + , conduit >= 0.5.5 && < 1.2 , http-types >= 0.7 , lifted-base >= 0.1 - , http-client >= 0.2.3.1 + , http-client >= 0.3 && < 0.4 , http-client-tls - , http-client-conduit < 0.3 + , monad-control + , mtl exposed-modules: Network.HTTP.Conduit + Network.HTTP.Client.Conduit ghc-options: -Wall test-suite test @@ -67,7 +67,8 @@ , network-conduit >= 0.6 , http-client , http-conduit - , http-client-multipart + , conduit-extra + , streaming-commons source-repository head type: git diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} import Test.Hspec @@ -20,7 +21,13 @@ import Network.Socket (sClose) import qualified Network.BSD import CookieTest (cookieTest) +#if MIN_VERSION_conduit(1,1,0) +import Data.Conduit.Network (runTCPServer, serverSettings, HostPreference (..), appSink, appSource, ServerSettings) +import Data.Streaming.Network (bindPortTCP, setAfterBind) +#define bindPort bindPortTCP +#else import Data.Conduit.Network (runTCPServer, serverSettings, HostPreference (..), appSink, appSource, bindPort, serverAfterBind, ServerSettings) +#endif import qualified Data.Conduit.Network import System.IO.Unsafe (unsafePerformIO) import Data.Conduit (($$), ($$+-), yield, Flush (Chunk, Flush), await) @@ -97,7 +104,7 @@ getPort :: IO Int getPort = do port <- I.atomicModifyIORef nextPort $ \p -> (p + 1, p) - esocket <- try $ bindPort port HostIPv4 + esocket <- try $ bindPort port "*4" case esocket of Left (_ :: IOException) -> getPort Right socket -> do @@ -210,7 +217,7 @@ describe "http" $ do it "response body" $ withApp app $ \port -> do withManager $ \manager -> do - req <- parseUrl $ "http://127.0.0.1:" ++ show port + req <- liftIO $ parseUrl $ "http://127.0.0.1:" ++ show port res1 <- http req manager bss <- responseBody res1 $$+- CL.consume res2 <- httpLbs req manager @@ -332,7 +339,7 @@ ["foo"] -> return $ responseLBS status200 [] "Hello World!" _ -> return $ responseSource status301 [("location", S8.pack $ "http://127.0.0.1:" ++ show port ++ "/foo")] $ forever $ yield $ Chunk $ fromByteString "hello\n" withApp' app' $ \port -> withManager $ \manager -> do - req <- parseUrl $ "http://127.0.0.1:" ++ show port + req <- liftIO $ parseUrl $ "http://127.0.0.1:" ++ show port res <- httpLbs req manager liftIO $ do Network.HTTP.Conduit.responseStatus res `shouldBe` status200 @@ -365,7 +372,7 @@ _ <- appSource app' $$ await yield "HTTP/1.0 200 OK\r\n\r\nThis is it!" $$ appSink app' withCApp baseHTTP $ \port -> withManager $ \manager -> do - req <- parseUrl $ "http://127.0.0.1:" ++ show port + req <- liftIO $ parseUrl $ "http://127.0.0.1:" ++ show port res1 <- httpLbs req manager res2 <- httpLbs req manager liftIO $ res1 @?= res2 @@ -397,13 +404,18 @@ _ <- http req man return () -withCApp :: Data.Conduit.Network.Application IO -> (Int -> IO ()) -> IO () +withCApp :: (Data.Conduit.Network.AppData -> IO ()) -> (Int -> IO ()) -> IO () withCApp app' f = do port <- getPort baton <- newEmptyMVar let start = putMVar baton () +#if MIN_VERSION_conduit(1,1,0) + settings :: ServerSettings + settings = setAfterBind (const start) (serverSettings port "*") +#else settings :: ServerSettings IO - settings = (serverSettings port HostAny :: ServerSettings IO) { serverAfterBind = const start } + settings = (serverSettings port "*" :: ServerSettings IO) { serverAfterBind = const start } +#endif bracket (forkIO $ runTCPServer settings app' `onException` start) killThread