eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Compiling servant-client-core

Browse source
This commit is contained in:
Julian K. Arni 2017-09-07 13:38:31 -07:00
parent 35599d8b38
commit 01f344dfbb
6 changed files with 115 additions and 95 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
servant-client-core/servant-client-core.cabal
View file

@ -41,6 +41,7 @@ library
, http-api-data >= 0.3.6 && < 0.4 , http-api-data >= 0.3.6 && < 0.4
, http-media >= 0.6.2 && < 0.8 , http-media >= 0.6.2 && < 0.8
, http-types >= 0.8.6 && < 0.10 , http-types >= 0.8.6 && < 0.10
, mtl >= 2.2 && < 2.3
, network-uri >= 2.6 && < 2.7 , network-uri >= 2.6 && < 2.7
, safe >= 0.3.9 && < 0.4 , safe >= 0.3.9 && < 0.4
, servant == 0.11.* , servant == 0.11.*

149
servant-client-core/src/Servant/Client/Core.hs
View file

@ -21,34 +21,52 @@ module Servant.Client.Core
, AuthenticateReq(..) , AuthenticateReq(..)
, client , client
, HasClient(..) , HasClient(..)
, ClientM
, runClientM, inClientM, clientM
, ClientEnv (ClientEnv)
, mkAuthenticateReq , mkAuthenticateReq
, ServantError(..) , ServantError(..)
, EmptyClient(..) , EmptyClient(..)
, module Servant.Common.BaseUrl , module Servant.Client.Core.Internal.BaseUrl
) where ) where
import Data.ByteString.Lazy (ByteString) import Control.Monad.Error.Class (throwError)
import Data.List import Data.List (foldl')
import Data.Proxy import Data.Proxy (Proxy (Proxy))
import Data.String.Conversions import Data.String (fromString)
import Data.Text (unpack) import Data.Text (pack)
import GHC.TypeLits import GHC.Exts (fromList, toList)
import Network.HTTP.Client (Response) import GHC.TypeLits (KnownSymbol, symbolVal)
import Network.HTTP.Media
import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types as H
import qualified Network.HTTP.Types.Header as HTTP
import Prelude () import Prelude ()
import Prelude.Compat import Prelude.Compat
import Servant.API import Servant.API ((:<|>) ((:<|>)), (:>),
import Servant.Client.Experimental.Auth AuthProtect, BasicAuth,
import Servant.Client.HttpClient BasicAuthData,
import Servant.Client.Class BuildHeadersTo (..),
import Servant.Common.BaseUrl Capture, CaptureAll,
import Servant.Common.BasicAuth Description, EmptyAPI,
import Servant.Common.Req 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 -- * Accessing APIs as a Client
@ -68,25 +86,15 @@ import Servant.Common.Req
-- > postNewBook :: Book -> ClientM Book -- > postNewBook :: Book -> ClientM Book
-- > (getAllBooks :<|> postNewBook) = client clientM myApi -- > (getAllBooks :<|> postNewBook) = client clientM myApi
client :: HasClient m api => Proxy m -> Proxy api -> Client m api client :: HasClient m api => Proxy m -> Proxy api -> Client m api
client pm p = clientWithRoute pm p defReq client pm p = clientWithRoute pm p defaultRequest
-- | 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
-- | This class lets us define how each API combinator -- | This class lets us define how each API combinator
-- influences the creation of an HTTP request. It's mostly -- influences the creation of an HTTP request. It's mostly
-- an internal class, you can just use 'client'. -- an internal class, you can just use 'client'.
class HasClient m api where class RunClient m => HasClient m api where
type Client (m :: * -> *) (api :: *) :: * 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 -- | 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 :: ClientM [Book]
-- > (getAllBooks :<|> EmptyClient) = client myApi -- > (getAllBooks :<|> EmptyClient) = client myApi
instance HasClient m EmptyAPI where instance RunClient m => HasClient m EmptyAPI where
type Client m EmptyAPI = EmptyClient type Client m EmptyAPI = EmptyClient
clientWithRoute _pm Proxy _ = EmptyClient clientWithRoute _pm Proxy _ = EmptyClient
@ -154,7 +162,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)
clientWithRoute pm (Proxy :: Proxy api) clientWithRoute pm (Proxy :: Proxy api)
(appendToPath p req) (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, -- | If you use a 'CaptureAll' in one of your endpoints in your API,
-- the corresponding querying function will automatically take an -- 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) clientWithRoute pm (Proxy :: Proxy sublayout)
(foldl' (flip appendToPath) req ps) (foldl' (flip appendToPath) req ps)
where ps = map (unpack . toUrlPiece) vals where ps = map (toUrlPiece) vals
instance OVERLAPPABLE_ instance OVERLAPPABLE_
-- Note [Non-Empty Content Types] -- 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 ) => HasClient m (Verb method status cts' a) where
type Client m (Verb method status cts' a) = m a type Client m (Verb method status cts' a) = m a
clientWithRoute _pm Proxy req = do clientWithRoute _pm Proxy req = do
(_hdrs, a) :: ([H.Header], a) <- runRequest (Proxy :: Proxy ct) method req response <- runRequest req
return a { 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) where method = reflectMethod (Proxy :: Proxy method)
accept = contentTypes (Proxy :: Proxy ct)
instance OVERLAPPING_ instance OVERLAPPING_
( RunClient m NoContent [HTTP.Header] ( RunClient m, ReflectMethod method
, ReflectMethod method) => HasClient m (Verb method status cts NoContent) where ) => HasClient m (Verb method status cts NoContent) where
type Client m (Verb method status cts NoContent) type Client m (Verb method status cts NoContent)
= m NoContent = m NoContent
clientWithRoute _pm Proxy req = do clientWithRoute _pm Proxy req = do
_hdrs :: [H.Header] <- runRequest (Proxy :: Proxy NoContent) method req _response <- runRequest req { requestMethod = method }
return NoContent return NoContent
where method = reflectMethod (Proxy :: Proxy method) where method = reflectMethod (Proxy :: Proxy method)
instance OVERLAPPING_ instance OVERLAPPING_
-- Note [Non-Empty Content Types] -- Note [Non-Empty Content Types]
( RunClient m ct ([H.Header], a) ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls
, MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts) , ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient m (Verb method status cts' (Headers ls a)) where ) => HasClient m (Verb method status cts' (Headers ls a)) where
type Client m (Verb method status cts' (Headers ls a)) type Client m (Verb method status cts' (Headers ls a))
= m (Headers ls a) = m (Headers ls a)
clientWithRoute _pm Proxy req = do clientWithRoute _pm Proxy req = do
let method = reflectMethod (Proxy :: Proxy method) response <- runRequest req
(hdrs, resp) <- runRequest (Proxy :: Proxy ct) method req { requestMethod = method
return $ Headers { getResponse = resp , requestAccept = fromList $ toList accept
, getHeadersHList = buildHeadersTo hdrs
} }
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_ instance OVERLAPPING_
( RunClient m NoContent [H.Header] ( RunClient m, BuildHeadersTo ls, ReflectMethod method
, BuildHeadersTo ls, ReflectMethod method
) => HasClient m (Verb method status cts (Headers ls NoContent)) where ) => HasClient m (Verb method status cts (Headers ls NoContent)) where
type Client m (Verb method status cts (Headers ls NoContent)) type Client m (Verb method status cts (Headers ls NoContent))
= m (Headers ls NoContent) = m (Headers ls NoContent)
clientWithRoute _pm Proxy req = do clientWithRoute _pm Proxy req = do
let method = reflectMethod (Proxy :: Proxy method) let method = reflectMethod (Proxy :: Proxy method)
hdrs <- runRequest (Proxy :: Proxy NoContent) method req response <- runRequest req { requestMethod = method }
return $ Headers { getResponse = NoContent 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 req mval =
clientWithRoute pm (Proxy :: Proxy api) clientWithRoute pm (Proxy :: Proxy api)
(maybe req (maybe req
(\value -> Servant.Common.Req.addHeader hname value req) (\value -> addHeader hname value req)
mval 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 -- | Using a 'HttpVersion' combinator in your API doesn't affect the client
-- functions. -- functions.
@ -338,8 +358,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
mparamText mparamText
) )
where pname = cs pname' where pname = pack $ symbolVal (Proxy :: Proxy sym)
pname' = symbolVal (Proxy :: Proxy sym)
mparamText = fmap toQueryParam mparam mparamText = fmap toQueryParam mparam
-- | If you use a 'QueryParams' in one of your endpoints in your API, -- | 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' paramlist'
) )
where pname = cs pname' where pname = pack $ symbolVal (Proxy :: Proxy sym)
pname' = symbolVal (Proxy :: Proxy sym)
paramlist' = map (Just . toQueryParam) paramlist paramlist' = map (Just . toQueryParam) paramlist
-- | If you use a 'QueryFlag' in one of your endpoints in your API, -- | 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 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 -- | Pick a 'Method' and specify where the server you want to query is. You get
-- back the full `Response`. -- back the full `Response`.
instance (RunClient m NoContent (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)) instance RunClient m => HasClient m Raw where
=> HasClient m Raw where
type Client m Raw 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 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, -- | If you use a 'ReqBody' in one of your endpoints in your API,
-- the corresponding querying function will automatically take -- the corresponding querying function will automatically take
@ -461,7 +478,7 @@ instance (MimeRender ct a, HasClient m api)
clientWithRoute pm Proxy req body = clientWithRoute pm Proxy req body =
clientWithRoute pm (Proxy :: Proxy api) clientWithRoute pm (Proxy :: Proxy api)
(let ctProxy = Proxy :: Proxy ct (let ctProxy = Proxy :: Proxy ct
in setReqBodyLBS (mimeRender ctProxy body) in setRequestBodyLBS (mimeRender ctProxy body)
-- We use first contentType from the Accept list -- We use first contentType from the Accept list
(contentType ctProxy) (contentType ctProxy)
req req
@ -475,7 +492,7 @@ instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
clientWithRoute pm (Proxy :: Proxy api) clientWithRoute pm (Proxy :: Proxy api)
(appendToPath p req) (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 instance HasClient m api => HasClient m (Vault :> api) where
type Client m (Vault :> api) = Client m api type Client m (Vault :> api) = Client m api

6
servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hs
View file

@ -1,6 +1,6 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
-- | Basic Authentication for clients -- | Basic Authentication for clients
@ -9,8 +9,8 @@ module Servant.Client.Core.Internal.BasicAuth where
import Data.ByteString.Base64 (encode) import Data.ByteString.Base64 (encode)
import Data.Monoid ((<>)) import Data.Monoid ((<>))
import Data.Text.Encoding (decodeUtf8) import Data.Text.Encoding (decodeUtf8)
import Servant.Client.Core.Internal.Request (addHeader, Request) import Servant.API.BasicAuth (BasicAuthData (BasicAuthData))
import Servant.API.BasicAuth (BasicAuthData(BasicAuthData)) import Servant.Client.Core.Internal.Request (Request, addHeader)
-- | Authenticate a request using Basic Authentication -- | Authenticate a request using Basic Authentication
basicAuthReq :: BasicAuthData -> Request -> Request basicAuthReq :: BasicAuthData -> Request -> Request

14
servant-client-core/src/Servant/Client/Core/Internal/Class.hs
View file

@ -1,13 +1,11 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-| Types for possible backends to run client-side `Request` queries -} {-| Types for possible backends to run client-side `Request` queries -}
module Servant.Client.Core.Internal.Class where module Servant.Client.Core.Internal.Class where
import Data.Proxy import Control.Monad.Error.Class (MonadError)
import Network.HTTP.Types import Servant.Client.Core.Internal.Request (Request, Response,
import Servant.Client.Core.Internal.Request (Request, Response) ServantError)
class (Monad m) => RunClient m ct where class (MonadError ServantError m) => RunClient m where
runRequest :: Proxy ct runRequest :: Request -> m Response
-> Method
-> Request
-> m Response

19
servant-client-core/src/Servant/Client/Core/Internal/Request.hs
View file

@ -17,11 +17,13 @@ import qualified Data.ByteString.Lazy as LBS
import Data.Semigroup ((<>)) import Data.Semigroup ((<>))
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Network.HTTP.Media (MediaType) import Network.HTTP.Media (MediaType)
import Network.HTTP.Types (Header, HeaderName, HttpVersion, import Network.HTTP.Types (Header, HeaderName, HttpVersion,
QueryItem, Status, http11) Method, QueryItem, Status, http11,
methodGet)
import Web.HttpApiData (ToHttpApiData, toEncodedUrlPiece, import Web.HttpApiData (ToHttpApiData, toEncodedUrlPiece,
toHeader) toHeader)
@ -40,6 +42,7 @@ data Request = Request
, requestAccept :: Seq.Seq MediaType , requestAccept :: Seq.Seq MediaType
, requestHeaders :: Seq.Seq Header , requestHeaders :: Seq.Seq Header
, requestHttpVersion :: HttpVersion , requestHttpVersion :: HttpVersion
, requestMethod :: Method
} deriving (Generic, Typeable) } deriving (Generic, Typeable)
newtype RequestBody = RequestBodyLBS LBS.ByteString newtype RequestBody = RequestBodyLBS LBS.ByteString
@ -60,18 +63,20 @@ defaultRequest = Request
, requestAccept = Seq.empty , requestAccept = Seq.empty
, requestHeaders = Seq.empty , requestHeaders = Seq.empty
, requestHttpVersion = http11 , requestHttpVersion = http11
, requestMethod = methodGet
} }
appendToPath :: Text -> Request -> Request appendToPath :: Text -> Request -> Request
appendToPath p req appendToPath p req
= req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p } = req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p }
{-appendToQueryString :: Text -- ^ param name-} appendToQueryString :: Text -- ^ param name
{--> Maybe Text -- ^ param value-} -> Maybe Text -- ^ param value
{--> Request-} -> Request
{--> Request-} -> Request
{-appendToQueryString pname pvalue req-} appendToQueryString pname pvalue req
{-= req { requestQueryString = requestQueryString req Seq.|> (pname, pvalue)}-} = req { requestQueryString = requestQueryString req
Seq.|> (encodeUtf8 pname, encodeUtf8 <$> pvalue)}
addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request
addHeader name val req addHeader name val req

1
servant-client/servant-client.cabal
View file

@ -49,7 +49,6 @@ library
, transformers >= 0.3 && < 0.6 , transformers >= 0.3 && < 0.6
, transformers-base >= 0.4.4 && < 0.5 , transformers-base >= 0.4.4 && < 0.5
, transformers-compat >= 0.4 && < 0.6 , transformers-compat >= 0.4 && < 0.6
, mtl
if !impl(ghc >= 8.0) if !impl(ghc >= 8.0)
build-depends: build-depends:
semigroups >=0.16.2.2 && <0.19 semigroups >=0.16.2.2 && <0.19