]> Git — Sourcephile - haskell/symantic-http.git/blob - symantic-http-client/Symantic/HTTP/Client.hs
stack: bump to lts-14.13
[haskell/symantic-http.git] / symantic-http-client / Symantic / HTTP / Client.hs
1 {-# LANGUAGE DeriveFunctor #-}
2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 {-# LANGUAGE Rank2Types #-}
5 {-# LANGUAGE StrictData #-}
6 {-# OPTIONS_GHC -fno-warn-orphans #-}
7 -- | See <https://hackage.haskell.org/package/symantic-http-demo symantic-http-demo>
8 -- for an example of how to use this module.
9 module Symantic.HTTP.Client where
10
11 import Control.Applicative (Applicative(..){-, Alternative(..)-})
12 import Control.Monad (Monad(..), unless)
13 import Control.Monad.Trans.Class (MonadTrans(..))
14 import Data.Bool
15 import Data.Either (Either(..))
16 import Data.Eq (Eq(..))
17 import Data.Foldable (null, for_, toList)
18 import Data.Function (($), (.), id, on)
19 import Data.Functor (Functor(..), (<$>))
20 import Data.Kind (Constraint)
21 import Data.Maybe (Maybe(..), maybe, fromMaybe)
22 import Data.Ord (Ord(..))
23 import Data.Proxy (Proxy(..))
24 import Data.Semigroup (Semigroup(..))
25 import Data.String (IsString(..), String)
26 import Data.Traversable (sequence)
27 import Data.Tuple (fst)
28 import GHC.Exts (fromList)
29 import System.IO (IO)
30 import Text.Read (readMaybe)
31 import Text.Show (Show(..))
32 import qualified Control.Concurrent.STM as STM
33 import qualified Control.Exception as Exn
34 import qualified Control.Monad.Classes as MC
35 import qualified Control.Monad.Trans.Except as E
36 import qualified Control.Monad.Trans.Reader as R
37 import qualified Data.ByteString as BS
38 import qualified Data.ByteString.Base64 as BS64
39 import qualified Data.ByteString.Builder as BSB
40 import qualified Data.ByteString.Lazy as BSL
41 import qualified Data.IORef as IO
42 import qualified Data.List as List
43 import qualified Data.List.NonEmpty as NonEmpty
44 import qualified Data.Sequence as Seq
45 import qualified Data.Text.Encoding as Text
46 import qualified Data.Time.Clock as Time
47 import qualified Network.HTTP.Client as Client
48 import qualified Network.HTTP.Media as Media
49 import qualified Network.HTTP.Types as HTTP
50 import qualified Network.URI as URI
51 import qualified Web.HttpApiData as Web
52
53 import Symantic.HTTP.API
54 import Symantic.HTTP.URI
55 import Symantic.HTTP.MIME
56
57 -- * Type 'Client'
58 -- | (@'Client' a k@) is a recipe to produce a 'ClientRequest'
59 -- from returned ('callers') (one per number of alternative routes)
60 -- separated by (':!:').
61 --
62 -- 'Client' is analogous to a printf using the API as a format customized for HTTP routing.
63 newtype Client callers k
64 = Client
65 { unClient :: (ClientModifier -> k) -> callers
66 }
67
68 -- | @'client' callers@ returns the 'ClientRequest'
69 -- builders from the given API.
70 client :: Client callers ClientRequest -> callers
71 client (Client callers) = callers ($ ini)
72 where
73 ini = ClientRequest
74 { clientReq_httpVersion = HTTP.http11
75 , clientReq_method = HTTP.methodGet
76 , clientReq_path = ""
77 , clientReq_queryString = Seq.empty
78 , clientReq_accept = Seq.empty
79 , clientReq_headers = Seq.empty
80 , clientReq_body = Nothing
81 }
82
83 -- ** Type 'ClientModifier'
84 type ClientModifier = ClientRequest -> ClientRequest
85
86 instance Cat Client where
87 Client x <.> Client y = Client $ \k ->
88 x $ \fx -> y $ \fy -> k $ fy . fx
89 instance Alt Client where
90 Client x <!> Client y = Client $ \k ->
91 x k :!: y k
92 {-
93 type AltMerge Client = (:!:)
94 Client x <!> Client y = Client $ \k ->
95 x (\cm -> let n:!:_ = k cm in n) :!:
96 y (\cm -> let _:!:n = k cm in n)
97 -}
98 -- try = id -- FIXME: see what to do
99 instance Pro Client where
100 dimap _a2b b2a r = Client $ \k -> unClient r k . b2a
101
102 instance HTTP_Path Client where
103 type PathConstraint Client a = Web.ToHttpApiData a
104 segment s = Client $ \k -> k $ \req ->
105 req{ clientReq_path = clientReq_path req <> "/" <> Web.toEncodedUrlPiece s }
106 capture' _n = Client $ \k a -> k $ \req ->
107 req{ clientReq_path = clientReq_path req <> "/" <> Web.toEncodedUrlPiece a }
108 captureAll = Client $ \k ss -> k $ \req ->
109 req{ clientReq_path =
110 List.foldl' (\acc s -> acc <> "/" <> Web.toEncodedUrlPiece s) "" $
111 Web.toUrlPiece <$> ss
112 }
113 instance HTTP_Header Client where
114 header n = Client $ \k v -> k $ \req ->
115 req{ clientReq_headers = clientReq_headers req Seq.|> (n, Web.toHeader v) }
116 instance HTTP_Raw Client where
117 type RawConstraint Client = ()
118 type RawArgs Client = HTTP.Method -> Proxy ('[]::[*]) -> Proxy ClientResponse -> ClientRequest
119 type Raw Client = ClientRequest
120 raw = Client $ \k meth Proxy Proxy -> k $ \req ->
121 req{ clientReq_method = meth }
122 instance HTTP_BasicAuth Client where
123 type BasicAuthConstraint Client a = ()
124 type BasicAuthArgs Client a k = BasicAuthUser -> BasicAuthPass -> k
125 basicAuth' realm = Client $ \k user pass -> k $ \req ->
126 req{ clientReq_headers =
127 let user_pass = Text.encodeUtf8 $ user<>":"<>pass in
128 clientReq_headers req Seq.|>
129 ( HTTP.hAuthorization
130 , Web.toHeader $ "Basic " <> BS64.encode user_pass
131 )
132 }
133 instance HTTP_Query Client where
134 type QueryConstraint Client a = Web.ToHttpApiData a
135 queryParams' n = Client $ \k vs -> k $ \req ->
136 req{ clientReq_queryString =
137 clientReq_queryString req <>
138 fromList ((\v -> (n, Just $ Text.encodeUtf8 $ Web.toQueryParam v)) <$> vs) }
139 instance HTTP_Version Client where
140 version v = Client $ \k -> k $ \req ->
141 req{clientReq_httpVersion = v}
142
143 -- ** Type 'ClientBodyArg'
144 newtype ClientBodyArg (ts::[*]) a = ClientBodyArg a
145 instance HTTP_Body Client where
146 type BodyConstraint Client a ts = MimeTypes ts (MimeEncodable a)
147 type BodyArg Client a ts = ClientBodyArg ts a
148 body' ::
149 forall a ts k repr.
150 BodyConstraint repr a ts =>
151 repr ~ Client =>
152 repr (BodyArg repr a ts -> k) k
153 body'= Client $ \k (ClientBodyArg a) -> k $ \req ->
154 req{clientReq_body =
155 case NonEmpty.head (mimeTypes @ts) :: MimeType (MimeEncodable a) of
156 MimeType (mt::Proxy t) ->
157 Just
158 ( Client.RequestBodyLBS $ mimeEncode mt a
159 , mediaType @t )
160 }
161
162 -- ** Type 'ClientBodyStreamArg'
163 newtype ClientBodyStreamArg framing (ts::[*]) as = ClientBodyStreamArg as
164 instance HTTP_BodyStream Client where
165 type BodyStreamConstraint Client as ts framing =
166 ( FramingEncode framing as
167 , MimeTypes ts (MimeEncodable (FramingYield as))
168 )
169 type BodyStreamArg Client as ts framing = ClientBodyStreamArg framing ts as
170 bodyStream' ::
171 forall as ts framing k repr.
172 BodyStreamConstraint repr as ts framing =>
173 repr ~ Client =>
174 repr (BodyStreamArg repr as ts framing -> k) k
175 bodyStream'= Client $ \k (ClientBodyStreamArg as) -> k $ \req ->
176 req{clientReq_body =
177 case NonEmpty.head (mimeTypes @ts) :: MimeType (MimeEncodable (FramingYield as)) of
178 MimeType (mt::Proxy t) ->
179 Just $ (, mediaType @t) $
180 Client.RequestBodyStreamChunked $ \write -> do
181 let enc = framingEncode (Proxy @framing) (mimeEncode mt)
182 ini <- enc as
183 ioref <- IO.newIORef ini
184 let go curr =
185 case curr of
186 Left _end -> return ""
187 Right (bsl, next)
188 | BSL.null bsl -> enc next >>= go
189 -- NOTE: skip all null 'ByteString' because it would end the stream.
190 | otherwise -> enc next >>= \n -> do
191 IO.writeIORef ioref n
192 return $ BSL.toStrict bsl
193 -- NOTE: strictify the 'bsl' 'ByteString'
194 -- instead of iterating on its chunks,
195 -- in order to diminish the number of 'Client.connectionWrite'.
196 write $ IO.readIORef ioref >>= go
197 }
198
199 instance HTTP_Response Client where
200 type ResponseConstraint Client a ts = MimeTypes ts (MimeDecodable a)
201 type ResponseArgs Client a ts = Proxy ts -> Proxy a -> ClientRequest
202 type Response Client = ClientRequest
203 response ::
204 forall a ts repr.
205 ResponseConstraint repr a ts =>
206 repr ~ Client =>
207 HTTP.Method ->
208 repr (ResponseArgs repr a ts)
209 (Response repr)
210 response meth = Client $ \k Proxy Proxy -> k $ \req ->
211 req
212 { clientReq_method = meth
213 , clientReq_accept =
214 clientReq_accept req <>
215 fromList (toList $ mediaTypes @ts @(MimeDecodable a))
216 }
217
218 instance HTTP_ResponseStream Client where
219 type ResponseStreamConstraint Client as ts framing =
220 MimeTypes ts (MimeDecodable (FramingYield as))
221 type ResponseStreamArgs Client as ts framing =
222 Proxy framing ->
223 Proxy ts ->
224 Proxy as ->
225 ClientRequest
226 type ResponseStream Client = ClientRequest
227
228 responseStream ::
229 forall as ts framing repr.
230 ResponseStreamConstraint repr as ts framing =>
231 repr ~ Client =>
232 HTTP.Method ->
233 repr (ResponseStreamArgs repr as ts framing)
234 (ResponseStream repr)
235 responseStream meth = Client $ \k Proxy Proxy Proxy -> k $ \req ->
236 req
237 { clientReq_method = meth
238 , clientReq_accept =
239 clientReq_accept req <>
240 fromList (toList $ mediaTypes @ts @(MimeDecodable (FramingYield as)))
241 }
242
243 instance Web.ToHttpApiData BS.ByteString where
244 toUrlPiece = Web.toUrlPiece . Text.decodeUtf8
245 toHeader = id
246
247 -- * Type 'ClientConn'
248 -- | A monadic connection from a client to a server.
249 -- It is specialized in 'ClientConnection' and 'ClientConnectionStream'.
250 --
251 -- NOTE: no 'Monad' transformer is put within this newtype
252 -- to let @monad-classes@ handle all the |lift|ing.
253 newtype ClientConn m a
254 = ClientConn
255 { unClientConn :: m a
256 } deriving (Functor, Applicative, Monad)
257 -- | All supported effects are handled by nested 'Monad's.
258 type instance MC.CanDo (ClientConn m) eff = 'False
259 instance MonadTrans ClientConn where
260 lift = ClientConn
261
262 -- ** Type 'ClientEnv'
263 data ClientEnv
264 = ClientEnv
265 { clientEnv_manager :: Client.Manager
266 , clientEnv_baseURI :: URI
267 , clientEnv_cookieJar :: Maybe (STM.TVar Client.CookieJar)
268 }
269 clientEnv :: Client.Manager -> URI -> ClientEnv
270 clientEnv clientEnv_manager clientEnv_baseURI =
271 ClientEnv
272 { clientEnv_cookieJar = Nothing
273 , ..
274 }
275
276 -- ** Type 'ClientError'
277 data ClientError
278 -- | The server returned an error response
279 = ClientError_FailureResponse ClientResponse
280 -- | The body could not be decoded at the expected type
281 | ClientError_DecodeFailure String ClientResponse
282 -- | The content-type of the response is not supported
283 | ClientError_UnsupportedContentType BS.ByteString ClientResponse
284 -- | There was a connection error, and no response was received
285 | ClientError_ConnectionError Client.HttpException
286 -- | 'ClientConn' is 'empty'
287 | ClientError_EmptyClient
288 deriving (Eq, Show{-, Generic, Typeable-})
289 instance Exn.Exception ClientError
290 instance Eq Client.HttpException where
291 (==) = (==) `on` show
292
293 -- ** Type 'ClientRequest'
294 data ClientRequest
295 = ClientRequest
296 { clientReq_httpVersion :: HTTP.HttpVersion
297 , clientReq_method :: HTTP.Method
298 , clientReq_path :: BSB.Builder
299 , clientReq_queryString :: Seq.Seq HTTP.QueryItem
300 , clientReq_accept :: Seq.Seq Media.MediaType
301 , clientReq_headers :: Seq.Seq HTTP.Header
302 , clientReq_body :: Maybe (Client.RequestBody, Media.MediaType)
303 }
304 instance Show ClientRequest where
305 show _ = "ClientRequest"
306
307 clientRequest :: URI -> ClientRequest -> Client.Request
308 clientRequest baseURI req =
309 Client.defaultRequest
310 { Client.method = clientReq_method req
311 , Client.host = maybe "" (fromString . URI.uriRegName) $ URI.uriAuthority baseURI
312 , Client.port = case URI.uriPort <$> URI.uriAuthority baseURI of
313 Just (':':p) | Just port <- readMaybe p -> port
314 _ -> 0
315 , Client.path = BSL.toStrict $ fromString (URI.uriPath baseURI) <> BSB.toLazyByteString (clientReq_path req)
316 , Client.queryString = HTTP.renderQuery True . toList $ clientReq_queryString req
317 , Client.requestHeaders = acceptHeader <> contentTypeHeader <> headers
318 , Client.requestBody
319 , Client.secure = URI.uriScheme baseURI == "https"
320 }
321 where
322 headers = List.filter (\(h, _) -> h/="Accept" && h/="Content-Type") $
323 toList $ clientReq_headers req
324
325 acceptHeader | null hs = []
326 | otherwise = [("Accept", Media.renderHeader hs)]
327 where
328 hs = toList $ clientReq_accept req
329
330 (requestBody, contentTypeHeader) =
331 case clientReq_body req of
332 Nothing -> (Client.RequestBodyBS "", [])
333 Just (b, mt) -> (b, [(HTTP.hContentType, Media.renderHeader mt)])
334
335 -- ** Type 'ClientConnection'
336 type ClientConnection
337 = ClientConn (R.ReaderT ClientEnv (E.ExceptT ClientError IO))
338
339 {-
340 -- | Try clients in order, last error is preserved.
341 instance Alternative ClientConnection where
342 empty = MC.throw $ ClientError_EmptyClient
343 x <|> y = ClientConn $ do
344 env <- MC.ask
345 MC.exec @IO (E.runExceptT $ R.runReaderT (unClientConn x) env) >>= \case
346 Right xa -> return xa
347 Left _err -> unClientConn y
348 -}
349
350 runClient ::
351 ClientConnectionConstraint a ts =>
352 ClientConnectionClass a ts =>
353 ClientEnv ->
354 (Proxy ts -> Proxy a -> ClientRequest) ->
355 IO (Either ClientError a)
356 runClient env =
357 E.runExceptT .
358 (`R.runReaderT` env) .
359 unClientConn .
360 clientConnection
361
362 -- ** Class 'ClientConnectionClass'
363 -- | 'clientConnection' is different when 'ts' is empty:
364 -- no 'mimeDecode' is performed.
365 -- This is used by the 'raw' combinator.
366 class ClientConnectionClass a (ts::[*]) where
367 type ClientConnectionConstraint a ts :: Constraint
368 clientConnection ::
369 ClientConnectionConstraint a ts =>
370 (Proxy ts -> Proxy a -> ClientRequest) ->
371 ClientConnection a
372 instance ClientConnectionClass ClientResponse '[] where
373 type ClientConnectionConstraint ClientResponse '[] = ()
374 clientConnection req = do
375 clientRes <- doClientRequest $ req
376 (Proxy::Proxy '[])
377 (Proxy::Proxy ClientResponse)
378 return clientRes
379 instance ClientConnectionClass a (t ': ts) where
380 type ClientConnectionConstraint a (t ': ts) =
381 MimeTypes (t ': ts) (MimeDecodable a)
382 clientConnection req = do
383 clientRes <- doClientRequest $ req (Proxy::Proxy (t ': ts)) (Proxy::Proxy a)
384 let mtRes =
385 fromMaybe "application/octet-stream" $
386 List.lookup "Content-Type" $
387 Client.responseHeaders clientRes
388 case matchContent @(t ': ts) @(MimeDecodable a) mtRes of
389 Nothing -> MC.throw $ ClientError_UnsupportedContentType mtRes clientRes
390 Just (MimeType mt) ->
391 case mimeDecode mt $ Client.responseBody clientRes of
392 Left err -> MC.throw $ ClientError_DecodeFailure err clientRes
393 Right a -> return a
394
395 doClientRequest :: ClientRequest -> ClientConnection ClientResponse
396 doClientRequest clientReq = do
397 ClientEnv{..} <- MC.ask
398 req <-
399 let req = clientRequest clientEnv_baseURI clientReq in
400 case clientEnv_cookieJar of
401 Nothing -> pure req
402 Just cj ->
403 MC.exec @IO $ do
404 now <- Time.getCurrentTime
405 STM.atomically $ do
406 oldCookieJar <- STM.readTVar cj
407 let (newRequest, newCookieJar) =
408 Client.insertCookiesIntoRequest req oldCookieJar now
409 STM.writeTVar cj newCookieJar
410 pure newRequest
411 lrRes <-
412 MC.exec @IO $ catchClientConnectionError $
413 Client.httpLbs req clientEnv_manager
414 case lrRes of
415 Left err -> MC.throw err
416 Right res -> do
417 for_ clientEnv_cookieJar $ \cj ->
418 MC.exec @IO $ do
419 now <- Time.getCurrentTime
420 STM.atomically $ STM.modifyTVar' cj (fst . Client.updateCookieJar res req now)
421 let code = HTTP.statusCode $ Client.responseStatus res
422 unless (code >= 200 && code < 300) $
423 MC.throw $ ClientError_FailureResponse res
424 return res
425
426 catchClientConnectionError :: IO a -> IO (Either ClientError a)
427 catchClientConnectionError ma =
428 Exn.catch (Right <$> ma) $ \err ->
429 return $ Left $ ClientError_ConnectionError err
430
431 -- *** Type 'ClientResponse'
432 type ClientResponse
433 = Client.Response BSL.ByteString
434
435 -- ** Type 'ClientConnectionStream'
436 type ClientConnectionStream
437 = ClientConn (R.ReaderT ClientEnv (Codensity (E.ExceptT ClientError IO)))
438
439 runClientStream ::
440 FramingDecode framing as =>
441 MC.MonadExec IO (FramingMonad as) =>
442 MimeTypes ts (MimeDecodable (FramingYield as)) =>
443 ClientEnv ->
444 (Proxy framing -> Proxy ts -> Proxy as -> ClientRequest) ->
445 (as -> IO b) -> IO (Either ClientError b)
446 runClientStream env req k =
447 E.runExceptT $
448 (`runCodensity` lift . k) $
449 (`R.runReaderT` env) $
450 unClientConn $
451 clientConnectionStream req
452
453 clientConnectionStream ::
454 forall as ts framing.
455 FramingDecode framing as =>
456 MC.MonadExec IO (FramingMonad as) =>
457 MimeTypes ts (MimeDecodable (FramingYield as)) =>
458 (Proxy framing -> Proxy ts -> Proxy as -> ClientRequest) ->
459 ClientConnectionStream as
460 clientConnectionStream req = do
461 doClientRequestStream (Proxy::Proxy ts) (req Proxy Proxy Proxy) $ \(MimeType mt) clientRes ->
462 return $
463 framingDecode (Proxy @framing) (mimeDecode mt) $
464 MC.exec @IO $ Client.responseBody clientRes
465
466 doClientRequestStream ::
467 forall (ts::[*]) as.
468 MimeTypes ts (MimeDecodable (FramingYield as)) =>
469 Proxy ts ->
470 ClientRequest ->
471 ( MimeType (MimeDecodable (FramingYield as)) ->
472 Client.Response Client.BodyReader ->
473 E.ExceptT ClientError IO as ) ->
474 ClientConnectionStream as
475 doClientRequestStream Proxy clientReq k = do
476 ClientEnv{..} <- MC.ask
477 let req = clientRequest clientEnv_baseURI $ clientReq
478 ClientConn $ lift $ Codensity $ \k' ->
479 E.ExceptT $ Client.withResponse req clientEnv_manager $ \res ->
480 E.runExceptT $ do{-E.ExceptT ClientError IO-}
481 -- Check status
482 let code = HTTP.statusCode $ Client.responseStatus res
483 unless (code >= 200 && code < 300) $ do
484 err <- MC.exec @IO $ sequence $ (BSL.fromChunks <$>) . Client.brConsume <$> res
485 E.throwE $ ClientError_FailureResponse err
486 -- Check Content-Type header
487 let contentTypeH =
488 fromMaybe "application/octet-stream" $
489 List.lookup "Content-Type" $
490 Client.responseHeaders res
491 case matchContent @ts @(MimeDecodable (FramingYield as)) contentTypeH of
492 Nothing -> do
493 err <- MC.exec @IO $ sequence $ (BSL.fromChunks <$>) . Client.brConsume <$> res
494 E.throwE $ ClientError_UnsupportedContentType contentTypeH err
495 Just ct -> k ct res >>= k'
496
497 -- *** Type 'Codensity'
498 -- | Copy from the @kan-extensions@ package to avoid the dependencies.
499 newtype Codensity m a
500 = Codensity
501 { runCodensity :: forall b. (a -> m b) -> m b }
502 type instance MC.CanDo (Codensity m) (MC.EffExec eff) = 'False
503 instance Functor (Codensity k) where
504 fmap f (Codensity m) = Codensity (\k -> m (k .f))
505 {-# INLINE fmap #-}
506 instance Applicative (Codensity f) where
507 pure x = Codensity (\k -> k x)
508 {-# INLINE pure #-}
509 Codensity f <*> Codensity g = Codensity (\bfr -> f (\ab -> g (bfr . ab)))
510 {-# INLINE (<*>) #-}
511 instance Monad (Codensity f) where
512 return = pure
513 {-# INLINE return #-}
514 m >>= k = Codensity (\c -> runCodensity m (\a -> runCodensity (k a) c))
515 {-# INLINE (>>=) #-}
516 instance MonadTrans Codensity where
517 lift m = Codensity (m >>=)
518 {-# INLINE lift #-}