servant-client-0.19/0000755000000000000000000000000007346545000012572 5ustar0000000000000000servant-client-0.19/CHANGELOG.md0000644000000000000000000003302107346545000014402 0ustar0000000000000000[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md) [Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions. 0.19 ---- ### Significant changes - Drop support for GHC < 8.6. - Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet). - Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)), which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864) related to hash collisions. - Add `NamedRoutes` combinator, making support for records first-class in Servant ([#1388](https://github.com/haskell-servant/servant/pull/1388)). - Add custom type errors for partially applied combinators ([#1289](https://github.com/haskell-servant/servant/pull/1289), [#1486](https://github.com/haskell-servant/servant/pull/1486)). - *servant-client* / *servant-client-core* / *servant-http-streams*: Fix erroneous behavior, where only 2XX status codes would be considered successful, irrelevant of the status parameter specified by the verb combinator. ([#1469](https://github.com/haskell-servant/servant/pull/1469)) - *servant-client* / *servant-client-core*: Fix `Show` instance for `Servant.Client.Core.Request`. - *servant-client* / *servant-client-core*: Allow passing arbitrary binary data in Query parameters. ([#1432](https://github.com/haskell-servant/servant/pull/1432)). ### Other changes - Various version bumps. 0.18.3 ------ ### Significant changes - Add response header support to UVerb (#1420) ### Other changes - Support GHC-9.0.1. - Bump `bytestring`, `hspec`, `http-client` and `QuickCheck` dependencies. 0.18.2 ------ ### Significant changes - Support `Fragment` combinator. 0.18.1 ------ ### Significant changes - Union verbs ### Other changes - Bump "tested-with" ghc versions 0.18 ---- ### Significant changes - Support for ghc8.8 (#1318, #1326, #1327) 0.17 ---- ### Significant changes - Add NoContentVerb [#1028](https://github.com/haskell-servant/servant/issues/1028) [#1219](https://github.com/haskell-servant/servant/pull/1219) [#1228](https://github.com/haskell-servant/servant/pull/1228) The `NoContent` API endpoints should now use `NoContentVerb` combinator. The API type changes are usually of the kind ```diff - :<|> PostNoContent '[JSON] NoContent + :<|> PostNoContent ``` i.e. one doesn't need to specify the content-type anymore. There is no content. - `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156) You can specify a lenient capture as ```haskell :<|> "capture-lenient" :> Capture' '[Lenient] "foo" Int :> GET ``` which will make the capture always succeed. Handlers will be of the type `Either String CapturedType`, where `Left err` represents the possible parse failure. - *servant-client* Added a function to create Client.Request in ClientEnv [#1213](https://github.com/haskell-servant/servant/pull/1213) [#1255](https://github.com/haskell-servant/servant/pull/1255) The new member `makeClientRequest` of `ClientEnv` is used to create `http-client` `Request` from `servant-client-core` `Request`. This functionality can be used for example to set dynamic timeouts for each request. ### Other changes - *servant-client* *servant-client-core* *servant-http-streams* Fix Verb with headers checking content type differently [#1200](https://github.com/haskell-servant/servant/issues/1200) [#1204](https://github.com/haskell-servant/servant/pull/1204) For `Verb`s with response `Headers`, the implementation didn't check for the content-type of the response. Now it does. - *servant-client* *servant-http-streams* `HasClient` instance for `Stream` with `Headers` [#1170](https://github.com/haskell-servant/servant/issues/1170) [#1197](https://github.com/haskell-servant/servant/pull/1197) - *servant-client* Redact the authorization header in Show and exceptions [#1238](https://github.com/haskell-servant/servant/pull/1238) 0.16.0.1 -------- - Allow `base-compat-0.11` 0.16 ---- - Rename `ServantError` to `ClientError`, `ServantErr` to `ServerError` [#1131](https://github.com/haskell-servant/servant/pull/1131) - *servant-client-core* Rearrange modules. No more `Internal` modules, whole API is versioned. [#1130](https://github.com/haskell-servant/servant/pull/1130) - *servant-client-core* `RequestBody` is now ```haskell = RequestBodyLBS LBS.ByteString | RequestBodyBS BS.ByteString | RequestBodySource (SourceIO LBS.ByteString) ``` i.e. no more replicates `http-client`s API. [#1117](https://github.com/haskell-servant/servant/pull/1117) - *servant-client-core* Keep structured exceptions in `ConnectionError` constructor of `ClientError` [#1115](https://github.com/haskell-servant/servant/pull/1115) ```diff -| ConnectionError Text +| ConnectionError SomeException ``` - *servant-client-core* Preserve failing request in `FailureResponse` constructor of `ClientError` [#1114](https://github.com/haskell-servant/servant/pull/1114) ```diff -FailureResponse Response +-- | The server returned an error response including the +-- failing request. 'requestPath' includes the 'BaseUrl' and the +-- path of the request. +FailureResponse (RequestF () (BaseUrl, BS.ByteString)) Response ``` - *servant-client* Fix (implement) `StreamBody` instance [#1110](https://github.com/haskell-servant/servant/pull/1110) - *servant-client* Update CookieJar with intermediate request/responses (redirects) [#1104](https://github.com/haskell-servant/servant/pull/1104) 0.15 ---- - Streaming refactoring. [#991](https://github.com/haskell-servant/servant/pull/991) [#1076](https://github.com/haskell-servant/servant/pull/1076) [#1077](https://github.com/haskell-servant/servant/pull/1077) The streaming functionality (`Servant.API.Stream`) is refactored to use `servant`'s own `SourceIO` type (see `Servant.Types.SourceT` documentation), which replaces both `StreamGenerator` and `ResultStream` types. New conversion type-classes are `ToSourceIO` and `FromSourceIO` (replacing `ToStreamGenerator` and `BuildFromStream`). There are instances for *conduit*, *pipes* and *machines* in new packages: [servant-conduit](https://hackage.haskell.org/package/servant-conduit) [servant-pipes](https://hackage.haskell.org/package/servant-pipes) and [servant-machines](https://hackage.haskell.org/package/servant-machines) respectively. Writing new framing strategies is simpler. Check existing strategies for examples. This change shouldn't affect you, if you don't use streaming endpoints. - *servant-client* Separate streaming client. [#1066](https://github.com/haskell-servant/servant/pull/1066) We now have two `http-client` based clients, in `Servant.Client` and `Servant.Client.Streaming`. Their API is the same, except for - `Servant.Client` **cannot** request `Stream` endpoints. - `Servant.Client` is *run* by direct `runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)` - `Servant.Client.Streaming` **can** request `Stream` endpoints. - `Servant.Client.Streaming` is *used* by CPSised `withClientM :: ClientM a -> ClientEnv -> (Either ServantError a -> IO b) -> IO b` To access `Stream` endpoints use `Servant.Client.Streaming` with `withClientM`; otherwise you can continue using `Servant.Client` with `runClientM`. You can use both too, `ClientEnv` and `BaseUrl` types are same for both. **Note:** `Servant.Client.Streaming` doesn't *stream* non-`Stream` endpoints. Requesting ordinary `Verb` endpoints (e.g. `Get`) will block until the whole response is received. There is `Servant.Client.Streaming.runClientM` function, but it has restricted type. `NFData a` constraint prevents using it with `SourceT`, `Conduit` etc. response types. ```haskell runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ServantError a) ``` This change shouldn't affect you, if you don't use streaming endpoints. - Drop support for GHC older than 8.0 [#1008](https://github.com/haskell-servant/servant/pull/1008) [#1009](https://github.com/haskell-servant/servant/pull/1009) - *servant-client-core* Add `NFData (GenResponse a)` and `NFData ServantError` instances. [#1076](https://github.com/haskell-servant/servant/pull/1076) *servant-client-core* Add `aeson` and `Lift BaseUrl` instances [#1037](https://github.com/haskell-servant/servant/pull/1037) 0.14 ---- - `Stream` takes a status code argument ```diff -Stream method framing ctype a +Stream method status framing ctype a ``` ([#966](https://github.com/haskell-servant/servant/pull/966) [#972](https://github.com/haskell-servant/servant/pull/972)) - `ToStreamGenerator` definition changed, so it's possible to write an instance for conduits. ```diff -class ToStreamGenerator f a where - toStreamGenerator :: f a -> StreamGenerator a +class ToStreamGenerator a b | a -> b where + toStreamGenerator :: a -> StreamGenerator b ``` ([#959](https://github.com/haskell-servant/servant/pull/959)) - Added `NoFraming` streaming strategy ([#959](https://github.com/haskell-servant/servant/pull/959)) - *servant-client-core* Add `hoistClient` to `HasClient`. Just like `hoistServer` allows us to change the monad in which request handlers of a web application live, we also have `hoistClient` for changing the monad in which *client functions* live. Read [tutorial section for more information](https://docs.servant.dev/en/release-0.14/tutorial/Client.html#changing-the-monad-the-client-functions-live-in). ([#936](https://github.com/haskell-servant/servant/pull/936)) - *servant-client* Add more constructors to `RequestBody`, including `RequestBodyStream`. *Note:* we are looking for http-library agnostic API, so the might change again soon. Tell us which constructors are useful for you! ([#913](https://github.com/haskell-servant/servant/pull/913)) 0.13.0.1 -------- - Support `base-compat-0.10` 0.13 ---- - Streaming endpoint support. ([#836](https://github.com/haskell-servant/servant/pull/836)) - *servant* Add `Servant.API.Modifiers` ([#873](https://github.com/haskell-servant/servant/pull/873)) - *servant-client* Support `http-client`’s `CookieJar` ([#897](https://github.com/haskell-servant/servant/pull/897) [#883](https://github.com/haskell-servant/servant/pull/883)) 0.12.0.1 -------- - Send `Accept` header. ([#858](https://github.com/haskell-servant/servant/issues/858)) 0.12 ---- - Factored out into `servant-client-core` all the functionality that was independent of the `http-client` backend. 0.11 ---- ### Other changes - Path components are escaped ([#696](https://github.com/haskell-servant/servant/pull/696)) - `Req` `reqPath` field changed from `String` to `BS.Builder` ([#696](https://github.com/haskell-servant/servant/pull/696)) - Include `Req` in failure errors ([#740](https://github.com/haskell-servant/servant/pull/740)) 0.10 ----- ### Breaking changes There shouldn't be breaking changes. Released as a part of `servant` suite. ### Other changes * Add MonadBase and MonadBaseControl instances for ClientM ([#663](https://github.com/haskell-servant/servant/issues/663)) * client asks for any content-type in Accept contentTypes non-empty list ([#615](https://github.com/haskell-servant/servant/pull/615)) * Add `ClientLike` class that matches client functions generated using `client` with client data structure. ([#640](https://github.com/haskell-servant/servant/pull/640)) * Allow direct use of 'RequestBody' ([#661](https://github.com/haskell-servant/servant/pull/661)) 0.9.1.1 ------- * Add MonadThrow and MonadCatch instances for ClientM 0.9 --- * BACKWARDS INCOMPATIBLE: `client` now returns a ClientM which is a Reader for BasicEnv. BasicEnv comprises the HttpManager and BaseUrl that have had to be passed to each method returned by `client`. 0.7.1 ----- * Support GHC 8.0 * `ServantError` has an `Eq` instance now. 0.6 --- * `client` no longer takes `BaseUrl` and `Manager` arguments. Instead, each function returned by `client` requires these two arguments. 0.5 --- * Use the `text` package instead of `String`. * Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators * Added support for `path` on `BaseUrl`. * `client` now takes an explicit `Manager` argument. * Use `http-api-data` instead of `Servant.Common.Text` * Client functions now consider any 2xx successful. * Remove matrix params. * Added support for Basic authentication * Add generalized authentication support via the `AuthClientData` type family and `AuthenticateReq` data type 0.4.1 ----- * The `HasClient` instance for `Delete cts ()` now does not care at all about content types provided. 0.4 --- * `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body * Support content-type aware combinators and `Accept`/`Content-type` headers * Added a lot of tests * Support multiple concurrent threads * Use `ServantError` to report Errors instead of `String` * Make the clients for `Raw` endpoints return the whole `Response` value (to be able to access response headers for example) * Support for PATCH * Make () instances expect No Content status code, and not try to decode body. * Add support for response headers 0.2.2 ----- * Add TLS support * Add matrix parameter support servant-client-0.19/LICENSE0000644000000000000000000000307307346545000013602 0ustar0000000000000000Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, 2016-2018 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 Zalora South East Asia Pte Ltd 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. servant-client-0.19/README.lhs0000644000000000000000000000211207346545000014233 0ustar0000000000000000# servant-client ![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png) This library lets you automatically derive Haskell functions that let you query each endpoint of a *servant* webservice. ## Example ``` haskell {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} import Data.Proxy import Data.Text import Network.HTTP.Client (newManager, defaultManagerSettings) import Servant.API import Servant.Client type Book = Text type MyApi = "books" :> Get '[JSON] [Book] -- GET /books :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books myApi :: Proxy MyApi myApi = Proxy -- 'client' allows you to produce operations to query an API from a client. postNewBook :: Book -> ClientM Book getAllBooks :: ClientM [Book] (getAllBooks :<|> postNewBook) = client myApi main :: IO () main = do manager' <- newManager defaultManagerSettings res <- runClientM getAllBooks (mkClientEnv manager' (BaseUrl Http "localhost" 8081 "")) case res of Left err -> putStrLn $ "Error: " ++ show err Right books -> print books ``` servant-client-0.19/README.md0000644000000000000000000000211207346545000014045 0ustar0000000000000000# servant-client ![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png) This library lets you automatically derive Haskell functions that let you query each endpoint of a *servant* webservice. ## Example ``` haskell {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} import Data.Proxy import Data.Text import Network.HTTP.Client (newManager, defaultManagerSettings) import Servant.API import Servant.Client type Book = Text type MyApi = "books" :> Get '[JSON] [Book] -- GET /books :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books myApi :: Proxy MyApi myApi = Proxy -- 'client' allows you to produce operations to query an API from a client. postNewBook :: Book -> ClientM Book getAllBooks :: ClientM [Book] (getAllBooks :<|> postNewBook) = client myApi main :: IO () main = do manager' <- newManager defaultManagerSettings res <- runClientM getAllBooks (mkClientEnv manager' (BaseUrl Http "localhost" 8081 "")) case res of Left err -> putStrLn $ "Error: " ++ show err Right books -> print books ``` servant-client-0.19/Setup.hs0000644000000000000000000000007007346545000014223 0ustar0000000000000000import Distribution.Simple main = defaultMain servant-client-0.19/servant-client.cabal0000644000000000000000000001120107346545000016507 0ustar0000000000000000cabal-version: 2.2 name: servant-client version: 0.19 synopsis: Automatic derivation of querying functions for servant category: Servant, Web description: This library lets you derive automatically Haskell functions that let you query each endpoint of a webservice. . See . . homepage: http://docs.servant.dev/ bug-reports: http://github.com/haskell-servant/servant/issues license: BSD-3-Clause license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors build-type: Simple tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1 , GHCJS ==8.6.0.1 extra-source-files: CHANGELOG.md README.md source-repository head type: git location: http://github.com/haskell-servant/servant.git library exposed-modules: Servant.Client Servant.Client.Streaming Servant.Client.Internal.HttpClient Servant.Client.Internal.HttpClient.Streaming -- Bundled with GHC: Lower bound to not force re-installs -- text and mtl are bundled starting with GHC-8.4 build-depends: base >= 4.9 && < 4.16 , bytestring >= 0.10.8.1 && < 0.12 , containers >= 0.5.7.1 && < 0.7 , deepseq >= 1.4.2.0 && < 1.5 , mtl >= 2.2.2 && < 2.3 , stm >= 2.4.5.1 && < 2.6 , text >= 1.2.3.0 && < 1.3 , time >= 1.6.0.1 && < 1.10 , transformers >= 0.5.2.0 && < 0.6 if !impl(ghc >= 8.2) build-depends: bifunctors >= 5.5.3 && < 5.6 -- Servant dependencies. -- Strict dependency on `servant-client-core` as we re-export things. build-depends: servant >= 0.18 && < 0.20 , servant-client-core >= 0.19 && < 0.19.1 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. build-depends: base-compat >= 0.10.5 && < 0.12 , http-client >= 0.5.13.1 && < 0.8 , http-media >= 0.7.1.3 && < 0.9 , http-types >= 0.12.2 && < 0.13 , exceptions >= 0.10.0 && < 0.11 , kan-extensions >= 5.2 && < 5.3 , monad-control >= 1.0.2.3 && < 1.1 , semigroupoids >= 5.3.1 && < 5.4 , transformers-base >= 0.4.5.2 && < 0.5 , transformers-compat >= 0.6.2 && < 0.8 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall -Wno-redundant-constraints test-suite spec type: exitcode-stdio-1.0 ghc-options: -Wall -rtsopts -threaded "-with-rtsopts=-T -N2" default-language: Haskell2010 if impl(ghcjs) buildable: False hs-source-dirs: test main-is: Spec.hs other-modules: Servant.BasicAuthSpec Servant.BrokenSpec Servant.ClientTestUtils Servant.ConnectionErrorSpec Servant.FailSpec Servant.GenAuthSpec Servant.GenericSpec Servant.HoistClientSpec Servant.StreamSpec Servant.SuccessSpec Servant.WrappedApiSpec -- Dependencies inherited from the library. No need to specify bounds. build-depends: base , aeson , base-compat , bytestring , http-api-data , http-client , http-types , mtl , kan-extensions , servant-client , servant-client-core , sop-core , stm , text , transformers , transformers-compat , wai , warp -- Additional dependencies build-depends: entropy >= 0.4.1.3 && < 0.5 , hspec >= 2.6.0 && < 2.9 , HUnit >= 1.6.0.0 && < 1.7 , network >= 2.8.0.0 && < 3.2 , QuickCheck >= 2.12.6.1 && < 2.15 , servant == 0.19.* , servant-server == 0.19.* , tdigest >= 0.2 && < 0.3 build-tool-depends: hspec-discover:hspec-discover >= 2.6.0 && < 2.9 test-suite readme type: exitcode-stdio-1.0 main-is: README.lhs build-depends: base, servant, http-client, text, servant-client, markdown-unlit build-tool-depends: markdown-unlit:markdown-unlit ghc-options: -pgmL markdown-unlit default-language: Haskell2010 if impl(ghcjs) buildable: False servant-client-0.19/src/Servant/0000755000000000000000000000000007346545000015003 5ustar0000000000000000servant-client-0.19/src/Servant/Client.hs0000644000000000000000000000067307346545000016563 0ustar0000000000000000 -- | This module provides 'client' which can automatically generate -- querying functions for each endpoint just from the type representing your -- API. module Servant.Client ( client , ClientM , runClientM , ClientEnv(..) , mkClientEnv , defaultMakeClientRequest , hoistClient , module Servant.Client.Core.Reexport ) where import Servant.Client.Core.Reexport import Servant.Client.Internal.HttpClient servant-client-0.19/src/Servant/Client/Internal/0000755000000000000000000000000007346545000017775 5ustar0000000000000000servant-client-0.19/src/Servant/Client/Internal/HttpClient.hs0000644000000000000000000002775107346545000022423 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} module Servant.Client.Internal.HttpClient where import Prelude () import Prelude.Compat import Control.Concurrent.MVar (modifyMVar, newMVar) import Control.Concurrent.STM.TVar import Control.Exception (SomeException (..), catch) import Control.Monad (unless) import Control.Monad.Base (MonadBase (..)) import Control.Monad.Catch (MonadCatch, MonadThrow) import Control.Monad.Error.Class (MonadError (..)) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT) import Control.Monad.STM (STM, atomically) import Control.Monad.Trans.Control (MonadBaseControl (..)) import Control.Monad.Trans.Except (ExceptT, runExceptT) import Data.Bifunctor (bimap) import qualified Data.ByteString as BS import Data.ByteString.Builder (toLazyByteString) import qualified Data.ByteString.Lazy as BSL import Data.Either (either) import Data.Foldable (foldl',toList) import Data.Functor.Alt (Alt (..)) import Data.Maybe (maybe, maybeToList) import Data.Proxy (Proxy (..)) import Data.Sequence (fromList) import Data.String (fromString) import Data.Time.Clock (UTCTime, getCurrentTime) import GHC.Generics import Network.HTTP.Media (renderHeader) import Network.HTTP.Types (hContentType, renderQuery, statusIsSuccessful, urlEncode, Status) import Servant.Client.Core import qualified Network.HTTP.Client as Client import qualified Servant.Types.SourceT as S -- | The environment in which a request is run. -- The 'baseUrl' and 'makeClientRequest' function are used to create a @http-client@ request. -- Cookies are then added to that request if a 'CookieJar' is set on the environment. -- Finally the request is executed with the 'manager'. -- The 'makeClientRequest' function can be used to modify the request to execute and set values which -- are not specified on a @servant@ 'Request' like 'responseTimeout' or 'redirectCount' data ClientEnv = ClientEnv { manager :: Client.Manager , baseUrl :: BaseUrl , cookieJar :: Maybe (TVar Client.CookieJar) , makeClientRequest :: BaseUrl -> Request -> Client.Request -- ^ this function can be used to customize the creation of @http-client@ requests from @servant@ requests. Default value: 'defaultMakeClientRequest' -- Note that: -- 1. 'makeClientRequest' exists to allow overriding operational semantics e.g. 'responseTimeout' per request, -- If you need global modifications, you should use 'managerModifyRequest' -- 2. the 'cookieJar', if defined, is being applied after 'makeClientRequest' is called. } -- | 'ClientEnv' smart constructor. mkClientEnv :: Client.Manager -> BaseUrl -> ClientEnv mkClientEnv mgr burl = ClientEnv mgr burl Nothing defaultMakeClientRequest -- | 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) -- | Change the monad the client functions live in, by -- supplying a conversion function -- (a natural transformation to be precise). -- -- For example, assuming you have some @manager :: 'Manager'@ and -- @baseurl :: 'BaseUrl'@ around: -- -- > type API = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int -- > api :: Proxy API -- > api = Proxy -- > getInt :: IO Int -- > postInt :: Int -> IO Int -- > getInt :<|> postInt = hoistClient api (flip runClientM cenv) (client api) -- > where cenv = mkClientEnv manager baseurl hoistClient :: HasClient ClientM api => Proxy api -> (forall a. m a -> n a) -> Client m api -> Client n api hoistClient = hoistClientMonad (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 { unClientM :: ReaderT ClientEnv (ExceptT ClientError IO) a } deriving ( Functor, Applicative, Monad, MonadIO, Generic , MonadReader ClientEnv, MonadError ClientError, MonadThrow , MonadCatch) instance MonadBase IO ClientM where liftBase = ClientM . liftBase instance MonadBaseControl IO ClientM where type StM ClientM a = Either ClientError a liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . unClientM))) 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 runRequestAcceptStatus = performRequest throwClientError = throwError runClientM :: ClientM a -> ClientEnv -> IO (Either ClientError a) runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm performRequest :: Maybe [Status] -> Request -> ClientM Response performRequest acceptStatus req = do ClientEnv m burl cookieJar' createClientRequest <- ask let clientRequest = createClientRequest burl req request <- case cookieJar' of Nothing -> pure clientRequest Just cj -> liftIO $ do now <- getCurrentTime atomically $ do oldCookieJar <- readTVar cj let (newRequest, newCookieJar) = Client.insertCookiesIntoRequest clientRequest oldCookieJar now writeTVar cj newCookieJar pure newRequest response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar' let status = Client.responseStatus response ourResponse = clientResponseToResponse id response goodStatus = case acceptStatus of Nothing -> statusIsSuccessful status Just good -> status `elem` good unless goodStatus $ do throwError $ mkFailureResponse burl req ourResponse return ourResponse where requestWithoutCookieJar :: Client.Manager -> Client.Request -> ClientM (Client.Response BSL.ByteString) requestWithoutCookieJar m' request' = do eResponse <- liftIO . catchConnectionError $ Client.httpLbs request' m' either throwError return eResponse requestWithCookieJar :: Client.Manager -> Client.Request -> TVar Client.CookieJar -> ClientM (Client.Response BSL.ByteString) requestWithCookieJar m' request' cj = do eResponse <- liftIO . catchConnectionError . Client.withResponseHistory request' m' $ updateWithResponseCookies cj either throwError return eResponse updateWithResponseCookies :: TVar Client.CookieJar -> Client.HistoriedResponse Client.BodyReader -> IO (Client.Response BSL.ByteString) updateWithResponseCookies cj responses = do now <- getCurrentTime bss <- Client.brConsume $ Client.responseBody fRes let fRes' = fRes { Client.responseBody = BSL.fromChunks bss } allResponses = Client.hrRedirects responses <> [(fReq, fRes')] atomically $ mapM_ (updateCookieJar now) allResponses return fRes' where updateCookieJar :: UTCTime -> (Client.Request, Client.Response BSL.ByteString) -> STM () updateCookieJar now' (req', res') = modifyTVar' cj (fst . Client.updateCookieJar res' req' now') fReq = Client.hrFinalRequest responses fRes = Client.hrFinalResponse responses mkFailureResponse :: BaseUrl -> Request -> ResponseF BSL.ByteString -> ClientError mkFailureResponse burl request = FailureResponse (bimap (const ()) f request) where f b = (burl, BSL.toStrict $ toLazyByteString b) clientResponseToResponse :: (a -> b) -> Client.Response a -> ResponseF b clientResponseToResponse f r = Response { responseStatusCode = Client.responseStatus r , responseBody = f (Client.responseBody r) , responseHeaders = fromList $ Client.responseHeaders r , responseHttpVersion = Client.responseVersion r } -- | Create a @http-client@ 'Client.Request' from a @servant@ 'Request' -- The 'Client.host', 'Client.path' and 'Client.port' fields are extracted from the 'BaseUrl' -- otherwise the body, headers and query string are derived from the @servant@ 'Request' defaultMakeClientRequest :: BaseUrl -> Request -> Client.Request defaultMakeClientRequest 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 = buildQueryString . toList $ requestQueryString r , Client.requestHeaders = maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers , Client.requestBody = body , Client.secure = isSecure } where -- Content-Type and Accept are specified by requestBody and requestAccept headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $ toList $requestHeaders r acceptHdr | null hs = Nothing | otherwise = Just ("Accept", renderHeader hs) where hs = toList $ requestAccept r convertBody bd = case bd of RequestBodyLBS body' -> Client.RequestBodyLBS body' RequestBodyBS body' -> Client.RequestBodyBS body' RequestBodySource sourceIO -> Client.RequestBodyStreamChunked givesPopper where givesPopper :: (IO BS.ByteString -> IO ()) -> IO () givesPopper needsPopper = S.unSourceT sourceIO $ \step0 -> do ref <- newMVar step0 -- Note sure we need locking, but it's feels safer. let popper :: IO BS.ByteString popper = modifyMVar ref nextBs needsPopper popper nextBs S.Stop = return (S.Stop, BS.empty) nextBs (S.Error err) = fail err nextBs (S.Skip s) = nextBs s nextBs (S.Effect ms) = ms >>= nextBs nextBs (S.Yield lbs s) = case BSL.toChunks lbs of [] -> nextBs s (x:xs) | BS.null x -> nextBs step' | otherwise -> return (step', x) where step' = S.Yield (BSL.fromChunks xs) s (body, contentTypeHdr) = case requestBody r of Nothing -> (Client.RequestBodyBS "", Nothing) Just (body', typ) -> (convertBody body', Just (hContentType, renderHeader typ)) isSecure = case baseUrlScheme burl of Http -> False Https -> True -- Query string builder which does not do any encoding buildQueryString = ("?" <>) . foldl' addQueryParam mempty addQueryParam qs (k, v) = qs <> (if BS.null qs then mempty else "&") <> urlEncode True k <> foldMap ("=" <>) v catchConnectionError :: IO a -> IO (Either ClientError a) catchConnectionError action = catch (Right <$> action) $ \e -> pure . Left . ConnectionError $ SomeException (e :: Client.HttpException) servant-client-0.19/src/Servant/Client/Internal/HttpClient/0000755000000000000000000000000007346545000022053 5ustar0000000000000000servant-client-0.19/src/Servant/Client/Internal/HttpClient/Streaming.hs0000644000000000000000000001555207346545000024350 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} module Servant.Client.Internal.HttpClient.Streaming ( module Servant.Client.Internal.HttpClient.Streaming, ClientEnv (..), mkClientEnv, clientResponseToResponse, defaultMakeClientRequest, catchConnectionError, ) where import Prelude () import Prelude.Compat import Control.Concurrent.STM.TVar import Control.DeepSeq (NFData, force) import Control.Exception (evaluate, throwIO) import Control.Monad () import Control.Monad.Base (MonadBase (..)) import Control.Monad.Codensity (Codensity (..)) import Control.Monad.Error.Class (MonadError (..)) import Control.Monad.Reader import Control.Monad.STM (atomically) import Control.Monad.Trans.Except import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import Data.Foldable (for_) import Data.Functor.Alt (Alt (..)) import Data.Proxy (Proxy (..)) import Data.Time.Clock (getCurrentTime) import GHC.Generics import Network.HTTP.Types (Status, statusIsSuccessful) import qualified Network.HTTP.Client as Client import Servant.Client.Core import Servant.Client.Internal.HttpClient (ClientEnv (..), catchConnectionError, clientResponseToResponse, mkClientEnv, mkFailureResponse, defaultMakeClientRequest) import qualified Servant.Types.SourceT as S -- | 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) -- | Change the monad the client functions live in, by -- supplying a conversion function -- (a natural transformation to be precise). -- -- For example, assuming you have some @manager :: 'Manager'@ and -- @baseurl :: 'BaseUrl'@ around: -- -- > type API = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int -- > api :: Proxy API -- > api = Proxy -- > getInt :: IO Int -- > postInt :: Int -> IO Int -- > getInt :<|> postInt = hoistClient api (flip runClientM cenv) (client api) -- > where cenv = mkClientEnv manager baseurl hoistClient :: HasClient ClientM api => Proxy api -> (forall a. m a -> n a) -> Client m api -> Client n api hoistClient = hoistClientMonad (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 { unClientM :: ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a } deriving ( Functor, Applicative, Monad, MonadIO, Generic , MonadReader ClientEnv, MonadError ClientError) instance MonadBase IO ClientM where liftBase = ClientM . liftIO -- | Try clients in order, last error is preserved. instance Alt ClientM where a b = a `catchError` \_ -> b instance RunClient ClientM where runRequestAcceptStatus = performRequest throwClientError = throwError instance RunStreamingClient ClientM where withStreamingRequest = performWithStreamingRequest withClientM :: ClientM a -> ClientEnv -> (Either ClientError a -> IO b) -> IO b withClientM cm env k = let Codensity f = runExceptT $ flip runReaderT env $ unClientM cm in f k -- | A 'runClientM' variant for streaming client. -- -- It allows using this module's 'ClientM' in a direct style. -- The 'NFData' constraint however prevents using this function with genuine -- streaming response types ('SourceT', 'Conduit', pipes 'Proxy' or 'Machine'). -- For those you have to use 'withClientM'. -- -- /Note:/ we 'force' the result, so the likelihood of accidentally leaking a -- connection is smaller. Use with care. -- runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ClientError a) runClientM cm env = withClientM cm env (evaluate . force) performRequest :: Maybe [Status] -> Request -> ClientM Response performRequest acceptStatus req = do -- TODO: should use Client.withResponse here too ClientEnv m burl cookieJar' createClientRequest <- ask let clientRequest = createClientRequest burl req request <- case cookieJar' of Nothing -> pure clientRequest Just cj -> liftIO $ do now <- getCurrentTime atomically $ do oldCookieJar <- readTVar cj let (newRequest, newCookieJar) = Client.insertCookiesIntoRequest clientRequest oldCookieJar now writeTVar cj newCookieJar pure newRequest eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m case eResponse of Left err -> throwError err Right response -> do for_ cookieJar' $ \cj -> liftIO $ do now' <- getCurrentTime atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now') let status = Client.responseStatus response ourResponse = clientResponseToResponse id response goodStatus = case acceptStatus of Nothing -> statusIsSuccessful status Just good -> status `elem` good unless goodStatus $ do throwError $ mkFailureResponse burl req ourResponse return ourResponse -- | TODO: support UVerb ('acceptStatus' argument, like in 'performRequest' above). performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a performWithStreamingRequest req k = do m <- asks manager burl <- asks baseUrl createClientRequest <- asks makeClientRequest let request = createClientRequest burl req ClientM $ lift $ lift $ Codensity $ \k1 -> Client.withResponse request m $ \res -> do let status = Client.responseStatus res -- we throw FailureResponse in IO :( unless (statusIsSuccessful status) $ do b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res) throwIO $ mkFailureResponse burl req (clientResponseToResponse (const b) res) x <- k (clientResponseToResponse (S.fromAction BS.null) res) k1 x servant-client-0.19/src/Servant/Client/0000755000000000000000000000000007346545000016221 5ustar0000000000000000servant-client-0.19/src/Servant/Client/Streaming.hs0000644000000000000000000000104207346545000020503 0ustar0000000000000000-- | This module provides 'client' which can automatically generate -- querying functions for each endpoint just from the type representing your -- API. -- -- This client supports streaming operations. module Servant.Client.Streaming ( client , ClientM , withClientM , runClientM , ClientEnv(..) , mkClientEnv , defaultMakeClientRequest , hoistClient , module Servant.Client.Core.Reexport ) where import Servant.Client.Core.Reexport import Servant.Client.Internal.HttpClient.Streaming servant-client-0.19/test/Servant/0000755000000000000000000000000007346545000015173 5ustar0000000000000000servant-client-0.19/test/Servant/BasicAuthSpec.hs0000644000000000000000000000375407346545000020216 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -freduction-depth=100 #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} module Servant.BasicAuthSpec (spec) where import Prelude () import Prelude.Compat import Control.Arrow (left) import Data.Monoid () import qualified Network.HTTP.Types as HTTP import Test.Hspec import Servant.API (BasicAuthData (..)) import Servant.Client import Servant.ClientTestUtils spec :: Spec spec = describe "Servant.BasicAuthSpec" $ do basicAuthSpec basicAuthSpec :: Spec basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ do context "Authentication works when requests are properly authenticated" $ do it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do let getBasic = client basicAuthAPI let basicAuthData = BasicAuthData "servant" "server" 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 _ r) <- runClient (getBasic basicAuthData) baseUrl responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden" servant-client-0.19/test/Servant/BrokenSpec.hs0000644000000000000000000000441507346545000017566 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -freduction-depth=100 #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} module Servant.BrokenSpec (spec) where import Prelude () import Prelude.Compat import Data.Monoid () import Data.Proxy import qualified Network.HTTP.Types as HTTP import Test.Hspec import Servant.API ((:<|>) ((:<|>)), (:>), JSON, Verb, Get, StdMethod (GET)) import Servant.Client import Servant.ClientTestUtils import Servant.Server -- * api for testing inconsistencies between client and server type Get201 = Verb 'GET 201 type Get301 = Verb 'GET 301 type BrokenAPI = -- the server should respond with 200, but returns 201 "get200" :> Get201 '[JSON] () -- the server should respond with 307, but returns 301 :<|> "get307" :> Get301 '[JSON] () brokenApi :: Proxy BrokenAPI brokenApi = Proxy brokenServer :: Application brokenServer = serve brokenApi (pure () :<|> pure ()) type PublicAPI = -- the client expects 200 "get200" :> Get '[JSON] () -- the client expects 307 :<|> "get307" :> Get307 '[JSON] () publicApi :: Proxy PublicAPI publicApi = Proxy get200Client :: ClientM () get307Client :: ClientM () get200Client :<|> get307Client = client publicApi spec :: Spec spec = describe "Servant.BrokenSpec" $ do brokenSpec brokenSpec :: Spec brokenSpec = beforeAll (startWaiApp brokenServer) $ afterAll endWaiApp $ do context "client returns errors for inconsistencies between client and server api" $ do it "reports FailureResponse with wrong 2xx status code" $ \(_, baseUrl) -> do res <- runClient get200Client baseUrl case res of Left (FailureResponse _ r) | responseStatusCode r == HTTP.status201 -> return () _ -> fail $ "expected 201 broken response, but got " <> show res it "reports FailureResponse with wrong 3xx status code" $ \(_, baseUrl) -> do res <- runClient get307Client baseUrl case res of Left (FailureResponse _ r) | responseStatusCode r == HTTP.status301 -> return () _ -> fail $ "expected 301 broken response, but got " <> show res servant-client-0.19/test/Servant/ClientTestUtils.hs0000644000000000000000000003324707346545000020637 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -freduction-depth=100 #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} module Servant.ClientTestUtils where import Prelude () import Prelude.Compat import Control.Concurrent (ThreadId, forkIO, killThread) import Control.Monad (join) import Control.Monad.Error.Class (throwError) import Data.Aeson import Data.ByteString (ByteString) import Data.ByteString.Builder (byteString) import qualified Data.ByteString.Lazy as LazyByteString import Data.Char (chr, isPrint) import Data.Monoid () import Data.Proxy import Data.SOP import Data.Text (Text) import qualified Data.Text as Text import Data.Text.Encoding (decodeUtf8, encodeUtf8) 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.QuickCheck import Web.FormUrlEncoded (FromForm, ToForm) import Servant.API ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData (..), Capture, CaptureAll, DeleteNoContent, EmptyAPI, FormUrlEncoded, Fragment, FromHttpApiData (..), Get, Header, Headers, JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender), NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam, QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), UVerb, Union, Verb, WithStatus (WithStatus), NamedRoutes, addHeader) import Servant.API.Generic ((:-)) import Servant.Client import qualified Servant.Client.Core.Auth as Auth import Servant.Server import Servant.Server.Experimental.Auth import Servant.Test.ComprehensiveAPI -- This declaration simply checks that all instances are in place. _ = client comprehensiveAPIWithoutStreaming -- * test data types data Person = Person { _name :: String , _age :: Integer } deriving (Eq, Show, Read, Generic) instance ToJSON Person instance FromJSON Person instance ToForm Person instance FromForm Person instance Arbitrary Person where arbitrary = Person <$> arbitrary <*> arbitrary instance MimeRender PlainText Person where mimeRender _ = LazyByteString.fromStrict . encodeUtf8 . Text.pack . show instance MimeUnrender PlainText Person where mimeUnrender _ = -- This does not handle any errors, but it should be fine for tests Right . read . Text.unpack . decodeUtf8 . LazyByteString.toStrict alice :: Person alice = Person "Alice" 42 carol :: Person carol = Person "Carol" 17 type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String] data RecordRoutes mode = RecordRoutes { version :: mode :- "version" :> Get '[JSON] Int , echo :: mode :- "echo" :> Capture "string" String :> Get '[JSON] String , otherRoutes :: mode :- "other" :> Capture "someParam" Int :> NamedRoutes OtherRoutes } deriving Generic data OtherRoutes mode = OtherRoutes { something :: mode :- "something" :> Get '[JSON] [String] } deriving Generic -- Get for HTTP 307 Temporary Redirect type Get307 = Verb 'GET 307 type Api = Get '[JSON] Person :<|> "get" :> Get '[JSON] Person -- This endpoint returns a response with status code 307 Temporary Redirect, -- different from the ones in the 2xx successful class, to test derivation -- of clients' api. :<|> "get307" :> Get307 '[PlainText] Text :<|> "deleteEmpty" :> DeleteNoContent :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person] :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person -- This endpoint makes use of a 'Raw' server because it is not currently -- possible to handle arbitrary binary query param values with -- @servant-server@ :<|> "param-binary" :> QueryParam "payload" UrlEncodedByteString :> Raw :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person] :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool :<|> "fragment" :> Fragment String :> Get '[JSON] Person :<|> "rawSuccess" :> Raw :<|> "rawSuccessPassHeaders" :> Raw :<|> "rawFailure" :> Raw :<|> "multiple" :> Capture "first" String :> QueryParam "second" Int :> QueryFlag "third" :> ReqBody '[JSON] [(String, [Rational])] :> Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])]) :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool) :<|> "uverb-headers" :> UVerb 'GET '[JSON] '[ WithStatus 200 (Headers TestHeaders Bool), WithStatus 204 String ] :<|> "deleteContentType" :> DeleteNoContent :<|> "redirectWithCookie" :> Raw :<|> "empty" :> EmptyAPI :<|> "uverb-success-or-redirect" :> Capture "bool" Bool :> UVerb 'GET '[PlainText] '[WithStatus 200 Person, WithStatus 301 Text] :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person] :<|> NamedRoutes RecordRoutes api :: Proxy Api api = Proxy getRoot :: ClientM Person getGet :: ClientM Person getGet307 :: ClientM Text getDeleteEmpty :: ClientM NoContent getCapture :: String -> ClientM Person getCaptureAll :: [String] -> ClientM [Person] getBody :: Person -> ClientM Person getQueryParam :: Maybe String -> ClientM Person getQueryParamBinary :: Maybe UrlEncodedByteString -> HTTP.Method -> ClientM Response getQueryParams :: [String] -> ClientM [Person] getQueryFlag :: Bool -> ClientM Bool getFragment :: ClientM Person getRawSuccess :: HTTP.Method -> ClientM Response getRawSuccessPassHeaders :: HTTP.Method -> ClientM Response getRawFailure :: HTTP.Method -> ClientM Response getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> ClientM (String, Maybe Int, Bool, [(String, [Rational])]) getRespHeaders :: ClientM (Headers TestHeaders Bool) getUVerbRespHeaders :: ClientM (Union '[ WithStatus 200 (Headers TestHeaders Bool), WithStatus 204 String ]) getDeleteContentType :: ClientM NoContent getRedirectWithCookie :: HTTP.Method -> ClientM Response uverbGetSuccessOrRedirect :: Bool -> ClientM (Union '[WithStatus 200 Person, WithStatus 301 Text]) uverbGetCreated :: ClientM (Union '[WithStatus 201 Person]) recordRoutes :: RecordRoutes (AsClientT ClientM) getRoot :<|> getGet :<|> getGet307 :<|> getDeleteEmpty :<|> getCapture :<|> getCaptureAll :<|> getBody :<|> getQueryParam :<|> getQueryParamBinary :<|> getQueryParams :<|> getQueryFlag :<|> getFragment :<|> getRawSuccess :<|> getRawSuccessPassHeaders :<|> getRawFailure :<|> getMultiple :<|> getRespHeaders :<|> getUVerbRespHeaders :<|> getDeleteContentType :<|> getRedirectWithCookie :<|> EmptyClient :<|> uverbGetSuccessOrRedirect :<|> uverbGetCreated :<|> recordRoutes = client api server :: Application server = serve api ( return carol :<|> return alice :<|> return "redirecting" :<|> return NoContent :<|> (\ name -> return $ Person name 0) :<|> (\ names -> return (zipWith Person names [0..])) :<|> return :<|> (\ name -> case name of Just "alice" -> return alice Just n -> throwError $ ServerError 400 (n ++ " not found") "" [] Nothing -> throwError $ ServerError 400 "missing parameter" "" []) :<|> const (Tagged $ \request respond -> respond . maybe (Wai.responseLBS HTTP.notFound404 [] "Missing: payload") (Wai.responseLBS HTTP.ok200 [] . LazyByteString.fromStrict) . join . lookup "payload" $ Wai.queryString request ) :<|> (\ names -> return (zipWith Person names [0..])) :<|> return :<|> return alice :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess") :<|> (Tagged $ \ request respond -> (respond $ Wai.responseLBS HTTP.ok200 (Wai.requestHeaders $ request) "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) :<|> (pure . Z . I . WithStatus $ addHeader 1729 $ addHeader "eg2" True) :<|> return NoContent :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "") :<|> emptyServer :<|> (\shouldRedirect -> if shouldRedirect then respond (WithStatus @301 ("redirecting" :: Text)) else respond (WithStatus @200 alice )) :<|> respond (WithStatus @201 carol) :<|> RecordRoutes { version = pure 42 , echo = pure , otherRoutes = \_ -> OtherRoutes { something = pure ["foo", "bar", "pweet"] } } ) -- * api for testing failures type FailApi = "get" :> Raw :<|> "capture" :> Capture "name" String :> Raw :<|> "body" :> Raw :<|> "headers" :> Raw failApi :: Proxy FailApi failApi = Proxy failServer :: Application failServer = serve failApi ( (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")] "") :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/x-www-form-urlencoded"), ("X-Example1", "1"), ("X-Example2", "foo")] "") ) -- * basic auth stuff type BasicAuthAPI = BasicAuth "foo-realm" () :> "private" :> "basic" :> Get '[JSON] Person basicAuthAPI :: Proxy BasicAuthAPI basicAuthAPI = Proxy basicAuthHandler :: BasicAuthCheck () basicAuthHandler = let check (BasicAuthData username password) = if username == "servant" && password == "server" then return (Authorized ()) else return Unauthorized in BasicAuthCheck check basicServerContext :: Context '[ BasicAuthCheck () ] basicServerContext = basicAuthHandler :. EmptyContext basicAuthServer :: Application basicAuthServer = serveWithContext basicAuthAPI basicServerContext (const (return alice)) -- * general auth stuff type GenAuthAPI = AuthProtect "auth-tag" :> "private" :> "auth" :> Get '[JSON] Person genAuthAPI :: Proxy GenAuthAPI genAuthAPI = Proxy type instance AuthServerData (AuthProtect "auth-tag") = () type instance Auth.AuthClientData (AuthProtect "auth-tag") = () genAuthHandler :: AuthHandler Wai.Request () genAuthHandler = 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 Wai.Request () ] genAuthServerContext = genAuthHandler :. EmptyContext genAuthServer :: Application genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice)) {-# NOINLINE manager' #-} manager' :: C.Manager manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings runClient :: ClientM a -> BaseUrl -> IO (Either ClientError a) runClient x baseUrl' = runClientM x (mkClientEnv manager' baseUrl') -- * utils startWaiApp :: Application -> IO (ThreadId, BaseUrl) startWaiApp app = do (port, socket) <- openTestSocket let settings = setPort port defaultSettings thread <- forkIO $ runSettingsSocket settings socket app return (thread, BaseUrl Http "localhost" port "") endWaiApp :: (ThreadId, BaseUrl) -> IO () endWaiApp (thread, _) = killThread thread openTestSocket :: IO (Port, Socket) openTestSocket = do s <- socket AF_INET Stream defaultProtocol let localhost = tupleToHostAddress (127, 0, 0, 1) bind s (SockAddrInet defaultPort localhost) listen s 1 port <- socketPort s return (fromIntegral port, s) pathGen :: Gen (NonEmptyList Char) pathGen = fmap NonEmpty path where path = listOf1 $ elements $ filter (not . (`elem` ("?%[]/#;" :: String))) $ filter isPrint $ map chr [0..127] newtype UrlEncodedByteString = UrlEncodedByteString { unUrlEncodedByteString :: ByteString } instance ToHttpApiData UrlEncodedByteString where toEncodedUrlPiece = byteString . HTTP.urlEncode True . unUrlEncodedByteString toUrlPiece = decodeUtf8 . HTTP.urlEncode True . unUrlEncodedByteString instance FromHttpApiData UrlEncodedByteString where parseUrlPiece = pure . UrlEncodedByteString . HTTP.urlDecode True . encodeUtf8 servant-client-0.19/test/Servant/ConnectionErrorSpec.hs0000644000000000000000000000354407346545000021461 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -freduction-depth=100 #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} module Servant.ConnectionErrorSpec (spec) where import Prelude () import Prelude.Compat import Control.Exception (fromException) import Data.Maybe (isJust) import Data.Monoid () import Data.Proxy import qualified Network.HTTP.Client as C import Test.Hspec import Servant.API (Get, JSON) import Servant.Client import Servant.ClientTestUtils spec :: Spec spec = describe "Servant.ConnectionErrorSpec" $ do connectionErrorSpec type ConnectionErrorAPI = Get '[JSON] Int connectionErrorAPI :: Proxy ConnectionErrorAPI connectionErrorAPI = Proxy connectionErrorSpec :: Spec connectionErrorSpec = describe "Servant.Client.ClientError" $ it "correctly catches ConnectionErrors when the HTTP request can't go through" $ do let getInt = client connectionErrorAPI let baseUrl' = BaseUrl Http "example.invalid" 80 "" let isHttpError (Left (ConnectionError e)) = isJust $ fromException @C.HttpException e isHttpError _ = False (isHttpError <$> runClient getInt baseUrl') `shouldReturn` True servant-client-0.19/test/Servant/FailSpec.hs0000644000000000000000000000622007346545000017215 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -freduction-depth=100 #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} module Servant.FailSpec (spec) where import Prelude () import Prelude.Compat import Data.Monoid () import qualified Network.HTTP.Types as HTTP import Test.Hspec import Servant.API ((:<|>) ((:<|>))) import Servant.Client import Servant.ClientTestUtils spec :: Spec spec = describe "Servant.FailSpec" $ do failSpec failSpec :: Spec failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do context "client returns errors appropriately" $ do it "reports FailureResponse" $ \(_, baseUrl) -> do let (_ :<|> _ :<|> _ :<|> getDeleteEmpty :<|> _) = client api Left res <- runClient getDeleteEmpty baseUrl case res of 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 <- runClient (getCapture "foo") baseUrl case res of DecodeFailure _ _ -> return () _ -> fail $ "expected DecodeFailure, but got " <> show res it "reports ConnectionError" $ \_ -> do let (getGetWrongHost :<|> _) = client api 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 <- runClient getGet baseUrl case res of UnsupportedContentType "application/octet-stream" _ -> return () _ -> fail $ "expected UnsupportedContentType, but got " <> show res it "reports UnsupportedContentType when there are response headers" $ \(_, baseUrl) -> do Left res <- runClient getRespHeaders baseUrl case res of UnsupportedContentType "application/x-www-form-urlencoded" _ -> return () _ -> fail $ "expected UnsupportedContentType, but got " <> show res it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api Left res <- runClient (getBody alice) baseUrl case res of InvalidContentTypeHeader _ -> return () _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res servant-client-0.19/test/Servant/GenAuthSpec.hs0000644000000000000000000000421307346545000017675 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -freduction-depth=100 #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} module Servant.GenAuthSpec (spec) where import Prelude () import Prelude.Compat import Control.Arrow (left) import Data.Monoid () import qualified Network.HTTP.Types as HTTP import Test.Hspec import Servant.Client import qualified Servant.Client.Core.Auth as Auth import qualified Servant.Client.Core.Request as Req import Servant.ClientTestUtils spec :: Spec spec = describe "Servant.GenAuthSpec" $ do genAuthSpec genAuthSpec :: Spec genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do context "Authentication works when requests are properly authenticated" $ do it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do let getProtected = client genAuthAPI 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 = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "Wrong" ("header" :: String) req) Left (FailureResponse _ r) <- runClient (getProtected authRequest) baseUrl responseStatusCode r `shouldBe` HTTP.Status 401 "Unauthorized" servant-client-0.19/test/Servant/GenericSpec.hs0000644000000000000000000000260607346545000017722 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -freduction-depth=100 #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} module Servant.GenericSpec (spec) where import Test.Hspec import Servant.Client ((//), (/:)) import Servant.ClientTestUtils spec :: Spec spec = describe "Servant.GenericSpec" $ do genericSpec genericSpec :: Spec genericSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do context "Record clients work as expected" $ do it "Client functions return expected values" $ \(_,baseUrl) -> do runClient (recordRoutes // version) baseUrl `shouldReturn` Right 42 runClient (recordRoutes // echo /: "foo") baseUrl `shouldReturn` Right "foo" it "Clients can be nested" $ \(_,baseUrl) -> do runClient (recordRoutes // otherRoutes /: 42 // something) baseUrl `shouldReturn` Right ["foo", "bar", "pweet"] servant-client-0.19/test/Servant/HoistClientSpec.hs0000644000000000000000000000366307346545000020577 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -freduction-depth=100 #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} module Servant.HoistClientSpec (spec) where import Prelude () import Prelude.Compat import Data.Monoid () import Data.Proxy import Test.Hspec import Servant.API ((:<|>) ((:<|>)), (:>), Capture, Get, JSON, Post) import Servant.Client import Servant.Server import Servant.ClientTestUtils spec :: Spec spec = describe "Servant.HoistClientSpec" $ do hoistClientSpec type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int hoistClientAPI :: Proxy HoistClientAPI hoistClientAPI = Proxy hoistClientServer :: Application -- implements HoistClientAPI hoistClientServer = serve hoistClientAPI $ return 5 :<|> return hoistClientSpec :: Spec hoistClientSpec = beforeAll (startWaiApp hoistClientServer) $ afterAll endWaiApp $ do describe "Servant.Client.hoistClient" $ do it "allows us to GET/POST/... requests in IO instead of ClientM" $ \(_, baseUrl) -> do let (getInt :<|> postInt) = hoistClient hoistClientAPI (fmap (either (error . show) id) . flip runClient baseUrl) (client hoistClientAPI) getInt `shouldReturn` 5 postInt 5 `shouldReturn` 5 servant-client-0.19/test/Servant/StreamSpec.hs0000644000000000000000000001460407346545000017602 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -freduction-depth=100 #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} module Servant.StreamSpec (spec) where import Control.Monad (when) import Control.Monad.Codensity (Codensity (..)) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Except import qualified Data.ByteString as BS import Data.Proxy import qualified Data.TDigest as TD import qualified Network.HTTP.Client as C import Prelude () import Prelude.Compat import Servant.API ((:<|>) ((:<|>)), (:>), JSON, NetstringFraming, StreamBody, NewlineFraming, NoFraming, OctetStream, SourceIO, StreamGet, ) import Servant.Client.Streaming import Servant.Server import Servant.Test.ComprehensiveAPI import Servant.Types.SourceT import System.Entropy (getEntropy, getHardwareEntropy) import System.IO.Unsafe (unsafePerformIO) import System.Mem (performGC) import Test.Hspec import Servant.ClientTestUtils (Person(..)) import qualified Servant.ClientTestUtils as CT #if MIN_VERSION_base(4,10,0) import GHC.Stats (gc, gcdetails_live_bytes, getRTSStats) #else import GHC.Stats (currentBytesUsed, getGCStats) #endif -- This declaration simply checks that all instances are in place. -- Note: this is streaming client _ = client comprehensiveAPI spec :: Spec spec = describe "Servant.Client.Streaming" $ do streamSpec type StreamApi = "streamGetNewline" :> StreamGet NewlineFraming JSON (SourceIO Person) :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (SourceIO Person) :<|> "streamALot" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString) :<|> "streamBody" :> StreamBody NoFraming OctetStream (SourceIO BS.ByteString) :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString) api :: Proxy StreamApi api = Proxy getGetNL, getGetNS :: ClientM (SourceIO Person) getGetALot :: ClientM (SourceIO BS.ByteString) getStreamBody :: SourceT IO BS.ByteString -> ClientM (SourceIO BS.ByteString) getGetNL :<|> getGetNS :<|> getGetALot :<|> getStreamBody = client api alice :: Person alice = Person "Alice" 42 bob :: Person bob = Person "Bob" 25 server :: Application server = serve api $ return (source [alice, bob, alice]) :<|> return (source [alice, bob, alice]) -- 2 ^ (18 + 10) = 256M :<|> return (SourceT ($ lots (powerOfTwo 18))) :<|> return where lots n | n < 0 = Stop | otherwise = Effect $ do let size = powerOfTwo 10 mbs <- getHardwareEntropy size bs <- maybe (getEntropy size) pure mbs return (Yield bs (lots (n - 1))) powerOfTwo :: Int -> Int powerOfTwo = (2 ^) {-# NOINLINE manager' #-} manager' :: C.Manager manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings withClient :: ClientM a -> BaseUrl -> (Either ClientError a -> IO r) -> IO r withClient x baseUrl' = withClientM x (mkClientEnv manager' baseUrl') testRunSourceIO :: SourceIO a -> IO (Either String [a]) testRunSourceIO = runExceptT . runSourceT streamSpec :: Spec streamSpec = beforeAll (CT.startWaiApp server) $ afterAll CT.endWaiApp $ do it "works with Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do withClient getGetNL baseUrl $ \(Right res) -> testRunSourceIO res `shouldReturn` Right [alice, bob, alice] it "works with Servant.API.StreamGet.Netstring" $ \(_, baseUrl) -> do withClient getGetNS baseUrl $ \(Right res) -> testRunSourceIO res `shouldReturn` Right [alice, bob, alice] it "works with Servant.API.StreamBody" $ \(_, baseUrl) -> do withClient (getStreamBody (source input)) baseUrl $ \(Right res) -> testRunSourceIO res `shouldReturn` Right output where input = ["foo", "", "bar"] output = ["foo", "bar"] {- it "streams in constant memory" $ \(_, baseUrl) -> do Right rs <- runClient getGetALot baseUrl performGC -- usage0 <- getUsage -- putStrLn $ "Start: " ++ show usage0 tdigest <- memoryUsage $ joinCodensitySourceT rs -- putStrLn $ "Median: " ++ show (TD.median tdigest) -- putStrLn $ "Mean: " ++ show (TD.mean tdigest) -- putStrLn $ "Stddev: " ++ show (TD.stddev tdigest) -- forM_ [0.01, 0.1, 0.2, 0.5, 0.8, 0.9, 0.99] $ \q -> -- putStrLn $ "q" ++ show q ++ ": " ++ show (TD.quantile q tdigest) let Just stddev = TD.stddev tdigest -- standard deviation of 100k is ok, we generate 256M of data after all. -- On my machine deviation is 40k-50k stddev `shouldSatisfy` (< 100000) memoryUsage :: SourceT IO BS.ByteString -> IO (TD.TDigest 25) memoryUsage src = unSourceT src $ loop mempty (0 :: Int) where loop !acc !_ Stop = return acc loop !_ !_ (Error err) = fail err -- ! loop !acc !n (Skip s) = loop acc n s loop !acc !n (Effect ms) = ms >>= loop acc n loop !acc !n (Yield _bs s) = do usage <- liftIO getUsage -- We perform GC in between as we generate garbage. when (n `mod` 1024 == 0) $ liftIO performGC loop (TD.insert usage acc) (n + 1) s getUsage :: IO Double getUsage = fromIntegral . #if MIN_VERSION_base(4,10,0) gcdetails_live_bytes . gc <$> getRTSStats #else currentBytesUsed <$> getGCStats #endif memUsed `shouldSatisfy` (< megabytes 22) megabytes :: Num a => a -> a megabytes n = n * (1000 ^ (2 :: Int)) -} servant-client-0.19/test/Servant/SuccessSpec.hs0000644000000000000000000002221607346545000017755 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -freduction-depth=100 #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} module Servant.SuccessSpec (spec) where import Prelude () import Prelude.Compat import Control.Arrow ((+++), left) import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TVar (newTVar, readTVar) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import Data.Foldable (forM_, toList) import Data.Maybe (listToMaybe) import Data.Monoid () import Data.Text (Text) import qualified Network.HTTP.Client as C import qualified Network.HTTP.Types as HTTP import Test.Hspec import Test.Hspec.QuickCheck import Test.HUnit import Test.QuickCheck import Servant.API (NoContent (NoContent), WithStatus (WithStatus), getHeaders, Headers(..)) import Servant.Client import qualified Servant.Client.Core.Request as Req import Servant.ClientTestUtils import Servant.Test.ComprehensiveAPI -- This declaration simply checks that all instances are in place. _ = client comprehensiveAPIWithoutStreaming spec :: Spec spec = describe "Servant.SuccessSpec" $ do successSpec successSpec :: Spec successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do describe "Servant.API.Get" $ do it "get root endpoint" $ \(_, baseUrl) -> do left show <$> runClient getRoot baseUrl `shouldReturn` Right carol it "get simple endpoint" $ \(_, baseUrl) -> do left show <$> runClient getGet baseUrl `shouldReturn` Right alice it "get redirection endpoint" $ \(_, baseUrl) -> do left show <$> runClient getGet307 baseUrl `shouldReturn` Right "redirecting" describe "Servant.API.Delete" $ do it "allows empty content type" $ \(_, baseUrl) -> do left show <$> runClient getDeleteEmpty baseUrl `shouldReturn` Right NoContent it "allows content type" $ \(_, baseUrl) -> do left show <$> runClient getDeleteContentType baseUrl `shouldReturn` Right NoContent it "Servant.API.Capture" $ \(_, baseUrl) -> do 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 <$> runClient (getCaptureAll ["Paula", "Peta"]) baseUrl `shouldReturn` Right expected it "Servant.API.ReqBody" $ \(_, baseUrl) -> do let p = Person "Clara" 42 left show <$> runClient (getBody p) baseUrl `shouldReturn` Right p it "Servant.API FailureResponse" $ \(_, baseUrl) -> do left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice Left (FailureResponse req _) <- runClient (getQueryParam (Just "bob")) baseUrl Req.requestPath req `shouldBe` (baseUrl, "/param") toList (Req.requestQueryString req) `shouldBe` [("name", Just "bob")] Req.requestMethod req `shouldBe` HTTP.methodGet it "Servant.API.QueryParam" $ \(_, baseUrl) -> do 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 binary data" $ \(_, baseUrl) -> do let payload = BS.pack [0, 1, 2, 4, 8, 16, 32, 64, 128] apiCall = getQueryParamBinary (Just $ UrlEncodedByteString payload) HTTP.methodGet (show +++ responseBody) <$> runClient apiCall baseUrl `shouldReturn` Right (BL.fromStrict payload) it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do 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 <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag it "Servant.API.Fragment" $ \(_, baseUrl) -> do left id <$> runClient getFragment baseUrl `shouldReturn` Right alice it "Servant.API.Raw on success" $ \(_, baseUrl) -> do res <- runClient (getRawSuccess HTTP.methodGet) baseUrl case res of Left e -> assertFailure $ show e 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 <- runClient (getRawFailure HTTP.methodGet) baseUrl case res of Right _ -> assertFailure "expected Left, but got Right" 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 <- runClient getRespHeaders baseUrl case res of Left e -> assertFailure $ show e Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] it "Returns headers on UVerb requests" $ \(_, baseUrl) -> do res <- runClient getUVerbRespHeaders baseUrl case res of Left e -> assertFailure $ show e Right val -> case matchUnion val of Just (WithStatus val' :: WithStatus 200 (Headers TestHeaders Bool)) -> getHeaders val' `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] Nothing -> assertFailure "unexpected alternative of union" it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do mgr <- C.newManager C.defaultManagerSettings cj <- atomically . newTVar $ C.createCookieJar [] _ <- runClientM (getRedirectWithCookie HTTP.methodGet) (ClientEnv mgr baseUrl (Just cj) defaultMakeClientRequest) cookie <- listToMaybe . C.destroyCookieJar <$> atomically (readTVar cj) C.cookie_name <$> cookie `shouldBe` Just "testcookie" C.cookie_value <$> cookie `shouldBe` Just "test" it "Can modify the outgoing Request using the ClientEnv" $ \(_, baseUrl) -> do mgr <- C.newManager C.defaultManagerSettings -- In proper situation, extra headers should probably be visible in API type. -- However, testing for response timeout is difficult, so we test with something which is easy to observe let createClientRequest url r = (defaultMakeClientRequest url r) { C.requestHeaders = [("X-Added-Header", "XXX")] } clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest } res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv case res of Left e -> assertFailure $ show e Right r -> ("X-Added-Header", "XXX") `elem` toList (responseHeaders r) `shouldBe` True modifyMaxSuccess (const 20) $ 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 <$> runClient (getMultiple cap num flag body) baseUrl return $ result === Right (cap, num, flag, body) context "With a route that can either return success or redirect" $ do it "Redirects when appropriate" $ \(_, baseUrl) -> do eitherResponse <- runClient (uverbGetSuccessOrRedirect True) baseUrl case eitherResponse of Left clientError -> fail $ show clientError Right response -> matchUnion response `shouldBe` Just (WithStatus @301 @Text "redirecting") it "Returns a proper response when appropriate" $ \(_, baseUrl) -> do eitherResponse <- runClient (uverbGetSuccessOrRedirect False) baseUrl case eitherResponse of Left clientError -> fail $ show clientError Right response -> matchUnion response `shouldBe` Just (WithStatus @200 alice) context "with a route that uses uverb but only has a single response" $ it "returns the expected response" $ \(_, baseUrl) -> do eitherResponse <- runClient (uverbGetCreated) baseUrl case eitherResponse of Left clientError -> fail $ show clientError Right response -> matchUnion response `shouldBe` Just (WithStatus @201 carol) servant-client-0.19/test/Servant/WrappedApiSpec.hs0000644000000000000000000000453407346545000020404 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -freduction-depth=100 #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} module Servant.WrappedApiSpec (spec) where import Prelude () import Prelude.Compat import Control.Exception (bracket) import Control.Monad.Error.Class (throwError) import Data.Monoid () import Data.Proxy import qualified Network.HTTP.Types as HTTP import Test.Hspec import Servant.API (Delete, Get, JSON, Post, Put) import Servant.Client import Servant.Server import Servant.ClientTestUtils spec :: Spec spec = describe "Servant.WrappedApiSpec" $ do wrappedApiSpec data WrappedApi where WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a, HasClient ClientM api, Client ClientM api ~ ClientM ()) => Proxy api -> WrappedApi wrappedApiSpec :: Spec wrappedApiSpec = describe "error status codes" $ do let serveW api = serve api $ throwError $ ServerError 500 "error message" "" [] context "are correctly handled by the client" $ let test :: (WrappedApi, String) -> Spec test (WrappedApi api, desc) = it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do let getResponse :: ClientM () getResponse = client api 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") : (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") : (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") : [] servant-client-0.19/test/0000755000000000000000000000000007346545000013551 5ustar0000000000000000servant-client-0.19/test/Spec.hs0000644000000000000000000000005407346545000014776 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-}