From 05db359296371488cbc658209055e1af3cf2d626 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 7 Sep 2017 16:07:18 -0700 Subject: [PATCH] Compiling HttpClient --- .../src/Servant/Client/Core.hs | 4 + .../Servant/Client/Core/Internal/Request.hs | 12 +- servant-client/servant-client.cabal | 14 +- .../src/Servant/Client/HttpClient.hs | 126 +++++++++++------- 4 files changed, 96 insertions(+), 60 deletions(-) diff --git a/servant-client-core/src/Servant/Client/Core.hs b/servant-client-core/src/Servant/Client/Core.hs index 42323d40..5701e8c2 100644 --- a/servant-client-core/src/Servant/Client/Core.hs +++ b/servant-client-core/src/Servant/Client/Core.hs @@ -24,6 +24,10 @@ module Servant.Client.Core , mkAuthenticateReq , ServantError(..) , EmptyClient(..) + , RunClient(..) + , Request(..) + , Response(..) + , RequestBody(..) , module Servant.Client.Core.Internal.BaseUrl ) where diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs index 3072aa08..bfcd1d70 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs @@ -27,11 +27,17 @@ import Network.HTTP.Types (Header, HeaderName, HttpVersion, import Web.HttpApiData (ToHttpApiData, toEncodedUrlPiece, toHeader) -data ServantError - = FailureResponse Response +-- | A type representing possible errors in a request +data ServantError = + -- | The server returned an error response + FailureResponse Response + -- | The body could not be decoded at the expected type | DecodeFailure Text Response + -- | The content-type of the response is not supported | UnsupportedContentType MediaType Response + -- | The content-type header is invalid | InvalidContentTypeHeader Response + -- | There was a connection error, and no response was received | ConnectionError Text deriving (Eq, Show, Generic, Typeable) @@ -45,6 +51,7 @@ data Request = Request , requestMethod :: Method } deriving (Generic, Typeable) +-- | The request body. Currently only lazy ByteStrings are supported. newtype RequestBody = RequestBodyLBS LBS.ByteString deriving (Eq, Ord, Read, Show, Typeable) @@ -55,6 +62,7 @@ data Response = Response , responseHttpVersion :: HttpVersion } deriving (Eq, Show, Generic, Typeable) +-- A GET request to the top-level path defaultRequest :: Request defaultRequest = Request { requestPath = "" diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index cbed6f55..d56ad33d 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -29,23 +29,23 @@ source-repository head library exposed-modules: - Servant.Client - Servant.Client.Class Servant.Client.HttpClient - Servant.Client.Generic - Servant.Client.Experimental.Auth - Servant.Common.BaseUrl - Servant.Common.BasicAuth - Servant.Common.Req build-depends: base >= 4.7 && < 4.11 , base-compat >= 0.9.1 && < 0.10 + , bytestring >= 0.10 && < 0.11 , aeson >= 0.7 && < 1.3 , attoparsec >= 0.12 && < 0.14 , http-client >= 0.4.18.1 && < 0.6 , http-client-tls >= 0.2.2 && < 0.4 + , http-media >= 0.6.2 && < 0.8 + , http-types >= 0.8.6 && < 0.10 + , exceptions >= 0.8 && < 0.9 , monad-control >= 1.0.0.4 && < 1.1 + , mtl >= 2.2 && < 2.3 , semigroupoids >= 4.3 && < 5.3 + , servant-client-core == 0.11.* + , text >= 1.2 && < 1.3 , transformers >= 0.3 && < 0.6 , transformers-base >= 0.4.4 && < 0.5 , transformers-compat >= 0.4 && < 0.6 diff --git a/servant-client/src/Servant/Client/HttpClient.hs b/servant-client/src/Servant/Client/HttpClient.hs index 60bab060..5dd84c30 100644 --- a/servant-client/src/Servant/Client/HttpClient.hs +++ b/servant-client/src/Servant/Client/HttpClient.hs @@ -20,41 +20,37 @@ import Control.Monad import Control.Monad.Base (MonadBase (..)) import Control.Monad.Catch (MonadCatch, MonadThrow) import Control.Monad.Error.Class (MonadError (..)) -import Control.Monad.IO.Class () +import Data.ByteString.Builder (toLazyByteString) +import qualified Data.ByteString.Lazy as BSL +import Data.Monoid ((<>)) +import Data.String (fromString) +import qualified Data.Text as T +import GHC.Exts (fromList) +{-import Control.Monad.IO.Class ()-} import Control.Monad.Reader import Control.Monad.Trans.Control (MonadBaseControl (..)) import Control.Monad.Trans.Except -import Data.ByteString.Lazy hiding (any, elem, filter, map, - null, pack) +{-import Data.ByteString.Lazy hiding (any, elem, filter, map,-} + {-null, pack)-} import Data.Foldable (toList) import Data.Functor.Alt (Alt (..)) import Data.Proxy -import Data.String.Conversions (cs) +{-import Data.String.Conversions (cs)-} import GHC.Generics -import Network.HTTP.Media -import Network.HTTP.Types -import Servant.API.ContentTypes -import Servant.Client.Class -import Servant.Common.BaseUrl -import Servant.Common.Req +import Network.HTTP.Media (parseAccept, renderHeader, (//)) +import Network.HTTP.Types (hContentType, renderQuery, + statusCode) +{-import Servant.API.ContentTypes-} +import Servant.Client.Core +{-import Servant.Common.BaseUrl-} +{-import Servant.Common.Req-} import qualified Network.HTTP.Client as Client -import qualified Network.HTTP.Types.Header as HTTP - -instance RunClient ClientM NoContent ( Int, ByteString, MediaType - , [HTTP.Header], Response ByteString) where - runRequest _ meth req = performRequest meth req - -instance (MimeUnrender ct a) => - RunClient ClientM ct ([HTTP.Header], a) where - runRequest p meth req = performRequestCT p meth req - -instance RunClient ClientM NoContent [HTTP.Header] where - runRequest _ meth req = performRequestNoBody meth req +{-import qualified Network.HTTP.Types.Header as HTTP-} data ClientEnv = ClientEnv - { manager :: Manager + { manager :: Client.Manager , baseUrl :: BaseUrl } @@ -82,55 +78,83 @@ instance MonadBaseControl IO ClientM where instance Alt ClientM where a b = a `catchError` \_ -> b +instance RunClient ClientM where + runRequest = performRequest + runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a) runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm -performRequest :: Method -> Req - -> ClientM Response -performRequest reqMethod req = do - m <- asks manager - reqHost <- asks baseUrl - partialRequest <- liftIO $ reqToRequest req reqHost - let request = partialRequest { Client.method = reqMethod } +performRequest :: Request -> ClientM Response +performRequest req = do + m <- asks manager + burl <- asks baseUrl + let request = requestToClientRequest burl req eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m case eResponse of - Left err -> - throwError . ConnectionError $ SomeException err - + Left err -> throwError $ err Right response -> do let status = Client.responseStatus response body = Client.responseBody response hdrs = Client.responseHeaders response status_code = statusCode status + ourResponse = clientResponseToReponse response ct <- case lookup "Content-Type" $ Client.responseHeaders response of Nothing -> pure $ "application"//"octet-stream" Just t -> case parseAccept t of - Nothing -> throwError $ InvalidContentTypeHeader (cs t) body + Nothing -> throwError $ InvalidContentTypeHeader ourResponse Just t' -> pure t' unless (status_code >= 200 && status_code < 300) $ - throwError $ FailureResponse (UrlReq reqHost req) status ct body - return (status_code, body, ct, hdrs, response) + throwError $ FailureResponse ourResponse + return ourResponse -performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req - -> ClientM ([HTTP.Header], result) -performRequestCT ct reqMethod req = do - let acceptCTS = contentTypes ct - (_status, respBody, respCT, hdrs, _response) <- - performRequest reqMethod (req { reqAccept = toList acceptCTS }) - unless (any (matches respCT) acceptCTS) $ throwError $ UnsupportedContentType respCT respBody - case mimeUnrender ct respBody of - Left err -> throwError $ DecodeFailure err respCT respBody - Right val -> return (hdrs, val) +clientResponseToReponse :: Client.Response BSL.ByteString -> Response +clientResponseToReponse r = Response + { responseStatusCode = Client.responseStatus r + , responseBody = Client.responseBody r + , responseHeaders = fromList $ Client.responseHeaders r + , responseHttpVersion = Client.responseVersion r + } -performRequestNoBody :: Method -> Req -> ClientM [HTTP.Header] -performRequestNoBody reqMethod req = do - (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req - return hdrs +requestToClientRequest :: BaseUrl -> Request -> Client.Request +requestToClientRequest burl r = Client.defaultRequest + { Client.method = requestMethod r + , Client.host = fromString $ baseUrlHost burl + , Client.port = baseUrlPort burl + , Client.path = BSL.toStrict + $ fromString (baseUrlPath burl) + <> toLazyByteString (requestPath r) + , Client.queryString = renderQuery True . toList $ requestQueryString r + , Client.requestHeaders = + let orig = toList $ requestHeaders r + in maybe orig (: orig) contentTypeHdr + , Client.requestBody = body + } + where + (body, contentTypeHdr) = case requestBody r of + Nothing -> (Client.RequestBodyLBS "", Nothing) + Just (RequestBodyLBS body, typ) + -> (Client.RequestBodyLBS body, Just (hContentType, renderHeader typ)) + +{-performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req-} + {--> ClientM ([HTTP.Header], result)-} +{-performRequestCT ct reqMethod req = do-} + {-let acceptCTS = contentTypes ct-} + {-(_status, respBody, respCT, hdrs, _response) <--} + {-performRequest reqMethod (req { reqAccept = toList acceptCTS })-} + {-unless (any (matches respCT) acceptCTS) $ throwError $ UnsupportedContentType respCT respBody-} + {-case mimeUnrender ct respBody of-} + {-Left err -> throwError $ DecodeFailure err respCT respBody-} + {-Right val -> return (hdrs, val)-} + +{-performRequestNoBody :: Method -> Req -> ClientM [HTTP.Header]-} +{-performRequestNoBody reqMethod req = do-} + {-(_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req-} + {-return hdrs-} catchConnectionError :: IO a -> IO (Either ServantError a) catchConnectionError action = catch (Right <$> action) $ \e -> - pure . Left . ConnectionError $ SomeException (e :: HttpException) + pure . Left . ConnectionError . T.pack $ show (e :: Client.HttpException)