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