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-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.*

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

@ -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 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 qualified Network.HTTP.Types.Header as HTTP
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,7 +478,7 @@ 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)
in setRequestBodyLBS (mimeRender ctProxy body)
-- We use first contentType from the Accept list
(contentType ctProxy)
req
@ -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

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

@ -1,6 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
-- | Basic Authentication for clients
@ -9,8 +9,8 @@ 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 Servant.Client.Core.Internal.Request (Request, addHeader)
-- | Authenticate a request using Basic Authentication
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 #-}
{-| 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

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 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

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

@ -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