{-# 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

-- information, see:

--

-- <https://haskell-lang.org/library/http-client>

--

-- For more information on using this module, please be sure to read the

-- documentation in the "Network.HTTP.Client" module.

module Network.HTTP.Client.Conduit
    ( -- * Conduit-specific interface

      withResponse
    , responseOpen
    , responseClose
    , acquireResponse
    , httpSource
      -- * Manager helpers

    , defaultManagerSettings
    , newManager
    , newManagerSettings
      -- * General HTTP client interface

    , module Network.HTTP.Client
    , httpLbs
    , httpNoBody
      -- * Lower-level conduit functions

    , requestBodySource
    , requestBodySourceChunked
    , bodyReaderSource
    ) where

import           Control.Monad                (unless)
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, ($$+), ($$++),
                                               await, yield, bracketP)
import           Data.Int                     (Int64)
import           Data.IORef                   (newIORef, readIORef, writeIORef)
import           Network.HTTP.Client          hiding (closeManager,
                                               defaultManagerSettings, httpLbs,
                                               newManager, responseClose,
                                               responseOpen,
                                               withResponse, BodyReader, brRead, brConsume, httpNoBody)
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 @MonadUnliftIO@, not just @IO@.

--

-- * The @Manager@ is contained by a @MonadReader@ context.

--

-- Since 2.1.0

withResponse :: (MonadUnliftIO m, MonadIO n, MonadReader env m, HasHttpManager env)
             => Request
             -> (Response (ConduitM i ByteString n ()) -> m a)
             -> m a
withResponse :: Request -> (Response (ConduitM i ByteString n ()) -> m a) -> m a
withResponse Request
req Response (ConduitM i ByteString n ()) -> m a
f = do
    env
env <- m env
forall r (m :: * -> *). MonadReader r m => m r
ask
    ((forall a. m a -> IO a) -> IO a) -> m a
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO a) -> m a)
-> ((forall a. m a -> IO a) -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run -> Acquire (Response (ConduitM i ByteString n ()))
-> (Response (ConduitM i ByteString n ()) -> IO a) -> IO a
forall (m :: * -> *) a b.
MonadUnliftIO m =>
Acquire a -> (a -> m b) -> m b
with (Request -> env -> Acquire (Response (ConduitM i ByteString n ()))
forall (n :: * -> *) env (m :: * -> *) i.
(MonadIO n, MonadReader env m, HasHttpManager env) =>
Request -> m (Acquire (Response (ConduitM i ByteString n ())))
acquireResponse Request
req env
env) (m a -> IO a
forall a. m a -> IO a
run (m a -> IO a)
-> (Response (ConduitM i ByteString n ()) -> m a)
-> Response (ConduitM i ByteString n ())
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response (ConduitM i ByteString n ()) -> m a
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 :: Request -> m (Acquire (Response (ConduitM i ByteString n ())))
acquireResponse Request
req = do
    env
env <- m env
forall r (m :: * -> *). MonadReader r m => m r
ask
    let man :: Manager
man = env -> Manager
forall a. HasHttpManager a => a -> Manager
getHttpManager env
env
    Acquire (Response (ConduitM i ByteString n ()))
-> m (Acquire (Response (ConduitM i ByteString n ())))
forall (m :: * -> *) a. Monad m => a -> m a
return (Acquire (Response (ConduitM i ByteString n ()))
 -> m (Acquire (Response (ConduitM i ByteString n ()))))
-> Acquire (Response (ConduitM i ByteString n ()))
-> m (Acquire (Response (ConduitM i ByteString n ())))
forall a b. (a -> b) -> a -> b
$ do
        Response BodyReader
res <- IO (Response BodyReader)
-> (Response BodyReader -> IO ()) -> Acquire (Response BodyReader)
forall a. IO a -> (a -> IO ()) -> Acquire a
mkAcquire (Request -> Manager -> IO (Response BodyReader)
H.responseOpen Request
req Manager
man) Response BodyReader -> IO ()
forall a. Response a -> IO ()
H.responseClose
        Response (ConduitM i ByteString n ())
-> Acquire (Response (ConduitM i ByteString n ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Response (ConduitM i ByteString n ())
 -> Acquire (Response (ConduitM i ByteString n ())))
-> Response (ConduitM i ByteString n ())
-> Acquire (Response (ConduitM i ByteString n ()))
forall a b. (a -> b) -> a -> b
$ (BodyReader -> ConduitM i ByteString n ())
-> Response BodyReader -> Response (ConduitM i ByteString n ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BodyReader -> ConduitM i ByteString n ()
forall (m :: * -> *) i.
MonadIO m =>
BodyReader -> ConduitM i ByteString m ()
bodyReaderSource Response BodyReader
res

-- | TLS-powered manager settings.

--

-- Since 2.1.0

defaultManagerSettings :: ManagerSettings
defaultManagerSettings :: ManagerSettings
defaultManagerSettings = ManagerSettings
tlsManagerSettings

-- | Get a new manager using 'defaultManagerSettings'.

--

-- Since 2.1.0

newManager :: MonadIO m => m Manager
newManager :: m Manager
newManager = ManagerSettings -> m Manager
forall (m :: * -> *). MonadIO m => ManagerSettings -> m Manager
newManagerSettings ManagerSettings
defaultManagerSettings

-- | Get a new manager using the given settings.

--

-- Since 2.1.0

newManagerSettings :: MonadIO m => ManagerSettings -> m Manager
newManagerSettings :: ManagerSettings -> m Manager
newManagerSettings = IO Manager -> m Manager
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Manager -> m Manager)
-> (ManagerSettings -> IO Manager) -> ManagerSettings -> m Manager
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ManagerSettings -> IO Manager
H.newManager

-- | 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 :: Request -> m (Response (ConduitM i ByteString n ()))
responseOpen Request
req = do
    env
env <- m env
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO (Response (ConduitM i ByteString n ()))
-> m (Response (ConduitM i ByteString n ()))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Response (ConduitM i ByteString n ()))
 -> m (Response (ConduitM i ByteString n ())))
-> IO (Response (ConduitM i ByteString n ()))
-> m (Response (ConduitM i ByteString n ()))
forall a b. (a -> b) -> a -> b
$ (BodyReader -> ConduitM i ByteString n ())
-> Response BodyReader -> Response (ConduitM i ByteString n ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BodyReader -> ConduitM i ByteString n ()
forall (m :: * -> *) i.
MonadIO m =>
BodyReader -> ConduitM i ByteString m ()
bodyReaderSource (Response BodyReader -> Response (ConduitM i ByteString n ()))
-> IO (Response BodyReader)
-> IO (Response (ConduitM i ByteString n ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Request -> Manager -> IO (Response BodyReader)
H.responseOpen Request
req (env -> Manager
forall a. HasHttpManager a => a -> Manager
getHttpManager env
env)

-- | Generalized version of 'H.responseClose'.

--

-- Since 2.1.0

responseClose :: MonadIO m => Response body -> m ()
responseClose :: Response body -> m ()
responseClose = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> (Response body -> IO ()) -> Response body -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response body -> IO ()
forall a. Response a -> IO ()
H.responseClose

bodyReaderSource :: MonadIO m
                 => H.BodyReader
                 -> ConduitM i ByteString m ()
bodyReaderSource :: BodyReader -> ConduitM i ByteString m ()
bodyReaderSource BodyReader
br =
    ConduitM i ByteString m ()
forall i. ConduitT i ByteString m ()
loop
  where
    loop :: ConduitT i ByteString m ()
loop = do
        ByteString
bs <- BodyReader -> ConduitT i ByteString m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (BodyReader -> ConduitT i ByteString m ByteString)
-> BodyReader -> ConduitT i ByteString m ByteString
forall a b. (a -> b) -> a -> b
$ BodyReader -> BodyReader
H.brRead BodyReader
br
        Bool -> ConduitT i ByteString m () -> ConduitT i ByteString m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) (ConduitT i ByteString m () -> ConduitT i ByteString m ())
-> ConduitT i ByteString m () -> ConduitT i ByteString m ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> ConduitT i ByteString m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
bs
            ConduitT i ByteString m ()
loop

requestBodySource :: Int64 -> ConduitM () ByteString IO () -> RequestBody
requestBodySource :: Int64 -> ConduitM () ByteString IO () -> RequestBody
requestBodySource Int64
size = Int64 -> GivesPopper () -> RequestBody
RequestBodyStream Int64
size (GivesPopper () -> RequestBody)
-> (ConduitM () ByteString IO () -> GivesPopper ())
-> ConduitM () ByteString IO ()
-> RequestBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConduitM () ByteString IO () -> GivesPopper ()
srcToPopperIO

requestBodySourceChunked :: ConduitM () ByteString IO () -> RequestBody
requestBodySourceChunked :: ConduitM () ByteString IO () -> RequestBody
requestBodySourceChunked = GivesPopper () -> RequestBody
RequestBodyStreamChunked (GivesPopper () -> RequestBody)
-> (ConduitM () ByteString IO () -> GivesPopper ())
-> ConduitM () ByteString IO ()
-> RequestBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConduitM () ByteString IO () -> GivesPopper ()
srcToPopperIO

srcToPopperIO :: ConduitM () ByteString IO () -> GivesPopper ()
srcToPopperIO :: ConduitM () ByteString IO () -> GivesPopper ()
srcToPopperIO ConduitM () ByteString IO ()
src NeedsPopper ()
f = do
    (SealedConduitT () ByteString IO ()
rsrc0, ()) <- ConduitM () ByteString IO ()
src ConduitM () ByteString IO ()
-> Sink ByteString IO ()
-> IO (SealedConduitT () ByteString IO (), ())
forall (m :: * -> *) a b.
Monad m =>
Source m a -> Sink a m b -> m (SealedConduitT () a m (), b)
$$+ () -> Sink ByteString IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    IORef (SealedConduitT () ByteString IO ())
irsrc <- SealedConduitT () ByteString IO ()
-> IO (IORef (SealedConduitT () ByteString IO ()))
forall a. a -> IO (IORef a)
newIORef SealedConduitT () ByteString IO ()
rsrc0
    let popper :: IO ByteString
        popper :: BodyReader
popper = do
            SealedConduitT () ByteString IO ()
rsrc <- IORef (SealedConduitT () ByteString IO ())
-> IO (SealedConduitT () ByteString IO ())
forall a. IORef a -> IO a
readIORef IORef (SealedConduitT () ByteString IO ())
irsrc
            (SealedConduitT () ByteString IO ()
rsrc', Maybe ByteString
mres) <- SealedConduitT () ByteString IO ()
rsrc SealedConduitT () ByteString IO ()
-> Sink ByteString IO (Maybe ByteString)
-> IO (SealedConduitT () ByteString IO (), Maybe ByteString)
forall (m :: * -> *) a b.
Monad m =>
SealedConduitT () a m ()
-> Sink a m b -> m (SealedConduitT () a m (), b)
$$++ Sink ByteString IO (Maybe ByteString)
forall (m :: * -> *) i. Monad m => Consumer i m (Maybe i)
await
            IORef (SealedConduitT () ByteString IO ())
-> SealedConduitT () ByteString IO () -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (SealedConduitT () ByteString IO ())
irsrc SealedConduitT () ByteString IO ()
rsrc'
            case Maybe ByteString
mres of
                Maybe ByteString
Nothing -> ByteString -> BodyReader
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
S.empty
                Just ByteString
bs
                    | ByteString -> Bool
S.null ByteString
bs -> BodyReader
popper
                    | Bool
otherwise -> ByteString -> BodyReader
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
    NeedsPopper ()
f BodyReader
popper

-- | Same as 'H.httpLbs', except it uses the @Manager@ in the reader environment.

--

-- Since 2.1.1

httpLbs :: (MonadIO m, HasHttpManager env, MonadReader env m)
        => Request
        -> m (Response L.ByteString)
httpLbs :: Request -> m (Response ByteString)
httpLbs Request
req = do
    env
env <- m env
forall r (m :: * -> *). MonadReader r m => m r
ask
    let man :: Manager
man = env -> Manager
forall a. HasHttpManager a => a -> Manager
getHttpManager env
env
    IO (Response ByteString) -> m (Response ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Response ByteString) -> m (Response ByteString))
-> IO (Response ByteString) -> m (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
H.httpLbs Request
req Manager
man

-- | Same as 'H.httpNoBody', except it uses the @Manager@ in the reader environment.

--

-- This can be more convenient that using 'withManager' as it avoids the need

-- to specify the base monad for the response body.

--

-- Since 2.1.2

httpNoBody :: (MonadIO m, HasHttpManager env, MonadReader env m)
           => Request
           -> m (Response ())
httpNoBody :: Request -> m (Response ())
httpNoBody Request
req = do
    env
env <- m env
forall r (m :: * -> *). MonadReader r m => m r
ask
    let man :: Manager
man = env -> Manager
forall a. HasHttpManager a => a -> Manager
getHttpManager env
env
    IO (Response ()) -> m (Response ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Response ()) -> m (Response ()))
-> IO (Response ()) -> m (Response ())
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ())
H.httpNoBody Request
req Manager
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
-> (Response (ConduitM () ByteString n ()) -> ConduitM () r m ())
-> ConduitM () r m ()
httpSource Request
request Response (ConduitM () ByteString n ()) -> ConduitM () r m ()
withRes = do
  env
env <- ConduitT () r m env
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO (Response (ConduitM () ByteString n ()))
-> (Response (ConduitM () ByteString n ()) -> IO ())
-> (Response (ConduitM () ByteString n ()) -> ConduitM () r m ())
-> ConduitM () r m ()
forall (m :: * -> *) a i o r.
MonadResource m =>
IO a -> (a -> IO ()) -> (a -> ConduitT i o m r) -> ConduitT i o m r
bracketP
    (ReaderT env IO (Response (ConduitM () ByteString n ()))
-> env -> IO (Response (ConduitM () ByteString n ()))
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Request -> ReaderT env IO (Response (ConduitM () ByteString n ()))
forall (m :: * -> *) (n :: * -> *) env i.
(MonadIO m, MonadIO n, MonadReader env m, HasHttpManager env) =>
Request -> m (Response (ConduitM i ByteString n ()))
responseOpen Request
request) env
env)
    Response (ConduitM () ByteString n ()) -> IO ()
forall (m :: * -> *) body. MonadIO m => Response body -> m ()
responseClose
    Response (ConduitM () ByteString n ()) -> ConduitM () r m ()
withRes