From 01f344dfbb7e4cdf81fc90033f6e4a130c15b866 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 7 Sep 2017 13:38:31 -0700 Subject: [PATCH] Compiling servant-client-core --- servant-client-core/servant-client-core.cabal | 1 + .../src/Servant/Client/Core.hs | 161 ++++++++++-------- .../Servant/Client/Core/Internal/BasicAuth.hs | 14 +- .../src/Servant/Client/Core/Internal/Class.hs | 14 +- .../Servant/Client/Core/Internal/Request.hs | 19 ++- servant-client/servant-client.cabal | 1 - 6 files changed, 115 insertions(+), 95 deletions(-) diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index 6ea04445..779c09ee 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/servant-client-core/servant-client-core.cabal @@ -41,6 +41,7 @@ library , http-api-data >= 0.3.6 && < 0.4 , http-media >= 0.6.2 && < 0.8 , http-types >= 0.8.6 && < 0.10 + , mtl >= 2.2 && < 2.3 , network-uri >= 2.6 && < 2.7 , safe >= 0.3.9 && < 0.4 , servant == 0.11.* diff --git a/servant-client-core/src/Servant/Client/Core.hs b/servant-client-core/src/Servant/Client/Core.hs index 6d1b014d..42323d40 100644 --- a/servant-client-core/src/Servant/Client/Core.hs +++ b/servant-client-core/src/Servant/Client/Core.hs @@ -21,34 +21,52 @@ module Servant.Client.Core , AuthenticateReq(..) , client , HasClient(..) - , ClientM - , runClientM, inClientM, clientM - , ClientEnv (ClientEnv) , mkAuthenticateReq , ServantError(..) , EmptyClient(..) - , module Servant.Common.BaseUrl + , module Servant.Client.Core.Internal.BaseUrl ) where -import Data.ByteString.Lazy (ByteString) -import Data.List -import Data.Proxy -import Data.String.Conversions -import Data.Text (unpack) -import GHC.TypeLits -import Network.HTTP.Client (Response) -import Network.HTTP.Media -import qualified Network.HTTP.Types as H -import qualified Network.HTTP.Types.Header as HTTP -import Prelude () +import Control.Monad.Error.Class (throwError) +import Data.List (foldl') +import Data.Proxy (Proxy (Proxy)) +import Data.String (fromString) +import Data.Text (pack) +import GHC.Exts (fromList, toList) +import GHC.TypeLits (KnownSymbol, symbolVal) +import qualified Network.HTTP.Types as H +import Prelude () import Prelude.Compat -import Servant.API -import Servant.Client.Experimental.Auth -import Servant.Client.HttpClient -import Servant.Client.Class -import Servant.Common.BaseUrl -import Servant.Common.BasicAuth -import Servant.Common.Req +import Servant.API ((:<|>) ((:<|>)), (:>), + AuthProtect, BasicAuth, + BasicAuthData, + BuildHeadersTo (..), + Capture, CaptureAll, + Description, EmptyAPI, + Header, Headers (..), + HttpVersion, IsSecure, + MimeRender (mimeRender), + MimeUnrender (mimeUnrender), + NoContent (NoContent), + QueryFlag, QueryParam, + QueryParams, Raw, + ReflectMethod (..), + RemoteHost, ReqBody, + Summary, ToHttpApiData, + Vault, Verb, + WithNamedContext, + contentType, + getHeadersHList, + getResponse, + toQueryParam, + toUrlPiece) +import Servant.API.ContentTypes (contentTypes) + +import Servant.Client.Core.Internal.Auth +import Servant.Client.Core.Internal.BaseUrl +import Servant.Client.Core.Internal.BasicAuth +import Servant.Client.Core.Internal.Class +import Servant.Client.Core.Internal.Request -- * Accessing APIs as a Client @@ -68,25 +86,15 @@ import Servant.Common.Req -- > postNewBook :: Book -> ClientM Book -- > (getAllBooks :<|> postNewBook) = client clientM myApi client :: HasClient m api => Proxy m -> Proxy api -> Client m api -client pm p = clientWithRoute pm p defReq - --- | Helper proxy to simplify common case of working in `ClientM` monad -inClientM :: Proxy ClientM -inClientM = Proxy - --- | Convenience method to declare clients running in the `ClientM` monad. --- --- Simply pass `inClientM` to `client`.... -clientM :: (HasClient ClientM api) => Proxy api -> Client ClientM api -clientM = client inClientM +client pm p = clientWithRoute pm p defaultRequest -- | This class lets us define how each API combinator -- influences the creation of an HTTP request. It's mostly -- an internal class, you can just use 'client'. -class HasClient m api where +class RunClient m => HasClient m api where type Client (m :: * -> *) (api :: *) :: * - clientWithRoute :: Proxy m -> Proxy api -> Req -> Client m api + clientWithRoute :: Proxy m -> Proxy api -> Request -> Client m api -- | A client querying function for @a ':<|>' b@ will actually hand you @@ -121,7 +129,7 @@ data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum) -- > -- > getAllBooks :: ClientM [Book] -- > (getAllBooks :<|> EmptyClient) = client myApi -instance HasClient m EmptyAPI where +instance RunClient m => HasClient m EmptyAPI where type Client m EmptyAPI = EmptyClient clientWithRoute _pm Proxy _ = EmptyClient @@ -154,7 +162,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m api) clientWithRoute pm (Proxy :: Proxy api) (appendToPath p req) - where p = unpack (toUrlPiece val) + where p = (toUrlPiece val) -- | If you use a 'CaptureAll' in one of your endpoints in your API, -- the corresponding querying function will automatically take an @@ -186,53 +194,65 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout) clientWithRoute pm (Proxy :: Proxy sublayout) (foldl' (flip appendToPath) req ps) - where ps = map (unpack . toUrlPiece) vals + where ps = map (toUrlPiece) vals instance OVERLAPPABLE_ -- Note [Non-Empty Content Types] - (RunClient m ct ([H.Header], a), MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) + ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) ) => HasClient m (Verb method status cts' a) where type Client m (Verb method status cts' a) = m a clientWithRoute _pm Proxy req = do - (_hdrs, a) :: ([H.Header], a) <- runRequest (Proxy :: Proxy ct) method req - return a + response <- runRequest req + { requestAccept = fromList $ toList accept + , requestMethod = method + } + case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of + Left err -> throwError $ DecodeFailure (pack err) response + Right val -> return val where method = reflectMethod (Proxy :: Proxy method) + accept = contentTypes (Proxy :: Proxy ct) instance OVERLAPPING_ - ( RunClient m NoContent [HTTP.Header] - , ReflectMethod method) => HasClient m (Verb method status cts NoContent) where + ( RunClient m, ReflectMethod method + ) => HasClient m (Verb method status cts NoContent) where type Client m (Verb method status cts NoContent) = m NoContent clientWithRoute _pm Proxy req = do - _hdrs :: [H.Header] <- runRequest (Proxy :: Proxy NoContent) method req + _response <- runRequest req { requestMethod = method } return NoContent where method = reflectMethod (Proxy :: Proxy method) instance OVERLAPPING_ -- Note [Non-Empty Content Types] - ( RunClient m ct ([H.Header], a) - , MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts) + ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls + , ReflectMethod method, cts' ~ (ct ': cts) ) => HasClient m (Verb method status cts' (Headers ls a)) where type Client m (Verb method status cts' (Headers ls a)) = m (Headers ls a) clientWithRoute _pm Proxy req = do - let method = reflectMethod (Proxy :: Proxy method) - (hdrs, resp) <- runRequest (Proxy :: Proxy ct) method req - return $ Headers { getResponse = resp - , getHeadersHList = buildHeadersTo hdrs - } + response <- runRequest req + { requestMethod = method + , requestAccept = fromList $ toList accept + } + case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of + Left err -> throwError $ DecodeFailure (pack err) response + Right val -> return $ Headers + { getResponse = val + , getHeadersHList = buildHeadersTo . toList $ responseHeaders response + } + where method = reflectMethod (Proxy :: Proxy method) + accept = contentTypes (Proxy :: Proxy ct) instance OVERLAPPING_ - ( RunClient m NoContent [H.Header] - , BuildHeadersTo ls, ReflectMethod method + ( RunClient m, BuildHeadersTo ls, ReflectMethod method ) => HasClient m (Verb method status cts (Headers ls NoContent)) where type Client m (Verb method status cts (Headers ls NoContent)) = m (Headers ls NoContent) clientWithRoute _pm Proxy req = do let method = reflectMethod (Proxy :: Proxy method) - hdrs <- runRequest (Proxy :: Proxy NoContent) method req + response <- runRequest req { requestMethod = method } return $ Headers { getResponse = NoContent - , getHeadersHList = buildHeadersTo hdrs + , getHeadersHList = buildHeadersTo . toList $ responseHeaders response } @@ -270,11 +290,11 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api) clientWithRoute pm Proxy req mval = clientWithRoute pm (Proxy :: Proxy api) (maybe req - (\value -> Servant.Common.Req.addHeader hname value req) + (\value -> addHeader hname value req) mval ) - where hname = symbolVal (Proxy :: Proxy sym) + where hname = fromString $ symbolVal (Proxy :: Proxy sym) -- | Using a 'HttpVersion' combinator in your API doesn't affect the client -- functions. @@ -338,8 +358,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api) mparamText ) - where pname = cs pname' - pname' = symbolVal (Proxy :: Proxy sym) + where pname = pack $ symbolVal (Proxy :: Proxy sym) mparamText = fmap toQueryParam mparam -- | If you use a 'QueryParams' in one of your endpoints in your API, @@ -382,8 +401,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api) paramlist' ) - where pname = cs pname' - pname' = symbolVal (Proxy :: Proxy sym) + where pname = pack $ symbolVal (Proxy :: Proxy sym) paramlist' = map (Just . toQueryParam) paramlist -- | If you use a 'QueryFlag' in one of your endpoints in your API, @@ -420,19 +438,18 @@ instance (KnownSymbol sym, HasClient m api) else req ) - where paramname = cs $ symbolVal (Proxy :: Proxy sym) + where paramname = pack $ symbolVal (Proxy :: Proxy sym) -- | Pick a 'Method' and specify where the server you want to query is. You get -- back the full `Response`. -instance (RunClient m NoContent (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)) - => HasClient m Raw where +instance RunClient m => HasClient m Raw where type Client m Raw - = H.Method -> m (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) + = H.Method -> m Response - clientWithRoute :: Proxy m -> Proxy Raw -> Req -> Client m Raw + clientWithRoute :: Proxy m -> Proxy Raw -> Request -> Client m Raw clientWithRoute _pm Proxy req httpMethod = do - runRequest (Proxy :: Proxy NoContent) httpMethod req + runRequest req { requestMethod = httpMethod } -- | If you use a 'ReqBody' in one of your endpoints in your API, -- the corresponding querying function will automatically take @@ -461,10 +478,10 @@ instance (MimeRender ct a, HasClient m api) clientWithRoute pm Proxy req body = clientWithRoute pm (Proxy :: Proxy api) (let ctProxy = Proxy :: Proxy ct - in setReqBodyLBS (mimeRender ctProxy body) - -- We use first contentType from the Accept list - (contentType ctProxy) - req + in setRequestBodyLBS (mimeRender ctProxy body) + -- We use first contentType from the Accept list + (contentType ctProxy) + req ) -- | Make the querying function append @path@ to the request path. @@ -475,7 +492,7 @@ instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where clientWithRoute pm (Proxy :: Proxy api) (appendToPath p req) - where p = symbolVal (Proxy :: Proxy path) + where p = pack $ symbolVal (Proxy :: Proxy path) instance HasClient m api => HasClient m (Vault :> api) where type Client m (Vault :> api) = Client m api diff --git a/servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hs b/servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hs index 978ef2b3..64dc8433 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TypeFamilies #-} -- | Basic Authentication for clients module Servant.Client.Core.Internal.BasicAuth where -import Data.ByteString.Base64 (encode) -import Data.Monoid ((<>)) -import Data.Text.Encoding (decodeUtf8) -import Servant.Client.Core.Internal.Request (addHeader, Request) -import Servant.API.BasicAuth (BasicAuthData(BasicAuthData)) +import Data.ByteString.Base64 (encode) +import Data.Monoid ((<>)) +import Data.Text.Encoding (decodeUtf8) +import Servant.API.BasicAuth (BasicAuthData (BasicAuthData)) +import Servant.Client.Core.Internal.Request (Request, addHeader) -- | Authenticate a request using Basic Authentication basicAuthReq :: BasicAuthData -> Request -> Request diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Class.hs b/servant-client-core/src/Servant/Client/Core/Internal/Class.hs index cea567f9..0428fcb8 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Class.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Class.hs @@ -1,13 +1,11 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-| Types for possible backends to run client-side `Request` queries -} module Servant.Client.Core.Internal.Class where -import Data.Proxy -import Network.HTTP.Types -import Servant.Client.Core.Internal.Request (Request, Response) +import Control.Monad.Error.Class (MonadError) +import Servant.Client.Core.Internal.Request (Request, Response, + ServantError) -class (Monad m) => RunClient m ct where - runRequest :: Proxy ct - -> Method - -> Request - -> m Response +class (MonadError ServantError m) => RunClient m where + runRequest :: Request -> m Response 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 8cdf79b7..3072aa08 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs @@ -17,11 +17,13 @@ import qualified Data.ByteString.Lazy as LBS import Data.Semigroup ((<>)) import qualified Data.Sequence as Seq import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) import Data.Typeable (Typeable) import GHC.Generics (Generic) import Network.HTTP.Media (MediaType) import Network.HTTP.Types (Header, HeaderName, HttpVersion, - QueryItem, Status, http11) + Method, QueryItem, Status, http11, + methodGet) import Web.HttpApiData (ToHttpApiData, toEncodedUrlPiece, toHeader) @@ -40,6 +42,7 @@ data Request = Request , requestAccept :: Seq.Seq MediaType , requestHeaders :: Seq.Seq Header , requestHttpVersion :: HttpVersion + , requestMethod :: Method } deriving (Generic, Typeable) newtype RequestBody = RequestBodyLBS LBS.ByteString @@ -60,18 +63,20 @@ defaultRequest = Request , requestAccept = Seq.empty , requestHeaders = Seq.empty , requestHttpVersion = http11 + , requestMethod = methodGet } appendToPath :: Text -> Request -> Request appendToPath p req = req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p } -{-appendToQueryString :: Text -- ^ param name-} - {--> Maybe Text -- ^ param value-} - {--> Request-} - {--> Request-} -{-appendToQueryString pname pvalue req-} - {-= req { requestQueryString = requestQueryString req Seq.|> (pname, pvalue)}-} +appendToQueryString :: Text -- ^ param name + -> Maybe Text -- ^ param value + -> Request + -> Request +appendToQueryString pname pvalue req + = req { requestQueryString = requestQueryString req + Seq.|> (encodeUtf8 pname, encodeUtf8 <$> pvalue)} addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request addHeader name val req diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 4015d683..cbed6f55 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -49,7 +49,6 @@ library , transformers >= 0.3 && < 0.6 , transformers-base >= 0.4.4 && < 0.5 , transformers-compat >= 0.4 && < 0.6 - , mtl if !impl(ghc >= 8.0) build-depends: semigroups >=0.16.2.2 && <0.19