git.iko.soy/typeable/servant
on master help sign in
extract module for http-client
2665693Arnaud Bailly
servant-client/servant-client.cabal+1
compare with master
unifiedsplit
@@ -30,6 +30,7 @@ source-repository head
30library
30library
31 exposed-modules:
31 exposed-modules:
32 Servant.Client
32 Servant.Client
33+ Servant.Client.HttpClient
33 Servant.Client.Generic
34 Servant.Client.Generic
34 Servant.Client.Experimental.Auth
35 Servant.Client.Experimental.Auth
35 Servant.Common.BaseUrl
36 Servant.Common.BaseUrl
servant-client/src/Servant/Client.hs+1
@@ -42,6 +42,7 @@ import Prelude ()
42import Prelude.Compat
42import Prelude.Compat
43import Servant.API
43import Servant.API
44import Servant.Client.Experimental.Auth
44import Servant.Client.Experimental.Auth
45+import Servant.Client.HttpClient
45import Servant.Common.BaseUrl
46import Servant.Common.BaseUrl
46import Servant.Common.BasicAuth
47import Servant.Common.BasicAuth
47import Servant.Common.Req
48import Servant.Common.Req
servant-client/src/Servant/Client/HttpClient.hsnew file+130
@@ -0,0 +1,130 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE DeriveGeneric #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE TypeFamilies #-}
7+{-# LANGUAGE OverloadedStrings #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+
10+{-| http-client based client requests executor -}
11+module Servant.Client.HttpClient where
12+
13+
14+import Prelude ()
15+import Prelude.Compat
16+
17+import Control.Exception
18+import Control.Monad
19+import Control.Monad.Catch (MonadThrow, MonadCatch)
20+import Data.Foldable (toList)
21+import Data.Functor.Alt (Alt (..))
22+
23+import Control.Monad.Error.Class (MonadError(..))
24+import Control.Monad.Trans.Except
25+
26+import GHC.Generics
27+import Control.Monad.Base (MonadBase (..))
28+import Control.Monad.IO.Class ()
29+import Control.Monad.Reader
30+import Control.Monad.Trans.Control (MonadBaseControl (..))
31+import Data.ByteString.Lazy hiding (pack, filter, map, null, elem, any)
32+import Data.String.Conversions (cs)
33+import Data.Proxy
34+import Network.HTTP.Media
35+import Network.HTTP.Types
36+import Network.HTTP.Client hiding (Proxy, path)
37+import qualified Network.HTTP.Types.Header as HTTP
38+import Servant.API.ContentTypes
39+import Servant.Common.BaseUrl
40+import Servant.Common.Req
41+
42+import qualified Network.HTTP.Client as Client
43+
44+
45+data ClientEnv
46+ = ClientEnv
47+ { manager :: Manager
48+ , baseUrl :: BaseUrl
49+ }
50+
51+
52+-- | @ClientM@ is the monad in which client functions run. Contains the
53+-- 'Manager' and 'BaseUrl' used for requests in the reader environment.
54+
55+newtype ClientM a = ClientM { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a }
56+ deriving ( Functor, Applicative, Monad, MonadIO, Generic
57+ , MonadReader ClientEnv
58+ , MonadError ServantError
59+ , MonadThrow, MonadCatch
60+ )
61+
62+instance MonadBase IO ClientM where
63+ liftBase = ClientM . liftBase
64+
65+instance MonadBaseControl IO ClientM where
66+ type StM ClientM a = Either ServantError a
67+
68+ -- liftBaseWith :: (RunInBase ClientM IO -> IO a) -> ClientM a
69+ liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . runClientM')))
70+
71+ -- restoreM :: StM ClientM a -> ClientM a
72+ restoreM st = ClientM (restoreM st)
73+
74+-- | Try clients in order, last error is preserved.
75+instance Alt ClientM where
76+ a <!> b = a `catchError` \_ -> b
77+
78+runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
79+runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm
80+
81+
82+performRequest :: Method -> Req
83+ -> ClientM ( Int, ByteString, MediaType
84+ , [HTTP.Header], Response ByteString)
85+performRequest reqMethod req = do
86+ m <- asks manager
87+ reqHost <- asks baseUrl
88+ partialRequest <- liftIO $ reqToRequest req reqHost
89+
90+ let request = partialRequest { Client.method = reqMethod }
91+
92+ eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m
93+ case eResponse of
94+ Left err ->
95+ throwError . ConnectionError $ SomeException err
96+
97+ Right response -> do
98+ let status = Client.responseStatus response
99+ body = Client.responseBody response
100+ hdrs = Client.responseHeaders response
101+ status_code = statusCode status
102+ ct <- case lookup "Content-Type" $ Client.responseHeaders response of
103+ Nothing -> pure $ "application"//"octet-stream"
104+ Just t -> case parseAccept t of
105+ Nothing -> throwError $ InvalidContentTypeHeader (cs t) body
106+ Just t' -> pure t'
107+ unless (status_code >= 200 && status_code < 300) $
108+ throwError $ FailureResponse (UrlReq reqHost req) status ct body
109+ return (status_code, body, ct, hdrs, response)
110+
111+performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req
112+ -> ClientM ([HTTP.Header], result)
113+performRequestCT ct reqMethod req = do
114+ let acceptCTS = contentTypes ct
115+ (_status, respBody, respCT, hdrs, _response) <-
116+ performRequest reqMethod (req { reqAccept = toList acceptCTS })
117+ unless (any (matches respCT) acceptCTS) $ throwError $ UnsupportedContentType respCT respBody
118+ case mimeUnrender ct respBody of
119+ Left err -> throwError $ DecodeFailure err respCT respBody
120+ Right val -> return (hdrs, val)
121+
122+performRequestNoBody :: Method -> Req -> ClientM [HTTP.Header]
123+performRequestNoBody reqMethod req = do
124+ (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req
125+ return hdrs
126+
127+catchConnectionError :: IO a -> IO (Either ServantError a)
128+catchConnectionError action =
129+ catch (Right <$> action) $ \e ->
130+ pure . Left . ConnectionError $ SomeException (e :: HttpException)
servant-client/src/Servant/Common/Req.hs+1−103
@@ -13,38 +13,23 @@ import Prelude ()
13import Prelude.Compat
13import Prelude.Compat
14
14
15import Control.Exception
15import Control.Exception
16−import Control.Monad
16+import Control.Monad.Catch (MonadThrow)
17−import Control.Monad.Catch (MonadThrow, MonadCatch)
18−import Data.Foldable (toList)
19−import Data.Functor.Alt (Alt (..))
20import Data.Semigroup ((<>))
17import Data.Semigroup ((<>))
21
18
22−import Control.Monad.Error.Class (MonadError(..))
23−import Control.Monad.Trans.Except
24−
25−import GHC.Generics
26−import Control.Monad.Base (MonadBase (..))
27import Control.Monad.IO.Class ()
19import Control.Monad.IO.Class ()
28−import Control.Monad.Reader
29−import Control.Monad.Trans.Control (MonadBaseControl (..))
30import qualified Data.ByteString.Builder as BS
20import qualified Data.ByteString.Builder as BS
31import Data.ByteString.Lazy hiding (pack, filter, map, null, elem, any)
21import Data.ByteString.Lazy hiding (pack, filter, map, null, elem, any)
32import Data.String
22import Data.String
33import Data.String.Conversions (cs)
23import Data.String.Conversions (cs)
34−import Data.Proxy
35import Data.Text (Text)
24import Data.Text (Text)
36import Data.Text.Encoding
25import Data.Text.Encoding
37import Data.Typeable
26import Data.Typeable
38import Network.HTTP.Media
27import Network.HTTP.Media
39import Network.HTTP.Types
28import Network.HTTP.Types
40import Network.HTTP.Client hiding (Proxy, path)
29import Network.HTTP.Client hiding (Proxy, path)
41−import qualified Network.HTTP.Types.Header as HTTP
42import Network.URI hiding (path)
30import Network.URI hiding (path)
43−import Servant.API.ContentTypes
44import Servant.Common.BaseUrl
31import Servant.Common.BaseUrl
45
32
46−import qualified Network.HTTP.Client as Client
47−
48import Web.HttpApiData
33import Web.HttpApiData
49
34
50data ServantError
35data ServantError
@@ -196,90 +181,3 @@ parseRequest url = liftM disableStatusCheck (parseUrl url)
196
181
197displayHttpRequest :: Method -> String
182displayHttpRequest :: Method -> String
198displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
183displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
199−
200−data ClientEnv
201− = ClientEnv
202− { manager :: Manager
203− , baseUrl :: BaseUrl
204− }
205−
206−
207−-- | @ClientM@ is the monad in which client functions run. Contains the
208−-- 'Manager' and 'BaseUrl' used for requests in the reader environment.
209−
210−newtype ClientM a = ClientM { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a }
211− deriving ( Functor, Applicative, Monad, MonadIO, Generic
212− , MonadReader ClientEnv
213− , MonadError ServantError
214− , MonadThrow, MonadCatch
215− )
216−
217−instance MonadBase IO ClientM where
218− liftBase = ClientM . liftBase
219−
220−instance MonadBaseControl IO ClientM where
221− type StM ClientM a = Either ServantError a
222−
223− -- liftBaseWith :: (RunInBase ClientM IO -> IO a) -> ClientM a
224− liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . runClientM')))
225−
226− -- restoreM :: StM ClientM a -> ClientM a
227− restoreM st = ClientM (restoreM st)
228−
229−-- | Try clients in order, last error is preserved.
230−instance Alt ClientM where
231− a <!> b = a `catchError` \_ -> b
232−
233−runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
234−runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm
235−
236−
237−performRequest :: Method -> Req
238− -> ClientM ( Int, ByteString, MediaType
239− , [HTTP.Header], Response ByteString)
240−performRequest reqMethod req = do
241− m <- asks manager
242− reqHost <- asks baseUrl
243− partialRequest <- liftIO $ reqToRequest req reqHost
244−
245− let request = partialRequest { Client.method = reqMethod }
246−
247− eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m
248− case eResponse of
249− Left err ->
250− throwError . ConnectionError $ SomeException err
251−
252− Right response -> do
253− let status = Client.responseStatus response
254− body = Client.responseBody response
255− hdrs = Client.responseHeaders response
256− status_code = statusCode status
257− ct <- case lookup "Content-Type" $ Client.responseHeaders response of
258− Nothing -> pure $ "application"//"octet-stream"
259− Just t -> case parseAccept t of
260− Nothing -> throwError $ InvalidContentTypeHeader (cs t) body
261− Just t' -> pure t'
262− unless (status_code >= 200 && status_code < 300) $
263− throwError $ FailureResponse (UrlReq reqHost req) status ct body
264− return (status_code, body, ct, hdrs, response)
265−
266−performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req
267− -> ClientM ([HTTP.Header], result)
268−performRequestCT ct reqMethod req = do
269− let acceptCTS = contentTypes ct
270− (_status, respBody, respCT, hdrs, _response) <-
271− performRequest reqMethod (req { reqAccept = toList acceptCTS })
272− unless (any (matches respCT) acceptCTS) $ throwError $ UnsupportedContentType respCT respBody
273− case mimeUnrender ct respBody of
274− Left err -> throwError $ DecodeFailure err respCT respBody
275− Right val -> return (hdrs, val)
276−
277−performRequestNoBody :: Method -> Req -> ClientM [HTTP.Header]
278−performRequestNoBody reqMethod req = do
279− (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req
280− return hdrs
281−
282−catchConnectionError :: IO a -> IO (Either ServantError a)
283−catchConnectionError action =
284− catch (Right <$> action) $ \e ->
285− pure . Left . ConnectionError $ SomeException (e :: HttpException)
servant-client/test/Servant/ClientSpec.hs+1
@@ -58,6 +58,7 @@ import Servant.API.Internal.Test.ComprehensiveAPI
58import Servant.Client
58import Servant.Client
59import Servant.Client.Generic
59import Servant.Client.Generic
60import qualified Servant.Common.Req as SCR
60import qualified Servant.Common.Req as SCR
61+import qualified Servant.Client.HttpClient as SCR
61import Servant.Server
62import Servant.Server
62import Servant.Server.Experimental.Auth
63import Servant.Server.Experimental.Auth
63
64