diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ----- diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README.lhs b/README.lhs new file mode 100644 --- /dev/null +++ b/README.lhs @@ -0,0 +1,41 @@ +# servant-client + +![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png) + +This library lets you automatically derive Haskell functions that let you query each endpoint of a *servant* webservice. + +## Example + +``` haskell +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +import Data.Proxy +import Data.Text (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 +``` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 ``` diff --git a/include/overlapping-compat.h b/include/overlapping-compat.h deleted file mode 100644 --- a/include/overlapping-compat.h +++ /dev/null @@ -1,8 +0,0 @@ -#if __GLASGOW_HASKELL__ >= 710 -#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} -#define OVERLAPPING_ {-# OVERLAPPING #-} -#else -{-# LANGUAGE OverlappingInstances #-} -#define OVERLAPPABLE_ -#define OVERLAPPING_ -#endif diff --git a/servant-client.cabal b/servant-client.cabal --- a/servant-client.cabal +++ b/servant-client.cabal @@ -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 webservice. . - See . + See . . -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 diff --git a/src/Servant/Client.hs b/src/Servant/Client.hs --- a/src/Servant/Client.hs +++ b/src/Servant/Client.hs @@ -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 diff --git a/src/Servant/Client/Experimental/Auth.hs b/src/Servant/Client/Experimental/Auth.hs deleted file mode 100644 --- a/src/Servant/Client/Experimental/Auth.hs +++ /dev/null @@ -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) diff --git a/src/Servant/Client/Generic.hs b/src/Servant/Client/Generic.hs deleted file mode 100644 --- a/src/Servant/Client/Generic.hs +++ /dev/null @@ -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 - diff --git a/src/Servant/Client/Internal/HttpClient.hs b/src/Servant/Client/Internal/HttpClient.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Internal/HttpClient.hs @@ -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) diff --git a/src/Servant/Client/Internal/HttpClient/Streaming.hs b/src/Servant/Client/Internal/HttpClient/Streaming.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Internal/HttpClient/Streaming.hs @@ -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 diff --git a/src/Servant/Client/Streaming.hs b/src/Servant/Client/Streaming.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Streaming.hs @@ -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 diff --git a/src/Servant/Common/BaseUrl.hs b/src/Servant/Common/BaseUrl.hs deleted file mode 100644 --- a/src/Servant/Common/BaseUrl.hs +++ /dev/null @@ -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 diff --git a/src/Servant/Common/BasicAuth.hs b/src/Servant/Common/BasicAuth.hs deleted file mode 100644 --- a/src/Servant/Common/BasicAuth.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TypeFamilies #-} - --- | Basic Authentication for clients - -module Servant.Common.BasicAuth ( - basicAuthReq - ) where - -import Data.ByteString.Base64 (encode) -import Data.Monoid ((<>)) -import Data.Text.Encoding (decodeUtf8) -import Servant.Common.Req (addHeader, Req) -import Servant.API.BasicAuth (BasicAuthData(BasicAuthData)) - --- | Authenticate a request using Basic Authentication -basicAuthReq :: BasicAuthData -> Req -> Req -basicAuthReq (BasicAuthData user pass) req = - let authText = decodeUtf8 ("Basic " <> encode (user <> ":" <> pass)) - in addHeader "Authorization" authText req diff --git a/src/Servant/Common/Req.hs b/src/Servant/Common/Req.hs deleted file mode 100644 --- a/src/Servant/Common/Req.hs +++ /dev/null @@ -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) diff --git a/test/Servant/BasicAuthSpec.hs b/test/Servant/BasicAuthSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/BasicAuthSpec.hs @@ -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" diff --git a/test/Servant/BrokenSpec.hs b/test/Servant/BrokenSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/BrokenSpec.hs @@ -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 diff --git a/test/Servant/ClientSpec.hs b/test/Servant/ClientSpec.hs deleted file mode 100644 --- a/test/Servant/ClientSpec.hs +++ /dev/null @@ -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] diff --git a/test/Servant/ClientTestUtils.hs b/test/Servant/ClientTestUtils.hs new file mode 100644 --- /dev/null +++ b/test/Servant/ClientTestUtils.hs @@ -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] diff --git a/test/Servant/Common/BaseUrlSpec.hs b/test/Servant/Common/BaseUrlSpec.hs deleted file mode 100644 --- a/test/Servant/Common/BaseUrlSpec.hs +++ /dev/null @@ -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) diff --git a/test/Servant/ConnectionErrorSpec.hs b/test/Servant/ConnectionErrorSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/ConnectionErrorSpec.hs @@ -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 diff --git a/test/Servant/FailSpec.hs b/test/Servant/FailSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/FailSpec.hs @@ -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 diff --git a/test/Servant/GenAuthSpec.hs b/test/Servant/GenAuthSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/GenAuthSpec.hs @@ -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" + diff --git a/test/Servant/GenericSpec.hs b/test/Servant/GenericSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/GenericSpec.hs @@ -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"] diff --git a/test/Servant/HoistClientSpec.hs b/test/Servant/HoistClientSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/HoistClientSpec.hs @@ -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 diff --git a/test/Servant/MiddlewareSpec.hs b/test/Servant/MiddlewareSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/MiddlewareSpec.hs @@ -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"] diff --git a/test/Servant/StreamSpec.hs b/test/Servant/StreamSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/StreamSpec.hs @@ -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"] diff --git a/test/Servant/SuccessSpec.hs b/test/Servant/SuccessSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/SuccessSpec.hs @@ -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 diff --git a/test/Servant/WrappedApiSpec.hs b/test/Servant/WrappedApiSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/WrappedApiSpec.hs @@ -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") : + []