]> Git — Sourcephile - haskell/symantic-http.git/blob - Symantic/HTTP/Client.hs
Drop the Language prefix in module names
[haskell/symantic-http.git] / Symantic / HTTP / Client.hs
1 {-# LANGUAGE DataKinds #-}
2 {-# LANGUAGE DeriveFunctor #-}
3 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 {-# LANGUAGE Rank2Types #-}
6 {-# LANGUAGE StrictData #-}
7 {-# LANGUAGE TypeFamilies #-}
8 {-# OPTIONS_GHC -fno-warn-orphans #-}
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.Default.Class (Default(..))
16 import Data.Either (Either(..))
17 import Data.Eq (Eq(..))
18 import Data.Foldable (null, for_, toList, any)
19 import Data.Function (($), (.), on)
20 import Data.Functor (Functor, (<$>))
21 import Data.Maybe (Maybe(..), maybe)
22 import Data.Ord (Ord(..))
23 import Data.Proxy (Proxy(..))
24 import Data.Semigroup (Semigroup(..))
25 import Data.Sequence (Seq)
26 import Data.String (IsString(..))
27 import Data.Text (Text)
28 import Data.Tuple (fst)
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.Builder as BSB
39 import qualified Data.ByteString.Lazy as BSL
40 import qualified Data.List as List
41 import qualified Data.Sequence as Seq
42 import qualified Data.Text as T
43 import qualified Data.Time.Clock as Time
44 import qualified Network.HTTP.Client as Client
45 import qualified Network.HTTP.Media as Media
46 import qualified Network.HTTP.Types as HTTP
47 import qualified Network.URI as URI
48
49 import Symantic.HTTP.Media
50 import Symantic.HTTP.Mime
51 import Symantic.HTTP.URI
52
53 -- * Type 'Client'
54 newtype Client a = Client { unClient :: R.ReaderT ClientEnv (E.ExceptT ClientError IO) a }
55 deriving (Functor, Applicative, Monad)
56 type instance MC.CanDo Client (MC.EffReader ClientEnv) = 'True
57 type instance MC.CanDo Client (MC.EffExcept ClientError) = 'True
58 type instance MC.CanDo Client (MC.EffExec IO) = 'True
59 instance MC.MonadExceptN 'MC.Zero ClientError Client where
60 throwN px = Client . lift . MC.throwN px
61 instance MC.MonadReaderN 'MC.Zero ClientEnv Client where
62 askN px = Client $ MC.askN px
63 instance MC.MonadExecN 'MC.Zero IO Client where
64 execN _px = Client . lift . lift
65
66 -- | Try clients in order, last error is preserved.
67 instance Alternative Client where
68 empty = MC.throw $ ClientError_EmptyClient
69 x <|> y = Client $ do
70 env <- MC.ask
71 MC.exec (runClient env x) >>= \case
72 Right xa -> return xa
73 Left _err -> unClient y
74
75 client ::
76 forall mt a.
77 MimeUnserialize mt a =>
78 (ClientRequestType mt a -> ClientRequest) -> Client a
79 client req = do
80 clientRes <- doClientRequest $ req ClientRequestType
81 mimeUnserializeResponse (Proxy::Proxy mt) clientRes
82
83 runClient :: ClientEnv -> Client a -> IO (Either ClientError a)
84 runClient env (Client c) = E.runExceptT $ R.runReaderT c env
85
86 runClientRequest :: ClientEnv -> ClientRequest -> IO (Either ClientError ClientResponse)
87 runClientRequest env req = runClient env (doClientRequest req)
88
89 -- ** Type 'ClientRequestType'
90 data ClientRequestType mt a = ClientRequestType
91
92 -- ** Type 'ClientEnv'
93 data ClientEnv = ClientEnv
94 { clientEnv_manager :: Client.Manager
95 , clientEnv_baseURI :: URI
96 , clientEnv_cookieJar :: Maybe (STM.TVar Client.CookieJar)
97 }
98 clientEnv :: Client.Manager -> URI -> ClientEnv
99 clientEnv clientEnv_manager clientEnv_baseURI =
100 ClientEnv
101 { clientEnv_cookieJar = Nothing
102 , ..
103 }
104
105 -- ** Type 'ClientError'
106 data ClientError
107 -- | The server returned an error response
108 = ClientError_FailureResponse ClientResponse
109 -- | The body could not be decoded at the expected type
110 | ClientError_DecodeFailure Text ClientResponse
111 -- | The content-type of the response is not supported
112 | ClientError_UnsupportedContentType MediaType ClientResponse
113 -- | The content-type header is invalid
114 | ClientError_InvalidContentTypeHeader ClientResponse
115 -- | There was a connection error, and no response was received
116 | ClientError_ConnectionError Client.HttpException
117 -- | 'Client' is 'empty'
118 | ClientError_EmptyClient
119 deriving (Eq, Show{-, Generic, Typeable-})
120 instance Exn.Exception ClientError
121 instance Eq Client.HttpException where
122 (==) = (==) `on` show
123
124 -- * Type 'ClientRequest'
125 data ClientRequest = ClientRequest
126 { clientReqHttpVersion :: HTTP.HttpVersion
127 , clientReqMethod :: HTTP.Method
128 , clientReqPath :: BSB.Builder
129 , clientReqQueryString :: Seq HTTP.QueryItem
130 , clientReqAccept :: Seq Media.MediaType
131 , clientReqHeaders :: Seq HTTP.Header
132 , clientReqBody :: Maybe (Client.RequestBody, Media.MediaType)
133 }
134 instance Default ClientRequest where
135 def = ClientRequest
136 { clientReqHttpVersion = HTTP.http11
137 , clientReqMethod = HTTP.methodGet
138 , clientReqPath = ""
139 , clientReqQueryString = Seq.empty
140 , clientReqAccept = Seq.empty
141 , clientReqHeaders = Seq.empty
142 , clientReqBody = Nothing
143 }
144
145 clientRequest :: URI -> ClientRequest -> Client.Request
146 clientRequest baseURI req =
147 Client.defaultRequest
148 { Client.method = clientReqMethod req
149 , Client.host = maybe "" (fromString . URI.uriRegName) $ URI.uriAuthority baseURI
150 , Client.port = case URI.uriPort <$> URI.uriAuthority baseURI of
151 Just (':':p) | Just port <- readMaybe p -> port
152 _ -> 0
153 , Client.path = BSL.toStrict $ fromString (URI.uriPath baseURI) <> BSB.toLazyByteString (clientReqPath req)
154 , Client.queryString = HTTP.renderQuery True . toList $ clientReqQueryString req
155 , Client.requestHeaders = acceptHeader <> contentTypeHeader <> headers
156 , Client.requestBody
157 , Client.secure = URI.uriScheme baseURI == "https"
158 }
159 where
160 headers = List.filter (\(h, _) -> h/="Accept" && h/="Content-Type") $
161 toList $ clientReqHeaders req
162
163 acceptHeader | null hs = []
164 | otherwise = [("Accept", Media.renderHeader hs)]
165 where
166 hs = toList $ clientReqAccept req
167
168 (requestBody, contentTypeHeader) =
169 case clientReqBody req of
170 Nothing -> (Client.RequestBodyLBS "", [])
171 Just (body, typ) -> (body, [(HTTP.hContentType, Media.renderHeader typ)])
172
173 setClientRequestBodyLBS :: BSL.ByteString -> MediaType -> ClientRequest -> ClientRequest
174 setClientRequestBodyLBS body mt req = req{ clientReqBody = Just (Client.RequestBodyLBS body, mt) }
175
176 setClientRequestBody :: Client.RequestBody -> MediaType -> ClientRequest -> ClientRequest
177 setClientRequestBody body mt req = req{ clientReqBody = Just (body, mt) }
178
179 -- ** Type 'ClientResponse'
180 type ClientResponse = ClientResponseWithBody BSL.ByteString
181 data ClientResponseWithBody a = ClientResponse
182 { clientResStatus :: HTTP.Status
183 , clientResHeaders :: Seq HTTP.Header
184 , clientResHttpVersion :: HTTP.HttpVersion
185 , clientResBody :: a
186 } deriving (Eq, Show, Functor)
187
188 clientResponse :: Client.Response a -> ClientResponseWithBody a
189 clientResponse res =
190 ClientResponse
191 { clientResStatus = Client.responseStatus res
192 , clientResBody = Client.responseBody res
193 , clientResHeaders = Seq.fromList $ Client.responseHeaders res
194 , clientResHttpVersion = Client.responseVersion res
195 }
196
197 doClientRequest :: ClientRequest -> Client ClientResponse
198 doClientRequest clientReq = do
199 ClientEnv{..} <- MC.ask
200 req <-
201 let req = clientRequest clientEnv_baseURI clientReq in
202 case clientEnv_cookieJar of
203 Nothing -> pure req
204 Just cj ->
205 MC.exec $ do
206 now <- Time.getCurrentTime
207 STM.atomically $ do
208 oldCookieJar <- STM.readTVar cj
209 let (newRequest, newCookieJar) =
210 Client.insertCookiesIntoRequest req oldCookieJar now
211 STM.writeTVar cj newCookieJar
212 pure newRequest
213 lrRes <-
214 MC.exec $ catchConnectionError $
215 Client.httpLbs req clientEnv_manager
216 case lrRes of
217 Left err -> MC.throw err
218 Right res -> do
219 for_ clientEnv_cookieJar $ \cj ->
220 MC.exec $ do
221 now <- Time.getCurrentTime
222 STM.atomically $ STM.modifyTVar' cj (fst . Client.updateCookieJar res req now)
223 let status = HTTP.statusCode $ Client.responseStatus res
224 clientRes = clientResponse res
225 unless (status >= 200 && status < 300) $
226 MC.throw $ ClientError_FailureResponse clientRes
227 return clientRes
228
229 catchConnectionError :: IO a -> IO (Either ClientError a)
230 catchConnectionError action =
231 Exn.catch (Right <$> action) $ \err ->
232 return $ Left $ ClientError_ConnectionError err
233
234 -- ** Type 'ClientResponseStreaming'
235 newtype ClientResponseStreaming = ClientResponseStreaming
236 { runResponseStreaming ::
237 forall a. (ClientResponseWithBody (IO BS.ByteString) -> IO a) -> IO a }
238
239 doClientRequestStreaming :: ClientRequest -> Client ClientResponseStreaming
240 doClientRequestStreaming clientReq = do
241 ClientEnv{..} <- MC.ask
242 let req = clientRequest clientEnv_baseURI clientReq
243 return $ ClientResponseStreaming $ \k ->
244 Client.withResponse req clientEnv_manager $ \res -> do
245 let status = HTTP.statusCode $ Client.responseStatus res
246 unless (status >= 200 && status < 300) $ do
247 responseBody <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)
248 Exn.throw $ ClientError_FailureResponse $ clientResponse res{Client.responseBody}
249 k $ clientResponse res
250
251 getContentType ::
252 MC.MonadExcept ClientError m =>
253 ClientResponse -> m MediaType
254 getContentType clientRes =
255 case List.lookup "Content-Type" $ toList $ clientResHeaders clientRes of
256 Nothing -> return $ "application"Media.//"octet-stream"
257 Just mt ->
258 case Media.parseAccept mt of
259 Nothing -> MC.throw $ ClientError_InvalidContentTypeHeader clientRes
260 Just mt' -> return mt'
261
262 mimeUnserializeResponse ::
263 MimeUnserialize mt a =>
264 MC.MonadExcept ClientError m =>
265 Proxy mt -> ClientResponse -> m a
266 mimeUnserializeResponse mt clientRes = do
267 mtRes <- getContentType clientRes
268 unless (any (Media.matches mtRes) $ mediaTypes mt) $
269 MC.throw $ ClientError_UnsupportedContentType mtRes clientRes
270 case mimeUnserialize mt $ clientResBody clientRes of
271 Left err -> MC.throw $ ClientError_DecodeFailure (T.pack err) clientRes
272 Right val -> return val