diff --git a/doc/tutorial/Client.lhs b/doc/tutorial/Client.lhs index 94aee690..b2279849 100644 --- a/doc/tutorial/Client.lhs +++ b/doc/tutorial/Client.lhs @@ -128,15 +128,15 @@ That's it. Let's now write some code that uses our client functions. ``` haskell queries :: ClientM (Position, HelloMessage, Email) queries = do - pos <- position 10 10 - message <- hello (Just "servant") + pos <- position 10 10 + message <- hello (Just "servant") em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]) return (pos, message, em) run :: IO () run = do - manager <- newManager defaultManagerSettings - res <- runClientM queries (ClientEnv manager (BaseUrl Http "localhost" 8081 "")) + manager' <- newManager defaultManagerSettings + res <- runClientM queries (ClientEnv manager' (BaseUrl Http "localhost" 8081 "")) case res of Left err -> putStrLn $ "Error: " ++ show err Right (pos, message, em) -> do diff --git a/servant-client-core/CHANGELOG.md b/servant-client-core/CHANGELOG.md new file mode 100644 index 00000000..10b2cd74 --- /dev/null +++ b/servant-client-core/CHANGELOG.md @@ -0,0 +1,6 @@ +# Revision history for servant-client-core + +## 0.12 -- YYYY-mm-dd + +* First version. Factored out of servant-client all the functionality that was +independent of the http-client backend. diff --git a/servant-client-core/LICENSE b/servant-client-core/LICENSE new file mode 100644 index 00000000..04bba964 --- /dev/null +++ b/servant-client-core/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2017, Servant Contributors + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Servant Contributors nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/servant-client-core/README.md b/servant-client-core/README.md new file mode 100644 index 00000000..59681225 --- /dev/null +++ b/servant-client-core/README.md @@ -0,0 +1,30 @@ +# servant-client-core + +![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png) + +HTTP-client-agnostic client functions for servant APIs. + +This library should mainly be of interest to backend- and combinator-writers. + +## For backend-writers + +If you are creating a new backend, you'll need to: + +1. Define a `RunClient` instance for your datatype (call it `MyMonad`) +2. Define a `ClientLike` instance. This will look like: + +``` haskell +instance ClientLike (MyMonad a) (MyMonad a) where + mkClient = id +``` + +3. Re-export the module Servant.Client.Core.Reexport so that your end-users + can be blissfully unaware of 'servant-client-core', and so each + backend-package comes closer to the warm hearth of the drop-in-replacement + equivalence class. + +## For combinator-writers + +You'll need to define a new `HasClient` instance for your combinator. There are +plenty of examples to guide you in the +[HasClient](src/Servant/Client/Core/Internal/HasClient.hs) module. diff --git a/servant-client-core/Setup.hs b/servant-client-core/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/servant-client-core/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-client-core/include/overlapping-compat.h b/servant-client-core/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-client-core/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal new file mode 100644 index 00000000..b8c52753 --- /dev/null +++ b/servant-client-core/servant-client-core.cabal @@ -0,0 +1,74 @@ +name: servant-client-core +version: 0.11 +synopsis: Core functionality and class for client function generation for servant APIs +description: + This library provides backend-agnostic generation of client functions. For + more information, see the README. +license: BSD3 +license-file: LICENSE +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +homepage: http://haskell-servant.readthedocs.org/ +bug-reports: http://github.com/haskell-servant/servant/issues +cabal-version: >=1.10 +copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2017 Servant Contributors +category: Web +build-type: Simple +extra-source-files: + include/*.h + CHANGELOG.md + README.md +source-repository head + type: git + location: http://github.com/haskell-servant/servant.git + +library + exposed-modules: + Servant.Client.Core + Servant.Client.Core.Reexport + Servant.Client.Core.Internal.Auth + Servant.Client.Core.Internal.BaseUrl + Servant.Client.Core.Internal.BasicAuth + Servant.Client.Core.Internal.Generic + Servant.Client.Core.Internal.HasClient + Servant.Client.Core.Internal.Request + Servant.Client.Core.Internal.RunClient + build-depends: + base >= 4.7 && < 4.11 + , base-compat >= 0.9.1 && < 0.10 + , base64-bytestring >= 1.0.0.1 && < 1.1 + , bytestring >= 0.10 && < 0.11 + , containers >= 0.5 && < 0.6 + , exceptions >= 0.8 && < 0.9 + , generics-sop >= 0.1.0.0 && < 0.4 + , http-api-data >= 0.3.6 && < 0.4 + , http-media >= 0.6.2 && < 0.8 + , http-types >= 0.8.6 && < 0.10 + , mtl >= 2.1 && < 2.3 + , network-uri >= 2.6 && < 2.7 + , safe >= 0.3.9 && < 0.4 + , servant == 0.11.* + , text >= 1.2 && < 1.3 + if !impl(ghc >= 8.0) + build-depends: + semigroups >=0.16.2.2 && <0.19 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + include-dirs: include + +test-suite spec + type: exitcode-stdio-1.0 + ghc-options: -Wall + default-language: Haskell2010 + hs-source-dirs: test + main-is: Spec.hs + build-depends: + base + , base-compat + , deepseq + , servant-client-core + , hspec == 2.* + , QuickCheck >= 2.7 && < 2.11 + other-modules: + Servant.Client.Core.Internal.BaseUrlSpec diff --git a/servant-client-core/src/Servant/Client/Core.hs b/servant-client-core/src/Servant/Client/Core.hs new file mode 100644 index 00000000..a926c169 --- /dev/null +++ b/servant-client-core/src/Servant/Client/Core.hs @@ -0,0 +1,65 @@ +-- | This module provides backend-agnostic functionality for generating clients +-- from @servant@ APIs. By "backend," we mean something that concretely +-- executes the request, such as: +-- +-- * The @http-client@ library +-- * The @haxl@ library +-- * GHCJS via FFI +-- +-- etc. +-- +-- Each backend is encapsulated in a monad that is an instance of the +-- 'RunClient' class. +-- +-- This library is primarily of interest to backend-writers and +-- combinator-writers. For more information, see the README.md +module Servant.Client.Core + ( + -- * Client generation + clientIn + , HasClient(..) + + -- * Request + , Request + , RequestF(..) + , defaultRequest + , RequestBody(..) + + -- * Authentication + , mkAuthenticatedRequest + , basicAuthReq + , AuthenticatedRequest(..) + , AuthClientData + + -- * Generic Client + , ClientLike(..) + , genericMkClientL + , genericMkClientP + , ServantError(..) + , EmptyClient(..) + + + -- * Response + , Response(..) + , RunClient(..) + , module Servant.Client.Core.Internal.BaseUrl + + -- * Writing HasClient instances + -- | These functions need not be re-exported by backend libraries. + , addHeader + , appendToQueryString + , appendToPath + , setRequestBodyLBS + , setRequestBody + ) where +import Servant.Client.Core.Internal.Auth +import Servant.Client.Core.Internal.BaseUrl (BaseUrl (..), + InvalidBaseUrlException, + Scheme (..), + parseBaseUrl, + showBaseUrl) +import Servant.Client.Core.Internal.BasicAuth +import Servant.Client.Core.Internal.HasClient +import Servant.Client.Core.Internal.Generic +import Servant.Client.Core.Internal.Request +import Servant.Client.Core.Internal.RunClient diff --git a/servant-client/src/Servant/Client/Experimental/Auth.hs b/servant-client-core/src/Servant/Client/Core/Internal/Auth.hs similarity index 56% rename from servant-client/src/Servant/Client/Experimental/Auth.hs rename to servant-client-core/src/Servant/Client/Core/Internal/Auth.hs index a98d0b41..7e10f054 100644 --- a/servant-client/src/Servant/Client/Experimental/Auth.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Auth.hs @@ -1,16 +1,12 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TypeFamilies #-} -- | Authentication for clients -module Servant.Client.Experimental.Auth ( - AuthenticateReq(AuthenticateReq, unAuthReq) - , AuthClientData - , mkAuthenticateReq - ) where +module Servant.Client.Core.Internal.Auth where -import Servant.Common.Req (Req) +import Servant.Client.Core.Internal.Request (Request) -- | For a resource protected by authentication (e.g. AuthProtect), we need -- to provide the client with some data used to add authentication data @@ -24,13 +20,13 @@ type family AuthClientData a :: * -- data to a request -- -- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE -newtype AuthenticateReq a = - AuthenticateReq { unAuthReq :: (AuthClientData a, AuthClientData a -> Req -> Req) } +newtype AuthenticatedRequest a = + AuthenticatedRequest { unAuthReq :: (AuthClientData a, AuthClientData a -> Request -> Request) } -- | Handy helper to avoid wrapping datatypes in tuples everywhere. -- -- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE -mkAuthenticateReq :: AuthClientData a - -> (AuthClientData a -> Req -> Req) - -> AuthenticateReq a -mkAuthenticateReq val func = AuthenticateReq (val, func) +mkAuthenticatedRequest :: AuthClientData a + -> (AuthClientData a -> Request -> Request) + -> AuthenticatedRequest a +mkAuthenticatedRequest val func = AuthenticatedRequest (val, func) diff --git a/servant-client/src/Servant/Common/BaseUrl.hs b/servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs similarity index 92% rename from servant-client/src/Servant/Common/BaseUrl.hs rename to servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs index 5c3c190a..b95f57bd 100644 --- a/servant-client/src/Servant/Common/BaseUrl.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs @@ -1,21 +1,13 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ViewPatterns #-} -module Servant.Common.BaseUrl ( - -- * types - BaseUrl (..) - , InvalidBaseUrlException - , Scheme (..) - -- * functions - , parseBaseUrl - , showBaseUrl -) where +module Servant.Client.Core.Internal.BaseUrl where import Control.Monad.Catch (Exception, MonadThrow, throwM) import Data.List import Data.Typeable import GHC.Generics -import Network.URI hiding (path) +import Network.URI hiding (path) import Safe import Text.Read diff --git a/servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hs b/servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hs new file mode 100644 index 00000000..64dc8433 --- /dev/null +++ b/servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-- | 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.API.BasicAuth (BasicAuthData (BasicAuthData)) +import Servant.Client.Core.Internal.Request (Request, addHeader) + +-- | Authenticate a request using Basic Authentication +basicAuthReq :: BasicAuthData -> Request -> Request +basicAuthReq (BasicAuthData user pass) req = + let authText = decodeUtf8 ("Basic " <> encode (user <> ":" <> pass)) + in addHeader "Authorization" authText req diff --git a/servant-client/src/Servant/Client/Generic.hs b/servant-client-core/src/Servant/Client/Core/Internal/Generic.hs similarity index 96% rename from servant-client/src/Servant/Client/Generic.hs rename to servant-client-core/src/Servant/Client/Core/Internal/Generic.hs index 425e7839..4bc1bda8 100644 --- a/servant-client/src/Servant/Client/Generic.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Generic.hs @@ -10,15 +10,10 @@ #include "overlapping-compat.h" -module Servant.Client.Generic - ( ClientLike(..) - , genericMkClientL - , genericMkClientP - ) where +module Servant.Client.Core.Internal.Generic where import Generics.SOP (Code, Generic, I(..), NP(..), NS(Z), SOP(..), to) import Servant.API ((:<|>)(..)) -import Servant.Client (ClientM) -- | This class allows us to match client structure with client functions -- produced with 'client' without explicit pattern-matching. @@ -111,9 +106,6 @@ instance ClientLike client custom => ClientLike (a -> client) (a -> custom) where mkClient c = mkClient . c -instance ClientLike (ClientM a) (ClientM a) where - mkClient = id - -- | Match client structure with client functions, regarding left-nested API clients -- as separate data structures. class GClientLikeP client xs where diff --git a/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs b/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs new file mode 100644 index 00000000..42d61d58 --- /dev/null +++ b/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs @@ -0,0 +1,541 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +#include "overlapping-compat.h" +module Servant.Client.Core.Internal.HasClient where + +import Prelude () +import Prelude.Compat + +import Data.Foldable (toList) +import Data.List (foldl') +import Data.Proxy (Proxy (Proxy)) +import Data.Sequence (fromList) +import Data.String (fromString) +import Data.Text (pack) +import GHC.TypeLits (KnownSymbol, symbolVal) +import qualified Network.HTTP.Types as H +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.BasicAuth +import Servant.Client.Core.Internal.Request +import Servant.Client.Core.Internal.RunClient + +-- * Accessing APIs as a Client + +-- | 'clientIn' allows you to produce operations to query an API from a client +-- within a 'RunClient' monad. +-- +-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books +-- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > clientM :: Proxy ClientM +-- > clientM = Proxy +-- > +-- > getAllBooks :: ClientM [Book] +-- > postNewBook :: Book -> ClientM Book +-- > (getAllBooks :<|> postNewBook) = myApi `clientIn` clientM +clientIn :: HasClient m api => Proxy api -> Proxy m -> Client m api +clientIn p pm = clientWithRoute pm p defaultRequest + + +-- | This class lets us define how each API combinator influences the creation +-- of an HTTP request. +-- +-- Unless you are writing a new backend for @servant-client-core@ or new +-- combinators that you want to support client-generation, you can ignore this +-- class. +class RunClient m => HasClient m api where + type Client (m :: * -> *) (api :: *) :: * + clientWithRoute :: Proxy m -> Proxy api -> Request -> Client m api + + +-- | A client querying function for @a ':<|>' b@ will actually hand you +-- one function for querying @a@ and another one for querying @b@, +-- stitching them together with ':<|>', which really is just like a pair. +-- +-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books +-- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getAllBooks :: ClientM [Book] +-- > postNewBook :: Book -> ClientM Book +-- > (getAllBooks :<|> postNewBook) = client myApi +instance (HasClient m a, HasClient m b) => HasClient m (a :<|> b) where + type Client m (a :<|> b) = Client m a :<|> Client m b + clientWithRoute pm Proxy req = + clientWithRoute pm (Proxy :: Proxy a) req :<|> + clientWithRoute pm (Proxy :: Proxy b) req + +-- | Singleton type representing a client for an empty API. +data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum) + +-- | The client for 'EmptyAPI' is simply 'EmptyClient'. +-- +-- > type MyAPI = "books" :> Get '[JSON] [Book] -- GET /books +-- > :<|> "nothing" :> EmptyAPI +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getAllBooks :: ClientM [Book] +-- > (getAllBooks :<|> EmptyClient) = client myApi +instance RunClient m => HasClient m EmptyAPI where + type Client m EmptyAPI = EmptyClient + clientWithRoute _pm Proxy _ = EmptyClient + +-- | If you use a 'Capture' in one of your endpoints in your API, +-- the corresponding querying function will automatically take +-- an additional argument of the type specified by your 'Capture'. +-- That function will take care of inserting a textual representation +-- of this value at the right place in the request path. +-- +-- You can control how values for this type are turned into +-- text by specifying a 'ToHttpApiData' instance for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBook :: Text -> ClientM Book +-- > getBook = client myApi +-- > -- then you can just use "getBook" to query that endpoint +instance (KnownSymbol capture, ToHttpApiData a, HasClient m api) + => HasClient m (Capture capture a :> api) where + + type Client m (Capture capture a :> api) = + a -> Client m api + + clientWithRoute pm Proxy req val = + clientWithRoute pm (Proxy :: Proxy api) + (appendToPath p req) + + 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 +-- additional argument of a list of the type specified by your +-- 'CaptureAll'. That function will take care of inserting a textual +-- representation of this value at the right place in the request +-- path. +-- +-- You can control how these values are turned into text by specifying +-- a 'ToHttpApiData' instance of your type. +-- +-- Example: +-- +-- > type MyAPI = "src" :> CaptureAll Text -> Get '[JSON] SourceFile +-- > +-- > myApi :: Proxy +-- > myApi = Proxy +-- +-- > getSourceFile :: [Text] -> ClientM SourceFile +-- > getSourceFile = client myApi +-- > -- then you can use "getSourceFile" to query that endpoint +instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout) + => HasClient m (CaptureAll capture a :> sublayout) where + + type Client m (CaptureAll capture a :> sublayout) = + [a] -> Client m sublayout + + clientWithRoute pm Proxy req vals = + clientWithRoute pm (Proxy :: Proxy sublayout) + (foldl' (flip appendToPath) req ps) + + where ps = map (toUrlPiece) vals + +instance OVERLAPPABLE_ + -- Note [Non-Empty Content Types] + ( 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 + response <- runRequest req + { requestAccept = fromList $ toList accept + , requestMethod = method + } + response `decodedAs` (Proxy :: Proxy ct) + where + accept = contentTypes (Proxy :: Proxy ct) + method = reflectMethod (Proxy :: Proxy method) + +instance OVERLAPPING_ + ( 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 + _response <- runRequest req { requestMethod = method } + return NoContent + where method = reflectMethod (Proxy :: Proxy method) + +instance OVERLAPPING_ + -- Note [Non-Empty Content Types] + ( 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 + response <- runRequest req + { requestMethod = method + , requestAccept = fromList $ toList accept + } + case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of + Left err -> throwServantError $ 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, 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) + response <- runRequest req { requestMethod = method } + return $ Headers { getResponse = NoContent + , getHeadersHList = buildHeadersTo . toList $ responseHeaders response + } + + +-- | If you use a 'Header' in one of your endpoints in your API, +-- the corresponding querying function will automatically take +-- an additional argument of the type specified by your 'Header', +-- wrapped in Maybe. +-- +-- That function will take care of encoding this argument as Text +-- in the request headers. +-- +-- All you need is for your type to have a 'ToHttpApiData' instance. +-- +-- Example: +-- +-- > newtype Referer = Referer { referrer :: Text } +-- > deriving (Eq, Show, Generic, ToHttpApiData) +-- > +-- > -- GET /view-my-referer +-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > viewReferer :: Maybe Referer -> ClientM Book +-- > viewReferer = client myApi +-- > -- then you can just use "viewRefer" to query that endpoint +-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments +instance (KnownSymbol sym, ToHttpApiData a, HasClient m api) + => HasClient m (Header sym a :> api) where + + type Client m (Header sym a :> api) = + Maybe a -> Client m api + + clientWithRoute pm Proxy req mval = + clientWithRoute pm (Proxy :: Proxy api) + (maybe req + (\value -> addHeader hname value req) + mval + ) + + where hname = fromString $ symbolVal (Proxy :: Proxy sym) + +-- | Using a 'HttpVersion' combinator in your API doesn't affect the client +-- functions. +instance HasClient m api + => HasClient m (HttpVersion :> api) where + + type Client m (HttpVersion :> api) = + Client m api + + clientWithRoute pm Proxy = + clientWithRoute pm (Proxy :: Proxy api) + +-- | Ignore @'Summary'@ in client functions. +instance HasClient m api => HasClient m (Summary desc :> api) where + type Client m (Summary desc :> api) = Client m api + + clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api) + +-- | Ignore @'Description'@ in client functions. +instance HasClient m api => HasClient m (Description desc :> api) where + type Client m (Description desc :> api) = Client m api + + clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api) + +-- | If you use a 'QueryParam' in one of your endpoints in your API, +-- the corresponding querying function will automatically take +-- an additional argument of the type specified by your 'QueryParam', +-- enclosed in Maybe. +-- +-- If you give Nothing, nothing will be added to the query string. +-- +-- If you give a non-'Nothing' value, this function will take care +-- of inserting a textual representation of this value in the query string. +-- +-- You can control how values for your type are turned into +-- text by specifying a 'ToHttpApiData' instance for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooksBy :: Maybe Text -> ClientM [Book] +-- > getBooksBy = client myApi +-- > -- then you can just use "getBooksBy" to query that endpoint. +-- > -- 'getBooksBy Nothing' for all books +-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov +instance (KnownSymbol sym, ToHttpApiData a, HasClient m api) + => HasClient m (QueryParam sym a :> api) where + + type Client m (QueryParam sym a :> api) = + Maybe a -> Client m api + + -- if mparam = Nothing, we don't add it to the query string + clientWithRoute pm Proxy req mparam = + clientWithRoute pm (Proxy :: Proxy api) + (maybe req + (flip (appendToQueryString pname) req . Just) + mparamText + ) + + where pname = pack $ symbolVal (Proxy :: Proxy sym) + mparamText = fmap toQueryParam mparam + +-- | If you use a 'QueryParams' in one of your endpoints in your API, +-- the corresponding querying function will automatically take +-- an additional argument, a list of values of the type specified +-- by your 'QueryParams'. +-- +-- If you give an empty list, nothing will be added to the query string. +-- +-- Otherwise, this function will take care +-- of inserting a textual representation of your values in the query string, +-- under the same query string parameter name. +-- +-- You can control how values for your type are turned into +-- text by specifying a 'ToHttpApiData' instance for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooksBy :: [Text] -> ClientM [Book] +-- > getBooksBy = client myApi +-- > -- then you can just use "getBooksBy" to query that endpoint. +-- > -- 'getBooksBy []' for all books +-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]' +-- > -- to get all books by Asimov and Heinlein +instance (KnownSymbol sym, ToHttpApiData a, HasClient m api) + => HasClient m (QueryParams sym a :> api) where + + type Client m (QueryParams sym a :> api) = + [a] -> Client m api + + clientWithRoute pm Proxy req paramlist = + clientWithRoute pm (Proxy :: Proxy api) + (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just)) + req + paramlist' + ) + + 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, +-- the corresponding querying function will automatically take +-- an additional 'Bool' argument. +-- +-- If you give 'False', nothing will be added to the query string. +-- +-- Otherwise, this function will insert a value-less query string +-- parameter under the name associated to your 'QueryFlag'. +-- +-- Example: +-- +-- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooks :: Bool -> ClientM [Book] +-- > getBooks = client myApi +-- > -- then you can just use "getBooks" to query that endpoint. +-- > -- 'getBooksBy False' for all books +-- > -- 'getBooksBy True' to only get _already published_ books +instance (KnownSymbol sym, HasClient m api) + => HasClient m (QueryFlag sym :> api) where + + type Client m (QueryFlag sym :> api) = + Bool -> Client m api + + clientWithRoute pm Proxy req flag = + clientWithRoute pm (Proxy :: Proxy api) + (if flag + then appendToQueryString paramname Nothing req + else req + ) + + 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 => HasClient m Raw where + type Client m Raw + = H.Method -> m Response + + clientWithRoute :: Proxy m -> Proxy Raw -> Request -> Client m Raw + clientWithRoute _pm Proxy req httpMethod = do + runRequest req { requestMethod = httpMethod } + +-- | If you use a 'ReqBody' in one of your endpoints in your API, +-- the corresponding querying function will automatically take +-- an additional argument of the type specified by your 'ReqBody'. +-- That function will take care of encoding this argument as JSON and +-- of using it as the request body. +-- +-- All you need is for your type to have a 'ToJSON' instance. +-- +-- Example: +-- +-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > addBook :: Book -> ClientM Book +-- > addBook = client myApi +-- > -- then you can just use "addBook" to query that endpoint +instance (MimeRender ct a, HasClient m api) + => HasClient m (ReqBody (ct ': cts) a :> api) where + + type Client m (ReqBody (ct ': cts) a :> api) = + a -> Client m api + + clientWithRoute pm Proxy req body = + clientWithRoute pm (Proxy :: Proxy api) + (let ctProxy = Proxy :: Proxy ct + 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. +instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where + type Client m (path :> api) = Client m api + + clientWithRoute pm Proxy req = + clientWithRoute pm (Proxy :: Proxy api) + (appendToPath p req) + + where p = pack $ symbolVal (Proxy :: Proxy path) + +instance HasClient m api => HasClient m (Vault :> api) where + type Client m (Vault :> api) = Client m api + + clientWithRoute pm Proxy req = + clientWithRoute pm (Proxy :: Proxy api) req + +instance HasClient m api => HasClient m (RemoteHost :> api) where + type Client m (RemoteHost :> api) = Client m api + + clientWithRoute pm Proxy req = + clientWithRoute pm (Proxy :: Proxy api) req + +instance HasClient m api => HasClient m (IsSecure :> api) where + type Client m (IsSecure :> api) = Client m api + + clientWithRoute pm Proxy req = + clientWithRoute pm (Proxy :: Proxy api) req + +instance HasClient m subapi => + HasClient m (WithNamedContext name context subapi) where + + type Client m (WithNamedContext name context subapi) = Client m subapi + clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi) + +instance ( HasClient m api + ) => HasClient m (AuthProtect tag :> api) where + type Client m (AuthProtect tag :> api) + = AuthenticatedRequest (AuthProtect tag) -> Client m api + + clientWithRoute pm Proxy req (AuthenticatedRequest (val,func)) = + clientWithRoute pm (Proxy :: Proxy api) (func val req) + +-- * Basic Authentication + +instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where + type Client m (BasicAuth realm usr :> api) = BasicAuthData -> Client m api + + clientWithRoute pm Proxy req val = + clientWithRoute pm (Proxy :: Proxy api) (basicAuthReq val req) + + +{- Note [Non-Empty Content Types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Rather than have + + instance (..., cts' ~ (ct ': cts)) => ... cts' ... + +It may seem to make more sense to have: + + instance (...) => ... (ct ': cts) ... + +But this means that if another instance exists that does *not* require +non-empty lists, but is otherwise more specific, no instance will be overall +more specific. This in turn generally means adding yet another instance (one +for empty and one for non-empty lists). +-} diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs new file mode 100644 index 00000000..458219b9 --- /dev/null +++ b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Servant.Client.Core.Internal.Request where + +import Prelude () +import Prelude.Compat + +import Control.Monad.Catch (Exception) +import qualified Data.ByteString.Builder as Builder +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, + Method, QueryItem, Status, http11, + methodGet) +import Web.HttpApiData (ToHttpApiData, toEncodedUrlPiece, + toHeader) + +-- | A type representing possible errors in a request +-- +-- Note that this type substantially changed in 0.12. +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) + +instance Exception ServantError + +data RequestF a = Request + { requestPath :: a + , requestQueryString :: Seq.Seq QueryItem + , requestBody :: Maybe (RequestBody, MediaType) + , requestAccept :: Seq.Seq MediaType + , requestHeaders :: Seq.Seq Header + , requestHttpVersion :: HttpVersion + , requestMethod :: Method + } deriving (Eq, Show, Functor, Generic, Typeable) + +type Request = RequestF Builder.Builder + +-- | The request body. Currently only lazy ByteStrings are supported. +newtype RequestBody = RequestBodyLBS LBS.ByteString + deriving (Eq, Ord, Read, Show, Typeable) + +data Response = Response + { responseStatusCode :: Status + , responseBody :: LBS.ByteString + , responseHeaders :: Seq.Seq Header + , responseHttpVersion :: HttpVersion + } deriving (Eq, Show, Generic, Typeable) + +-- A GET request to the top-level path +defaultRequest :: Request +defaultRequest = Request + { requestPath = "" + , requestQueryString = Seq.empty + , requestBody = Nothing + , 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.|> (encodeUtf8 pname, encodeUtf8 <$> pvalue)} + +addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request +addHeader name val req + = req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)} + +-- | Set body and media type of the request being constructed. +-- +-- The body is set to the given bytestring using the 'RequestBodyLBS' +-- constructor. +-- +-- @since 0.12 +-- +setRequestBodyLBS :: LBS.ByteString -> MediaType -> Request -> Request +setRequestBodyLBS b t req + = req { requestBody = Just (RequestBodyLBS b, t) } + +-- | Set body and media type of the request being constructed. +-- +-- @since 0.12 +-- +setRequestBody :: RequestBody -> MediaType -> Request -> Request +setRequestBody b t req = req { requestBody = Just (b, t) } diff --git a/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs b/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs new file mode 100644 index 00000000..564cbb39 --- /dev/null +++ b/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- | Types for possible backends to run client-side `Request` queries +module Servant.Client.Core.Internal.RunClient where + +import Prelude () +import Prelude.Compat + +import Control.Monad (unless) +import Data.Foldable (toList) +import Data.Proxy (Proxy) +import qualified Data.Text as T +import Network.HTTP.Media (MediaType, matches, + parseAccept, (//)) +import Servant.API (MimeUnrender, + contentTypes, + mimeUnrender) +import Servant.Client.Core.Internal.Request (Request, Response (..), + ServantError (..)) + +class (Monad m) => RunClient m where + -- | How to make a request. + runRequest :: Request -> m Response + throwServantError :: ServantError -> m a + catchServantError :: m a -> (ServantError -> m a) -> m a + +checkContentTypeHeader :: RunClient m => Response -> m MediaType +checkContentTypeHeader response = + case lookup "Content-Type" $ toList $ responseHeaders response of + Nothing -> return $ "application"//"octet-stream" + Just t -> case parseAccept t of + Nothing -> throwServantError $ InvalidContentTypeHeader response + Just t' -> return t' + +decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m) + => Response -> Proxy ct -> m a +decodedAs response contentType = do + responseContentType <- checkContentTypeHeader response + unless (any (matches responseContentType) accept) $ + throwServantError $ UnsupportedContentType responseContentType response + case mimeUnrender contentType $ responseBody response of + Left err -> throwServantError $ DecodeFailure (T.pack err) response + Right val -> return val + where + accept = toList $ contentTypes contentType diff --git a/servant-client-core/src/Servant/Client/Core/Reexport.hs b/servant-client-core/src/Servant/Client/Core/Reexport.hs new file mode 100644 index 00000000..4c90a6f2 --- /dev/null +++ b/servant-client-core/src/Servant/Client/Core/Reexport.hs @@ -0,0 +1,30 @@ +-- | This module is a utility for @servant-client-core@ backend writers. It +-- contains all the functionality from @servant-client-core@ that should be +-- re-exported. +module Servant.Client.Core.Reexport + ( + -- * HasClient + HasClient(..) + -- * Response (for @Raw@) + , Response(..) + + -- * Generic Client + , ClientLike(..) + , genericMkClientL + , genericMkClientP + , ServantError(..) + , EmptyClient(..) + + -- * BaseUrl + , BaseUrl(..) + , Scheme(..) + , showBaseUrl + , parseBaseUrl + , InvalidBaseUrlException + ) where + + +import Servant.Client.Core.Internal.BaseUrl +import Servant.Client.Core.Internal.HasClient +import Servant.Client.Core.Internal.Generic +import Servant.Client.Core.Internal.Request diff --git a/servant-client/test/Servant/Common/BaseUrlSpec.hs b/servant-client-core/test/Servant/Client/Core/Internal/BaseUrlSpec.hs similarity index 94% rename from servant-client/test/Servant/Common/BaseUrlSpec.hs rename to servant-client-core/test/Servant/Client/Core/Internal/BaseUrlSpec.hs index e25da65d..09ece081 100644 --- a/servant-client/test/Servant/Common/BaseUrlSpec.hs +++ b/servant-client-core/test/Servant/Client/Core/Internal/BaseUrlSpec.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -module Servant.Common.BaseUrlSpec where +module Servant.Client.Core.Internal.BaseUrlSpec (spec) where + import Control.DeepSeq import Prelude () @@ -7,7 +8,7 @@ import Prelude.Compat import Test.Hspec import Test.QuickCheck -import Servant.Common.BaseUrl +import Servant.Client.Core.Internal.BaseUrl spec :: Spec spec = do @@ -78,6 +79,3 @@ instance Arbitrary BaseUrl where (1, choose (1, 20000)) : [] pathGen = listOf1 . elements $ letters - -isLeft :: Either a b -> Bool -isLeft = either (const True) (const False) diff --git a/servant-client-core/test/Spec.hs b/servant-client-core/test/Spec.hs new file mode 100644 index 00000000..a824f8c3 --- /dev/null +++ b/servant-client-core/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 6e2c6499..14ea3ad2 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -12,7 +12,7 @@ license: BSD3 license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com -copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors +copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2017 Servant Contributors category: Servant, Web build-type: Simple cabal-version: >=1.10 @@ -30,39 +30,27 @@ source-repository head library exposed-modules: Servant.Client - Servant.Client.Generic - Servant.Client.Experimental.Auth - Servant.Common.BaseUrl - Servant.Common.BasicAuth - Servant.Common.Req + Servant.Client.Internal.HttpClient 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 - , base64-bytestring >= 1.0.0.1 && < 1.1 - , bytestring >= 0.10 && < 0.11 - , exceptions >= 0.8 && < 0.9 - , generics-sop >= 0.1.0.0 && < 0.4 - , http-api-data >= 0.3.6 && < 0.4 - , http-client >= 0.4.18.1 && < 0.6 + , containers >= 0.5 && < 0.6 + , http-client >= 0.4.30 && < 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 - , network-uri >= 2.6 && < 2.7 - , safe >= 0.3.9 && < 0.4 + , mtl >= 2.1 && < 2.3 , semigroupoids >= 4.3 && < 5.3 - , servant == 0.11.* - , string-conversions >= 0.3 && < 0.5 + , 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 - , mtl - if !impl(ghc >= 8.0) - build-depends: - semigroups >=0.16.2.2 && <0.19 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall @@ -78,12 +66,12 @@ test-suite spec main-is: Spec.hs other-modules: Servant.ClientSpec - , Servant.Common.BaseUrlSpec build-depends: base == 4.* , aeson , base-compat , bytestring + , containers , deepseq , hspec == 2.* , http-api-data @@ -96,6 +84,7 @@ test-suite spec , QuickCheck >= 2.7 , servant , servant-client + , servant-client-core , servant-server == 0.11.* , text , transformers diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index b79fcf08..ac35a669 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -1,510 +1,13 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -#include "overlapping-compat.h" -- | This module provides 'client' which can automatically generate -- querying functions for each endpoint just from the type representing your -- API. module Servant.Client - ( AuthClientData - , AuthenticateReq(..) - , client - , HasClient(..) + ( client , ClientM , runClientM - , ClientEnv (ClientEnv) - , mkAuthenticateReq - , ServantError(..) - , EmptyClient(..) - , module Servant.Common.BaseUrl + , ClientEnv(..) + , module Servant.Client.Core.Reexport ) 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 Prelude.Compat -import Servant.API -import Servant.Client.Experimental.Auth -import Servant.Common.BaseUrl -import Servant.Common.BasicAuth -import Servant.Common.Req - --- * Accessing APIs as a Client - --- | 'client' allows you to produce operations to query an API from a client. --- --- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books --- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getAllBooks :: ClientM [Book] --- > postNewBook :: Book -> ClientM Book --- > (getAllBooks :<|> postNewBook) = client myApi -client :: HasClient api => Proxy api -> Client api -client p = clientWithRoute p defReq - --- | 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 api where - type Client api :: * - clientWithRoute :: Proxy api -> Req -> Client api - - --- | A client querying function for @a ':<|>' b@ will actually hand you --- one function for querying @a@ and another one for querying @b@, --- stitching them together with ':<|>', which really is just like a pair. --- --- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books --- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getAllBooks :: ClientM [Book] --- > postNewBook :: Book -> ClientM Book --- > (getAllBooks :<|> postNewBook) = client myApi -instance (HasClient a, HasClient b) => HasClient (a :<|> b) where - type Client (a :<|> b) = Client a :<|> Client b - clientWithRoute Proxy req = - clientWithRoute (Proxy :: Proxy a) req :<|> - clientWithRoute (Proxy :: Proxy b) req - --- | Singleton type representing a client for an empty API. -data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum) - --- | The client for 'EmptyAPI' is simply 'EmptyClient'. --- --- > type MyAPI = "books" :> Get '[JSON] [Book] -- GET /books --- > :<|> "nothing" :> EmptyAPI --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getAllBooks :: ClientM [Book] --- > (getAllBooks :<|> EmptyClient) = client myApi -instance HasClient EmptyAPI where - type Client EmptyAPI = EmptyClient - clientWithRoute Proxy _ = EmptyClient - --- | If you use a 'Capture' in one of your endpoints in your API, --- the corresponding querying function will automatically take --- an additional argument of the type specified by your 'Capture'. --- That function will take care of inserting a textual representation --- of this value at the right place in the request path. --- --- You can control how values for this type are turned into --- text by specifying a 'ToHttpApiData' instance for your type. --- --- Example: --- --- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getBook :: Text -> ClientM Book --- > getBook = client myApi --- > -- then you can just use "getBook" to query that endpoint -instance (KnownSymbol capture, ToHttpApiData a, HasClient api) - => HasClient (Capture capture a :> api) where - - type Client (Capture capture a :> api) = - a -> Client api - - clientWithRoute Proxy req val = - clientWithRoute (Proxy :: Proxy api) - (appendToPath p req) - - where p = unpack (toUrlPiece val) - --- | If you use a 'CaptureAll' in one of your endpoints in your API, --- the corresponding querying function will automatically take an --- additional argument of a list of the type specified by your --- 'CaptureAll'. That function will take care of inserting a textual --- representation of this value at the right place in the request --- path. --- --- You can control how these values are turned into text by specifying --- a 'ToHttpApiData' instance of your type. --- --- Example: --- --- > type MyAPI = "src" :> CaptureAll Text -> Get '[JSON] SourceFile --- > --- > myApi :: Proxy --- > myApi = Proxy --- --- > getSourceFile :: [Text] -> ClientM SourceFile --- > getSourceFile = client myApi --- > -- then you can use "getSourceFile" to query that endpoint -instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout) - => HasClient (CaptureAll capture a :> sublayout) where - - type Client (CaptureAll capture a :> sublayout) = - [a] -> Client sublayout - - clientWithRoute Proxy req vals = - clientWithRoute (Proxy :: Proxy sublayout) - (foldl' (flip appendToPath) req ps) - - where ps = map (unpack . toUrlPiece) vals - -instance OVERLAPPABLE_ - -- Note [Non-Empty Content Types] - (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) - ) => HasClient (Verb method status cts' a) where - type Client (Verb method status cts' a) = ClientM a - clientWithRoute Proxy req = do - snd <$> performRequestCT (Proxy :: Proxy ct) method req - where method = reflectMethod (Proxy :: Proxy method) - -instance OVERLAPPING_ - (ReflectMethod method) => HasClient (Verb method status cts NoContent) where - type Client (Verb method status cts NoContent) - = ClientM NoContent - clientWithRoute Proxy req = do - performRequestNoBody method req >> return NoContent - where method = reflectMethod (Proxy :: Proxy method) - -instance OVERLAPPING_ - -- Note [Non-Empty Content Types] - ( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts) - ) => HasClient (Verb method status cts' (Headers ls a)) where - type Client (Verb method status cts' (Headers ls a)) - = ClientM (Headers ls a) - clientWithRoute Proxy req = do - let method = reflectMethod (Proxy :: Proxy method) - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req - return $ Headers { getResponse = resp - , getHeadersHList = buildHeadersTo hdrs - } - -instance OVERLAPPING_ - ( BuildHeadersTo ls, ReflectMethod method - ) => HasClient (Verb method status cts (Headers ls NoContent)) where - type Client (Verb method status cts (Headers ls NoContent)) - = ClientM (Headers ls NoContent) - clientWithRoute Proxy req = do - let method = reflectMethod (Proxy :: Proxy method) - hdrs <- performRequestNoBody method req - return $ Headers { getResponse = NoContent - , getHeadersHList = buildHeadersTo hdrs - } - - --- | If you use a 'Header' in one of your endpoints in your API, --- the corresponding querying function will automatically take --- an additional argument of the type specified by your 'Header', --- wrapped in Maybe. --- --- That function will take care of encoding this argument as Text --- in the request headers. --- --- All you need is for your type to have a 'ToHttpApiData' instance. --- --- Example: --- --- > newtype Referer = Referer { referrer :: Text } --- > deriving (Eq, Show, Generic, ToHttpApiData) --- > --- > -- GET /view-my-referer --- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > viewReferer :: Maybe Referer -> ClientM Book --- > viewReferer = client myApi --- > -- then you can just use "viewRefer" to query that endpoint --- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments -instance (KnownSymbol sym, ToHttpApiData a, HasClient api) - => HasClient (Header sym a :> api) where - - type Client (Header sym a :> api) = - Maybe a -> Client api - - clientWithRoute Proxy req mval = - clientWithRoute (Proxy :: Proxy api) - (maybe req - (\value -> Servant.Common.Req.addHeader hname value req) - mval - ) - - where hname = symbolVal (Proxy :: Proxy sym) - --- | Using a 'HttpVersion' combinator in your API doesn't affect the client --- functions. -instance HasClient api - => HasClient (HttpVersion :> api) where - - type Client (HttpVersion :> api) = - Client api - - clientWithRoute Proxy = - clientWithRoute (Proxy :: Proxy api) - --- | Ignore @'Summary'@ in client functions. -instance HasClient api => HasClient (Summary desc :> api) where - type Client (Summary desc :> api) = Client api - - clientWithRoute _ = clientWithRoute (Proxy :: Proxy api) - --- | Ignore @'Description'@ in client functions. -instance HasClient api => HasClient (Description desc :> api) where - type Client (Description desc :> api) = Client api - - clientWithRoute _ = clientWithRoute (Proxy :: Proxy api) - --- | If you use a 'QueryParam' in one of your endpoints in your API, --- the corresponding querying function will automatically take --- an additional argument of the type specified by your 'QueryParam', --- enclosed in Maybe. --- --- If you give Nothing, nothing will be added to the query string. --- --- If you give a non-'Nothing' value, this function will take care --- of inserting a textual representation of this value in the query string. --- --- You can control how values for your type are turned into --- text by specifying a 'ToHttpApiData' instance for your type. --- --- Example: --- --- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book] --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getBooksBy :: Maybe Text -> ClientM [Book] --- > getBooksBy = client myApi --- > -- then you can just use "getBooksBy" to query that endpoint. --- > -- 'getBooksBy Nothing' for all books --- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov -instance (KnownSymbol sym, ToHttpApiData a, HasClient api) - => HasClient (QueryParam sym a :> api) where - - type Client (QueryParam sym a :> api) = - Maybe a -> Client api - - -- if mparam = Nothing, we don't add it to the query string - clientWithRoute Proxy req mparam = - clientWithRoute (Proxy :: Proxy api) - (maybe req - (flip (appendToQueryString pname) req . Just) - mparamText - ) - - where pname = cs pname' - pname' = symbolVal (Proxy :: Proxy sym) - mparamText = fmap toQueryParam mparam - --- | If you use a 'QueryParams' in one of your endpoints in your API, --- the corresponding querying function will automatically take --- an additional argument, a list of values of the type specified --- by your 'QueryParams'. --- --- If you give an empty list, nothing will be added to the query string. --- --- Otherwise, this function will take care --- of inserting a textual representation of your values in the query string, --- under the same query string parameter name. --- --- You can control how values for your type are turned into --- text by specifying a 'ToHttpApiData' instance for your type. --- --- Example: --- --- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book] --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getBooksBy :: [Text] -> ClientM [Book] --- > getBooksBy = client myApi --- > -- then you can just use "getBooksBy" to query that endpoint. --- > -- 'getBooksBy []' for all books --- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]' --- > -- to get all books by Asimov and Heinlein -instance (KnownSymbol sym, ToHttpApiData a, HasClient api) - => HasClient (QueryParams sym a :> api) where - - type Client (QueryParams sym a :> api) = - [a] -> Client api - - clientWithRoute Proxy req paramlist = - clientWithRoute (Proxy :: Proxy api) - (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just)) - req - paramlist' - ) - - where pname = cs pname' - pname' = symbolVal (Proxy :: Proxy sym) - paramlist' = map (Just . toQueryParam) paramlist - --- | If you use a 'QueryFlag' in one of your endpoints in your API, --- the corresponding querying function will automatically take --- an additional 'Bool' argument. --- --- If you give 'False', nothing will be added to the query string. --- --- Otherwise, this function will insert a value-less query string --- parameter under the name associated to your 'QueryFlag'. --- --- Example: --- --- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book] --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getBooks :: Bool -> ClientM [Book] --- > getBooks = client myApi --- > -- then you can just use "getBooks" to query that endpoint. --- > -- 'getBooksBy False' for all books --- > -- 'getBooksBy True' to only get _already published_ books -instance (KnownSymbol sym, HasClient api) - => HasClient (QueryFlag sym :> api) where - - type Client (QueryFlag sym :> api) = - Bool -> Client api - - clientWithRoute Proxy req flag = - clientWithRoute (Proxy :: Proxy api) - (if flag - then appendToQueryString paramname Nothing req - else req - ) - - where paramname = cs $ symbolVal (Proxy :: Proxy sym) - - --- | Pick a 'Method' and specify where the server you want to query is. You get --- back the full `Response`. -instance HasClient Raw where - type Client Raw - = H.Method -> ClientM (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) - - clientWithRoute :: Proxy Raw -> Req -> Client Raw - clientWithRoute Proxy req httpMethod = do - performRequest httpMethod req - --- | If you use a 'ReqBody' in one of your endpoints in your API, --- the corresponding querying function will automatically take --- an additional argument of the type specified by your 'ReqBody'. --- That function will take care of encoding this argument as JSON and --- of using it as the request body. --- --- All you need is for your type to have a 'ToJSON' instance. --- --- Example: --- --- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > addBook :: Book -> ClientM Book --- > addBook = client myApi --- > -- then you can just use "addBook" to query that endpoint -instance (MimeRender ct a, HasClient api) - => HasClient (ReqBody (ct ': cts) a :> api) where - - type Client (ReqBody (ct ': cts) a :> api) = - a -> Client api - - clientWithRoute Proxy req body = - clientWithRoute (Proxy :: Proxy api) - (let ctProxy = Proxy :: Proxy ct - in setReqBodyLBS (mimeRender ctProxy body) - -- We use first contentType from the Accept list - (contentType ctProxy) - req - ) - --- | Make the querying function append @path@ to the request path. -instance (KnownSymbol path, HasClient api) => HasClient (path :> api) where - type Client (path :> api) = Client api - - clientWithRoute Proxy req = - clientWithRoute (Proxy :: Proxy api) - (appendToPath p req) - - where p = symbolVal (Proxy :: Proxy path) - -instance HasClient api => HasClient (Vault :> api) where - type Client (Vault :> api) = Client api - - clientWithRoute Proxy req = - clientWithRoute (Proxy :: Proxy api) req - -instance HasClient api => HasClient (RemoteHost :> api) where - type Client (RemoteHost :> api) = Client api - - clientWithRoute Proxy req = - clientWithRoute (Proxy :: Proxy api) req - -instance HasClient api => HasClient (IsSecure :> api) where - type Client (IsSecure :> api) = Client api - - clientWithRoute Proxy req = - clientWithRoute (Proxy :: Proxy api) req - -instance HasClient subapi => - HasClient (WithNamedContext name context subapi) where - - type Client (WithNamedContext name context subapi) = Client subapi - clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy subapi) - -instance ( HasClient api - ) => HasClient (AuthProtect tag :> api) where - type Client (AuthProtect tag :> api) - = AuthenticateReq (AuthProtect tag) -> Client api - - clientWithRoute Proxy req (AuthenticateReq (val,func)) = - clientWithRoute (Proxy :: Proxy api) (func val req) - --- * Basic Authentication - -instance HasClient api => HasClient (BasicAuth realm usr :> api) where - type Client (BasicAuth realm usr :> api) = BasicAuthData -> Client api - - clientWithRoute Proxy req val = - clientWithRoute (Proxy :: Proxy api) (basicAuthReq val req) - - -{- Note [Non-Empty Content Types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Rather than have - - instance (..., cts' ~ (ct ': cts)) => ... cts' ... - -It may seem to make more sense to have: - - instance (...) => ... (ct ': cts) ... - -But this means that if another instance exists that does *not* require -non-empty lists, but is otherwise more specific, no instance will be overall -more specific. This in turn generally means adding yet another instance (one -for empty and one for non-empty lists). --} +import Servant.Client.Internal.HttpClient +import Servant.Client.Core.Reexport diff --git a/servant-client/src/Servant/Client/Internal/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs new file mode 100644 index 00000000..e61b29e3 --- /dev/null +++ b/servant-client/src/Servant/Client/Internal/HttpClient.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | @http-client@-based client requests executor +module Servant.Client.Internal.HttpClient where + + +import Prelude () +import Prelude.Compat + +import Control.Exception +import Control.Monad +import Control.Monad.Base (MonadBase (..)) +import Control.Monad.Catch (MonadCatch, MonadThrow) +import Control.Monad.Error.Class (MonadError (..)) +import Control.Monad.Reader +import Control.Monad.Trans.Control (MonadBaseControl (..)) +import Control.Monad.Trans.Except +import Data.ByteString.Builder (toLazyByteString) +import qualified Data.ByteString.Lazy as BSL +import Data.Foldable (toList) +import Data.Functor.Alt (Alt (..)) +import Data.Monoid ((<>)) +import Data.Proxy (Proxy (..)) +import Data.Sequence (fromList) +import Data.String (fromString) +import qualified Data.Text as T +import GHC.Generics +import Network.HTTP.Media (renderHeader) +import Network.HTTP.Types (hContentType, renderQuery, + statusCode) +import Servant.Client.Core + +import qualified Network.HTTP.Client as Client + +-- | The environment in which a request is run. +data ClientEnv + = ClientEnv + { manager :: Client.Manager + , baseUrl :: BaseUrl + } + +-- | Generates a set of client functions for an API. +-- +-- Example: +-- +-- > type API = Capture "no" Int :> Get '[JSON] Int +-- > :<|> Get '[JSON] [Bool] +-- > +-- > api :: Proxy API +-- > api = Proxy +-- > +-- > getInt :: Int -> ClientM Int +-- > getBools :: ClientM [Bool] +-- > getInt :<|> getBools = client api +client :: HasClient ClientM api => Proxy api -> Client ClientM api +client api = api `clientIn` (Proxy :: Proxy ClientM) + +-- | @ClientM@ is the monad in which client functions run. Contains the +-- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment. +newtype ClientM a = ClientM + { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a } + deriving ( Functor, Applicative, Monad, MonadIO, Generic + , MonadReader ClientEnv, MonadError ServantError, MonadThrow + , MonadCatch) + +instance MonadBase IO ClientM where + liftBase = ClientM . liftBase + +instance MonadBaseControl IO ClientM where + type StM ClientM a = Either ServantError a + + liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . runClientM'))) + + restoreM st = ClientM (restoreM st) + +-- | Try clients in order, last error is preserved. +instance Alt ClientM where + a b = a `catchError` \_ -> b + +instance RunClient ClientM where + runRequest = performRequest + throwServantError = throwError + catchServantError = catchError + +instance ClientLike (ClientM a) (ClientM a) where + mkClient = id + +runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a) +runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm + + +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 $ err + Right response -> do + let status = Client.responseStatus response + status_code = statusCode status + ourResponse = clientResponseToReponse response + unless (status_code >= 200 && status_code < 300) $ + throwError $ FailureResponse ourResponse + return ourResponse + +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 + } + +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)) + +catchConnectionError :: IO a -> IO (Either ServantError a) +catchConnectionError action = + catch (Right <$> action) $ \e -> + pure . Left . ConnectionError . T.pack $ show (e :: Client.HttpException) diff --git a/servant-client/src/Servant/Common/BasicAuth.hs b/servant-client/src/Servant/Common/BasicAuth.hs deleted file mode 100644 index e2802699..00000000 --- a/servant-client/src/Servant/Common/BasicAuth.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TypeFamilies #-} - --- | Basic Authentication for clients - -module Servant.Common.BasicAuth ( - basicAuthReq - ) where - -import Data.ByteString.Base64 (encode) -import Data.Monoid ((<>)) -import Data.Text.Encoding (decodeUtf8) -import Servant.Common.Req (addHeader, Req) -import Servant.API.BasicAuth (BasicAuthData(BasicAuthData)) - --- | Authenticate a request using Basic Authentication -basicAuthReq :: BasicAuthData -> Req -> Req -basicAuthReq (BasicAuthData user pass) req = - let authText = decodeUtf8 ("Basic " <> encode (user <> ":" <> pass)) - in addHeader "Authorization" authText req diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs deleted file mode 100644 index 88d1d001..00000000 --- a/servant-client/src/Servant/Common/Req.hs +++ /dev/null @@ -1,285 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Servant.Common.Req where - -import Prelude () -import Prelude.Compat - -import Control.Exception -import Control.Monad -import Control.Monad.Catch (MonadThrow, MonadCatch) -import Data.Foldable (toList) -import Data.Functor.Alt (Alt (..)) -import Data.Semigroup ((<>)) - -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Trans.Except - -import GHC.Generics -import Control.Monad.Base (MonadBase (..)) -import Control.Monad.IO.Class () -import Control.Monad.Reader -import Control.Monad.Trans.Control (MonadBaseControl (..)) -import qualified Data.ByteString.Builder as BS -import Data.ByteString.Lazy hiding (pack, filter, map, null, elem, any) -import Data.String -import Data.String.Conversions (cs) -import Data.Proxy -import Data.Text (Text) -import Data.Text.Encoding -import Data.Typeable -import Network.HTTP.Media -import Network.HTTP.Types -import Network.HTTP.Client hiding (Proxy, path) -import qualified Network.HTTP.Types.Header as HTTP -import Network.URI hiding (path) -import Servant.API.ContentTypes -import Servant.Common.BaseUrl - -import qualified Network.HTTP.Client as Client - -import Web.HttpApiData - -data ServantError - = FailureResponse - { failingRequest :: UrlReq - , responseStatus :: Status - , responseContentType :: MediaType - , responseBody :: ByteString - } - | DecodeFailure - { decodeError :: String - , responseContentType :: MediaType - , responseBody :: ByteString - } - | UnsupportedContentType - { responseContentType :: MediaType - , responseBody :: ByteString - } - | InvalidContentTypeHeader - { responseContentTypeHeader :: ByteString - , responseBody :: ByteString - } - | ConnectionError - { connectionError :: SomeException - } - deriving (Show, Typeable) - -instance Eq ServantError where - FailureResponse _ a b c == FailureResponse _ x y z = - (a, b, c) == (x, y, z) - DecodeFailure a b c == DecodeFailure x y z = - (a, b, c) == (x, y, z) - UnsupportedContentType a b == UnsupportedContentType x y = - (a, b) == (x, y) - InvalidContentTypeHeader a b == InvalidContentTypeHeader x y = - (a, b) == (x, y) - ConnectionError a == ConnectionError x = - show a == show x - _ == _ = False - -instance Exception ServantError - -data UrlReq = UrlReq BaseUrl Req - -instance Show UrlReq where - show (UrlReq url req) = showBaseUrl url ++ path ++ "?" ++ show (qs req) - where - path = cs (BS.toLazyByteString (reqPath req)) - -data Req = Req - { reqPath :: BS.Builder - , qs :: QueryText - , reqBody :: Maybe (RequestBody, MediaType) - , reqAccept :: [MediaType] - , headers :: [(String, Text)] - } - -defReq :: Req -defReq = Req "" [] Nothing [] [] - -appendToPath :: String -> Req -> Req -appendToPath p req = - req { reqPath = reqPath req <> "/" <> toEncodedUrlPiece p } - -appendToQueryString :: Text -- ^ param name - -> Maybe Text -- ^ param value - -> Req - -> Req -appendToQueryString pname pvalue req = - req { qs = qs req ++ [(pname, pvalue)] - } - -addHeader :: ToHttpApiData a => String -> a -> Req -> Req -addHeader name val req = req { headers = headers req - ++ [(name, decodeUtf8 (toHeader val))] - } - --- | Set body and media type of the request being constructed. --- --- The body is set to the given bytestring using the 'RequestBodyLBS' --- constructor. --- -{-# DEPRECATED setRQBody "Use setReqBodyLBS instead" #-} -setRQBody :: ByteString -> MediaType -> Req -> Req -setRQBody = setReqBodyLBS - --- | Set body and media type of the request being constructed. --- --- The body is set to the given bytestring using the 'RequestBodyLBS' --- constructor. --- --- @since 0.9.2.0 --- -setReqBodyLBS :: ByteString -> MediaType -> Req -> Req -setReqBodyLBS b t req = req { reqBody = Just (RequestBodyLBS b, t) } - --- | Set body and media type of the request being constructed. --- --- @since 0.9.2.0 --- -setReqBody :: RequestBody -> MediaType -> Req -> Req -setReqBody b t req = req { reqBody = Just (b, t) } - -reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request -reqToRequest req (BaseUrl reqScheme reqHost reqPort path) = - setheaders . setAccept . setrqb . setQS <$> parseRequest url - - where url = show $ nullURI { uriScheme = case reqScheme of - Http -> "http:" - Https -> "https:" - , uriAuthority = Just $ - URIAuth { uriUserInfo = "" - , uriRegName = reqHost - , uriPort = ":" ++ show reqPort - } - , uriPath = fullPath - } - fullPath = path ++ cs (BS.toLazyByteString (reqPath req)) - - setrqb r = case reqBody req of - Nothing -> r - Just (b,t) -> r { requestBody = b - , requestHeaders = requestHeaders r - ++ [(hContentType, cs . show $ t)] } - setQS = setQueryString $ queryTextToQuery (qs req) - setheaders r = r { requestHeaders = requestHeaders r - <> fmap toProperHeader (headers req) } - setAccept r = r { requestHeaders = filter ((/= "Accept") . fst) (requestHeaders r) - <> [("Accept", renderHeader $ reqAccept req) - | not . null . reqAccept $ req] } - toProperHeader (name, val) = - (fromString name, encodeUtf8 val) - -#if !MIN_VERSION_http_client(0,4,30) --- 'parseRequest' is introduced in http-client-0.4.30 --- it differs from 'parseUrl', by not throwing exceptions on non-2xx http statuses --- --- See for implementations: --- http://hackage.haskell.org/package/http-client-0.4.30/docs/src/Network-HTTP-Client-Request.html#parseRequest --- http://hackage.haskell.org/package/http-client-0.5.0/docs/src/Network-HTTP-Client-Request.html#parseRequest -parseRequest :: MonadThrow m => String -> m Request -parseRequest url = liftM disableStatusCheck (parseUrl url) - where - disableStatusCheck req = req { checkStatus = \ _status _headers _cookies -> Nothing } -#endif - - --- * performing requests - -displayHttpRequest :: Method -> String -displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" - -data ClientEnv - = ClientEnv - { manager :: Manager - , baseUrl :: BaseUrl - } - - --- | @ClientM@ is the monad in which client functions run. Contains the --- 'Manager' and 'BaseUrl' used for requests in the reader environment. - -newtype ClientM a = ClientM { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a } - deriving ( Functor, Applicative, Monad, MonadIO, Generic - , MonadReader ClientEnv - , MonadError ServantError - , MonadThrow, MonadCatch - ) - -instance MonadBase IO ClientM where - liftBase = ClientM . liftBase - -instance MonadBaseControl IO ClientM where - type StM ClientM a = Either ServantError a - - -- liftBaseWith :: (RunInBase ClientM IO -> IO a) -> ClientM a - liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . runClientM'))) - - -- restoreM :: StM ClientM a -> ClientM a - restoreM st = ClientM (restoreM st) - --- | Try clients in order, last error is preserved. -instance Alt ClientM where - a b = a `catchError` \_ -> b - -runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a) -runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm - - -performRequest :: Method -> Req - -> ClientM ( Int, ByteString, MediaType - , [HTTP.Header], Response ByteString) -performRequest reqMethod req = do - m <- asks manager - reqHost <- asks baseUrl - partialRequest <- liftIO $ reqToRequest req reqHost - - let request = partialRequest { Client.method = reqMethod } - - eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m - case eResponse of - Left err -> - throwError . ConnectionError $ SomeException err - - Right response -> do - let status = Client.responseStatus response - body = Client.responseBody response - hdrs = Client.responseHeaders response - status_code = statusCode status - 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 - 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) - -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) diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 14e9f917..fda25428 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -24,40 +24,57 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} #include "overlapping-compat.h" -module Servant.ClientSpec where +module Servant.ClientSpec (spec) where -import Control.Arrow (left) -import Control.Concurrent (forkIO, killThread, ThreadId) -import Control.Exception (bracket) -import Control.Monad.Error.Class (throwError ) -import Data.Aeson -import qualified Data.ByteString.Lazy as BS -import Data.Char (chr, isPrint) -import Data.Foldable (forM_) -import Data.Monoid hiding (getLast) -import Data.Proxy -import qualified Generics.SOP as SOP -import GHC.Generics (Generic) -import qualified Network.HTTP.Client as C -import Network.HTTP.Media -import qualified Network.HTTP.Types as HTTP -import Network.Socket -import Network.Wai (Request, requestHeaders, responseLBS) -import Network.Wai.Handler.Warp -import Prelude () +import Prelude () import Prelude.Compat -import System.IO.Unsafe (unsafePerformIO) -import Test.HUnit + +import Control.Arrow (left) +import Control.Concurrent (ThreadId, forkIO, + killThread) +import Control.Exception (bracket) +import Control.Monad.Error.Class (throwError) +import Data.Aeson +import Data.Char (chr, isPrint) +import Data.Foldable (forM_) +import Data.Monoid hiding (getLast) +import Data.Proxy +import qualified Generics.SOP as SOP +import GHC.Generics (Generic) +import qualified Network.HTTP.Client as C +import qualified Network.HTTP.Types as HTTP +import Network.Socket +import qualified Network.Wai as Wai +import Network.Wai.Handler.Warp +import System.IO.Unsafe (unsafePerformIO) import Test.Hspec import Test.Hspec.QuickCheck +import Test.HUnit import Test.QuickCheck -import Web.FormUrlEncoded (FromForm, ToForm) +import Web.FormUrlEncoded (FromForm, ToForm) -import Servant.API +import Servant.API ((:<|>) ((:<|>)), + (:>), AuthProtect, + BasicAuth, + BasicAuthData (..), + Capture, + CaptureAll, Delete, + DeleteNoContent, + EmptyAPI, addHeader, + FormUrlEncoded, + Get, Header, + Headers, JSON, + NoContent (NoContent), + Post, Put, Raw, + QueryFlag, + QueryParam, + QueryParams, + ReqBody, + getHeaders) import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Client -import Servant.Client.Generic -import qualified Servant.Common.Req as SCR +import qualified Servant.Client.Core.Internal.Request as Req +import qualified Servant.Client.Core.Internal.Auth as Auth import Servant.Server import Servant.Server.Experimental.Auth @@ -75,17 +92,16 @@ spec = describe "Servant.Client" $ do -- * test data types -data Person = Person { - name :: String, - age :: Integer - } - deriving (Eq, Show, Generic) +data Person = Person + { _name :: String + , _age :: Integer + } deriving (Eq, Show, Generic) instance ToJSON Person instance FromJSON Person -instance ToForm Person where -instance FromForm Person where +instance ToForm Person +instance FromForm Person alice :: Person alice = Person "Alice" 42 @@ -116,22 +132,20 @@ type Api = api :: Proxy Api api = Proxy -getGet :: SCR.ClientM Person -getDeleteEmpty :: SCR.ClientM NoContent -getCapture :: String -> SCR.ClientM Person -getCaptureAll :: [String] -> SCR.ClientM [Person] -getBody :: Person -> SCR.ClientM Person -getQueryParam :: Maybe String -> SCR.ClientM Person -getQueryParams :: [String] -> SCR.ClientM [Person] -getQueryFlag :: Bool -> SCR.ClientM Bool -getRawSuccess :: HTTP.Method - -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString) -getRawFailure :: HTTP.Method - -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString) +getGet :: ClientM Person +getDeleteEmpty :: ClientM NoContent +getCapture :: String -> ClientM Person +getCaptureAll :: [String] -> ClientM [Person] +getBody :: Person -> ClientM Person +getQueryParam :: Maybe String -> ClientM Person +getQueryParams :: [String] -> ClientM [Person] +getQueryFlag :: Bool -> ClientM Bool +getRawSuccess :: HTTP.Method -> ClientM Response +getRawFailure :: HTTP.Method -> ClientM Response getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] - -> SCR.ClientM (String, Maybe Int, Bool, [(String, [Rational])]) -getRespHeaders :: SCR.ClientM (Headers TestHeaders Bool) -getDeleteContentType :: SCR.ClientM NoContent + -> ClientM (String, Maybe Int, Bool, [(String, [Rational])]) +getRespHeaders :: ClientM (Headers TestHeaders Bool) +getDeleteContentType :: ClientM NoContent getGet :<|> getDeleteEmpty @@ -161,8 +175,8 @@ server = serve api ( Nothing -> throwError $ ServantErr 400 "missing parameter" "" []) :<|> (\ names -> return (zipWith Person names [0..])) :<|> return - :<|> (Tagged $ \ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess") - :<|> (Tagged $ \ _request respond -> respond $ responseLBS HTTP.badRequest400 [] "rawFailure") + :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess") + :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure") :<|> (\ a b c d -> return (a, b, c, d)) :<|> (return $ addHeader 1729 $ addHeader "eg2" True) :<|> return NoContent @@ -178,9 +192,9 @@ failApi = Proxy failServer :: Application failServer = serve failApi ( - (Tagged $ \ _request respond -> respond $ responseLBS HTTP.ok200 [] "") - :<|> (\ _capture -> Tagged $ \_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "") - :<|> (Tagged $ \_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "") + (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "") + :<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "") + :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "") ) -- * basic auth stuff @@ -214,16 +228,16 @@ genAuthAPI :: Proxy GenAuthAPI genAuthAPI = Proxy type instance AuthServerData (AuthProtect "auth-tag") = () -type instance AuthClientData (AuthProtect "auth-tag") = () +type instance Auth.AuthClientData (AuthProtect "auth-tag") = () -genAuthHandler :: AuthHandler Request () +genAuthHandler :: AuthHandler Wai.Request () genAuthHandler = - let handler req = case lookup "AuthHeader" (requestHeaders req) of + let handler req = case lookup "AuthHeader" (Wai.requestHeaders req) of Nothing -> throwError (err401 { errBody = "Missing auth header" }) Just _ -> return () in mkAuthHandler handler -genAuthServerContext :: Context '[ AuthHandler Request () ] +genAuthServerContext :: Context '[ AuthHandler Wai.Request () ] genAuthServerContext = genAuthHandler :. EmptyContext genAuthServer :: Application @@ -236,11 +250,11 @@ type GenericClientAPI :<|> Capture "foo" String :> NestedAPI1 data GenericClient = GenericClient - { getSqr :: Maybe Int -> SCR.ClientM Int + { getSqr :: Maybe Int -> ClientM Int , mkNestedClient1 :: String -> NestedClient1 } deriving Generic instance SOP.Generic GenericClient -instance (Client GenericClientAPI ~ client) => ClientLike client GenericClient +instance (Client ClientM GenericClientAPI ~ client) => ClientLike client GenericClient type NestedAPI1 = QueryParam "int" Int :> NestedAPI2 @@ -248,21 +262,21 @@ type NestedAPI1 data NestedClient1 = NestedClient1 { mkNestedClient2 :: Maybe Int -> NestedClient2 - , idChar :: Maybe Char -> SCR.ClientM Char + , idChar :: Maybe Char -> ClientM Char } deriving Generic instance SOP.Generic NestedClient1 -instance (Client NestedAPI1 ~ client) => ClientLike client NestedClient1 +instance (Client ClientM NestedAPI1 ~ client) => ClientLike client NestedClient1 type NestedAPI2 = "sum" :> Capture "first" Int :> Capture "second" Int :> Get '[JSON] Int :<|> "void" :> Post '[JSON] () data NestedClient2 = NestedClient2 - { getSum :: Int -> Int -> SCR.ClientM Int - , doNothing :: SCR.ClientM () + { getSum :: Int -> Int -> ClientM Int + , doNothing :: ClientM () } deriving Generic instance SOP.Generic NestedClient2 -instance (Client NestedAPI2 ~ client) => ClientLike client NestedClient2 +instance (Client ClientM NestedAPI2 ~ client) => ClientLike client NestedClient2 genericClientServer :: Application genericClientServer = serve (Proxy :: Proxy GenericClientAPI) ( @@ -276,67 +290,70 @@ genericClientServer = serve (Proxy :: Proxy GenericClientAPI) ( nestedServer1 _str = nestedServer2 :<|> (maybe (throwError $ ServantErr 400 "missing parameter" "" []) return) nestedServer2 _int = (\ x y -> return (x + y)) :<|> return () -{-# NOINLINE manager #-} -manager :: C.Manager -manager = unsafePerformIO $ C.newManager C.defaultManagerSettings +{-# NOINLINE manager' #-} +manager' :: C.Manager +manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings + +runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a) +runClient x baseUrl' = runClientM x (ClientEnv manager' baseUrl') sucessSpec :: Spec sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do it "Servant.API.Get" $ \(_, baseUrl) -> do - (left show <$> (runClientM getGet (ClientEnv manager baseUrl))) `shouldReturn` Right alice + left show <$> runClient getGet baseUrl `shouldReturn` Right alice describe "Servant.API.Delete" $ do it "allows empty content type" $ \(_, baseUrl) -> do - (left show <$> (runClientM getDeleteEmpty (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent + left show <$> runClient getDeleteEmpty baseUrl `shouldReturn` Right NoContent it "allows content type" $ \(_, baseUrl) -> do - (left show <$> (runClientM getDeleteContentType (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent + left show <$> runClient getDeleteContentType baseUrl `shouldReturn` Right NoContent it "Servant.API.Capture" $ \(_, baseUrl) -> do - (left show <$> (runClientM (getCapture "Paula") (ClientEnv manager baseUrl))) `shouldReturn` Right (Person "Paula" 0) + left show <$> runClient (getCapture "Paula") baseUrl `shouldReturn` Right (Person "Paula" 0) it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do let expected = [(Person "Paula" 0), (Person "Peta" 1)] - (left show <$> (runClientM (getCaptureAll ["Paula", "Peta"]) (ClientEnv manager baseUrl))) `shouldReturn` Right expected + left show <$> runClient (getCaptureAll ["Paula", "Peta"]) baseUrl `shouldReturn` Right expected it "Servant.API.ReqBody" $ \(_, baseUrl) -> do let p = Person "Clara" 42 - (left show <$> runClientM (getBody p) (ClientEnv manager baseUrl)) `shouldReturn` Right p + left show <$> runClient (getBody p) baseUrl `shouldReturn` Right p it "Servant.API.QueryParam" $ \(_, baseUrl) -> do - left show <$> runClientM (getQueryParam (Just "alice")) (ClientEnv manager baseUrl) `shouldReturn` Right alice - Left FailureResponse{..} <- runClientM (getQueryParam (Just "bob")) (ClientEnv manager baseUrl) - responseStatus `shouldBe` HTTP.Status 400 "bob not found" + left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice + Left (FailureResponse r) <- runClient (getQueryParam (Just "bob")) baseUrl + responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found" it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do - (left show <$> runClientM (getQueryParams []) (ClientEnv manager baseUrl)) `shouldReturn` Right [] - (left show <$> runClientM (getQueryParams ["alice", "bob"]) (ClientEnv manager baseUrl)) + left show <$> runClient (getQueryParams []) baseUrl `shouldReturn` Right [] + left show <$> runClient (getQueryParams ["alice", "bob"]) baseUrl `shouldReturn` Right [Person "alice" 0, Person "bob" 1] context "Servant.API.QueryParam.QueryFlag" $ forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do - (left show <$> runClientM (getQueryFlag flag) (ClientEnv manager baseUrl)) `shouldReturn` Right flag + left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag it "Servant.API.Raw on success" $ \(_, baseUrl) -> do - res <- runClientM (getRawSuccess HTTP.methodGet) (ClientEnv manager baseUrl) + res <- runClient (getRawSuccess HTTP.methodGet) baseUrl case res of Left e -> assertFailure $ show e - Right (code, body, ct, _, response) -> do - (code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream") - C.responseBody response `shouldBe` body - C.responseStatus response `shouldBe` HTTP.ok200 + Right r -> do + responseStatusCode r `shouldBe` HTTP.status200 + responseBody r `shouldBe` "rawSuccess" it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do - res <- runClientM (getRawFailure HTTP.methodGet) (ClientEnv manager baseUrl) + res <- runClient (getRawFailure HTTP.methodGet) baseUrl case res of Right _ -> assertFailure "expected Left, but got Right" - Left e -> do - Servant.Client.responseStatus e `shouldBe` HTTP.status400 - Servant.Client.responseBody e `shouldBe` "rawFailure" + Left (FailureResponse r) -> do + responseStatusCode r `shouldBe` HTTP.status400 + responseBody r `shouldBe` "rawFailure" + Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e it "Returns headers appropriately" $ \(_, baseUrl) -> do - res <- runClientM getRespHeaders (ClientEnv manager baseUrl) + res <- runClient getRespHeaders baseUrl case res of Left e -> assertFailure $ show e Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] @@ -345,7 +362,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) -> property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> ioProperty $ do - result <- left show <$> runClientM (getMultiple cap num flag body) (ClientEnv manager baseUrl) + result <- left show <$> runClient (getMultiple cap num flag body) baseUrl return $ result === Right (cap, num, flag, body) @@ -357,10 +374,10 @@ wrappedApiSpec = describe "error status codes" $ do let test :: (WrappedApi, String) -> Spec test (WrappedApi api, desc) = it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do - let getResponse :: SCR.ClientM () + let getResponse :: ClientM () getResponse = client api - Left FailureResponse{..} <- runClientM getResponse (ClientEnv manager baseUrl) - responseStatus `shouldBe` (HTTP.Status 500 "error message") + Left (FailureResponse r) <- runClient getResponse baseUrl + responseStatusCode r `shouldBe` (HTTP.Status 500 "error message") in mapM_ test $ (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") : (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") : @@ -374,42 +391,42 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do context "client returns errors appropriately" $ do it "reports FailureResponse" $ \(_, baseUrl) -> do let (_ :<|> getDeleteEmpty :<|> _) = client api - Left res <- runClientM getDeleteEmpty (ClientEnv manager baseUrl) + Left res <- runClient getDeleteEmpty baseUrl case res of - FailureResponse _ (HTTP.Status 404 "Not Found") _ _ -> return () + FailureResponse r | responseStatusCode r == HTTP.status404 -> return () _ -> fail $ "expected 404 response, but got " <> show res it "reports DecodeFailure" $ \(_, baseUrl) -> do let (_ :<|> _ :<|> getCapture :<|> _) = client api - Left res <- runClientM (getCapture "foo") (ClientEnv manager baseUrl) + Left res <- runClient (getCapture "foo") baseUrl case res of - DecodeFailure _ ("application/json") _ -> return () + DecodeFailure _ _ -> return () _ -> fail $ "expected DecodeFailure, but got " <> show res it "reports ConnectionError" $ \_ -> do let (getGetWrongHost :<|> _) = client api - Left res <- runClientM getGetWrongHost (ClientEnv manager (BaseUrl Http "127.0.0.1" 19872 "")) + Left res <- runClient getGetWrongHost (BaseUrl Http "127.0.0.1" 19872 "") case res of ConnectionError _ -> return () _ -> fail $ "expected ConnectionError, but got " <> show res it "reports UnsupportedContentType" $ \(_, baseUrl) -> do let (getGet :<|> _ ) = client api - Left res <- runClientM getGet (ClientEnv manager baseUrl) + Left res <- runClient getGet baseUrl case res of UnsupportedContentType ("application/octet-stream") _ -> return () _ -> fail $ "expected UnsupportedContentType, but got " <> show res it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api - Left res <- runClientM (getBody alice) (ClientEnv manager baseUrl) + Left res <- runClient (getBody alice) baseUrl case res of - InvalidContentTypeHeader "fooooo" _ -> return () + InvalidContentTypeHeader _ -> return () _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res data WrappedApi where WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a, - HasClient api, Client api ~ SCR.ClientM ()) => + HasClient ClientM api, Client ClientM api ~ ClientM ()) => Proxy api -> WrappedApi basicAuthSpec :: Spec @@ -419,15 +436,15 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do let getBasic = client basicAuthAPI let basicAuthData = BasicAuthData "servant" "server" - (left show <$> runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)) `shouldReturn` Right alice + left show <$> runClient (getBasic basicAuthData) baseUrl `shouldReturn` Right alice context "Authentication is rejected when requests are not authenticated properly" $ do it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do let getBasic = client basicAuthAPI let basicAuthData = BasicAuthData "not" "password" - Left FailureResponse{..} <- runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl) - responseStatus `shouldBe` HTTP.Status 403 "Forbidden" + Left (FailureResponse r) <- runClient (getBasic basicAuthData) baseUrl + responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden" genAuthSpec :: Spec genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do @@ -435,16 +452,16 @@ genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do let getProtected = client genAuthAPI - let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req) - (left show <$> runClientM (getProtected authRequest) (ClientEnv manager baseUrl)) `shouldReturn` Right alice + let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "AuthHeader" ("cool" :: String) req) + left show <$> runClient (getProtected authRequest) baseUrl `shouldReturn` Right alice context "Authentication is rejected when requests are not authenticated properly" $ do it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do let getProtected = client genAuthAPI - let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req) - Left FailureResponse{..} <- runClientM (getProtected authRequest) (ClientEnv manager baseUrl) - responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized") + let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "Wrong" ("header" :: String) req) + Left (FailureResponse r) <- runClient (getProtected authRequest) baseUrl + responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized") genericClientSpec :: Spec genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWaiApp $ do @@ -454,13 +471,13 @@ genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWa NestedClient1{..} = mkNestedClient1 "example" NestedClient2{..} = mkNestedClient2 (Just 42) - it "works for top-level client function" $ \(_, baseUrl) -> do - (left show <$> (runClientM (getSqr (Just 5)) (ClientEnv manager baseUrl))) `shouldReturn` Right 25 + it "works for top-level client inClientM function" $ \(_, baseUrl) -> do + left show <$> runClient (getSqr (Just 5)) baseUrl `shouldReturn` Right 25 it "works for nested clients" $ \(_, baseUrl) -> do - (left show <$> (runClientM (idChar (Just 'c')) (ClientEnv manager baseUrl))) `shouldReturn` Right 'c' - (left show <$> (runClientM (getSum 3 4) (ClientEnv manager baseUrl))) `shouldReturn` Right 7 - (left show <$> (runClientM doNothing (ClientEnv manager baseUrl))) `shouldReturn` Right () + left show <$> runClient (idChar (Just 'c')) baseUrl `shouldReturn` Right 'c' + left show <$> runClient (getSum 3 4) baseUrl `shouldReturn` Right 7 + left show <$> runClient doNothing baseUrl `shouldReturn` Right () -- * utils diff --git a/stack-ghc-7.10.3.yaml b/stack-ghc-7.10.3.yaml index fb18aac7..e1f14b91 100644 --- a/stack-ghc-7.10.3.yaml +++ b/stack-ghc-7.10.3.yaml @@ -2,6 +2,7 @@ flags: {} packages: - servant/ - servant-client/ +- servant-client-core/ - servant-docs/ - servant-foreign/ - servant-server/ diff --git a/stack-ghc-7.8.4.yaml b/stack-ghc-7.8.4.yaml index 01bb6420..97049725 100644 --- a/stack-ghc-7.8.4.yaml +++ b/stack-ghc-7.8.4.yaml @@ -2,6 +2,7 @@ flags: {} packages: - servant/ - servant-client/ +- servant-client-core/ - servant-docs/ - servant-foreign/ - servant-server/ @@ -19,6 +20,7 @@ extra-deps: - hspec-expectations-0.8.2 - hspec-wai-0.8.0 - http-api-data-0.3.6 +- http-client-0.4.30 - natural-transformation-0.4 - primitive-0.6.1.0 - servant-js-0.9.3 diff --git a/stack-ghc-8.2.1.yaml b/stack-ghc-8.2.1.yaml index c1a64f37..926f72cf 100644 --- a/stack-ghc-8.2.1.yaml +++ b/stack-ghc-8.2.1.yaml @@ -1,6 +1,7 @@ resolver: nightly-2017-09-01 packages: - servant-client/ +- servant-client-core/ - servant-docs/ - servant-foreign/ - servant-server/ diff --git a/stack.yaml b/stack.yaml index 62ff4f2b..e283f7fd 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,6 +2,7 @@ resolver: nightly-2017-04-01 packages: - servant/ - servant-client/ +- servant-client-core/ - servant-docs/ - servant-foreign/ - servant-server/