git.iko.soy/typeable/servant
on master help sign in
Compiling HttpClient
05db359Julian K. Arni
servant-client-core/src/Servant/Client/Core.hs+4
compare with master
unifiedsplit
@@ -24,6 +24,10 @@ module Servant.Client.Core
24 , mkAuthenticateReq
24 , mkAuthenticateReq
25 , ServantError(..)
25 , ServantError(..)
26 , EmptyClient(..)
26 , EmptyClient(..)
27+ , RunClient(..)
28+ , Request(..)
29+ , Response(..)
30+ , RequestBody(..)
27 , module Servant.Client.Core.Internal.BaseUrl
31 , module Servant.Client.Core.Internal.BaseUrl
28 ) where
32 ) where
29
33
servant-client-core/src/Servant/Client/Core/Internal/Request.hs+10−2
@@ -27,11 +27,17 @@ import Network.HTTP.Types (Header, HeaderName, HttpVersion,
27import Web.HttpApiData (ToHttpApiData, toEncodedUrlPiece,
27import Web.HttpApiData (ToHttpApiData, toEncodedUrlPiece,
28 toHeader)
28 toHeader)
29
29
30+-- | A type representing possible errors in a request
30−data ServantError
31+data ServantError =
32+ -- | The server returned an error response
31− = FailureResponse Response
33+ FailureResponse Response
34+ -- | The body could not be decoded at the expected type
32 | DecodeFailure Text Response
35 | DecodeFailure Text Response
36+ -- | The content-type of the response is not supported
33 | UnsupportedContentType MediaType Response
37 | UnsupportedContentType MediaType Response
38+ -- | The content-type header is invalid
34 | InvalidContentTypeHeader Response
39 | InvalidContentTypeHeader Response
40+ -- | There was a connection error, and no response was received
35 | ConnectionError Text
41 | ConnectionError Text
36 deriving (Eq, Show, Generic, Typeable)
42 deriving (Eq, Show, Generic, Typeable)
37
43
@@ -45,6 +51,7 @@ data Request = Request
45 , requestMethod :: Method
51 , requestMethod :: Method
46 } deriving (Generic, Typeable)
52 } deriving (Generic, Typeable)
47
53
54+-- | The request body. Currently only lazy ByteStrings are supported.
48newtype RequestBody = RequestBodyLBS LBS.ByteString
55newtype RequestBody = RequestBodyLBS LBS.ByteString
49 deriving (Eq, Ord, Read, Show, Typeable)
56 deriving (Eq, Ord, Read, Show, Typeable)
50
57
@@ -55,6 +62,7 @@ data Response = Response
55 , responseHttpVersion :: HttpVersion
62 , responseHttpVersion :: HttpVersion
56 } deriving (Eq, Show, Generic, Typeable)
63 } deriving (Eq, Show, Generic, Typeable)
57
64
65+-- A GET request to the top-level path
58defaultRequest :: Request
66defaultRequest :: Request
59defaultRequest = Request
67defaultRequest = Request
60 { requestPath = ""
68 { requestPath = ""
servant-client/servant-client.cabal+7−7
@@ -29,23 +29,23 @@ source-repository head
29
29
30library
30library
31 exposed-modules:
31 exposed-modules:
32− Servant.Client
33− Servant.Client.Class
34 Servant.Client.HttpClient
32 Servant.Client.HttpClient
35− Servant.Client.Generic
36− Servant.Client.Experimental.Auth
37− Servant.Common.BaseUrl
38− Servant.Common.BasicAuth
39− Servant.Common.Req
40 build-depends:
33 build-depends:
41 base >= 4.7 && < 4.11
34 base >= 4.7 && < 4.11
42 , base-compat >= 0.9.1 && < 0.10
35 , base-compat >= 0.9.1 && < 0.10
36+ , bytestring >= 0.10 && < 0.11
43 , aeson >= 0.7 && < 1.3
37 , aeson >= 0.7 && < 1.3
44 , attoparsec >= 0.12 && < 0.14
38 , attoparsec >= 0.12 && < 0.14
45 , http-client >= 0.4.18.1 && < 0.6
39 , http-client >= 0.4.18.1 && < 0.6
46 , http-client-tls >= 0.2.2 && < 0.4
40 , http-client-tls >= 0.2.2 && < 0.4
41+ , http-media >= 0.6.2 && < 0.8
42+ , http-types >= 0.8.6 && < 0.10
43+ , exceptions >= 0.8 && < 0.9
47 , monad-control >= 1.0.0.4 && < 1.1
44 , monad-control >= 1.0.0.4 && < 1.1
45+ , mtl >= 2.2 && < 2.3
48 , semigroupoids >= 4.3 && < 5.3
46 , semigroupoids >= 4.3 && < 5.3
47+ , servant-client-core == 0.11.*
48+ , text >= 1.2 && < 1.3
49 , transformers >= 0.3 && < 0.6
49 , transformers >= 0.3 && < 0.6
50 , transformers-base >= 0.4.4 && < 0.5
50 , transformers-base >= 0.4.4 && < 0.5
51 , transformers-compat >= 0.4 && < 0.6
51 , transformers-compat >= 0.4 && < 0.6
servant-client/src/Servant/Client/HttpClient.hs+77−53
@@ -20,41 +20,37 @@ import Control.Monad
20import Control.Monad.Base (MonadBase (..))
20import Control.Monad.Base (MonadBase (..))
21import Control.Monad.Catch (MonadCatch, MonadThrow)
21import Control.Monad.Catch (MonadCatch, MonadThrow)
22import Control.Monad.Error.Class (MonadError (..))
22import Control.Monad.Error.Class (MonadError (..))
23+import Data.ByteString.Builder (toLazyByteString)
24+import qualified Data.ByteString.Lazy as BSL
25+import Data.Monoid ((<>))
26+import Data.String (fromString)
27+import qualified Data.Text as T
28+import GHC.Exts (fromList)
23−import Control.Monad.IO.Class ()
29+{-import Control.Monad.IO.Class ()-}
24import Control.Monad.Reader
30import Control.Monad.Reader
25import Control.Monad.Trans.Control (MonadBaseControl (..))
31import Control.Monad.Trans.Control (MonadBaseControl (..))
26import Control.Monad.Trans.Except
32import Control.Monad.Trans.Except
27−import Data.ByteString.Lazy hiding (any, elem, filter, map,
33+{-import Data.ByteString.Lazy hiding (any, elem, filter, map,-}
28− null, pack)
34+ {-null, pack)-}
29import Data.Foldable (toList)
35import Data.Foldable (toList)
30import Data.Functor.Alt (Alt (..))
36import Data.Functor.Alt (Alt (..))
31import Data.Proxy
37import Data.Proxy
32−import Data.String.Conversions (cs)
38+{-import Data.String.Conversions (cs)-}
33import GHC.Generics
39import GHC.Generics
34−import Network.HTTP.Media
40+import Network.HTTP.Media (parseAccept, renderHeader, (//))
35−import Network.HTTP.Types
41+import Network.HTTP.Types (hContentType, renderQuery,
42+ statusCode)
36−import Servant.API.ContentTypes
43+{-import Servant.API.ContentTypes-}
37−import Servant.Client.Class
44+import Servant.Client.Core
38−import Servant.Common.BaseUrl
45+{-import Servant.Common.BaseUrl-}
39−import Servant.Common.Req
46+{-import Servant.Common.Req-}
40
47
41import qualified Network.HTTP.Client as Client
48import qualified Network.HTTP.Client as Client
42−import qualified Network.HTTP.Types.Header as HTTP
49+{-import qualified Network.HTTP.Types.Header as HTTP-}
43−
44−instance RunClient ClientM NoContent ( Int, ByteString, MediaType
45− , [HTTP.Header], Response ByteString) where
46− runRequest _ meth req = performRequest meth req
47−
48−instance (MimeUnrender ct a) =>
49− RunClient ClientM ct ([HTTP.Header], a) where
50− runRequest p meth req = performRequestCT p meth req
51−
52−instance RunClient ClientM NoContent [HTTP.Header] where
53− runRequest _ meth req = performRequestNoBody meth req
54
50
55data ClientEnv
51data ClientEnv
56 = ClientEnv
52 = ClientEnv
57− { manager :: Manager
53+ { manager :: Client.Manager
58 , baseUrl :: BaseUrl
54 , baseUrl :: BaseUrl
59 }
55 }
60
56
@@ -82,55 +78,83 @@ instance MonadBaseControl IO ClientM where
82instance Alt ClientM where
78instance Alt ClientM where
83 a <!> b = a `catchError` \_ -> b
79 a <!> b = a `catchError` \_ -> b
84
80
81+instance RunClient ClientM where
82+ runRequest = performRequest
83+
85runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
84runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
86runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm
85runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm
87
86
88
87
89−performRequest :: Method -> Req
90− -> ClientM Response
91−performRequest reqMethod req = do
92− m <- asks manager
93− reqHost <- asks baseUrl
94− partialRequest <- liftIO $ reqToRequest req reqHost
95
88
96− let request = partialRequest { Client.method = reqMethod }
89+performRequest :: Request -> ClientM Response
90+performRequest req = do
91+ m <- asks manager
92+ burl <- asks baseUrl
93+ let request = requestToClientRequest burl req
97
94
98 eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m
95 eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m
99 case eResponse of
96 case eResponse of
100− Left err ->
97+ Left err -> throwError $ err
101− throwError . ConnectionError $ SomeException err
102−
103 Right response -> do
98 Right response -> do
104 let status = Client.responseStatus response
99 let status = Client.responseStatus response
105 body = Client.responseBody response
100 body = Client.responseBody response
106 hdrs = Client.responseHeaders response
101 hdrs = Client.responseHeaders response
107 status_code = statusCode status
102 status_code = statusCode status
103+ ourResponse = clientResponseToReponse response
108 ct <- case lookup "Content-Type" $ Client.responseHeaders response of
104 ct <- case lookup "Content-Type" $ Client.responseHeaders response of
109 Nothing -> pure $ "application"//"octet-stream"
105 Nothing -> pure $ "application"//"octet-stream"
110 Just t -> case parseAccept t of
106 Just t -> case parseAccept t of
111− Nothing -> throwError $ InvalidContentTypeHeader (cs t) body
107+ Nothing -> throwError $ InvalidContentTypeHeader ourResponse
112 Just t' -> pure t'
108 Just t' -> pure t'
113 unless (status_code >= 200 && status_code < 300) $
109 unless (status_code >= 200 && status_code < 300) $
114− throwError $ FailureResponse (UrlReq reqHost req) status ct body
110+ throwError $ FailureResponse ourResponse
115− return (status_code, body, ct, hdrs, response)
111+ return ourResponse
116−
112+
113+clientResponseToReponse :: Client.Response BSL.ByteString -> Response
114+clientResponseToReponse r = Response
115+ { responseStatusCode = Client.responseStatus r
116+ , responseBody = Client.responseBody r
117+ , responseHeaders = fromList $ Client.responseHeaders r
118+ , responseHttpVersion = Client.responseVersion r
119+ }
120+
121+requestToClientRequest :: BaseUrl -> Request -> Client.Request
122+requestToClientRequest burl r = Client.defaultRequest
123+ { Client.method = requestMethod r
124+ , Client.host = fromString $ baseUrlHost burl
125+ , Client.port = baseUrlPort burl
126+ , Client.path = BSL.toStrict
127+ $ fromString (baseUrlPath burl)
128+ <> toLazyByteString (requestPath r)
129+ , Client.queryString = renderQuery True . toList $ requestQueryString r
130+ , Client.requestHeaders =
131+ let orig = toList $ requestHeaders r
132+ in maybe orig (: orig) contentTypeHdr
133+ , Client.requestBody = body
134+ }
135+ where
136+ (body, contentTypeHdr) = case requestBody r of
137+ Nothing -> (Client.RequestBodyLBS "", Nothing)
138+ Just (RequestBodyLBS body, typ)
139+ -> (Client.RequestBodyLBS body, Just (hContentType, renderHeader typ))
140+
117−performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req
141+{-performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req-}
118− -> ClientM ([HTTP.Header], result)
142+ {--> ClientM ([HTTP.Header], result)-}
119−performRequestCT ct reqMethod req = do
143+{-performRequestCT ct reqMethod req = do-}
120− let acceptCTS = contentTypes ct
144+ {-let acceptCTS = contentTypes ct-}
121− (_status, respBody, respCT, hdrs, _response) <-
145+ {-(_status, respBody, respCT, hdrs, _response) <--}
122− performRequest reqMethod (req { reqAccept = toList acceptCTS })
146+ {-performRequest reqMethod (req { reqAccept = toList acceptCTS })-}
123− unless (any (matches respCT) acceptCTS) $ throwError $ UnsupportedContentType respCT respBody
147+ {-unless (any (matches respCT) acceptCTS) $ throwError $ UnsupportedContentType respCT respBody-}
124− case mimeUnrender ct respBody of
148+ {-case mimeUnrender ct respBody of-}
125− Left err -> throwError $ DecodeFailure err respCT respBody
149+ {-Left err -> throwError $ DecodeFailure err respCT respBody-}
126− Right val -> return (hdrs, val)
150+ {-Right val -> return (hdrs, val)-}
127−
151+
128−performRequestNoBody :: Method -> Req -> ClientM [HTTP.Header]
152+{-performRequestNoBody :: Method -> Req -> ClientM [HTTP.Header]-}
129−performRequestNoBody reqMethod req = do
153+{-performRequestNoBody reqMethod req = do-}
130− (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req
154+ {-(_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req-}
131− return hdrs
155+ {-return hdrs-}
132
156
133catchConnectionError :: IO a -> IO (Either ServantError a)
157catchConnectionError :: IO a -> IO (Either ServantError a)
134catchConnectionError action =
158catchConnectionError action =
135 catch (Right <$> action) $ \e ->
159 catch (Right <$> action) $ \e ->
136− pure . Left . ConnectionError $ SomeException (e :: HttpException)
160+ pure . Left . ConnectionError . T.pack $ show (e :: Client.HttpException)