1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
|
{-# 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 req f = do
env <- ask
withRunInIO $ \run -> with (acquireResponse req env) (run . 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
-- | 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
bodyReaderSource :: MonadIO m
=> H.BodyReader
-> ConduitM i ByteString m ()
bodyReaderSource br =
loop
where
loop = do
bs <- liftIO $ H.brRead br
unless (S.null bs) $ do
yield bs
loop
requestBodySource :: Int64 -> ConduitM () ByteString IO () -> RequestBody
requestBodySource size = RequestBodyStream size . srcToPopperIO
requestBodySourceChunked :: ConduitM () ByteString IO () -> RequestBody
requestBodySourceChunked = RequestBodyStreamChunked . srcToPopperIO
srcToPopperIO :: ConduitM () ByteString IO () -> 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
-- | 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 req = do
env <- ask
let man = getHttpManager env
liftIO $ H.httpLbs req 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 req = do
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
|
