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