servant-client 0.10 → 0.20.3.0
raw patch · 29 files changed
Files
- CHANGELOG.md +372/−0
- LICENSE +1/−1
- README.lhs +41/−0
- README.md +24/−3
- include/overlapping-compat.h +0/−8
- servant-client.cabal +168/−73
- src/Servant/Client.hs +9/−471
- src/Servant/Client/Experimental/Auth.hs +0/−36
- src/Servant/Client/Generic.hs +0/−164
- src/Servant/Client/Internal/HttpClient.hs +312/−0
- src/Servant/Client/Internal/HttpClient/Streaming.hs +204/−0
- src/Servant/Client/Streaming.hs +19/−0
- src/Servant/Common/BaseUrl.hs +0/−77
- src/Servant/Common/BasicAuth.hs +0/−21
- src/Servant/Common/Req.hs +0/−275
- test/Servant/BasicAuthSpec.hs +53/−0
- test/Servant/BrokenSpec.hs +71/−0
- test/Servant/ClientSpec.hs +0/−489
- test/Servant/ClientTestUtils.hs +483/−0
- test/Servant/Common/BaseUrlSpec.hs +0/−83
- test/Servant/ConnectionErrorSpec.hs +55/−0
- test/Servant/FailSpec.hs +79/−0
- test/Servant/GenAuthSpec.hs +54/−0
- test/Servant/GenericSpec.hs +37/−0
- test/Servant/HoistClientSpec.hs +58/−0
- test/Servant/MiddlewareSpec.hs +115/−0
- test/Servant/StreamSpec.hs +115/−0
- test/Servant/SuccessSpec.hs +202/−0
- test/Servant/WrappedApiSpec.hs +64/−0
CHANGELOG.md view
@@ -1,3 +1,375 @@+[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.20.3.0+--------++- Server-sent events (SSE) for client-side [#1811](https://github.com/haskell-servant/servant/issues/1811)++ Implement Server-sent events (SSE) for the Servant client using a new+ combinator "ServerSentEvents". The raw event messages, accumulated events and+ JSON-processed events can be exposed.++- Integrate MultiVerb [#1766](https://github.com/haskell-servant/servant/pull/1766) [#1804](https://github.com/haskell-servant/servant/pull/1804)++ Expose MultiVerb, a more ergonomic way of defining endpoints that return+ many kinds of responses. Read the cookbook https://docs.servant.dev/en/master/cookbook/multiverb/MultiVerb.html++- Add public re-export of renderCurlBasePath lens [#1706](https://github.com/haskell-servant/servant/pull/1706)+- Remove GHC <= 8.10.7 from the support window [#1778](https://github.com/haskell-servant/servant/pull/1778)+- Add Servant.API.Range type [#1805](https://github.com/haskell-servant/servant/pull/1805)+- Add missing HasLink instance for DeepQuery [#1784](https://github.com/haskell-servant/servant/issues/1784) [#1814](https://github.com/haskell-servant/servant/pull/1814)+- Add Host API combinator [#1800](https://github.com/haskell-servant/servant/pull/1800)++ Adding a Host combinator allows servant users to select APIs according+ to the Host header provided by clients.++0.20.2+------++- Client Middleware [#1720](https://github.com/haskell-servant/servant/pull/1720)++ Clients now support real middleware of type `(Request -> ClientM Response) -> Request -> ClientM Response` which can be configured in `ClientEnv`.+ This allows access to raw request and response data. It can also be used to control how/when/if actual requests are performed.+ Middleware can be chained with function composition `mid1 . mid2 . mid3`.++0.20+----++- Escape special chars in QueryParams. [#1584](https://github.com/haskell-servant/servant/issues/1584) [#1597](https://github.com/haskell-servant/servant/pull/1597)++ Escape special chars in QueryParam (`:@&=+$`) in servant-client. Note that this+ mean binary data will not work as is, and so reverts the functionality in+ [#1432](https://github.com/haskell-servant/servant/pull/1432).++- Handle Cookies correctly for RunStreamingClient [#1605](https://github.com/haskell-servant/servant/issues/1605) [#1606](https://github.com/haskell-servant/servant/pull/1606)++ Makes `performWithStreamingRequest` take into consideration the+ CookieJar, which it previously didn't.++- Fix the handling of multiple headers with the same name. [#1666](https://github.com/haskell-servant/servant/pull/1666)++ servant-client no longer concatenates the values of response headers with the same name.+ This fixes an issue with parsing multiple `Set-Cookie` headers.++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 -----
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors+Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors All rights reserved.
+ README.lhs view
@@ -0,0 +1,41 @@+# servant-client++++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 (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+```
README.md view
@@ -7,14 +7,35 @@ ## Example ``` haskell+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}++import Data.Proxy+import Data.Text (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 Book :> Post '[JSON] Book -- POST /books+ :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books myApi :: Proxy MyApi myApi = Proxy -getAllBooks :: Manager -> BaseUrl -> ExceptT String IO [Book]-postNewBook :: Book -> Manager -> BaseUrl -> ExceptT String IO Book -- '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 ```
− include/overlapping-compat.h
@@ -1,8 +0,0 @@-#if __GLASGOW_HASKELL__ >= 710-#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}-#define OVERLAPPING_ {-# OVERLAPPING #-}-#else-{-# LANGUAGE OverlappingInstances #-}-#define OVERLAPPABLE_-#define OVERLAPPING_-#endif
servant-client.cabal view
@@ -1,105 +1,200 @@-name: servant-client-version: 0.10-synopsis: automatical derivation of querying functions for servant webservices+cabal-version: 3.0+name: servant-client+version: 0.20.3.0+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 <http://hackage.haskell.org/package/servant servant> webservice. .- See <http://haskell-servant.readthedocs.org/en/stable/tutorial/Client.html the client section of the tutorial>.+ See <http://docs.servant.dev/en/stable/tutorial/Client.html the client section of the tutorial>. . <https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG>-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-category: Servant Web-build-type: Simple-cabal-version: >=1.10-tested-with: GHC >= 7.8-homepage: http://haskell-servant.readthedocs.org/-Bug-reports: http://github.com/haskell-servant/servant/issues++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 ==9.2.8 || ==9.4.8 || ==9.6.6 || ==9.8.4 || ==9.10.1 || ==9.12.1+ extra-source-files:- include/*.h CHANGELOG.md README.md+ source-repository head- type: git+ type: git location: http://github.com/haskell-servant/servant.git +common extensions+ default-extensions:+ AllowAmbiguousTypes+ ConstraintKinds+ DataKinds+ DeriveAnyClass+ DeriveDataTypeable+ DeriveFunctor+ DeriveGeneric+ DerivingStrategies+ DerivingVia+ DuplicateRecordFields+ ExplicitNamespaces+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ GeneralizedNewtypeDeriving+ InstanceSigs+ KindSignatures+ LambdaCase+ MultiParamTypeClasses+ NamedFieldPuns+ NoStarIsType+ OverloadedLabels+ OverloadedStrings+ PackageImports+ PolyKinds+ QuantifiedConstraints+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ StrictData+ TupleSections+ TypeApplications+ TypeFamilies+ TypeOperators+ UndecidableInstances+ ViewPatterns++ default-language: Haskell2010++common ghc-options+ ghc-options:+ -Wall -Wcompat -Widentities -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints+ -fhide-source-paths -Wno-unused-do-bind -fdicts-strict+ -Wno-unticked-promoted-constructors -Werror=unused-imports+ -Wunused-packages+ library+ import: extensions+ import: ghc-options exposed-modules: Servant.Client- Servant.Client.Generic- Servant.Client.Experimental.Auth- Servant.Common.BaseUrl- Servant.Common.BasicAuth- Servant.Common.Req+ Servant.Client.Internal.HttpClient+ Servant.Client.Internal.HttpClient.Streaming+ Servant.Client.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.7 && < 4.10- , base-compat >= 0.9.1 && < 0.10- , aeson >= 0.7 && < 1.2- , 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.3- , http-api-data >= 0.3 && < 0.4- , http-client >= 0.4.18.1 && < 0.6- , http-client-tls >= 0.2.2 && < 0.4- , http-media >= 0.6.2 && < 0.7- , http-types >= 0.8.6 && < 0.10- , monad-control >= 1.0.0.4 && < 1.1- , network-uri >= 2.6 && < 2.7- , safe >= 0.3.9 && < 0.4- , semigroupoids >= 4.3 && < 5.2- , servant == 0.10.*- , string-conversions >= 0.3 && < 0.5- , 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- if impl(ghc >= 8.0)- ghc-options: -Wno-redundant-constraints- include-dirs: include+ , base >= 4.16.4.0 && < 4.22+ , bytestring >=0.11 && <0.13+ , containers >=0.6.5.1 && <0.9+ , deepseq >=1.4.2.0 && <1.6+ , mtl ^>=2.2.2 || ^>=2.3.1+ , stm >=2.4.5.1 && <2.6+ , time >=1.6.0.1 && <1.15+ , transformers >=0.5.2.0 && <0.7 + -- Servant dependencies.+ -- Strict dependency on `servant-client-core` as we re-export things.+ build-depends:+ , servant >=0.20.2 && <0.21+ , servant-client-core >=0.20.2 && <0.21++ -- 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.15+ , exceptions >=0.10.0 && <0.11+ , http-client >=0.5.13.1 && <0.8+ , http-media >=0.7.1.3 && <0.9+ , http-types >=0.12.2 && <0.13+ , kan-extensions >=5.2 && <5.3+ , monad-control >=1.0.2.3 && <1.1+ , semigroupoids >=5.3.1 && <6.1+ , transformers-base >=0.4.5.2 && <0.5++ hs-source-dirs: src+ test-suite spec- type: exitcode-stdio-1.0- ghc-options: -Wall- default-language: Haskell2010- hs-source-dirs: test- main-is: Spec.hs+ import: extensions+ import: ghc-options+ type: exitcode-stdio-1.0+ ghc-options: -Wall -rtsopts -threaded "-with-rtsopts=-T -N2"++ if impl(ghcjs)+ buildable: False++ hs-source-dirs: test+ main-is: Spec.hs other-modules:- Servant.ClientSpec- , Servant.Common.BaseUrlSpec+ Servant.BasicAuthSpec+ Servant.BrokenSpec+ Servant.ClientTestUtils+ Servant.ConnectionErrorSpec+ Servant.FailSpec+ Servant.GenAuthSpec+ Servant.GenericSpec+ Servant.HoistClientSpec+ Servant.MiddlewareSpec+ Servant.StreamSpec+ Servant.SuccessSpec+ Servant.WrappedApiSpec++ -- Dependencies inherited from the library. No need to specify bounds. build-depends:- base == 4.* , aeson+ , base , base-compat , bytestring- , deepseq- , hspec == 2.* , http-api-data , http-client- , http-media , http-types- , HUnit , mtl- , network >= 2.6- , QuickCheck >= 2.7- , servant == 0.10.* , servant-client- , servant-server == 0.10.*+ , servant-client-core+ , sop-core+ , generics-sop+ , stm , text , transformers- , transformers-compat , wai , warp- , generics-sop++ -- Additional dependencies+ build-depends:+ , entropy >=0.4.1.3 && <0.5+ , hspec >=2.6.0 && <2.12+ , HUnit >=1.6.0.0 && <1.7+ , network >=2.8.0.0 && <3.3+ , QuickCheck >=2.12.6.1 && <2.16+ , servant >=0.20.2 && <0.21+ , servant-server >=0.20.2 && <0.21++ build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.12++test-suite readme+ import: extensions+ import: ghc-options+ type: exitcode-stdio-1.0+ main-is: README.lhs+ build-depends:+ , base+ , http-client+ , markdown-unlit+ , servant+ , servant-client+ , text++ build-tool-depends: markdown-unlit:markdown-unlit+ ghc-options: -pgmL markdown-unlit++ if impl(ghcjs)+ buildable: False
src/Servant/Client.hs view
@@ -1,480 +1,18 @@-{-# 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(..)- , module Servant.Common.BaseUrl+ , ClientEnv(..)+ , mkClientEnv+ , defaultMakeClientRequest+ , hoistClient+ , 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---- | 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)---- | 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.Core.Reexport+import Servant.Client.Internal.HttpClient
− src/Servant/Client/Experimental/Auth.hs
@@ -1,36 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE TypeFamilies #-}---- | Authentication for clients--module Servant.Client.Experimental.Auth (- AuthenticateReq(AuthenticateReq, unAuthReq)- , AuthClientData- , mkAuthenticateReq- ) where--import Servant.Common.Req (Req)---- | For a resource protected by authentication (e.g. AuthProtect), we need--- to provide the client with some data used to add authentication data--- to a request------ NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE-type family AuthClientData a :: *---- | For better type inference and to avoid usage of a data family, we newtype--- wrap the combination of some 'AuthClientData' and a function to add authentication--- data to a request------ NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE-newtype AuthenticateReq a =- AuthenticateReq { unAuthReq :: (AuthClientData a, AuthClientData a -> Req -> Req) }---- | 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)
− src/Servant/Client/Generic.hs
@@ -1,164 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--#include "overlapping-compat.h"--module Servant.Client.Generic- ( ClientLike(..)- , genericMkClientL- , genericMkClientP- ) 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.------ The client structure needs a 'Generics.SOP.Generic' instance.------ Example:------ > type API--- > = "foo" :> Capture "x" Int :> Get '[JSON] Int--- > :<|> "bar" :> QueryParam "a" Char :> QueryParam "b" String :> Post '[JSON] [Int]--- > :<|> Capture "nested" Int :> NestedAPI--- >--- > type NestedAPI--- > = Get '[JSON] String--- > :<|> "baz" :> QueryParam "c" Char :> Post '[JSON] ()--- >--- > data APIClient = APIClient--- > { getFoo :: Int -> ClientM Int--- > , postBar :: Maybe Char -> Maybe String -> ClientM [Int]--- > , mkNestedClient :: Int -> NestedClient--- > } deriving GHC.Generic--- >--- > instance Generics.SOP.Generic APIClient--- > instance (Client API ~ client) => ClientLike client APIClient--- >--- > data NestedClient = NestedClient--- > { getString :: ClientM String--- > , postBaz :: Maybe Char -> ClientM ()--- > } deriving GHC.Generic--- >--- > instance Generics.SOP.Generic NestedClient--- > instance (Client NestedAPI ~ client) => ClientLike client NestedClient--- >--- > mkAPIClient :: APIClient--- > mkAPIClient = mkClient (client (Proxy :: Proxy API))------ By default, left-nested alternatives are expanded:------ > type API1--- > = "foo" :> Capture "x" Int :> Get '[JSON] Int--- > :<|> "bar" :> QueryParam "a" Char :> Post '[JSON] String--- >--- > type API2--- > = "baz" :> QueryParam "c" Char :> Post '[JSON] ()--- >--- > type API = API1 :<|> API2--- >--- > data APIClient = APIClient--- > { getFoo :: Int -> ClientM Int--- > , postBar :: Maybe Char -> ClientM String--- > , postBaz :: Maybe Char -> ClientM ()--- > } deriving GHC.Generic--- >--- > instance Generics.SOP.Generic APIClient--- > instance (Client API ~ client) => ClientLike client APIClient--- >--- > mkAPIClient :: APIClient--- > mkAPIClient = mkClient (client (Proxy :: Proxy API))------ If you want to define client for @API1@ as a separate data structure,--- you can use 'genericMkClientP':------ > data APIClient1 = APIClient1--- > { getFoo :: Int -> ClientM Int--- > , postBar :: Maybe Char -> ClientM String--- > } deriving GHC.Generic--- >--- > instance Generics.SOP.Generic APIClient1--- > instance (Client API1 ~ client) => ClientLike client APIClient1--- >--- > data APIClient = APIClient--- > { mkAPIClient1 :: APIClient1--- > , postBaz :: Maybe Char -> ClientM ()--- > } deriving GHC.Generic--- >--- > instance Generics.SOP.Generic APIClient--- > instance (Client API ~ client) => ClientLike client APIClient where--- > mkClient = genericMkClientP--- >--- > mkAPIClient :: APIClient--- > mkAPIClient = mkClient (client (Proxy :: Proxy API))-class ClientLike client custom where- mkClient :: client -> custom- default mkClient :: (Generic custom, Code custom ~ '[xs], GClientList client '[], GClientLikeL (ClientList client '[]) xs)- => client -> custom- mkClient = genericMkClientL--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- gMkClientP :: client -> NP I xs--instance (GClientLikeP b (y ': xs), ClientLike a x)- => GClientLikeP (a :<|> b) (x ': y ': xs) where- gMkClientP (a :<|> b) = I (mkClient a) :* gMkClientP b--instance ClientLike a x => GClientLikeP a '[x] where- gMkClientP a = I (mkClient a) :* Nil---- | Match client structure with client functions, expanding left-nested API clients--- in the same structure.-class GClientLikeL (xs :: [*]) (ys :: [*]) where- gMkClientL :: NP I xs -> NP I ys--instance GClientLikeL '[] '[] where- gMkClientL Nil = Nil--instance (ClientLike x y, GClientLikeL xs ys) => GClientLikeL (x ': xs) (y ': ys) where- gMkClientL (I x :* xs) = I (mkClient x) :* gMkClientL xs--type family ClientList (client :: *) (acc :: [*]) :: [*] where- ClientList (a :<|> b) acc = ClientList a (ClientList b acc)- ClientList a acc = a ': acc--class GClientList client (acc :: [*]) where- gClientList :: client -> NP I acc -> NP I (ClientList client acc)--instance (GClientList b acc, GClientList a (ClientList b acc))- => GClientList (a :<|> b) acc where- gClientList (a :<|> b) acc = gClientList a (gClientList b acc)--instance OVERLAPPABLE_ (ClientList client acc ~ (client ': acc))- => GClientList client acc where- gClientList c acc = I c :* acc---- | Generate client structure from client type, expanding left-nested API (done by default).-genericMkClientL :: (Generic custom, Code custom ~ '[xs], GClientList client '[], GClientLikeL (ClientList client '[]) xs)- => client -> custom-genericMkClientL = to . SOP . Z . gMkClientL . flip gClientList Nil---- | Generate client structure from client type, regarding left-nested API clients as separate data structures.-genericMkClientP :: (Generic custom, Code custom ~ '[xs], GClientLikeP client xs)- => client -> custom-genericMkClientP = to . SOP . Z . gMkClientP-
+ src/Servant/Client/Internal/HttpClient.hs view
@@ -0,0 +1,312 @@+{-# LANGUAGE CPP #-}+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, MonadMask)+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 qualified Data.List as List+import Data.Foldable+ (toList)+import Data.Functor.Alt+ (Alt (..))+import Data.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, 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 -> IO 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.+ , middleware :: ClientMiddleware + }++type ClientApplication = Request -> ClientM Response++type ClientMiddleware = ClientApplication -> ClientApplication++-- | 'ClientEnv' smart constructor.+mkClientEnv :: Client.Manager -> BaseUrl -> ClientEnv+mkClientEnv manager baseUrl = ClientEnv + { manager+ , baseUrl+ , cookieJar = Nothing+ , makeClientRequest = defaultMakeClientRequest+ , middleware = id+ }++-- | 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 newtype ( Functor, Applicative, Monad, MonadIO, Generic+ , MonadReader ClientEnv, MonadError ClientError, MonadThrow+ , MonadCatch, MonadMask)++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 statuses req = do+ ClientEnv {middleware} <- ask+ let oldApp = performRequest statuses+ middleware oldApp req+ 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+ clientRequest <- liftIO $ 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'+--+-- Note that @Applicative@ dependency is not really needed for this function+-- implementation. But in the past the return type was wrapped into @IO@+-- without a necessity breaking the API backward-compatibility. In order to not+-- break the API again it was changed to @Applicative@ so that you can just use+-- something like @Data.Functor.Identity@ without a need to involve @IO@ but+-- still keeping it compatible with the code written when it was typed as @IO@.+defaultMakeClientRequest :: Applicative f => BaseUrl -> Request -> f Client.Request+defaultMakeClientRequest burl r = pure 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 [] = mempty+ buildQueryString qps = "?" <> List.foldl' addQueryParam mempty qps++ 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)
+ src/Servant/Client/Internal/HttpClient/Streaming.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE CPP #-}+{-# 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+ (unless)+import Control.Monad.Base+ (MonadBase (..))+import Control.Monad.Codensity+ (Codensity (..))+import Control.Monad.Error.Class+ (MonadError (..))+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Reader (MonadReader(..), ReaderT(..))+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+import Control.Monad.Trans.Class (MonadTrans(..))+++-- | 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 newtype ( 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+ clientRequest <- liftIO $ 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+ ClientEnv m burl cookieJar' createClientRequest _ <- ask+ clientRequest <- liftIO $ 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+ 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
+ src/Servant/Client/Streaming.hs view
@@ -0,0 +1,19 @@+-- | 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
− src/Servant/Common/BaseUrl.hs
@@ -1,77 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE ViewPatterns #-}-module Servant.Common.BaseUrl (- -- * types- BaseUrl (..)- , InvalidBaseUrlException- , Scheme (..)- -- * functions- , parseBaseUrl- , showBaseUrl-) where--import Control.Monad.Catch (Exception, MonadThrow, throwM)-import Data.List-import Data.Typeable-import GHC.Generics-import Network.URI hiding (path)-import Safe-import Text.Read---- | URI scheme to use-data Scheme =- Http -- ^ http://- | Https -- ^ https://- deriving (Show, Eq, Ord, Generic)---- | Simple data type to represent the target of HTTP requests--- for servant's automatically-generated clients.-data BaseUrl = BaseUrl- { baseUrlScheme :: Scheme -- ^ URI scheme to use- , baseUrlHost :: String -- ^ host (eg "haskell.org")- , baseUrlPort :: Int -- ^ port (eg 80)- , baseUrlPath :: String -- ^ path (eg "/a/b/c")- } deriving (Show, Ord, Generic)--instance Eq BaseUrl where- BaseUrl a b c path == BaseUrl a' b' c' path'- = a == a' && b == b' && c == c' && s path == s path'- where s ('/':x) = x- s x = x--showBaseUrl :: BaseUrl -> String-showBaseUrl (BaseUrl urlscheme host port path) =- schemeString ++ "//" ++ host ++ (portString </> path)- where- a </> b = if "/" `isPrefixOf` b || null b then a ++ b else a ++ '/':b- schemeString = case urlscheme of- Http -> "http:"- Https -> "https:"- portString = case (urlscheme, port) of- (Http, 80) -> ""- (Https, 443) -> ""- _ -> ":" ++ show port--data InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show, Typeable)-instance Exception InvalidBaseUrlException--parseBaseUrl :: MonadThrow m => String -> m BaseUrl-parseBaseUrl s = case parseURI (removeTrailingSlash s) of- -- This is a rather hacky implementation and should be replaced with something- -- implemented in attoparsec (which is already a dependency anyhow (via aeson)).- Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) path "" "") ->- return (BaseUrl Http host port path)- Just (URI "http:" (Just (URIAuth "" host "")) path "" "") ->- return (BaseUrl Http host 80 path)- Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) path "" "") ->- return (BaseUrl Https host port path)- Just (URI "https:" (Just (URIAuth "" host "")) path "" "") ->- return (BaseUrl Https host 443 path)- _ -> if "://" `isInfixOf` s- then throwM (InvalidBaseUrlException $ "Invalid base URL: " ++ s)- else parseBaseUrl ("http://" ++ s)- where- removeTrailingSlash str = case lastMay str of- Just '/' -> init str- _ -> str
− src/Servant/Common/BasicAuth.hs
@@ -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
− src/Servant/Common/Req.hs
@@ -1,275 +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 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- { 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 Req = Req- { reqPath :: String- , 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 ++ "/" ++ 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 = path ++ 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 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)
+ test/Servant/BasicAuthSpec.hs view
@@ -0,0 +1,53 @@+{-# 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"
+ test/Servant/BrokenSpec.hs view
@@ -0,0 +1,71 @@+{-# 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
− test/Servant/ClientSpec.hs
@@ -1,489 +0,0 @@-{-# 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 #-}-#if __GLASGOW_HASKELL__ >= 800-{-# OPTIONS_GHC -freduction-depth=100 #-}-#else-{-# OPTIONS_GHC -fcontext-stack=100 #-}-#endif-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}--#include "overlapping-compat.h"-module Servant.ClientSpec 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.Compat-import System.IO.Unsafe (unsafePerformIO)-import Test.HUnit-import Test.Hspec-import Test.Hspec.QuickCheck-import Test.QuickCheck-import Web.FormUrlEncoded (FromForm, ToForm)--import Servant.API-import Servant.API.Internal.Test.ComprehensiveAPI-import Servant.Client-import Servant.Client.Generic-import qualified Servant.Common.Req as SCR-import Servant.Server-import Servant.Server.Experimental.Auth---- This declaration simply checks that all instances are in place.-_ = client comprehensiveAPI--spec :: Spec-spec = describe "Servant.Client" $ do- sucessSpec- failSpec- wrappedApiSpec- basicAuthSpec- genAuthSpec- genericClientSpec---- * test data types--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--alice :: Person-alice = Person "Alice" 42--type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]--type Api =- "get" :> Get '[JSON] Person- :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent- :<|> "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- :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]- :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool- :<|> "rawSuccess" :> 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)- :<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent-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)-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-getGet- :<|> getDeleteEmpty- :<|> getCapture- :<|> getCaptureAll- :<|> getBody- :<|> getQueryParam- :<|> getQueryParams- :<|> getQueryFlag- :<|> getRawSuccess- :<|> getRawFailure- :<|> getMultiple- :<|> getRespHeaders- :<|> getDeleteContentType = client api--server :: Application-server = serve api (- return alice- :<|> 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 $ ServantErr 400 (n ++ " not found") "" []- Nothing -> throwError $ ServantErr 400 "missing parameter" "" [])- :<|> (\ names -> return (zipWith Person names [0..]))- :<|> return- :<|> (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess")- :<|> (\ _request respond -> respond $ responseLBS HTTP.badRequest400 [] "rawFailure")- :<|> (\ a b c d -> return (a, b, c, d))- :<|> (return $ addHeader 1729 $ addHeader "eg2" True)- :<|> return NoContent- )---type FailApi =- "get" :> Raw- :<|> "capture" :> Capture "name" String :> Raw- :<|> "body" :> Raw-failApi :: Proxy FailApi-failApi = Proxy--failServer :: Application-failServer = serve failApi (- (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "")- :<|> (\ _capture _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "")- :<|> (\_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "")- )---- * 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 AuthClientData (AuthProtect "auth-tag") = ()--genAuthHandler :: AuthHandler Request ()-genAuthHandler =- let handler req = case lookup "AuthHeader" (requestHeaders req) of- Nothing -> throwError (err401 { errBody = "Missing auth header" })- Just _ -> return ()- in mkAuthHandler handler--genAuthServerContext :: Context '[ AuthHandler Request () ]-genAuthServerContext = genAuthHandler :. EmptyContext--genAuthServer :: Application-genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))---- * generic client stuff--type GenericClientAPI- = QueryParam "sqr" Int :> Get '[JSON] Int- :<|> Capture "foo" String :> NestedAPI1--data GenericClient = GenericClient- { getSqr :: Maybe Int -> SCR.ClientM Int- , mkNestedClient1 :: String -> NestedClient1- } deriving Generic-instance SOP.Generic GenericClient-instance (Client GenericClientAPI ~ client) => ClientLike client GenericClient--type NestedAPI1- = QueryParam "int" Int :> NestedAPI2- :<|> QueryParam "id" Char :> Get '[JSON] Char--data NestedClient1 = NestedClient1- { mkNestedClient2 :: Maybe Int -> NestedClient2- , idChar :: Maybe Char -> SCR.ClientM Char- } deriving Generic-instance SOP.Generic NestedClient1-instance (Client 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 ()- } deriving Generic-instance SOP.Generic NestedClient2-instance (Client NestedAPI2 ~ client) => ClientLike client NestedClient2--genericClientServer :: Application-genericClientServer = serve (Proxy :: Proxy GenericClientAPI) (- (\ mx -> case mx of- Just x -> return (x*x)- Nothing -> throwError $ ServantErr 400 "missing parameter" "" []- )- :<|> nestedServer1- )- where- 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--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-- describe "Servant.API.Delete" $ do- it "allows empty content type" $ \(_, baseUrl) -> do- (left show <$> (runClientM getDeleteEmpty (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent-- it "allows content type" $ \(_, baseUrl) -> do- (left show <$> (runClientM getDeleteContentType (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent-- it "Servant.API.Capture" $ \(_, baseUrl) -> do- (left show <$> (runClientM (getCapture "Paula") (ClientEnv manager 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-- it "Servant.API.ReqBody" $ \(_, baseUrl) -> do- let p = Person "Clara" 42- (left show <$> runClientM (getBody p) (ClientEnv manager 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"-- 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))- `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-- it "Servant.API.Raw on success" $ \(_, baseUrl) -> do- res <- runClientM (getRawSuccess HTTP.methodGet) (ClientEnv manager 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-- it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do- res <- runClientM (getRawFailure HTTP.methodGet) (ClientEnv manager 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"-- it "Returns headers appropriately" $ \(_, baseUrl) -> do- res <- runClientM getRespHeaders (ClientEnv manager baseUrl)- case res of- Left e -> assertFailure $ show e- Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]-- 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 <$> runClientM (getMultiple cap num flag body) (ClientEnv manager baseUrl)- return $- result === Right (cap, num, flag, body)---wrappedApiSpec :: Spec-wrappedApiSpec = describe "error status codes" $ do- let serveW api = serve api $ throwError $ ServantErr 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 :: SCR.ClientM ()- getResponse = client api- Left FailureResponse{..} <- runClientM getResponse (ClientEnv manager baseUrl)- responseStatus `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") :- []--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 <- runClientM getDeleteEmpty (ClientEnv manager baseUrl)- case res of- FailureResponse (HTTP.Status 404 "Not Found") _ _ -> 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)- case res of- DecodeFailure _ ("application/json") _ -> 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 ""))- 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)- 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)- case res of- InvalidContentTypeHeader "fooooo" _ -> return ()- _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res--data WrappedApi where- WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a,- HasClient api, Client api ~ SCR.ClientM ()) =>- Proxy api -> WrappedApi--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 <$> runClientM (getBasic basicAuthData) (ClientEnv manager 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"--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 = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req)- (left show <$> runClientM (getProtected authRequest) (ClientEnv manager 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")--genericClientSpec :: Spec-genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWaiApp $ do- describe "Servant.Client.Generic" $ do-- let GenericClient{..} = mkClient (client (Proxy :: Proxy GenericClientAPI))- 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 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 ()---- * 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- localhost <- inet_addr "127.0.0.1"- bind s (SockAddrInet aNY_PORT 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]
+ test/Servant/ClientTestUtils.hs view
@@ -0,0 +1,483 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# 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.Char8 as C8+import qualified Data.ByteString.Lazy as LazyByteString+import Data.Char (chr, isPrint)+import Data.Maybe (fromMaybe)+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 qualified Generics.SOP as GSOP+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 Text.Read (readMaybe)+import Web.FormUrlEncoded (FromForm, ToForm)++import Servant.API+ (AuthProtect, BasicAuth, BasicAuthData (..), Capture,+ CaptureAll, DeepQuery, DeleteNoContent, EmptyAPI,+ FormUrlEncoded, Fragment, FromHttpApiData (..), Get, Header,+ Headers, Host, JSON, MimeRender (mimeRender),+ MimeUnrender (mimeUnrender), NamedRoutes,+ NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,+ QueryParams, QueryString, Raw, ReqBody, StdMethod (GET),+ ToHttpApiData (..), UVerb, Union, Verb,+ WithStatus (WithStatus), addHeader, (:<|>) ((:<|>)), (:>))+import Servant.API.Generic ((:-))+import Servant.API.MultiVerb+import Servant.API.QueryString+ (FromDeepQuery (..), ToDeepQuery (..))+import Servant.API.Range+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]+type TestSetCookieHeaders = '[Header "Set-Cookie" String, Header "Set-Cookie" 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++newtype OtherRoutes mode = OtherRoutes+ { something :: mode :- "something" :> Get '[JSON] [String]+ } deriving Generic++-- Get for HTTP 307 Temporary Redirect+type Get307 = Verb 'GET 307++data Filter = Filter+ { ageFilter :: Integer+ , nameFilter :: String+ }+ deriving Show++instance FromDeepQuery Filter where+ fromDeepQuery params = do+ let maybeToRight l = maybe (Left l) Right+ age' <- maybeToRight "missing age" $ readMaybe . Text.unpack =<< join (lookup ["age"] params)+ name' <- maybeToRight "missing name" $ join $ lookup ["name"] params+ return $ Filter age' (Text.unpack name')++instance ToDeepQuery Filter where+ toDeepQuery (Filter age' name') =+ [ (["age"], Just (Text.pack $ show age'))+ , (["name"], Just (Text.pack name'))+ ]++-----------------------------+-- MultiVerb test endpoint --+-----------------------------++-- This is the list of all possible responses+type MultipleChoicesIntResponses =+ '[ RespondEmpty 400 "Negative"+ , Respond 200 "Even number" Bool+ , Respond 200 "Odd number" Int+ ]++data MultipleChoicesIntResult+ = NegativeNumber+ | Even Bool+ | Odd Int+ deriving stock (Generic)+ deriving (AsUnion MultipleChoicesIntResponses)+ via GenericAsUnion MultipleChoicesIntResponses MultipleChoicesIntResult++instance GSOP.Generic MultipleChoicesIntResult++-- This is our endpoint description+type MultipleChoicesInt =+ Capture "int" Int+ :> MultiVerb+ 'GET+ '[JSON]+ MultipleChoicesIntResponses+ MultipleChoicesIntResult++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+ :<|> "query-string" :> QueryString :> Get '[JSON] Person+ :<|> "deep-query" :> DeepQuery "filter" Filter :> Get '[JSON] Person+ :<|> "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 ]+ :<|> "set-cookie-headers" :> Get '[JSON] (Headers TestSetCookieHeaders Bool)+ :<|> "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+ :<|> "multiple-choices-int" :> MultipleChoicesInt+ :<|> "captureVerbatim" :> Capture "someString" Verbatim :> Get '[PlainText] Text+ :<|> "host-test" :> Host "servant.example" :> Get '[JSON] Bool+ :<|> PaginatedAPI++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+getQueryString :: [(ByteString, Maybe ByteString)] -> ClientM Person+getDeepQuery :: Filter -> ClientM Person+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 ])+getSetCookieHeaders :: ClientM (Headers TestSetCookieHeaders Bool)+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)+multiChoicesInt :: Int -> ClientM MultipleChoicesIntResult+captureVerbatim :: Verbatim -> ClientM Text+getHost :: ClientM Bool+getPaginatedPerson :: Maybe (Range 1 100) -> ClientM [Person]++getRoot+ :<|> getGet+ :<|> getGet307+ :<|> getDeleteEmpty+ :<|> getCapture+ :<|> getCaptureAll+ :<|> getBody+ :<|> getQueryParam+ :<|> getQueryParamBinary+ :<|> getQueryParams+ :<|> getQueryFlag+ :<|> getQueryString+ :<|> getDeepQuery+ :<|> getFragment+ :<|> getRawSuccess+ :<|> getRawSuccessPassHeaders+ :<|> getRawFailure+ :<|> getMultiple+ :<|> getRespHeaders+ :<|> getUVerbRespHeaders+ :<|> getSetCookieHeaders+ :<|> getDeleteContentType+ :<|> getRedirectWithCookie+ :<|> EmptyClient+ :<|> uverbGetSuccessOrRedirect+ :<|> uverbGetCreated+ :<|> recordRoutes+ :<|> multiChoicesInt+ :<|> captureVerbatim+ :<|> getHost+ :<|> getPaginatedPerson = 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+ :<|> (\case+ 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+ :<|> (\ q -> return alice { _name = maybe mempty C8.unpack $ join (lookup "name" q)+ , _age = fromMaybe 0 (readMaybe . C8.unpack =<< join (lookup "age" q))+ }+ )+ :<|> (\ filter' -> return alice { _name = nameFilter filter'+ , _age = ageFilter filter'+ }+ )+ :<|> 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 (addHeader "cookie1" $ addHeader "cookie2" 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 = const OtherRoutes+ { something = pure ["foo", "bar", "pweet"]+ }+ }+ :<|> (\param ->+ if param < 0+ then pure NegativeNumber+ else+ if even param+ then pure $ Odd 3+ else pure $ Even True+ )++ :<|> pure . decodeUtf8 . unVerbatim+ :<|> pure True+ :<|> usersServer+ )++-- * 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++newtype Verbatim = Verbatim { unVerbatim :: ByteString }++instance ToHttpApiData Verbatim where+ toEncodedUrlPiece = byteString . unVerbatim+ toUrlPiece = decodeUtf8 . unVerbatim++instance FromHttpApiData Verbatim where+ parseUrlPiece = pure . Verbatim . encodeUtf8++-- * range type example++type PaginatedAPI =+ "users" :> QueryParam "page" (Range 1 100) :> Get '[JSON] [Person]++usersServer :: Maybe (Range 1 100) -> Handler [Person]+usersServer mpage = do+ let pageNum = maybe 1 unRange mpage+ -- pageNum is guaranteed to be between 1 and 100+ return [Person "Example" $ fromIntegral pageNum]
− test/Servant/Common/BaseUrlSpec.hs
@@ -1,83 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Servant.Common.BaseUrlSpec where--import Control.DeepSeq-import Prelude ()-import Prelude.Compat-import Test.Hspec-import Test.QuickCheck--import Servant.Common.BaseUrl--spec :: Spec-spec = do- let parse = parseBaseUrl :: String -> Maybe BaseUrl- describe "showBaseUrl" $ do- it "shows a BaseUrl" $ do- showBaseUrl (BaseUrl Http "foo.com" 80 "") `shouldBe` "http://foo.com"- it "shows a https BaseUrl" $ do- showBaseUrl (BaseUrl Https "foo.com" 443 "") `shouldBe` "https://foo.com"- it "shows the path of a BaseUrl" $ do- showBaseUrl (BaseUrl Http "foo.com" 80 "api") `shouldBe` "http://foo.com/api"- it "shows the path of an https BaseUrl" $ do- showBaseUrl (BaseUrl Https "foo.com" 443 "api") `shouldBe` "https://foo.com/api"- it "handles leading slashes in path" $ do- showBaseUrl (BaseUrl Https "foo.com" 443 "/api") `shouldBe` "https://foo.com/api"-- describe "httpBaseUrl" $ do- it "allows to construct default http BaseUrls" $ do- BaseUrl Http "bar" 80 "" `shouldBe` BaseUrl Http "bar" 80 ""-- describe "parseBaseUrl" $ do- it "is total" $ do- property $ \ string ->- deepseq (fmap show (parse string )) True-- it "is the inverse of showBaseUrl" $ do- property $ \ baseUrl -> counterexample (showBaseUrl baseUrl) $- parse (showBaseUrl baseUrl) === Just baseUrl-- context "trailing slashes" $ do- it "allows trailing slashes" $ do- parse "foo.com/" `shouldBe` Just (BaseUrl Http "foo.com" 80 "")-- it "allows trailing slashes in paths" $ do- parse "foo.com/api/" `shouldBe` Just (BaseUrl Http "foo.com" 80 "api")-- context "urls without scheme" $ do- it "assumes http" $ do- parse "foo.com" `shouldBe` Just (BaseUrl Http "foo.com" 80 "")-- it "allows port numbers" $ do- parse "foo.com:8080" `shouldBe` Just (BaseUrl Http "foo.com" 8080 "")-- it "can parse paths" $ do- parse "http://foo.com/api" `shouldBe` Just (BaseUrl Http "foo.com" 80 "api")-- it "rejects ftp urls" $ do- parse "ftp://foo.com" `shouldBe` Nothing--instance Arbitrary BaseUrl where- arbitrary = BaseUrl <$>- elements [Http, Https] <*>- hostNameGen <*>- portGen <*>- pathGen- where- letters = ['a' .. 'z'] ++ ['A' .. 'Z']- -- this does not perfectly mirror the url standard, but I hope it's good- -- enough.- hostNameGen = do- first <- elements letters- middle <- listOf1 $ elements (letters ++ ['0' .. '9'] ++ ['.', '-'])- last' <- elements letters- return (first : middle ++ [last'])- portGen = frequency $- (1, return 80) :- (1, return 443) :- (1, choose (1, 20000)) :- []- pathGen = listOf1 . elements $ letters--isLeft :: Either a b -> Bool-isLeft = either (const True) (const False)
+ test/Servant/ConnectionErrorSpec.hs view
@@ -0,0 +1,55 @@+{-# 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
+ test/Servant/FailSpec.hs view
@@ -0,0 +1,79 @@+{-# 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
+ test/Servant/GenAuthSpec.hs view
@@ -0,0 +1,54 @@+{-# 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"+
+ test/Servant/GenericSpec.hs view
@@ -0,0 +1,37 @@+{-# 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"]
+ test/Servant/HoistClientSpec.hs view
@@ -0,0 +1,58 @@+{-# 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
+ test/Servant/MiddlewareSpec.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -freduction-depth=100 #-}++module Servant.MiddlewareSpec (spec) where++import Control.Arrow (left)+import Control.Concurrent (newEmptyMVar, putMVar, takeMVar)+import Control.Exception (Exception, throwIO, try)+import Control.Monad.IO.Class+import Data.ByteString.Builder (toLazyByteString)+import Data.IORef (modifyIORef, newIORef, readIORef)+import Data.Monoid ()+import Prelude.Compat+import Servant.Client+import Servant.Client.Core (RequestF (..))+import Servant.Client.Internal.HttpClient (ClientMiddleware)+import Servant.ClientTestUtils+import Test.Hspec+import Prelude ()++runClientWithMiddleware :: ClientM a -> ClientMiddleware -> BaseUrl -> IO (Either ClientError a)+runClientWithMiddleware x mid baseUrl' =+ runClientM x ((mkClientEnv manager' baseUrl') {middleware = mid})++data CustomException = CustomException deriving (Show, Eq)++instance Exception CustomException++spec :: Spec+spec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do+ it "Raw request and response can be accessed in middleware" $ \(_, baseUrl) -> do+ mvarReq <- newEmptyMVar+ mvarResp <- newEmptyMVar++ let mid :: ClientMiddleware+ mid oldApp req = do+ -- "Log" request+ liftIO $ putMVar mvarReq req+ -- perform request+ resp <- oldApp req+ -- "Log" response+ liftIO $ putMVar mvarResp resp+ pure resp++ -- Same as without middleware+ left show <$> runClientWithMiddleware getGet mid baseUrl `shouldReturn` Right alice++ -- Access some raw request data+ req <- takeMVar mvarReq+ toLazyByteString (requestPath req) `shouldBe` "/get"++ -- Access some raw response data+ resp <- takeMVar mvarResp+ responseBody resp `shouldBe` "{\"_age\":42,\"_name\":\"Alice\"}"++ it "errors can be thrown in middleware" $ \(_, baseUrl) -> do+ let mid :: ClientMiddleware+ mid oldApp req = do+ -- perform request+ resp <- oldApp req+ -- throw error+ _ <- liftIO $ throwIO CustomException+ pure resp++ try (runClientWithMiddleware getGet mid baseUrl) `shouldReturn` Left CustomException++ it "runs in the expected order" $ \(_, baseUrl) -> do+ ref <- newIORef []++ let mid1 :: ClientMiddleware+ mid1 oldApp req = do+ liftIO $ modifyIORef ref (\xs -> xs <> ["req1"])+ resp <- oldApp req+ liftIO $ modifyIORef ref (\xs -> xs <> ["resp1"])+ pure resp++ let mid2 :: ClientMiddleware+ mid2 oldApp req = do+ liftIO $ modifyIORef ref (\xs -> xs <> ["req2"])+ resp <- oldApp req+ liftIO $ modifyIORef ref (\xs -> xs <> ["resp2"])+ pure resp++ let mid3 :: ClientMiddleware+ mid3 oldApp req = do+ liftIO $ modifyIORef ref (\xs -> xs <> ["req3"])+ resp <- oldApp req+ liftIO $ modifyIORef ref (\xs -> xs <> ["resp3"])+ pure resp++ let mid :: ClientMiddleware+ mid = mid1 . mid2 . mid3+ -- \^ Composition in "reverse order".+ -- It is equivalent to the following, which is more intuitive:+ -- mid :: ClientMiddleware+ -- mid oldApp = mid1 (mid2 (mid3 oldApp))++ -- Same as without middleware+ left show <$> runClientWithMiddleware getGet mid baseUrl `shouldReturn` Right alice++ ref <- readIORef ref+ ref `shouldBe` ["req1", "req2", "req3", "resp3", "resp2", "resp1"]
+ test/Servant/StreamSpec.hs view
@@ -0,0 +1,115 @@+{-# 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.StreamSpec (spec) where++import Control.Monad.Trans.Except+import qualified Data.ByteString as BS+import Data.Proxy+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 Test.Hspec+import Servant.ClientTestUtils (Person(..))+import qualified Servant.ClientTestUtils as CT++-- 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"]
+ test/Servant/SuccessSpec.hs view
@@ -0,0 +1,202 @@+{-# 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 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 Data.Foldable+ (forM_, toList)+import Data.Maybe+ (listToMaybe)+import Data.Monoid ()+import Data.Text+ (Text)+import Data.Text.Encoding+ (encodeUtf8)+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" $ successSpec++successSpec :: Spec+successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do+ describe "Servant.API.Get" $ do+ it "get root endpoint" $ \(_, baseUrl) -> left show <$> runClient getRoot baseUrl `shouldReturn` Right carol++ it "get simple endpoint" $ \(_, baseUrl) -> left show <$> runClient getGet baseUrl `shouldReturn` Right alice++ it "get redirection endpoint" $ \(_, baseUrl) -> left show <$> runClient getGet307 baseUrl `shouldReturn` Right "redirecting"++ describe "Servant.API.Delete" $ do+ it "allows empty content type" $ \(_, baseUrl) -> left show <$> runClient getDeleteEmpty baseUrl `shouldReturn` Right NoContent++ it "allows content type" $ \(_, baseUrl) -> left show <$> runClient getDeleteContentType baseUrl `shouldReturn` Right NoContent++ it "Servant.API.Capture" $ \(_, baseUrl) -> 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.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) -> left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag++ it "Servant.API.QueryParam.QueryString" $ \(_, baseUrl) -> do+ let qs = [("name", Just "bob"), ("age", Just "1")]+ left show <$> runClient (getQueryString qs) baseUrl `shouldReturn` Right (Person "bob" 1)++ it "Servant.API.QueryParam.DeepQuery" $ \(_, baseUrl) -> left show <$> runClient (getDeepQuery $ Filter 1 "bob") baseUrl `shouldReturn` (Right (Person "bob" 1))++ it "Servant.API.Fragment" $ \(_, baseUrl) -> 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 "Returns multiple Set-Cookie headers appropriately" $ \(_, baseUrl) -> do+ res <- runClient getSetCookieHeaders baseUrl+ case res of+ Left e -> assertFailure $ show e+ Right val -> getHeaders val `shouldBe` [("Set-Cookie", "cookie1"), ("Set-Cookie", "cookie2")]++ 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 id)+ 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 = fmap (\req -> req { C.requestHeaders = [("X-Added-Header", "XXX")] })+ (defaultMakeClientRequest url r)+ 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) $ 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)++ it "encodes URL pieces following ToHttpApiData instance" $ \(_, baseUrl) -> do+ let textOrig = "*"+ eitherResponse <- runClient (captureVerbatim $ Verbatim $ encodeUtf8 textOrig) baseUrl+ case eitherResponse of+ Left clientError -> fail $ show clientError+ Right textBack -> textBack `shouldBe` textOrig
+ test/Servant/WrappedApiSpec.hs view
@@ -0,0 +1,64 @@+{-# 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 Data.Kind (Type)+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 :: Type) '[], 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") :+ []