diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,354 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client-core/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) +- 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 +---- + +- Full query string helpers [#1604](https://github.com/haskell-servant/servant/pull/1604) + This involves exporting `setQueryString` from Servant.Client.Core.Request. + +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`, `base64-bytestring` 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 +- Loosen bound on base16-bytestring + +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. + +### 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 +---- + +- 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. + +- *servant-client-core* Related to the previous: + `streamingResponse` is removed from `RunClient`. + We have a new type-class: + + ```haskell + class RunClient m => RunStreamingClient m where + withStreamingRequest :: Request -> (StreamingResponse -> IO a) -> m a + ``` + +- 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.1 +------ + +- Merge in `servant-generic` (by [Patrick Chilton](https://github.com/chpatrick)) + into `servant` (`Servant.API.Generic`), + `servant-client-code` (`Servant.Client.Generic`) + and `servant-server` (`Servant.Server.Generic`). + +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* Free `Client` implementation. + Useful for testing `HasClient` instances. + ([#920](https://github.com/haskell-servant/servant/pull/920)) + +- *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)) + + iF you have own combinators, you'll need to define a new method of + `HasClient` class, for example: + + ```haskell + type Client m (MyCombinator :> api) = MyValue :> Client m api + hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy api) nt . cl + ``` + +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)) + 0.12 ---- diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2017, Servant Contributors +Copyright (c) 2017-2018, Servant Contributors All rights reserved. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple +import Distribution.Simple main = defaultMain 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-core.cabal b/servant-client-core.cabal --- a/servant-client-core.cabal +++ b/servant-client-core.cabal @@ -1,82 +1,160 @@ -name: servant-client-core -version: 0.12 -synopsis: Core functionality and class for client function generation for servant APIs +cabal-version: 3.0 +name: servant-client-core +version: 0.20.3.0 +synopsis: + Core functionality and class for client function generation for servant APIs + +category: Servant, Web description: This library provides backend-agnostic generation of client functions. For more information, see the README. -license: BSD3 -license-file: LICENSE -author: Servant Contributors -maintainer: haskell-servant-maintainers@googlegroups.com -homepage: http://haskell-servant.readthedocs.org/ -bug-reports: http://github.com/haskell-servant/servant/issues -cabal-version: >=1.10 -copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2017 Servant Contributors -category: Web -build-type: Simple + +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 -tested-with: - GHC==7.8.4 - GHC==7.10.3 - GHC==8.0.2 - GHC==8.2.1 source-repository head - type: git - location: http://github.com/haskell-servant/servant.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 + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + NoStarIsType + OverloadedLabels + OverloadedStrings + PackageImports + PolyKinds + RankNTypes + RecordWildCards + QuantifiedConstraints + 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.Core - Servant.Client.Core.Reexport - Servant.Client.Core.Internal.Auth - Servant.Client.Core.Internal.BaseUrl - Servant.Client.Core.Internal.BasicAuth - Servant.Client.Core.Internal.Generic - Servant.Client.Core.Internal.HasClient - Servant.Client.Core.Internal.Request - Servant.Client.Core.Internal.RunClient + Servant.Client.Core + Servant.Client.Core.Auth + Servant.Client.Core.BaseUrl + Servant.Client.Core.BasicAuth + Servant.Client.Core.ClientError + Servant.Client.Core.HasClient + Servant.Client.Core.Reexport + Servant.Client.Core.Request + Servant.Client.Core.Response + Servant.Client.Core.MultiVerb.ResponseUnrender + Servant.Client.Core.RunClient + Servant.Client.Core.ServerSentEvents + Servant.Client.Free + Servant.Client.Generic + + other-modules: Servant.Client.Core.Internal + + -- Bundled with GHC: Lower bound to not force re-installs + -- text and mtl are bundled starting with GHC-8.4 + -- + -- note: mtl lower bound is so low because of GHC-7.8 build-depends: - base >= 4.7 && < 4.11 - , base-compat >= 0.9.1 && < 0.10 - , base64-bytestring >= 1.0.0.1 && < 1.1 - , bytestring >= 0.10 && < 0.11 - , containers >= 0.5 && < 0.6 - , exceptions >= 0.8 && < 0.9 - , generics-sop >= 0.1.0.0 && < 0.4 - , http-api-data >= 0.3.6 && < 0.4 - , http-media >= 0.6.2 && < 0.8 - , http-types >= 0.8.6 && < 0.11 - , mtl >= 2.1 && < 2.3 - , network-uri >= 2.6 && < 2.7 - , safe >= 0.3.9 && < 0.4 - , servant == 0.12.* - , text >= 1.2 && < 1.3 - if !impl(ghc >= 8.0) - build-depends: - semigroups >=0.16.2.2 && <0.19 - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall - include-dirs: include + , attoparsec >= 0.13.2.2 && < 0.15 + , base >= 4.16.4.0 && < 4.22 + , bytestring >=0.11 && <0.13 + , constraints >=0.2 && <0.15 + , containers >=0.6.5.1 && <0.9 + , deepseq >=1.4.2.0 && <1.6 + , template-haskell >=2.11.1.0 && <2.24 + , text >=1.2.3.0 && <2.2 + -- Servant dependencies + build-depends: servant >=0.20.2 + + -- 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: + , aeson >=1.4.1.0 && <3 + , base-compat >=0.10.5 && <0.15 + , base64-bytestring >=1.0.0.1 && <1.3 + , exceptions >=0.10.0 && <0.11 + , free >=5.1 && <5.3 + , http-media >=0.7.1.3 && <0.9 + , http-types >=0.12.2 && <0.13 + , network-uri >=2.6.1.0 && <2.7 + , safe >=0.3.17 && <0.4 + , sop-core >=0.4.0.0 && <0.6 + + 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 + hs-source-dirs: test + main-is: Spec.hs + other-modules: + Servant.Client.Core.Internal.BaseUrlSpec + Servant.Client.Core.RequestSpec + Servant.Client.Core.ServerSentEventsSpec + + -- Dependencies inherited from the library. No need to specify bounds. build-depends: - base + , base , base-compat - , deepseq + , bytestring + , transformers + , servant , servant-client-core - , hspec == 2.* - , QuickCheck >= 2.7 && < 2.11 - build-tool-depends: - hspec-discover:hspec-discover - other-modules: - Servant.Client.Core.Internal.BaseUrlSpec + + -- Additional dependencies + build-depends: + , deepseq >=1.4.2.0 && <1.6 + , hspec >=2.6.0 && <2.12 + , QuickCheck >=2.12.6.1 && <2.16 + + build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.12 diff --git a/src/Servant/Client/Core.hs b/src/Servant/Client/Core.hs --- a/src/Servant/Client/Core.hs +++ b/src/Servant/Client/Core.hs @@ -18,6 +18,8 @@ -- * Client generation clientIn , HasClient(..) + , foldMapUnion + , matchUnion -- * Request , Request @@ -32,18 +34,24 @@ , AuthClientData -- * Generic Client - , ClientLike(..) - , genericMkClientL - , genericMkClientP - , ServantError(..) + , ClientError(..) , EmptyClient(..) - -- * Response - , Response(..) + , Response + , ResponseF (..) , RunClient(..) - , module Servant.Client.Core.Internal.BaseUrl + -- * BaseUrl + , BaseUrl (..) + , Scheme (..) + , showBaseUrl + , parseBaseUrl + , InvalidBaseUrlException (..) + -- ** Streaming + , RunStreamingClient(..) + , StreamingResponse + -- * Writing HasClient instances -- | These functions need not be re-exported by backend libraries. , addHeader @@ -51,15 +59,15 @@ , appendToPath , setRequestBodyLBS , setRequestBody + , encodeQueryParamValue ) where -import Servant.Client.Core.Internal.Auth -import Servant.Client.Core.Internal.BaseUrl (BaseUrl (..), - InvalidBaseUrlException, - Scheme (..), - parseBaseUrl, - showBaseUrl) -import Servant.Client.Core.Internal.BasicAuth -import Servant.Client.Core.Internal.HasClient -import Servant.Client.Core.Internal.Generic -import Servant.Client.Core.Internal.Request -import Servant.Client.Core.Internal.RunClient +import Servant.Client.Core.Auth +import Servant.Client.Core.BaseUrl + (BaseUrl (..), InvalidBaseUrlException (..), Scheme (..), + parseBaseUrl, showBaseUrl) +import Servant.Client.Core.BasicAuth +import Servant.Client.Core.ClientError +import Servant.Client.Core.HasClient +import Servant.Client.Core.Request +import Servant.Client.Core.Response +import Servant.Client.Core.RunClient diff --git a/src/Servant/Client/Core/Auth.hs b/src/Servant/Client/Core/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Core/Auth.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-- | Authentication for clients + +module Servant.Client.Core.Auth ( + AuthClientData, + AuthenticatedRequest (..), + mkAuthenticatedRequest, + ) where + +import Data.Kind (Type) + +import Servant.Client.Core.Request + (Request) + +-- | For a resource protected by authentication (e.g. AuthProtect), we need +-- to provide the client with some data used to add authentication data +-- to a request +-- +-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE +type family AuthClientData a :: Type + +-- | 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 AuthenticatedRequest a = + AuthenticatedRequest { unAuthReq :: (AuthClientData a, AuthClientData a -> Request -> Request) } + +-- | Handy helper to avoid wrapping datatypes in tuples everywhere. +-- +-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE +mkAuthenticatedRequest :: AuthClientData a + -> (AuthClientData a -> Request -> Request) + -> AuthenticatedRequest a +mkAuthenticatedRequest val func = AuthenticatedRequest (val, func) diff --git a/src/Servant/Client/Core/BaseUrl.hs b/src/Servant/Client/Core/BaseUrl.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Core/BaseUrl.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE DeriveLift #-} +module Servant.Client.Core.BaseUrl ( + BaseUrl (..), + Scheme (..), + showBaseUrl, + parseBaseUrl, + InvalidBaseUrlException (..), + ) where + +import Control.DeepSeq + (NFData (..)) +import Control.Monad.Catch + (Exception, MonadThrow, throwM) +import Data.Aeson + (FromJSON (..), FromJSONKey (..), ToJSON (..), ToJSONKey (..)) +import Data.Aeson.Types + (FromJSONKeyFunction (..), contramapToJSONKeyFunction, + withText) +import Data.Data + (Data) +import qualified Data.List as List +import qualified Data.Text as T +import GHC.Generics +import Language.Haskell.TH.Syntax + (Lift) +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, Lift, Data) + +-- | 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, Lift, Data) +-- TODO: Ord is more precise than Eq +-- TODO: Add Hashable instance? +-- +instance NFData BaseUrl where + rnf (BaseUrl a b c d) = a `seq` rnf b `seq` rnf c `seq` rnf d + +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 + +-- | >>> traverse_ (LBS8.putStrLn . encode) (parseBaseUrl "api.example.com" :: [BaseUrl]) +-- "http://api.example.com" +instance ToJSON BaseUrl where + toJSON = toJSON . showBaseUrl + toEncoding = toEncoding . showBaseUrl + +-- | >>> parseBaseUrl "api.example.com" >>= decode . encode :: Maybe BaseUrl +-- Just (BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = ""}) +instance FromJSON BaseUrl where + parseJSON = withText "BaseUrl" $ \t -> case parseBaseUrl (T.unpack t) of + Just u -> return u + Nothing -> fail $ "Invalid base url: " ++ T.unpack t + +-- | >>> :{ +-- traverse_ (LBS8.putStrLn . encode) $ do +-- u1 <- parseBaseUrl "api.example.com" :: [BaseUrl] +-- u2 <- parseBaseUrl "example.com" :: [BaseUrl] +-- return $ Map.fromList [(u1, 'x'), (u2, 'y')] +-- :} +-- {"http://api.example.com":"x","http://example.com":"y"} +instance ToJSONKey BaseUrl where + toJSONKey = contramapToJSONKeyFunction showBaseUrl toJSONKey + +instance FromJSONKey BaseUrl where + fromJSONKey = FromJSONKeyTextParser $ \t -> case parseBaseUrl (T.unpack t) of + Just u -> return u + Nothing -> fail $ "Invalid base url: " ++ T.unpack t + +-- | >>> showBaseUrl <$> parseBaseUrl "api.example.com" +-- "http://api.example.com" +showBaseUrl :: BaseUrl -> String +showBaseUrl (BaseUrl urlscheme host port path) = + schemeString ++ "//" ++ host ++ (portString path) + where + a b = if "/" `List.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 + +newtype InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show) +instance Exception InvalidBaseUrlException + +-- | +-- +-- >>> parseBaseUrl "api.example.com" +-- BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = ""} +-- +-- /Note:/ trailing slash is removed +-- +-- >>> parseBaseUrl "api.example.com/" +-- BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = ""} +-- +-- >>> parseBaseUrl "api.example.com/dir/" +-- BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = "/dir"} +-- +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 "://" `List.isInfixOf` s + then throwM (InvalidBaseUrlException $ "Invalid base URL: " ++ s) + else parseBaseUrl ("http://" ++ s) + where + removeTrailingSlash str = case lastMay str of + Just '/' -> init str + _ -> str + +-- $setup +-- +-- >>> import Data.Aeson +-- >>> import Data.Foldable (traverse_) +-- >>> import qualified Data.ByteString.Lazy.Char8 as LBS8 +-- >>> import qualified Data.Map.Strict as Map diff --git a/src/Servant/Client/Core/BasicAuth.hs b/src/Servant/Client/Core/BasicAuth.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Core/BasicAuth.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-- | Basic Authentication for clients +module Servant.Client.Core.BasicAuth ( + basicAuthReq, + ) where + +import Data.ByteString.Base64 + (encode) +import Data.Text.Encoding + (decodeUtf8) +import Servant.API.BasicAuth + (BasicAuthData (BasicAuthData)) +import Servant.Client.Core.Request + (Request, addHeader) + +-- | Authenticate a request using Basic Authentication +basicAuthReq :: BasicAuthData -> Request -> Request +basicAuthReq (BasicAuthData user pass) req = + let authText = decodeUtf8 ("Basic " <> encode (user <> ":" <> pass)) + in addHeader "Authorization" authText req diff --git a/src/Servant/Client/Core/ClientError.hs b/src/Servant/Client/Core/ClientError.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Core/ClientError.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Servant.Client.Core.ClientError ( + ClientError (..), + ) where + +import Prelude () +import Prelude.Compat + +import Control.DeepSeq + (NFData (..)) +import Control.Exception + (SomeException (..)) +import Control.Monad.Catch + (Exception) +import qualified Data.ByteString as BS +import Data.Text + (Text) +import Data.Typeable + (Typeable, typeOf) +import GHC.Generics + (Generic) +import Network.HTTP.Media + (MediaType) +import Network.HTTP.Types () + +import Servant.Client.Core.BaseUrl +import Servant.Client.Core.Internal + (mediaTypeRnf) +import Servant.Client.Core.Request +import Servant.Client.Core.Response + + +-- | A type representing possible errors in a request +-- +-- Note that this type substantially changed in 0.12. +data ClientError = + -- | 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 + -- | The body could not be decoded at the expected type + | DecodeFailure Text Response + -- | The content-type of the response is not supported + | UnsupportedContentType MediaType Response + -- | The content-type header is invalid + | InvalidContentTypeHeader Response + -- | There was a connection error, and no response was received + | ConnectionError SomeException + deriving (Show, Generic, Typeable) + +instance Eq ClientError where + FailureResponse req res == FailureResponse req' res' = req == req' && res == res' + DecodeFailure t r == DecodeFailure t' r' = t == t' && r == r' + UnsupportedContentType mt r == UnsupportedContentType mt' r' = mt == mt' && r == r' + InvalidContentTypeHeader r == InvalidContentTypeHeader r' = r == r' + ConnectionError exc == ConnectionError exc' = eqSomeException exc exc' + where + -- returns true, if type of exception is the same + eqSomeException (SomeException a) (SomeException b) = typeOf a == typeOf b + + -- prevent wild card blindness + FailureResponse {} == _ = False + DecodeFailure {} == _ = False + UnsupportedContentType {} == _ = False + InvalidContentTypeHeader {} == _ = False + ConnectionError {} == _ = False + +instance Exception ClientError + +-- | Note: an exception in 'ConnectionError' might not be evaluated fully, +-- We only 'rnf' its 'show'ed value. +instance NFData ClientError where + rnf (FailureResponse req res) = rnf req `seq` rnf res + rnf (DecodeFailure err res) = rnf err `seq` rnf res + rnf (UnsupportedContentType mt' res) = mediaTypeRnf mt' `seq` rnf res + rnf (InvalidContentTypeHeader res) = rnf res + rnf (ConnectionError err) = err `seq` rnf (show err) diff --git a/src/Servant/Client/Core/HasClient.hs b/src/Servant/Client/Core/HasClient.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Core/HasClient.hs @@ -0,0 +1,1149 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ApplicativeDo #-} +{-# OPTIONS_GHC -Wno-missing-methods #-} +module Servant.Client.Core.HasClient ( + clientIn, + HasClient (..), + EmptyClient (..), + AsClientT, + (//), + (/:), + foldMapUnion, + matchUnion, + fromSomeClientResponse + ) where + +import Prelude () +import Prelude.Compat + +import Control.Arrow + (left, (+++)) +import qualified Data.Text as Text +import Control.Monad + (unless) +import qualified Data.ByteString.Lazy as BSL +import Data.Either + (partitionEithers) +import Data.Constraint (Dict(..)) +import Data.Foldable + (toList) +import Data.Kind + (Type) +import qualified Data.List as List +import Data.Sequence + (fromList) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Network.HTTP.Media + (MediaType, matches, parseAccept) +import qualified Network.HTTP.Media as Media +import qualified Data.Sequence as Seq +import Data.SOP.BasicFunctors + (I (I), (:.:) (Comp)) +import Data.SOP.Constraint + (All) +import Data.SOP.NP + (NP (..), cpure_NP) +import Data.SOP.NS + (NS (..)) +import Data.String + (fromString) +import Data.Text + (Text, pack) +import GHC.TypeLits + (KnownNat, KnownSymbol, TypeError, symbolVal) +import Network.HTTP.Types + (Status) +import qualified Network.HTTP.Types as H +import Servant.API + ((:<|>) ((:<|>)), (:>), + BuildHeadersTo (..), + EmptyAPI, + FromSourceIO (..), + IsSecure, + MimeUnrender (mimeUnrender), + NoContentVerb, + ReflectMethod (..), + StreamBody', + Verb, + getResponse, AuthProtect, BasicAuth, BasicAuthData, Capture', CaptureAll, DeepQuery, Description, Fragment, FramingRender (..), FramingUnrender (..), Header', Headers (..), HttpVersion, MimeRender (mimeRender), NoContent (NoContent), QueryFlag, QueryParam', QueryParams, QueryString, Raw, RawM, RemoteHost, ReqBody', SBoolI, Stream, Summary, ToHttpApiData, ToSourceIO (..), Vault, WithNamedContext, WithResource, WithStatus (..), contentType, getHeadersHList, toEncodedUrlPiece, NamedRoutes, Host) +import Servant.API.Generic + (GenericMode(..), ToServant, ToServantApi + , GenericServant, toServant, fromServant) +import Servant.API.ContentTypes + (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender), EventStream) +import Servant.API.QueryString (ToDeepQuery(..), generateDeepParam) +import Servant.API.Status + (statusFromNat) +import Servant.API.TypeLevel (FragmentUnique, AtMostOneFragment) +import Servant.API.Modifiers + (FoldRequired, RequiredArgument, foldRequiredArgument) +import Servant.API.TypeErrors +import Servant.API.UVerb + (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion) +import Servant.API.ServerSentEvents + (EventKind (JsonEvent, RawEvent), ServerSentEvents') +import Servant.API.Stream + (NoFraming) + +import Servant.Client.Core.Auth +import Servant.Client.Core.BasicAuth +import Servant.Client.Core.ClientError +import Servant.Client.Core.Request +import Servant.Client.Core.Response +import Servant.Client.Core.MultiVerb.ResponseUnrender +import qualified Servant.Client.Core.Response as Response +import Servant.Client.Core.RunClient +import Servant.Client.Core.ServerSentEvents +import Servant.API.MultiVerb +import qualified Network.HTTP.Media as M +import Data.Typeable + +-- * Accessing APIs as a Client + +-- | 'clientIn' allows you to produce operations to query an API from a client +-- within a 'RunClient' monad. +-- +-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books +-- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > clientM :: Proxy ClientM +-- > clientM = Proxy +-- > +-- > getAllBooks :: ClientM [Book] +-- > postNewBook :: Book -> ClientM Book +-- > (getAllBooks :<|> postNewBook) = myApi `clientIn` clientM +clientIn :: HasClient m api => Proxy api -> Proxy m -> Client m api +clientIn p pm = clientWithRoute pm p defaultRequest + +-- | This class lets us define how each API combinator influences the creation +-- of an HTTP request. +-- +-- Unless you are writing a new backend for @servant-client-core@ or new +-- combinators that you want to support client-generation, you can ignore this +-- class. +class RunClient m => HasClient m api where + type Client (m :: Type -> Type) (api :: Type) :: Type + clientWithRoute :: Proxy m -> Proxy api -> Request -> Client m api + hoistClientMonad + :: Proxy m + -> Proxy api + -> (forall x. mon x -> mon' x) + -> Client mon api + -> Client mon' api + +-- | A client querying function for @a ':<|>' b@ will actually hand you +-- one function for querying @a@ and another one for querying @b@, +-- stitching them together with ':<|>', which really is just like a pair. +-- +-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books +-- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getAllBooks :: ClientM [Book] +-- > postNewBook :: Book -> ClientM Book +-- > (getAllBooks :<|> postNewBook) = client myApi +instance (HasClient m a, HasClient m b) => HasClient m (a :<|> b) where + type Client m (a :<|> b) = Client m a :<|> Client m b + clientWithRoute pm Proxy req = + clientWithRoute pm (Proxy :: Proxy a) req :<|> + clientWithRoute pm (Proxy :: Proxy b) req + + hoistClientMonad pm _ f (ca :<|> cb) = + hoistClientMonad pm (Proxy :: Proxy a) f ca :<|> + hoistClientMonad pm (Proxy :: Proxy b) f cb + +-- | Singleton type representing a client for an empty API. +data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum) + +-- | The client for 'EmptyAPI' is simply 'EmptyClient'. +-- +-- > type MyAPI = "books" :> Get '[JSON] [Book] -- GET /books +-- > :<|> "nothing" :> EmptyAPI +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getAllBooks :: ClientM [Book] +-- > (getAllBooks :<|> EmptyClient) = client myApi +instance RunClient m => HasClient m EmptyAPI where + type Client m EmptyAPI = EmptyClient + clientWithRoute _pm Proxy _ = EmptyClient + hoistClientMonad _ _ _ EmptyClient = EmptyClient + +-- | If you use a 'Capture' in one of your endpoints in your API, +-- the corresponding querying function will automatically take +-- an additional argument of the type specified by your 'Capture'. +-- That function will take care of inserting a textual representation +-- of this value at the right place in the request path. +-- +-- You can control how values for this type are turned into +-- text by specifying a 'ToHttpApiData' instance for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBook :: Text -> ClientM Book +-- > getBook = client myApi +-- > -- then you can just use "getBook" to query that endpoint +instance (ToHttpApiData a, HasClient m api) + => HasClient m (Capture' mods capture a :> api) where + + type Client m (Capture' mods capture a :> api) = + a -> Client m api + + clientWithRoute pm Proxy req val = + clientWithRoute pm (Proxy :: Proxy api) + (appendToPath p req) + + where p = toEncodedUrlPiece val + + hoistClientMonad pm _ f cl = \a -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl a) + +-- | 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 (ToHttpApiData a, HasClient m sublayout) + => HasClient m (CaptureAll capture a :> sublayout) where + + type Client m (CaptureAll capture a :> sublayout) = + [a] -> Client m sublayout + + clientWithRoute pm Proxy req vals = + clientWithRoute pm (Proxy :: Proxy sublayout) + (List.foldl' (flip appendToPath) req ps) + + where ps = map toEncodedUrlPiece vals + + hoistClientMonad pm _ f cl = \as -> + hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as) + +instance {-# OVERLAPPABLE #-} + -- Note [Non-Empty Content Types] + ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) + , KnownNat status + ) => HasClient m (Verb method status cts' a) where + type Client m (Verb method status cts' a) = m a + clientWithRoute _pm Proxy req = do + response <- runRequestAcceptStatus (Just [status]) req + { requestAccept = fromList $ toList accept + , requestMethod = method + } + response `decodedAs` (Proxy :: Proxy ct) + where + accept = contentTypes (Proxy :: Proxy ct) + method = reflectMethod (Proxy :: Proxy method) + status = statusFromNat (Proxy :: Proxy status) + + hoistClientMonad _ _ f ma = f ma + +instance {-# OVERLAPPING #-} + ( RunClient m, ReflectMethod method, KnownNat status + ) => HasClient m (Verb method status cts NoContent) where + type Client m (Verb method status cts NoContent) + = m NoContent + clientWithRoute _pm Proxy req = do + _response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method } + return NoContent + where method = reflectMethod (Proxy :: Proxy method) + status = statusFromNat (Proxy :: Proxy status) + + hoistClientMonad _ _ f ma = f ma + +instance (RunClient m, ReflectMethod method) => + HasClient m (NoContentVerb method) where + type Client m (NoContentVerb method) + = m NoContent + clientWithRoute _pm Proxy req = do + _response <- runRequest req { requestMethod = method } + return NoContent + where method = reflectMethod (Proxy :: Proxy method) + + hoistClientMonad _ _ f ma = f ma + +instance {-# OVERLAPPING #-} + -- Note [Non-Empty Content Types] + ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls, KnownNat status + , ReflectMethod method, cts' ~ (ct ': cts) + ) => HasClient m (Verb method status cts' (Headers ls a)) where + type Client m (Verb method status cts' (Headers ls a)) + = m (Headers ls a) + clientWithRoute _pm Proxy req = do + response <- runRequestAcceptStatus (Just [status]) req + { requestMethod = method + , requestAccept = fromList $ toList accept + } + val <- response `decodedAs` (Proxy :: Proxy ct) + return $ Headers { getResponse = val + , getHeadersHList = buildHeadersTo . toList $ responseHeaders response + } + where + method = reflectMethod (Proxy :: Proxy method) + accept = contentTypes (Proxy :: Proxy ct) + status = statusFromNat (Proxy :: Proxy status) + + hoistClientMonad _ _ f ma = f ma + +instance {-# OVERLAPPING #-} + ( RunClient m, BuildHeadersTo ls, ReflectMethod method, KnownNat status + ) => HasClient m (Verb method status cts (Headers ls NoContent)) where + type Client m (Verb method status cts (Headers ls NoContent)) + = m (Headers ls NoContent) + clientWithRoute _pm Proxy req = do + response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method } + return $ Headers { getResponse = NoContent + , getHeadersHList = buildHeadersTo . toList $ responseHeaders response + } + where + method = reflectMethod (Proxy :: Proxy method) + status = statusFromNat (Proxy :: Proxy status) + + hoistClientMonad _ _ f ma = f ma + +data ClientParseError = ClientParseError MediaType String | ClientStatusMismatch | ClientNoMatchingStatus + deriving (Eq, Show) + +class UnrenderResponse (cts :: [Type]) (a :: Type) where + unrenderResponse :: Seq.Seq H.Header -> BSL.ByteString -> Proxy cts + -> [Either (MediaType, String) a] + +instance {-# OVERLAPPABLE #-} AllMimeUnrender cts a => UnrenderResponse cts a where + unrenderResponse _ body = map parse . allMimeUnrender + where parse (mediaType, parser) = left ((,) mediaType) (parser body) + +instance {-# OVERLAPPING #-} forall cts a h . (UnrenderResponse cts a, BuildHeadersTo h) + => UnrenderResponse cts (Headers h a) where + unrenderResponse hs body = (map . fmap) setHeaders . unrenderResponse hs body + where + setHeaders :: a -> Headers h a + setHeaders x = Headers x (buildHeadersTo (toList hs)) + +instance {-# OVERLAPPING #-} UnrenderResponse cts a + => UnrenderResponse cts (WithStatus n a) where + unrenderResponse hs body = (map . fmap) WithStatus . unrenderResponse hs body + +instance {-# OVERLAPPING #-} + ( RunClient m, + contentTypes ~ (contentType ': otherContentTypes), + -- ('otherContentTypes' should be '_', but even -XPartialTypeSignatures does not seem + -- allow this in instance types as of 8.8.3.) + as ~ (a ': as'), + AllMime contentTypes, + ReflectMethod method, + All (UnrenderResponse contentTypes) as, + All HasStatus as, HasStatuses as', + Unique (Statuses as) + ) => + HasClient m (UVerb method contentTypes as) + where + type Client m (UVerb method contentTypes as) = m (Union as) + + clientWithRoute _ _ request = do + let accept = Seq.fromList . allMime $ Proxy @contentTypes + -- offering to accept all mime types listed in the api gives best compatibility. eg., + -- we might not own the server implementation, and the server may choose to support + -- only part of the api. + + method = reflectMethod $ Proxy @method + acceptStatus = statuses (Proxy @as) + response@Response{responseBody=body, responseStatusCode=status, responseHeaders=headers} + <- runRequestAcceptStatus (Just acceptStatus) (request {requestMethod = method, requestAccept = accept}) + responseContentType <- checkContentTypeHeader response + unless (any (matches responseContentType) accept) $ do + throwClientError $ UnsupportedContentType responseContentType response + + let res = tryParsers status $ mimeUnrenders (Proxy @contentTypes) headers body + case res of + Left errors -> throwClientError $ DecodeFailure (T.pack (show errors)) response + Right x -> return x + where + -- | Given a list of parsers of 'mkres', returns the first one that succeeds and all the + -- failures it encountered along the way + -- TODO; better name, rewrite haddocs. + tryParsers :: forall xs. All HasStatus xs => Status -> NP ([] :.: Either (MediaType, String)) xs -> Either [ClientParseError] (Union xs) + tryParsers _ Nil = Left [ClientNoMatchingStatus] + tryParsers status (Comp x :* xs) + | status == statusOf (Comp x) = + case partitionEithers x of + (err', []) -> (map (uncurry ClientParseError) err' ++) +++ S $ tryParsers status xs + (_, (res : _)) -> Right . inject . I $ res + | otherwise = -- no reason to parse in the first place. This ain't the one we're looking for + (ClientStatusMismatch :) +++ S $ tryParsers status xs + + -- | Given a list of types, parses the given response body as each type + mimeUnrenders :: + forall cts xs. + All (UnrenderResponse cts) xs => + Proxy cts -> + Seq.Seq H.Header -> + BSL.ByteString -> + NP ([] :.: Either (MediaType, String)) xs + mimeUnrenders ctp headers body = cpure_NP + (Proxy @(UnrenderResponse cts)) + (Comp . unrenderResponse headers body $ ctp) + + hoistClientMonad _ _ nt s = nt s + +instance {-# OVERLAPPABLE #-} + ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method, + FramingUnrender framing, FromSourceIO chunk a + ) => HasClient m (Stream method status framing ct a) where + + type Client m (Stream method status framing ct a) = m a + + hoistClientMonad _ _ f ma = f ma + + clientWithRoute _pm Proxy req = withStreamingRequest req' $ \Response{responseBody=body} -> do + let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BSL.ByteString -> Either String chunk + framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' + fromSourceIO $ framingUnrender' body + where + req' = req + { requestAccept = fromList [contentType (Proxy :: Proxy ct)] + , requestMethod = reflectMethod (Proxy :: Proxy method) + } + +instance {-# OVERLAPPING #-} + ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method, + FramingUnrender framing, FromSourceIO chunk a, + BuildHeadersTo hs + ) => HasClient m (Stream method status framing ct (Headers hs a)) where + + type Client m (Stream method status framing ct (Headers hs a)) = m (Headers hs a) + + hoistClientMonad _ _ f ma = f ma + + clientWithRoute _pm Proxy req = withStreamingRequest req' $ + \Response{responseBody=body, responseHeaders=headers} -> do + let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BSL.ByteString -> Either String chunk + framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' + val <- fromSourceIO $ framingUnrender' body + return $ Headers + { getResponse = val + , getHeadersHList = buildHeadersTo $ toList headers + } + + where + req' = req + { requestAccept = fromList [contentType (Proxy :: Proxy ct)] + , requestMethod = reflectMethod (Proxy :: Proxy method) + } + +type SseClientDelegate method status = + Stream method status NoFraming EventStream + +instance + ( RunClient m + , HasClient m (SseClientDelegate method status (EventMessageStreamT IO)) + ) + => HasClient m (ServerSentEvents' method status 'RawEvent EventMessage) where + type Client m (ServerSentEvents' method status 'RawEvent EventMessage) = + Client m (SseClientDelegate method status (EventMessageStreamT IO)) + + hoistClientMonad p _ = + hoistClientMonad + p + (Proxy :: Proxy (SseClientDelegate method status (EventMessageStreamT IO))) + + clientWithRoute p _ = + clientWithRoute + p + (Proxy :: Proxy (SseClientDelegate method status (EventMessageStreamT IO))) + +instance + ( RunClient m + , HasClient m (SseClientDelegate method status (EventStreamT IO)) + ) + => HasClient m (ServerSentEvents' method status 'RawEvent (Event a)) where + type Client m (ServerSentEvents' method status 'RawEvent (Event a)) = + Client m (SseClientDelegate method status (EventStreamT IO)) + + hoistClientMonad p _ = + hoistClientMonad + p + (Proxy :: Proxy (SseClientDelegate method status (EventStreamT IO))) + + clientWithRoute p _ = + clientWithRoute + p + (Proxy :: Proxy (SseClientDelegate method status (EventStreamT IO))) + +instance + ( RunClient m + , HasClient m (SseClientDelegate method status (JsonEventStreamT IO a)) + ) + => HasClient m (ServerSentEvents' method status 'JsonEvent a) where + type Client m (ServerSentEvents' method status 'JsonEvent a) = + Client m (SseClientDelegate method status (JsonEventStreamT IO a)) + + hoistClientMonad p _ = + hoistClientMonad + p + (Proxy :: Proxy (SseClientDelegate method status (JsonEventStreamT IO a))) + + clientWithRoute p _ = + clientWithRoute + p + (Proxy :: Proxy (SseClientDelegate method status (JsonEventStreamT IO a))) + +-- | If you use a 'Header' in one of your endpoints in your API, +-- the corresponding querying function will automatically take +-- an additional argument of the type specified by your 'Header', +-- wrapped in Maybe. +-- +-- That function will take care of encoding this argument as Text +-- in the request headers. +-- +-- All you need is for your type to have a 'ToHttpApiData' instance. +-- +-- Example: +-- +-- > newtype Referer = Referer { referrer :: Text } +-- > deriving (Eq, Show, Generic, ToHttpApiData) +-- > +-- > -- GET /view-my-referer +-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > viewReferer :: Maybe Referer -> ClientM Book +-- > viewReferer = client myApi +-- > -- then you can just use "viewRefer" to query that endpoint +-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments +instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods)) + => HasClient m (Header' mods sym a :> api) where + + type Client m (Header' mods sym a :> api) = + RequiredArgument mods a -> Client m api + + clientWithRoute pm Proxy req mval = + clientWithRoute pm (Proxy :: Proxy api) $ foldRequiredArgument + (Proxy :: Proxy mods) add (maybe req add) mval + where + hname = fromString $ symbolVal (Proxy :: Proxy sym) + + add :: a -> Request + add value = addHeader hname value req + + hoistClientMonad pm _ f cl = \arg -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl arg) + +instance (KnownSymbol sym, HasClient m api) => HasClient m (Host sym :> api) where + type Client m (Host sym :> api) = Client m api + + clientWithRoute pm Proxy req = + clientWithRoute pm (Proxy :: Proxy api) $ + addHeader "Host" (symbolVal (Proxy :: Proxy sym)) req + + hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api) + +-- | Using a 'HttpVersion' combinator in your API doesn't affect the client +-- functions. +instance HasClient m api + => HasClient m (HttpVersion :> api) where + + type Client m (HttpVersion :> api) = + Client m api + + clientWithRoute pm Proxy = + clientWithRoute pm (Proxy :: Proxy api) + + hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl + +-- | Ignore @'Summary'@ in client functions. +instance HasClient m api => HasClient m (Summary desc :> api) where + type Client m (Summary desc :> api) = Client m api + + clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api) + + hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl + +-- | Ignore @'Description'@ in client functions. +instance HasClient m api => HasClient m (Description desc :> api) where + type Client m (Description desc :> api) = Client m api + + clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api) + + hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl + +-- | If you use a 'QueryParam' in one of your endpoints in your API, +-- the corresponding querying function will automatically take +-- an additional argument of the type specified by your 'QueryParam', +-- enclosed in Maybe. +-- +-- If you give Nothing, nothing will be added to the query string. +-- +-- If you give a non-'Nothing' value, this function will take care +-- of inserting a textual representation of this value in the query string. +-- +-- You can control how values for your type are turned into +-- text by specifying a 'ToHttpApiData' instance for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooksBy :: Maybe Text -> ClientM [Book] +-- > getBooksBy = client myApi +-- > -- then you can just use "getBooksBy" to query that endpoint. +-- > -- 'getBooksBy Nothing' for all books +-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov +instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods)) + => HasClient m (QueryParam' mods sym a :> api) where + + type Client m (QueryParam' mods sym a :> api) = + RequiredArgument mods a -> Client m api + + -- if mparam = Nothing, we don't add it to the query string + clientWithRoute pm Proxy req mparam = + clientWithRoute pm (Proxy :: Proxy api) $ foldRequiredArgument + (Proxy :: Proxy mods) add (maybe req add) mparam + where + add :: a -> Request + add param = appendToQueryString pname (Just $ encodeQueryParamValue param) req + + pname :: Text + pname = pack $ symbolVal (Proxy :: Proxy sym) + + hoistClientMonad pm _ f cl = \arg -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl arg) + +-- | If you use a 'QueryParams' in one of your endpoints in your API, +-- the corresponding querying function will automatically take +-- an additional argument, a list of values of the type specified +-- by your 'QueryParams'. +-- +-- If you give an empty list, nothing will be added to the query string. +-- +-- Otherwise, this function will take care +-- of inserting a textual representation of your values in the query string, +-- under the same query string parameter name. +-- +-- You can control how values for your type are turned into +-- text by specifying a 'ToHttpApiData' instance for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooksBy :: [Text] -> ClientM [Book] +-- > getBooksBy = client myApi +-- > -- then you can just use "getBooksBy" to query that endpoint. +-- > -- 'getBooksBy []' for all books +-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]' +-- > -- to get all books by Asimov and Heinlein +instance (KnownSymbol sym, ToHttpApiData a, HasClient m api) + => HasClient m (QueryParams sym a :> api) where + + type Client m (QueryParams sym a :> api) = + [a] -> Client m api + + clientWithRoute pm Proxy req paramlist = + clientWithRoute pm (Proxy :: Proxy api) + (List.foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just)) + req + paramlist' + ) + + where pname = pack $ symbolVal (Proxy :: Proxy sym) + paramlist' = map (Just . encodeQueryParamValue) paramlist + + hoistClientMonad pm _ f cl = \as -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl as) + +-- | If you use a 'QueryFlag' in one of your endpoints in your API, +-- the corresponding querying function will automatically take +-- an additional 'Bool' argument. +-- +-- If you give 'False', nothing will be added to the query string. +-- +-- Otherwise, this function will insert a value-less query string +-- parameter under the name associated to your 'QueryFlag'. +-- +-- Example: +-- +-- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooks :: Bool -> ClientM [Book] +-- > getBooks = client myApi +-- > -- then you can just use "getBooks" to query that endpoint. +-- > -- 'getBooksBy False' for all books +-- > -- 'getBooksBy True' to only get _already published_ books +instance (KnownSymbol sym, HasClient m api) + => HasClient m (QueryFlag sym :> api) where + + type Client m (QueryFlag sym :> api) = + Bool -> Client m api + + clientWithRoute pm Proxy req flag = + clientWithRoute pm (Proxy :: Proxy api) + (if flag + then appendToQueryString paramname Nothing req + else req + ) + + where paramname = pack $ symbolVal (Proxy :: Proxy sym) + + hoistClientMonad pm _ f cl = \b -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl b) + +instance (HasClient m api) + => HasClient m (QueryString :> api) where + type Client m (QueryString :> api) = + H.Query -> Client m api + + clientWithRoute pm Proxy req query = + clientWithRoute pm (Proxy :: Proxy api) + (setQueryString query req) + + hoistClientMonad pm _ f cl = \b -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl b) + +instance (KnownSymbol sym, ToDeepQuery a, HasClient m api) + => HasClient m (DeepQuery sym a :> api) where + type Client m (DeepQuery sym a :> api) = + a -> Client m api + + clientWithRoute pm Proxy req deepObject = + let params = toDeepQuery deepObject + withParams = List.foldl' addDeepParam req params + addDeepParam r' kv = + let (k, textV) = generateDeepParam paramname kv + in appendToQueryString k (encodeUtf8 <$> textV) r' + paramname = pack $ symbolVal (Proxy :: Proxy sym) + in clientWithRoute pm (Proxy :: Proxy api) + withParams + + hoistClientMonad pm _ f cl = \b -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl b) + +-- | Pick a 'Method' and specify where the server you want to query is. You get +-- back the full `Response`. +instance RunClient m => HasClient m Raw where + type Client m Raw + = H.Method -> m Response + + clientWithRoute :: Proxy m -> Proxy Raw -> Request -> Client m Raw + clientWithRoute _pm Proxy req httpMethod = do + runRequest req { requestMethod = httpMethod } + + hoistClientMonad _ _ f cl = \meth -> f (cl meth) + +instance RunClient m => HasClient m RawM where + type Client m RawM + = H.Method -> m Response + + clientWithRoute :: Proxy m -> Proxy RawM -> Request -> Client m RawM + clientWithRoute _pm Proxy req httpMethod = do + runRequest req { requestMethod = httpMethod } + + hoistClientMonad _ _ f cl = \meth -> f (cl meth) + +-- | If you use a 'ReqBody' in one of your endpoints in your API, +-- the corresponding querying function will automatically take +-- an additional argument of the type specified by your 'ReqBody'. +-- That function will take care of encoding this argument as JSON and +-- of using it as the request body. +-- +-- All you need is for your type to have a 'ToJSON' instance. +-- +-- Example: +-- +-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > addBook :: Book -> ClientM Book +-- > addBook = client myApi +-- > -- then you can just use "addBook" to query that endpoint +instance (MimeRender ct a, HasClient m api) + => HasClient m (ReqBody' mods (ct ': cts) a :> api) where + + type Client m (ReqBody' mods (ct ': cts) a :> api) = + a -> Client m api + + clientWithRoute pm Proxy req body = + clientWithRoute pm (Proxy :: Proxy api) + (let ctProxy = Proxy :: Proxy ct + in setRequestBodyLBS (mimeRender ctProxy body) + -- We use first contentType from the Accept list + (contentType ctProxy) + req + ) + + hoistClientMonad pm _ f cl = \a -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl a) + +instance + ( HasClient m api, MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a + ) => HasClient m (StreamBody' mods framing ctype a :> api) + where + + type Client m (StreamBody' mods framing ctype a :> api) = a -> Client m api + + hoistClientMonad pm _ f cl = \a -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl a) + + clientWithRoute pm Proxy req body + = clientWithRoute pm (Proxy :: Proxy api) + $ setRequestBody (RequestBodySource sourceIO) (contentType ctypeP) req + where + ctypeP = Proxy :: Proxy ctype + framingP = Proxy :: Proxy framing + + sourceIO = framingRender + framingP + (mimeRender ctypeP :: chunk -> BSL.ByteString) + (toSourceIO body) + +-- | Make the querying function append @path@ to the request path. +instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where + type Client m (path :> api) = Client m api + + clientWithRoute pm Proxy req = + clientWithRoute pm (Proxy :: Proxy api) + (appendToPath p req) + + where p = toEncodedUrlPiece $ pack $ symbolVal (Proxy :: Proxy path) + + hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl + +instance HasClient m api => HasClient m (Vault :> api) where + type Client m (Vault :> api) = Client m api + + clientWithRoute pm Proxy req = + clientWithRoute pm (Proxy :: Proxy api) req + + hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl + +instance HasClient m api => HasClient m (RemoteHost :> api) where + type Client m (RemoteHost :> api) = Client m api + + clientWithRoute pm Proxy req = + clientWithRoute pm (Proxy :: Proxy api) req + + hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl + +instance HasClient m api => HasClient m (IsSecure :> api) where + type Client m (IsSecure :> api) = Client m api + + clientWithRoute pm Proxy req = + clientWithRoute pm (Proxy :: Proxy api) req + + hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl + +instance HasClient m subapi => + HasClient m (WithNamedContext name context subapi) where + + type Client m (WithNamedContext name context subapi) = Client m subapi + clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi) + + hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl + +instance HasClient m subapi => + HasClient m (WithResource res :> subapi) where + + type Client m (WithResource res :> subapi) = Client m subapi + clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi) + + hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl + +instance ( HasClient m api + ) => HasClient m (AuthProtect tag :> api) where + type Client m (AuthProtect tag :> api) + = AuthenticatedRequest (AuthProtect tag) -> Client m api + + clientWithRoute pm Proxy req (AuthenticatedRequest (val,func)) = + clientWithRoute pm (Proxy :: Proxy api) (func val req) + + hoistClientMonad pm _ f cl = \authreq -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq) + +-- | Ignore @'Fragment'@ in client functions. +-- See for more details. +-- +-- Example: +-- +-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooks :: ClientM [Book] +-- > getBooks = client myApi +-- > -- then you can just use "getBooksBy" to query that endpoint. +-- > -- 'getBooks' for all books. +instance (AtMostOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api + ) => HasClient m (Fragment a :> api) where + + type Client m (Fragment a :> api) = Client m api + + clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api) + + hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api) + +-- * Basic Authentication + +instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where + type Client m (BasicAuth realm usr :> api) = BasicAuthData -> Client m api + + clientWithRoute pm Proxy req val = + clientWithRoute pm (Proxy :: Proxy api) (basicAuthReq val req) + + hoistClientMonad pm _ f cl = \bauth -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth) + +-- | A type that specifies that an API record contains a client implementation. +data AsClientT (m :: Type -> Type) +instance GenericMode (AsClientT m) where + type AsClientT m :- api = Client m api + +type GClientConstraints api m = + ( GenericServant api (AsClientT m) + , Client m (ToServantApi api) ~ ToServant api (AsClientT m) + ) + +class GClient (api :: Type -> Type) m where + gClientProof :: Dict (GClientConstraints api m) + +instance GClientConstraints api m => GClient api m where + gClientProof = Dict + +instance + ( forall n. GClient api n + , HasClient m (ToServantApi api) + , RunClient m + , ErrorIfNoGeneric api + ) + => HasClient m (NamedRoutes api) where + type Client m (NamedRoutes api) = api (AsClientT m) + + clientWithRoute :: Proxy m -> Proxy (NamedRoutes api) -> Request -> Client m (NamedRoutes api) + clientWithRoute pm _ request = + case gClientProof @api @m of + Dict -> fromServant $ clientWithRoute pm (Proxy @(ToServantApi api)) request + + hoistClientMonad + :: forall ma mb. + Proxy m + -> Proxy (NamedRoutes api) + -> (forall x. ma x -> mb x) + -> Client ma (NamedRoutes api) + -> Client mb (NamedRoutes api) + hoistClientMonad _ _ nat clientA = + case (gClientProof @api @ma, gClientProof @api @mb) of + (Dict, Dict) -> + fromServant @api @(AsClientT mb) $ + hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $ + toServant @api @(AsClientT ma) clientA + +infixl 1 // +infixl 2 /: + +-- | Helper to make code using records of clients more readable. +-- +-- Can be mixed with (/:) for supplying arguments. +-- +-- Example: +-- +-- @ +-- type Api = NamedRoutes RootApi +-- +-- data RootApi mode = RootApi +-- { subApi :: mode :- NamedRoutes SubApi +-- , … +-- } deriving Generic +-- +-- data SubApi mode = SubApi +-- { endpoint :: mode :- Get '[JSON] Person +-- , … +-- } deriving Generic +-- +-- api :: Proxy API +-- api = Proxy +-- +-- rootClient :: RootApi (AsClientT ClientM) +-- rootClient = client api +-- +-- endpointClient :: ClientM Person +-- endpointClient = client \/\/ subApi \/\/ endpoint +-- @ +(//) :: a -> (a -> b) -> b +x // f = f x + +-- | Convenience function for supplying arguments to client functions when +-- working with records of clients. +-- +-- Intended to be used in conjunction with '(//)'. +-- +-- Example: +-- +-- @ +-- type Api = NamedRoutes RootApi +-- +-- data RootApi mode = RootApi +-- { subApi :: mode :- Capture "token" String :> NamedRoutes SubApi +-- , hello :: mode :- Capture "name" String :> Get '[JSON] String +-- , … +-- } deriving Generic +-- +-- data SubApi mode = SubApi +-- { endpoint :: mode :- Get '[JSON] Person +-- , … +-- } deriving Generic +-- +-- api :: Proxy API +-- api = Proxy +-- +-- rootClient :: RootApi (AsClientT ClientM) +-- rootClient = client api +-- +-- hello :: String -> ClientM String +-- hello name = rootClient \/\/ hello \/: name +-- +-- endpointClient :: ClientM Person +-- endpointClient = client \/\/ subApi \/: "foobar123" \/\/ endpoint +-- @ +(/:) :: (a -> b -> c) -> b -> a -> c +(/:) = flip + +instance + ( ResponseListUnrender cs as, + AllMime cs, + ReflectMethod method, + AsUnion as r, + RunClient m + ) => + HasClient m (MultiVerb method cs as r) + where + type Client m (MultiVerb method cs as r) = m r + + clientWithRoute _ _ req = do + response@Response{responseBody=body} <- + runRequestAcceptStatus + (Just (responseListStatuses @cs @as)) + req + { requestMethod = method, + requestAccept = Seq.fromList accept + } + + c <- getResponseContentType response + unless (any (M.matches c) accept) $ do + throwClientError $ UnsupportedContentType c response + + -- NOTE: support streaming in the future + let sresp = + if BSL.null body + then SomeClientResponse $ response {Response.responseBody = ()} + else SomeClientResponse response + case responseListUnrender @cs @as c sresp of + StatusMismatch -> throwClientError (DecodeFailure "Status mismatch" response) + UnrenderError e -> throwClientError (DecodeFailure (Text.pack e) response) + UnrenderSuccess x -> pure (fromUnion @as x) + where + accept = allMime (Proxy @cs) + method = reflectMethod (Proxy @method) + + hoistClientMonad _ _ f = f + +getResponseContentType :: (RunClient m) => Response -> m M.MediaType +getResponseContentType response = + case lookup "Content-Type" (toList (responseHeaders response)) of + Nothing -> pure $ "application" M.// "octet-stream" + Just t -> case M.parseAccept t of + Nothing -> throwClientError $ InvalidContentTypeHeader response + Just t' -> pure t' + +{- 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). +-} + +------------------------------------------------------------------------------- +-- helpers +------------------------------------------------------------------------------- + +checkContentTypeHeader :: RunClient m => Response -> m MediaType +checkContentTypeHeader response = + case lookup "Content-Type" $ toList $ responseHeaders response of + Nothing -> return $ "application" Media.// "octet-stream" + Just t -> case parseAccept t of + Nothing -> throwClientError $ InvalidContentTypeHeader response + Just t' -> return t' + +decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m) + => Response -> Proxy ct -> m a +decodedAs response@Response{responseBody=body} ct = do + responseContentType <- checkContentTypeHeader response + unless (any (matches responseContentType) accept) $ + throwClientError $ UnsupportedContentType responseContentType response + case mimeUnrender ct body of + Left err -> throwClientError $ DecodeFailure (T.pack err) response + Right val -> return val + where + accept = toList $ contentTypes ct + +------------------------------------------------------------------------------- +-- Custom type errors +------------------------------------------------------------------------------- + +-- Erroring instance for HasClient' when a combinator is not fully applied +instance (RunClient m, TypeError (PartialApplication HasClient arr)) => HasClient m ((arr :: a -> b) :> sub) + where + type Client m (arr :> sub) = TypeError (PartialApplication HasClient arr) + clientWithRoute _ _ _ = error "unreachable" + hoistClientMonad _ _ _ _ = error "unreachable" + +-- Erroring instances for 'HasClient' for unknown API combinators +instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceForSub (HasClient m) ty)) => HasClient m (ty :> sub) + +instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceFor (HasClient m api))) => HasClient m api diff --git a/src/Servant/Client/Core/Internal.hs b/src/Servant/Client/Core/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Core/Internal.hs @@ -0,0 +1,12 @@ +module Servant.Client.Core.Internal where + +import Control.DeepSeq + (rnf) +import Network.HTTP.Media + (MediaType, mainType, parameters, subType) + +mediaTypeRnf :: MediaType -> () +mediaTypeRnf mt = + rnf (mainType mt) `seq` + rnf (subType mt) `seq` + rnf (parameters mt) diff --git a/src/Servant/Client/Core/Internal/Auth.hs b/src/Servant/Client/Core/Internal/Auth.hs deleted file mode 100644 --- a/src/Servant/Client/Core/Internal/Auth.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} - --- | Authentication for clients - -module Servant.Client.Core.Internal.Auth where - -import Servant.Client.Core.Internal.Request (Request) - --- | For a resource protected by authentication (e.g. AuthProtect), we need --- to provide the client with some data used to add authentication data --- 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 AuthenticatedRequest a = - AuthenticatedRequest { unAuthReq :: (AuthClientData a, AuthClientData a -> Request -> Request) } - --- | Handy helper to avoid wrapping datatypes in tuples everywhere. --- --- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE -mkAuthenticatedRequest :: AuthClientData a - -> (AuthClientData a -> Request -> Request) - -> AuthenticatedRequest a -mkAuthenticatedRequest val func = AuthenticatedRequest (val, func) diff --git a/src/Servant/Client/Core/Internal/BaseUrl.hs b/src/Servant/Client/Core/Internal/BaseUrl.hs deleted file mode 100644 --- a/src/Servant/Client/Core/Internal/BaseUrl.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ViewPatterns #-} -module Servant.Client.Core.Internal.BaseUrl where - -import Control.Monad.Catch (Exception, MonadThrow, throwM) -import Data.List -import Data.Typeable -import GHC.Generics -import Network.URI hiding (path) -import 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/Client/Core/Internal/BasicAuth.hs b/src/Servant/Client/Core/Internal/BasicAuth.hs deleted file mode 100644 --- a/src/Servant/Client/Core/Internal/BasicAuth.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} - --- | Basic Authentication for clients - -module Servant.Client.Core.Internal.BasicAuth where - -import Data.ByteString.Base64 (encode) -import Data.Monoid ((<>)) -import Data.Text.Encoding (decodeUtf8) -import Servant.API.BasicAuth (BasicAuthData (BasicAuthData)) -import Servant.Client.Core.Internal.Request (Request, addHeader) - --- | Authenticate a request using Basic Authentication -basicAuthReq :: BasicAuthData -> Request -> Request -basicAuthReq (BasicAuthData user pass) req = - let authText = decodeUtf8 ("Basic " <> encode (user <> ":" <> pass)) - in addHeader "Authorization" authText req diff --git a/src/Servant/Client/Core/Internal/Generic.hs b/src/Servant/Client/Core/Internal/Generic.hs deleted file mode 100644 --- a/src/Servant/Client/Core/Internal/Generic.hs +++ /dev/null @@ -1,156 +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.Core.Internal.Generic where - -import Generics.SOP (Code, Generic, I(..), NP(..), NS(Z), SOP(..), to) -import Servant.API ((:<|>)(..)) - --- | 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 - --- | 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/Core/Internal/HasClient.hs b/src/Servant/Client/Core/Internal/HasClient.hs deleted file mode 100644 --- a/src/Servant/Client/Core/Internal/HasClient.hs +++ /dev/null @@ -1,541 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -#include "overlapping-compat.h" -module Servant.Client.Core.Internal.HasClient where - -import Prelude () -import Prelude.Compat - -import Data.Foldable (toList) -import Data.List (foldl') -import Data.Proxy (Proxy (Proxy)) -import Data.Sequence (fromList) -import Data.String (fromString) -import Data.Text (pack) -import GHC.TypeLits (KnownSymbol, symbolVal) -import qualified Network.HTTP.Types as H -import Servant.API ((:<|>) ((:<|>)), (:>), - AuthProtect, BasicAuth, - BasicAuthData, - BuildHeadersTo (..), - Capture, CaptureAll, - Description, EmptyAPI, - Header, Headers (..), - HttpVersion, IsSecure, - MimeRender (mimeRender), - MimeUnrender (mimeUnrender), - NoContent (NoContent), - QueryFlag, QueryParam, - QueryParams, Raw, - ReflectMethod (..), - RemoteHost, ReqBody, - Summary, ToHttpApiData, - Vault, Verb, - WithNamedContext, - contentType, - getHeadersHList, - getResponse, - toQueryParam, - toUrlPiece) -import Servant.API.ContentTypes (contentTypes) - -import Servant.Client.Core.Internal.Auth -import Servant.Client.Core.Internal.BasicAuth -import Servant.Client.Core.Internal.Request -import Servant.Client.Core.Internal.RunClient - --- * Accessing APIs as a Client - --- | 'clientIn' allows you to produce operations to query an API from a client --- within a 'RunClient' monad. --- --- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books --- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > clientM :: Proxy ClientM --- > clientM = Proxy --- > --- > getAllBooks :: ClientM [Book] --- > postNewBook :: Book -> ClientM Book --- > (getAllBooks :<|> postNewBook) = myApi `clientIn` clientM -clientIn :: HasClient m api => Proxy api -> Proxy m -> Client m api -clientIn p pm = clientWithRoute pm p defaultRequest - - --- | This class lets us define how each API combinator influences the creation --- of an HTTP request. --- --- Unless you are writing a new backend for @servant-client-core@ or new --- combinators that you want to support client-generation, you can ignore this --- class. -class RunClient m => HasClient m api where - type Client (m :: * -> *) (api :: *) :: * - clientWithRoute :: Proxy m -> Proxy api -> Request -> Client m api - - --- | A client querying function for @a ':<|>' b@ will actually hand you --- one function for querying @a@ and another one for querying @b@, --- stitching them together with ':<|>', which really is just like a pair. --- --- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books --- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getAllBooks :: ClientM [Book] --- > postNewBook :: Book -> ClientM Book --- > (getAllBooks :<|> postNewBook) = client myApi -instance (HasClient m a, HasClient m b) => HasClient m (a :<|> b) where - type Client m (a :<|> b) = Client m a :<|> Client m b - clientWithRoute pm Proxy req = - clientWithRoute pm (Proxy :: Proxy a) req :<|> - clientWithRoute pm (Proxy :: Proxy b) req - --- | Singleton type representing a client for an empty API. -data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum) - --- | The client for 'EmptyAPI' is simply 'EmptyClient'. --- --- > type MyAPI = "books" :> Get '[JSON] [Book] -- GET /books --- > :<|> "nothing" :> EmptyAPI --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getAllBooks :: ClientM [Book] --- > (getAllBooks :<|> EmptyClient) = client myApi -instance RunClient m => HasClient m EmptyAPI where - type Client m EmptyAPI = EmptyClient - clientWithRoute _pm Proxy _ = EmptyClient - --- | If you use a 'Capture' in one of your endpoints in your API, --- the corresponding querying function will automatically take --- an additional argument of the type specified by your 'Capture'. --- That function will take care of inserting a textual representation --- of this value at the right place in the request path. --- --- You can control how values for this type are turned into --- text by specifying a 'ToHttpApiData' instance for your type. --- --- Example: --- --- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getBook :: Text -> ClientM Book --- > getBook = client myApi --- > -- then you can just use "getBook" to query that endpoint -instance (KnownSymbol capture, ToHttpApiData a, HasClient m api) - => HasClient m (Capture capture a :> api) where - - type Client m (Capture capture a :> api) = - a -> Client m api - - clientWithRoute pm Proxy req val = - clientWithRoute pm (Proxy :: Proxy api) - (appendToPath p req) - - where p = (toUrlPiece val) - --- | If you use a 'CaptureAll' in one of your endpoints in your API, --- the corresponding querying function will automatically take an --- additional argument of a list of the type specified by your --- 'CaptureAll'. That function will take care of inserting a textual --- representation of this value at the right place in the request --- path. --- --- You can control how these values are turned into text by specifying --- a 'ToHttpApiData' instance of your type. --- --- Example: --- --- > type MyAPI = "src" :> CaptureAll Text -> Get '[JSON] SourceFile --- > --- > myApi :: Proxy --- > myApi = Proxy --- --- > getSourceFile :: [Text] -> ClientM SourceFile --- > getSourceFile = client myApi --- > -- then you can use "getSourceFile" to query that endpoint -instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout) - => HasClient m (CaptureAll capture a :> sublayout) where - - type Client m (CaptureAll capture a :> sublayout) = - [a] -> Client m sublayout - - clientWithRoute pm Proxy req vals = - clientWithRoute pm (Proxy :: Proxy sublayout) - (foldl' (flip appendToPath) req ps) - - where ps = map (toUrlPiece) vals - -instance OVERLAPPABLE_ - -- Note [Non-Empty Content Types] - ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) - ) => HasClient m (Verb method status cts' a) where - type Client m (Verb method status cts' a) = m a - clientWithRoute _pm Proxy req = do - response <- runRequest req - { requestAccept = fromList $ toList accept - , requestMethod = method - } - response `decodedAs` (Proxy :: Proxy ct) - where - accept = contentTypes (Proxy :: Proxy ct) - method = reflectMethod (Proxy :: Proxy method) - -instance OVERLAPPING_ - ( RunClient m, ReflectMethod method - ) => HasClient m (Verb method status cts NoContent) where - type Client m (Verb method status cts NoContent) - = m NoContent - clientWithRoute _pm Proxy req = do - _response <- runRequest req { requestMethod = method } - return NoContent - where method = reflectMethod (Proxy :: Proxy method) - -instance OVERLAPPING_ - -- Note [Non-Empty Content Types] - ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls - , ReflectMethod method, cts' ~ (ct ': cts) - ) => HasClient m (Verb method status cts' (Headers ls a)) where - type Client m (Verb method status cts' (Headers ls a)) - = m (Headers ls a) - clientWithRoute _pm Proxy req = do - response <- runRequest req - { requestMethod = method - , requestAccept = fromList $ toList accept - } - case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of - Left err -> throwServantError $ DecodeFailure (pack err) response - Right val -> return $ Headers - { getResponse = val - , getHeadersHList = buildHeadersTo . toList $ responseHeaders response - } - where method = reflectMethod (Proxy :: Proxy method) - accept = contentTypes (Proxy :: Proxy ct) - -instance OVERLAPPING_ - ( RunClient m, BuildHeadersTo ls, ReflectMethod method - ) => HasClient m (Verb method status cts (Headers ls NoContent)) where - type Client m (Verb method status cts (Headers ls NoContent)) - = m (Headers ls NoContent) - clientWithRoute _pm Proxy req = do - let method = reflectMethod (Proxy :: Proxy method) - response <- runRequest req { requestMethod = method } - return $ Headers { getResponse = NoContent - , getHeadersHList = buildHeadersTo . toList $ responseHeaders response - } - - --- | If you use a 'Header' in one of your endpoints in your API, --- the corresponding querying function will automatically take --- an additional argument of the type specified by your 'Header', --- wrapped in Maybe. --- --- That function will take care of encoding this argument as Text --- in the request headers. --- --- All you need is for your type to have a 'ToHttpApiData' instance. --- --- Example: --- --- > newtype Referer = Referer { referrer :: Text } --- > deriving (Eq, Show, Generic, ToHttpApiData) --- > --- > -- GET /view-my-referer --- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > viewReferer :: Maybe Referer -> ClientM Book --- > viewReferer = client myApi --- > -- then you can just use "viewRefer" to query that endpoint --- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments -instance (KnownSymbol sym, ToHttpApiData a, HasClient m api) - => HasClient m (Header sym a :> api) where - - type Client m (Header sym a :> api) = - Maybe a -> Client m api - - clientWithRoute pm Proxy req mval = - clientWithRoute pm (Proxy :: Proxy api) - (maybe req - (\value -> addHeader hname value req) - mval - ) - - where hname = fromString $ symbolVal (Proxy :: Proxy sym) - --- | Using a 'HttpVersion' combinator in your API doesn't affect the client --- functions. -instance HasClient m api - => HasClient m (HttpVersion :> api) where - - type Client m (HttpVersion :> api) = - Client m api - - clientWithRoute pm Proxy = - clientWithRoute pm (Proxy :: Proxy api) - --- | Ignore @'Summary'@ in client functions. -instance HasClient m api => HasClient m (Summary desc :> api) where - type Client m (Summary desc :> api) = Client m api - - clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api) - --- | Ignore @'Description'@ in client functions. -instance HasClient m api => HasClient m (Description desc :> api) where - type Client m (Description desc :> api) = Client m api - - clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api) - --- | If you use a 'QueryParam' in one of your endpoints in your API, --- the corresponding querying function will automatically take --- an additional argument of the type specified by your 'QueryParam', --- enclosed in Maybe. --- --- If you give Nothing, nothing will be added to the query string. --- --- If you give a non-'Nothing' value, this function will take care --- of inserting a textual representation of this value in the query string. --- --- You can control how values for your type are turned into --- text by specifying a 'ToHttpApiData' instance for your type. --- --- Example: --- --- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book] --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getBooksBy :: Maybe Text -> ClientM [Book] --- > getBooksBy = client myApi --- > -- then you can just use "getBooksBy" to query that endpoint. --- > -- 'getBooksBy Nothing' for all books --- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov -instance (KnownSymbol sym, ToHttpApiData a, HasClient m api) - => HasClient m (QueryParam sym a :> api) where - - type Client m (QueryParam sym a :> api) = - Maybe a -> Client m api - - -- if mparam = Nothing, we don't add it to the query string - clientWithRoute pm Proxy req mparam = - clientWithRoute pm (Proxy :: Proxy api) - (maybe req - (flip (appendToQueryString pname) req . Just) - mparamText - ) - - where pname = pack $ symbolVal (Proxy :: Proxy sym) - mparamText = fmap toQueryParam mparam - --- | If you use a 'QueryParams' in one of your endpoints in your API, --- the corresponding querying function will automatically take --- an additional argument, a list of values of the type specified --- by your 'QueryParams'. --- --- If you give an empty list, nothing will be added to the query string. --- --- Otherwise, this function will take care --- of inserting a textual representation of your values in the query string, --- under the same query string parameter name. --- --- You can control how values for your type are turned into --- text by specifying a 'ToHttpApiData' instance for your type. --- --- Example: --- --- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book] --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getBooksBy :: [Text] -> ClientM [Book] --- > getBooksBy = client myApi --- > -- then you can just use "getBooksBy" to query that endpoint. --- > -- 'getBooksBy []' for all books --- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]' --- > -- to get all books by Asimov and Heinlein -instance (KnownSymbol sym, ToHttpApiData a, HasClient m api) - => HasClient m (QueryParams sym a :> api) where - - type Client m (QueryParams sym a :> api) = - [a] -> Client m api - - clientWithRoute pm Proxy req paramlist = - clientWithRoute pm (Proxy :: Proxy api) - (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just)) - req - paramlist' - ) - - where pname = pack $ symbolVal (Proxy :: Proxy sym) - paramlist' = map (Just . toQueryParam) paramlist - --- | If you use a 'QueryFlag' in one of your endpoints in your API, --- the corresponding querying function will automatically take --- an additional 'Bool' argument. --- --- If you give 'False', nothing will be added to the query string. --- --- Otherwise, this function will insert a value-less query string --- parameter under the name associated to your 'QueryFlag'. --- --- Example: --- --- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book] --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > getBooks :: Bool -> ClientM [Book] --- > getBooks = client myApi --- > -- then you can just use "getBooks" to query that endpoint. --- > -- 'getBooksBy False' for all books --- > -- 'getBooksBy True' to only get _already published_ books -instance (KnownSymbol sym, HasClient m api) - => HasClient m (QueryFlag sym :> api) where - - type Client m (QueryFlag sym :> api) = - Bool -> Client m api - - clientWithRoute pm Proxy req flag = - clientWithRoute pm (Proxy :: Proxy api) - (if flag - then appendToQueryString paramname Nothing req - else req - ) - - where paramname = pack $ symbolVal (Proxy :: Proxy sym) - - --- | Pick a 'Method' and specify where the server you want to query is. You get --- back the full `Response`. -instance RunClient m => HasClient m Raw where - type Client m Raw - = H.Method -> m Response - - clientWithRoute :: Proxy m -> Proxy Raw -> Request -> Client m Raw - clientWithRoute _pm Proxy req httpMethod = do - runRequest req { requestMethod = httpMethod } - --- | If you use a 'ReqBody' in one of your endpoints in your API, --- the corresponding querying function will automatically take --- an additional argument of the type specified by your 'ReqBody'. --- That function will take care of encoding this argument as JSON and --- of using it as the request body. --- --- All you need is for your type to have a 'ToJSON' instance. --- --- Example: --- --- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book --- > --- > myApi :: Proxy MyApi --- > myApi = Proxy --- > --- > addBook :: Book -> ClientM Book --- > addBook = client myApi --- > -- then you can just use "addBook" to query that endpoint -instance (MimeRender ct a, HasClient m api) - => HasClient m (ReqBody (ct ': cts) a :> api) where - - type Client m (ReqBody (ct ': cts) a :> api) = - a -> Client m api - - clientWithRoute pm Proxy req body = - clientWithRoute pm (Proxy :: Proxy api) - (let ctProxy = Proxy :: Proxy ct - in setRequestBodyLBS (mimeRender ctProxy body) - -- We use first contentType from the Accept list - (contentType ctProxy) - req - ) - --- | Make the querying function append @path@ to the request path. -instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where - type Client m (path :> api) = Client m api - - clientWithRoute pm Proxy req = - clientWithRoute pm (Proxy :: Proxy api) - (appendToPath p req) - - where p = pack $ symbolVal (Proxy :: Proxy path) - -instance HasClient m api => HasClient m (Vault :> api) where - type Client m (Vault :> api) = Client m api - - clientWithRoute pm Proxy req = - clientWithRoute pm (Proxy :: Proxy api) req - -instance HasClient m api => HasClient m (RemoteHost :> api) where - type Client m (RemoteHost :> api) = Client m api - - clientWithRoute pm Proxy req = - clientWithRoute pm (Proxy :: Proxy api) req - -instance HasClient m api => HasClient m (IsSecure :> api) where - type Client m (IsSecure :> api) = Client m api - - clientWithRoute pm Proxy req = - clientWithRoute pm (Proxy :: Proxy api) req - -instance HasClient m subapi => - HasClient m (WithNamedContext name context subapi) where - - type Client m (WithNamedContext name context subapi) = Client m subapi - clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi) - -instance ( HasClient m api - ) => HasClient m (AuthProtect tag :> api) where - type Client m (AuthProtect tag :> api) - = AuthenticatedRequest (AuthProtect tag) -> Client m api - - clientWithRoute pm Proxy req (AuthenticatedRequest (val,func)) = - clientWithRoute pm (Proxy :: Proxy api) (func val req) - --- * Basic Authentication - -instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where - type Client m (BasicAuth realm usr :> api) = BasicAuthData -> Client m api - - clientWithRoute pm Proxy req val = - clientWithRoute pm (Proxy :: Proxy api) (basicAuthReq val req) - - -{- Note [Non-Empty Content Types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Rather than have - - instance (..., cts' ~ (ct ': cts)) => ... cts' ... - -It may seem to make more sense to have: - - instance (...) => ... (ct ': cts) ... - -But this means that if another instance exists that does *not* require -non-empty lists, but is otherwise more specific, no instance will be overall -more specific. This in turn generally means adding yet another instance (one -for empty and one for non-empty lists). --} diff --git a/src/Servant/Client/Core/Internal/Request.hs b/src/Servant/Client/Core/Internal/Request.hs deleted file mode 100644 --- a/src/Servant/Client/Core/Internal/Request.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - -module Servant.Client.Core.Internal.Request where - -import Prelude () -import Prelude.Compat - -import Control.Monad.Catch (Exception) -import qualified Data.ByteString.Builder as Builder -import qualified Data.ByteString.Lazy as LBS -import Data.Semigroup ((<>)) -import qualified Data.Sequence as Seq -import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) -import Data.Typeable (Typeable) -import GHC.Generics (Generic) -import Network.HTTP.Media (MediaType) -import Network.HTTP.Types (Header, HeaderName, HttpVersion, - Method, QueryItem, Status, http11, - methodGet) -import Web.HttpApiData (ToHttpApiData, toEncodedUrlPiece, - toHeader) - --- | A type representing possible errors in a request --- --- Note that this type substantially changed in 0.12. -data ServantError = - -- | The server returned an error response - FailureResponse Response - -- | The body could not be decoded at the expected type - | DecodeFailure Text Response - -- | The content-type of the response is not supported - | UnsupportedContentType MediaType Response - -- | The content-type header is invalid - | InvalidContentTypeHeader Response - -- | There was a connection error, and no response was received - | ConnectionError Text - deriving (Eq, Show, Generic, Typeable) - -instance Exception ServantError - -data RequestF a = Request - { requestPath :: a - , requestQueryString :: Seq.Seq QueryItem - , requestBody :: Maybe (RequestBody, MediaType) - , requestAccept :: Seq.Seq MediaType - , requestHeaders :: Seq.Seq Header - , requestHttpVersion :: HttpVersion - , requestMethod :: Method - } deriving (Eq, Show, Functor, Generic, Typeable) - -type Request = RequestF Builder.Builder - --- | The request body. Currently only lazy ByteStrings are supported. -newtype RequestBody = RequestBodyLBS LBS.ByteString - deriving (Eq, Ord, Read, Show, Typeable) - -data Response = Response - { responseStatusCode :: Status - , responseBody :: LBS.ByteString - , responseHeaders :: Seq.Seq Header - , responseHttpVersion :: HttpVersion - } deriving (Eq, Show, Generic, Typeable) - --- A GET request to the top-level path -defaultRequest :: Request -defaultRequest = Request - { requestPath = "" - , requestQueryString = Seq.empty - , requestBody = Nothing - , requestAccept = Seq.empty - , requestHeaders = Seq.empty - , requestHttpVersion = http11 - , requestMethod = methodGet - } - -appendToPath :: Text -> Request -> Request -appendToPath p req - = req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p } - -appendToQueryString :: Text -- ^ param name - -> Maybe Text -- ^ param value - -> Request - -> Request -appendToQueryString pname pvalue req - = req { requestQueryString = requestQueryString req - Seq.|> (encodeUtf8 pname, encodeUtf8 <$> pvalue)} - -addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request -addHeader name val req - = req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)} - --- | Set body and media type of the request being constructed. --- --- The body is set to the given bytestring using the 'RequestBodyLBS' --- constructor. --- --- @since 0.12 --- -setRequestBodyLBS :: LBS.ByteString -> MediaType -> Request -> Request -setRequestBodyLBS b t req - = req { requestBody = Just (RequestBodyLBS b, t) } - --- | Set body and media type of the request being constructed. --- --- @since 0.12 --- -setRequestBody :: RequestBody -> MediaType -> Request -> Request -setRequestBody b t req = req { requestBody = Just (b, t) } diff --git a/src/Servant/Client/Core/Internal/RunClient.hs b/src/Servant/Client/Core/Internal/RunClient.hs deleted file mode 100644 --- a/src/Servant/Client/Core/Internal/RunClient.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} --- | Types for possible backends to run client-side `Request` queries -module Servant.Client.Core.Internal.RunClient where - -import Prelude () -import Prelude.Compat - -import Control.Monad (unless) -import Data.Foldable (toList) -import Data.Proxy (Proxy) -import qualified Data.Text as T -import Network.HTTP.Media (MediaType, matches, - parseAccept, (//)) -import Servant.API (MimeUnrender, - contentTypes, - mimeUnrender) -import Servant.Client.Core.Internal.Request (Request, Response (..), - ServantError (..)) - -class (Monad m) => RunClient m where - -- | How to make a request. - runRequest :: Request -> m Response - throwServantError :: ServantError -> m a - catchServantError :: m a -> (ServantError -> m a) -> m a - -checkContentTypeHeader :: RunClient m => Response -> m MediaType -checkContentTypeHeader response = - case lookup "Content-Type" $ toList $ responseHeaders response of - Nothing -> return $ "application"//"octet-stream" - Just t -> case parseAccept t of - Nothing -> throwServantError $ InvalidContentTypeHeader response - Just t' -> return t' - -decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m) - => Response -> Proxy ct -> m a -decodedAs response contentType = do - responseContentType <- checkContentTypeHeader response - unless (any (matches responseContentType) accept) $ - throwServantError $ UnsupportedContentType responseContentType response - case mimeUnrender contentType $ responseBody response of - Left err -> throwServantError $ DecodeFailure (T.pack err) response - Right val -> return val - where - accept = toList $ contentTypes contentType diff --git a/src/Servant/Client/Core/MultiVerb/ResponseUnrender.hs b/src/Servant/Client/Core/MultiVerb/ResponseUnrender.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Core/MultiVerb/ResponseUnrender.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE ApplicativeDo #-} +module Servant.Client.Core.MultiVerb.ResponseUnrender where + +import Control.Applicative +import Control.Monad +import Data.Kind (Type) +import Data.SOP +import Data.Typeable +import GHC.TypeLits +import Network.HTTP.Types.Status (Status) +import qualified Data.ByteString.Lazy as BSL +import qualified Network.HTTP.Media as M + +import Servant.API.ContentTypes +import Servant.API.MultiVerb +import Servant.API.Status +import Servant.API.UVerb.Union (Union) +import Servant.Client.Core.Response (ResponseF(..)) +import qualified Servant.Client.Core.Response as Response +import Servant.API.Stream (SourceIO) +import Data.ByteString (ByteString) + +data SomeClientResponse = forall a. Typeable a => SomeClientResponse (ResponseF a) + +fromSomeClientResponse + :: forall a m. (Alternative m, Typeable a) + => SomeClientResponse + -> m (ResponseF a) +fromSomeClientResponse (SomeClientResponse Response {..}) = do + body <- maybe empty pure $ cast @_ @a responseBody + pure $ + Response + { responseBody = body, + .. + } + +class ResponseUnrender cs a where + type ResponseBody a :: Type + type ResponseStatus a :: Nat + responseUnrender + :: M.MediaType + -> ResponseF (ResponseBody a) + -> UnrenderResult (ResponseType a) + +class (Typeable as) => ResponseListUnrender cs as where + responseListUnrender + :: M.MediaType + -> SomeClientResponse + -> UnrenderResult (Union (ResponseTypes as)) + + responseListStatuses :: [Status] + +instance ResponseListUnrender cs '[] where + responseListUnrender _ _ = StatusMismatch + responseListStatuses = [] + +instance + ( Typeable a, + Typeable (ResponseBody a), + ResponseUnrender cs a, + ResponseListUnrender cs as, + KnownStatus (ResponseStatus a) + ) => + ResponseListUnrender cs (a ': as) + where + responseListUnrender c output = + Z . I <$> (responseUnrender @cs @a c =<< fromSomeClientResponse output) + <|> S <$> responseListUnrender @cs @as c output + + responseListStatuses = statusVal (Proxy @(ResponseStatus a)) : responseListStatuses @cs @as + +instance + ( KnownStatus s, + MimeUnrender ct a + ) => + ResponseUnrender cs (RespondAs (ct :: Type) s desc a) + where + type ResponseStatus (RespondAs ct s desc a) = s + type ResponseBody (RespondAs ct s desc a) = BSL.ByteString + + responseUnrender _ output = do + guard (responseStatusCode output == statusVal (Proxy @s)) + either UnrenderError UnrenderSuccess $ + mimeUnrender (Proxy @ct) (Response.responseBody output) + +instance (KnownStatus s) => ResponseUnrender cs (RespondAs '() s desc ()) where + type ResponseStatus (RespondAs '() s desc ()) = s + type ResponseBody (RespondAs '() s desc ()) = () + + responseUnrender _ output = + guard (responseStatusCode output == statusVal (Proxy @s)) + +instance + (KnownStatus s) + => ResponseUnrender cs (RespondStreaming s desc framing ct) + where + type ResponseStatus (RespondStreaming s desc framing ct) = s + type ResponseBody (RespondStreaming s desc framing ct) = SourceIO ByteString + + responseUnrender _ resp = do + guard (Response.responseStatusCode resp == statusVal (Proxy @s)) + pure $ Response.responseBody resp + +instance + (AllMimeUnrender cs a, KnownStatus s) + => ResponseUnrender cs (Respond s desc a) where + type ResponseStatus (Respond s desc a) = s + type ResponseBody (Respond s desc a) = BSL.ByteString + + responseUnrender c output = do + guard (responseStatusCode output == statusVal (Proxy @s)) + let results = allMimeUnrender (Proxy @cs) + case lookup c results of + Nothing -> empty + Just f -> either UnrenderError UnrenderSuccess (f (responseBody output)) + +instance + ( AsHeaders xs (ResponseType r) a, + ServantHeaders hs xs, + ResponseUnrender cs r + ) => + ResponseUnrender cs (WithHeaders hs a r) + where + type ResponseStatus (WithHeaders hs a r) = ResponseStatus r + type ResponseBody (WithHeaders hs a r) = ResponseBody r + + responseUnrender c output = do + x <- responseUnrender @cs @r c output + case extractHeaders @hs (responseHeaders output) of + Nothing -> UnrenderError "Failed to parse headers" + Just hs -> pure $ fromHeaders @xs (hs, x) diff --git a/src/Servant/Client/Core/Reexport.hs b/src/Servant/Client/Core/Reexport.hs --- a/src/Servant/Client/Core/Reexport.hs +++ b/src/Servant/Client/Core/Reexport.hs @@ -5,14 +5,19 @@ ( -- * HasClient HasClient(..) + , foldMapUnion + , matchUnion + , AsClientT + , (//) + , (/:) + -- * Response (for @Raw@) - , Response(..) + , Response + , StreamingResponse + , ResponseF(..) - -- * Generic Client - , ClientLike(..) - , genericMkClientL - , genericMkClientP - , ServantError(..) + -- * Data types + , ClientError(..) , EmptyClient(..) -- * BaseUrl @@ -21,10 +26,11 @@ , showBaseUrl , parseBaseUrl , InvalidBaseUrlException + ) where -import Servant.Client.Core.Internal.BaseUrl -import Servant.Client.Core.Internal.HasClient -import Servant.Client.Core.Internal.Generic -import Servant.Client.Core.Internal.Request +import Servant.Client.Core.BaseUrl +import Servant.Client.Core.HasClient +import Servant.Client.Core.Response +import Servant.Client.Core.ClientError diff --git a/src/Servant/Client/Core/Request.hs b/src/Servant/Client/Core/Request.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Core/Request.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Servant.Client.Core.Request ( + Request, + RequestF (..), + RequestBody (..), + defaultRequest, + -- ** Modifiers + addHeader, + appendToPath, + appendToQueryString, + encodeQueryParamValue, + setQueryString, + setRequestBody, + setRequestBodyLBS, + ) where + +import Prelude () +import Prelude.Compat + +import Control.DeepSeq + (NFData (..)) +import Data.Bifoldable + (Bifoldable (..)) +import Data.Bifunctor + (Bifunctor (..)) +import Data.Bitraversable + (Bitraversable (..), bifoldMapDefault, bimapDefault) +import qualified Data.ByteString as BS +import Data.ByteString.Builder + (Builder) +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Sequence as Seq +import Data.Text + (Text) +import Data.Text.Encoding + (encodeUtf8) +import Data.Typeable + (Typeable) +import GHC.Generics + (Generic) +import Network.HTTP.Media + (MediaType) +import Network.HTTP.Types + (Header, HeaderName, HttpVersion (..), Method, Query, QueryItem, + http11, methodGet, urlEncodeBuilder) +import Servant.API + (ToHttpApiData, toQueryParam, toHeader, SourceIO) + +import Servant.Client.Core.Internal (mediaTypeRnf) + +data RequestF body path = Request + { requestPath :: path + , requestQueryString :: Seq.Seq QueryItem + , requestBody :: Maybe (body, MediaType) + , requestAccept :: Seq.Seq MediaType + , requestHeaders :: Seq.Seq Header + , requestHttpVersion :: HttpVersion + , requestMethod :: Method + } deriving (Generic, Typeable, Eq, Functor, Foldable, Traversable) + +instance (Show a, Show b) => + Show (Servant.Client.Core.Request.RequestF a b) where + showsPrec p req + = showParen + (p >= 11) + ( showString "Request {requestPath = " + . showsPrec 0 (requestPath req) + . showString ", requestQueryString = " + . showsPrec 0 (requestQueryString req) + . showString ", requestBody = " + . showsPrec 0 (requestBody req) + . showString ", requestAccept = " + . showsPrec 0 (requestAccept req) + . showString ", requestHeaders = " + . showsPrec 0 (redactSensitiveHeader <$> requestHeaders req) + . showString ", requestHttpVersion = " + . showsPrec 0 (requestHttpVersion req) + . showString ", requestMethod = " + . showsPrec 0 (requestMethod req) + . showString "}" + ) + where + redactSensitiveHeader :: Header -> Header + redactSensitiveHeader ("Authorization", _) = ("Authorization", "") + redactSensitiveHeader h = h +instance Bifunctor RequestF where bimap = bimapDefault +instance Bifoldable RequestF where bifoldMap = bifoldMapDefault +instance Bitraversable RequestF where + bitraverse f g r = mk + <$> traverse (bitraverse f pure) (requestBody r) + <*> g (requestPath r) + where + mk b p = r { requestBody = b, requestPath = p } + +instance (NFData path, NFData body) => NFData (RequestF body path) where + rnf r = + rnf (requestPath r) + `seq` rnf (requestQueryString r) + `seq` rnfB (requestBody r) + `seq` rnf (fmap mediaTypeRnf (requestAccept r)) + `seq` rnf (requestHeaders r) + `seq` requestHttpVersion r + `seq` rnf (requestMethod r) + where + rnfB Nothing = () + rnfB (Just (b, mt)) = rnf b `seq` mediaTypeRnf mt + +type Request = RequestF RequestBody Builder + +-- | The request body. R replica of the @http-client@ @RequestBody@. +data RequestBody + = RequestBodyLBS LBS.ByteString + | RequestBodyBS BS.ByteString + | RequestBodySource (SourceIO LBS.ByteString) + deriving (Generic, Typeable) + +instance Show RequestBody where + showsPrec d (RequestBodyLBS lbs) = showParen (d > 10) + $ showString "RequestBodyLBS " + . showsPrec 11 lbs + showsPrec d (RequestBodyBS bs) = showParen (d > 10) + $ showString "RequestBodyBS " + . showsPrec 11 bs + showsPrec d (RequestBodySource _) = showParen (d > 10) + $ showString "RequestBodySource " + +-- A GET request to the top-level path +defaultRequest :: Request +defaultRequest = Request + { requestPath = "" + , requestQueryString = Seq.empty + , requestBody = Nothing + , requestAccept = Seq.empty + , requestHeaders = Seq.empty + , requestHttpVersion = http11 + , requestMethod = methodGet + } + +-- | Append extra path to the request being constructed. +-- +-- Warning: This function assumes that the path fragment is already URL-encoded. +appendToPath :: Builder -> Request -> Request +appendToPath p req + = req { requestPath = requestPath req <> "/" <> p } + +-- | Append a query parameter to the request being constructed. +-- +appendToQueryString :: Text -- ^ query param name + -> Maybe BS.ByteString -- ^ query param value + -> Request + -> Request +appendToQueryString pname pvalue req + = req { requestQueryString = requestQueryString req + Seq.|> (encodeUtf8 pname, pvalue)} + +setQueryString :: Query + -> Request + -> Request +setQueryString query req + = req { requestQueryString = Seq.fromList query } + +-- | Encode a query parameter value. +-- +encodeQueryParamValue :: ToHttpApiData a => a -> BS.ByteString +encodeQueryParamValue = LBS.toStrict . Builder.toLazyByteString + . urlEncodeBuilder True . encodeUtf8 . toQueryParam + +-- | Add header to the request being constructed. +-- +addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request +addHeader name val req + = req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)} + +-- | Set body and media type of the request being constructed. +-- +-- The body is set to the given bytestring using the 'RequestBodyLBS' +-- constructor. +-- +-- @since 0.12 +-- +setRequestBodyLBS :: LBS.ByteString -> MediaType -> Request -> Request +setRequestBodyLBS b t req + = req { requestBody = Just (RequestBodyLBS b, t) } + +-- | Set body and media type of the request being constructed. +-- +-- @since 0.12 +-- +setRequestBody :: RequestBody -> MediaType -> Request -> Request +setRequestBody b t req = req { requestBody = Just (b, t) } diff --git a/src/Servant/Client/Core/Response.hs b/src/Servant/Client/Core/Response.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Core/Response.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Servant.Client.Core.Response ( + Response, + StreamingResponse, + ResponseF (..), + responseToInternalResponse, + ) where + +import Prelude () +import Prelude.Compat + +import Control.DeepSeq + (NFData (..)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Sequence as Seq +import Data.Typeable + (Typeable) +import GHC.Generics + (Generic) +import Network.HTTP.Types + (Header, HttpVersion (..), Status (..)) + +import Servant.API.Stream + (SourceIO) +import Servant.Types.Internal.Response + +data ResponseF a = Response + { responseStatusCode :: Status + , responseHeaders :: Seq.Seq Header + , responseHttpVersion :: HttpVersion + , responseBody :: a + } deriving (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable) + +instance NFData a => NFData (ResponseF a) where + rnf (Response sc hs hv body) = + rnfStatus sc `seq` + rnf hs `seq` + rnfHttpVersion hv `seq` + rnf body + where + rnfStatus (Status code msg) = rnf code `seq` rnf msg + rnfHttpVersion (HttpVersion _ _) = () -- HttpVersion fields are strict + +type Response = ResponseF LBS.ByteString +type StreamingResponse = ResponseF (SourceIO BS.ByteString) + +responseToInternalResponse :: ResponseF a -> InternalResponse a +responseToInternalResponse Response{responseStatusCode, responseHeaders,responseBody} = + InternalResponse responseStatusCode responseHeaders responseBody diff --git a/src/Servant/Client/Core/RunClient.hs b/src/Servant/Client/Core/RunClient.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Core/RunClient.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +-- | Types for possible backends to run client-side `Request` queries +module Servant.Client.Core.RunClient ( + RunClient (..), + runRequest, + RunStreamingClient (..), + ClientF (..), + ) where + +import Prelude () +import Prelude.Compat + +import Network.HTTP.Types.Status + (Status) +import Control.Monad.Free + (Free (..), liftF) + +import Servant.Client.Core.ClientError +import Servant.Client.Core.Request +import Servant.Client.Core.Response + +class Monad m => RunClient m where + -- | How to make a request, with an optional list of status codes to not throw exceptions + -- for (default: [200..299]). + runRequestAcceptStatus :: Maybe [Status] -> Request -> m Response + throwClientError :: ClientError -> m a + +-- | How to make a request. +runRequest :: RunClient m => Request -> m Response +runRequest = runRequestAcceptStatus Nothing + +class RunClient m => RunStreamingClient m where + withStreamingRequest :: Request -> (StreamingResponse -> IO a) -> m a + +------------------------------------------------------------------------------- +-- Free +------------------------------------------------------------------------------- + +-- | 'ClientF' cannot stream. +-- +-- Compare to 'RunClient'. +data ClientF a + = RunRequest Request (Response -> a) + | Throw ClientError + deriving (Functor) + +-- TODO: honour the accept-status argument. +instance ClientF ~ f => RunClient (Free f) where + runRequestAcceptStatus _ req = liftF (RunRequest req id) + throwClientError = liftF . Throw diff --git a/src/Servant/Client/Core/ServerSentEvents.hs b/src/Servant/Client/Core/ServerSentEvents.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Core/ServerSentEvents.hs @@ -0,0 +1,304 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-error=unused-imports #-} + +-- | Server-sent events +-- +-- See for more details +-- on server-sent events (SSE). +-- +module Servant.Client.Core.ServerSentEvents ( + EventMessage (..), + EventIgnoreReason (..), + Event (..), + EventStreamT (..), + JsonEventStreamT (..), + EventMessageStreamT (..) +) where + +import Control.Applicative (Alternative ((<|>))) +import Control.Monad.IO.Class (MonadIO) +import qualified Data.Aeson as Aeson +import qualified Data.Attoparsec.ByteString as Attoparsec +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 as ByteString.Char8 +import qualified Data.ByteString.Lazy as ByteString.Lazy +import Data.Char (chr) +import Data.Coerce (coerce) +import Data.Foldable (traverse_) +import Data.Functor (void) +import qualified Data.Text as Text +import Data.Text.Encoding (encodeUtf8) +import GHC.Generics (Generic) +import Numeric.Natural (Natural) +import Servant.API.ContentTypes (EventStreamChunk (..)) +import Servant.API.Stream (FromSourceIO (..)) +import Servant.Types.SourceT + (SourceT, StepT (..), foreachYieldStep, mapStepT, + transformStepWithAtto) + +-- For compatibility with GHC <= 8.2 +import Data.Semigroup (Semigroup (..)) + +-- | Line (or frame) of an event stream +newtype EventStreamLine = EventStreamLine + { unEventStreamLine :: ByteString.ByteString } + deriving Show + +-- | Consume chunks to produce event stream lines. +eventLinesFromRawChunks + :: Monad m + => StepT m ByteString.ByteString + -> StepT m EventStreamLine +eventLinesFromRawChunks = + transformStepWithAtto eventLine + +-- | Consume event stream chunks to produce event stream lines. +eventLinesFromChunks + :: Monad m + => StepT m EventStreamChunk + -> StepT m EventStreamLine +eventLinesFromChunks = + -- 'coerce' efficiently unpacks the 'EventStreamChunk' + eventLinesFromRawChunks . fmap (coerce ByteString.Lazy.toStrict) + +-- | Apply a 'Attoparsec.Parser' to each line of the event stream individually. +parseEventLines + :: Monad m + => Attoparsec.Parser a + -> StepT m EventStreamLine + -> StepT m a +parseEventLines parser = + foreachYieldStep $ \(EventStreamLine line) next -> + case Attoparsec.parseOnly parser line of + Left err -> Error err + Right value -> Yield value next + +-- | A line of an event stream +eventLine :: Attoparsec.Parser EventStreamLine +eventLine = do + Attoparsec.option () byteOrderMark -- A line may be prefixed with a byte order mark + EventStreamLine <$> untilLineEnd <* lineEnd + +-- | Byte order mark (U+FEFF) in UTF-8 representation +byteOrderMark :: Attoparsec.Parser () +byteOrderMark = + traverse_ Attoparsec.word8 + $ ByteString.unpack + $ encodeUtf8 + $ Text.singleton + $ chr 0xFEFF + +-- | Event stream line ending +lineEnd :: Attoparsec.Parser () +lineEnd = + (cr >> lf) <|> cr <|> lf <|> Attoparsec.endOfInput + where + cr = void (Attoparsec.word8 0x0D) + lf = void (Attoparsec.word8 0x0A) + +-- | Consume all contents until the end of the line. +untilLineEnd :: Attoparsec.Parser ByteString.ByteString +untilLineEnd = Attoparsec.takeWhile (\w8 -> w8 /= 0x0D && w8 /= 0x0A) + +-- | Structured variant of an event line of an event stream +data EventMessage + = EventDispatch + -- ^ Dispatch on the accumulated event. + | EventSetName ByteString.ByteString + -- ^ Set the name of the current event. + | EventSetLastId ByteString.ByteString + -- ^ Set the last event identifier. + | EventData ByteString.ByteString + -- ^ Append data to the event's data buffer. + | EventRetry Natural + -- ^ Set the event stream's reconnection time. + | EventIgnore EventIgnoreReason + -- ^ Ignored + deriving (Show, Eq, Ord) + +-- | Reason why a event line can be ignored +data EventIgnoreReason + = EventFieldNameUnknown ByteString.ByteString + | EventRetryNonNumeric ByteString.ByteString + | EventComment ByteString.ByteString + deriving (Show, Eq, Ord) + +-- | Parse the event stream lines into more structured messages. +eventMessagesFromLines + :: Monad m + => StepT m EventStreamLine + -> StepT m EventMessage +eventMessagesFromLines = + ensureLastDispatch False . parseEventLines eventMessage + where + -- | Make sure the last event message is a dispatch. + ensureLastDispatch didDispatch step = case step of + Stop -> + if not didDispatch then Yield EventDispatch Stop else Stop + Yield other next -> + Yield other $ ensureLastDispatch (other == EventDispatch) next + Skip next -> + Skip $ ensureLastDispatch didDispatch next + Effect eff -> + Effect $ ensureLastDispatch didDispatch <$> eff + err@Error{} -> + err + +-- | Event line parser for an event message. +eventMessage :: Attoparsec.Parser EventMessage +eventMessage = + ignore <|> field <|> dispatch + where + ignore = do + _ <- Attoparsec.word8 0x3A -- ':' + EventIgnore . EventComment <$> Attoparsec.takeByteString + + dispatch = do + Attoparsec.endOfInput + pure EventDispatch + + field = do + name <- Attoparsec.takeWhile1 (/= 0x3A) -- Up to ':' or the end + + value <- Attoparsec.option ByteString.empty $ do + _ <- Attoparsec.word8 0x3A -- ':' + _ <- Attoparsec.option 0x20 $ Attoparsec.word8 0x20 -- Optional ' ' + Attoparsec.takeByteString + + pure $ case name of + "event" -> EventSetName value + + "data" -> EventData value + + "id" -> EventSetLastId value + + "retry" -> + -- The retry value consist of digits. + if ByteString.all (\w8 -> 0x30 <= w8 && w8 <= 0x39) value then + EventRetry (read (ByteString.Char8.unpack value)) + else + EventIgnore (EventRetryNonNumeric value) + + _ -> EventIgnore (EventFieldNameUnknown name) + +-- | Event sent by the remote +data Event a = Event + { eventName :: Maybe ByteString.ByteString + , eventData :: a + } + deriving (Show, Eq, Ord, Functor, Generic) + +-- | Accumulate event messages to build individual 'Event's. +eventsFromMessages + :: Functor m + => StepT m EventMessage + -> StepT m (Event ByteString.ByteString) +eventsFromMessages = + initGo + where + initGo = go Nothing ByteString.Lazy.empty + + combineData dataBuffer newData = + if ByteString.Lazy.null dataBuffer then + ByteString.Lazy.fromStrict newData + else + ByteString.Lazy.concat + [ dataBuffer + , ByteString.Lazy.singleton 0x0A -- Line feed + , ByteString.Lazy.fromStrict newData + ] + + go name dataBuffer step = case step of + Stop -> + Stop + Skip next -> + go name dataBuffer next + Effect eff -> + Effect (go name dataBuffer <$> eff) + Error err -> + Error err + Yield message next -> case message of + EventSetName newName -> + go (Just newName) dataBuffer next + EventData newData -> + go name (combineData dataBuffer newData) next + EventDispatch -> + Yield + (Event name (ByteString.Lazy.toStrict dataBuffer)) + (initGo next) + _ -> + -- We ignore other message because they don't fit into + -- the 'Event' type. If a user needs more fine grained + -- control, the 'EventMessage' interface is better suited. + go name dataBuffer next + +-- | Server-sent event stream (SSE) +-- +-- See for more details. +-- +newtype EventMessageStreamT m = EventMessageStreamT + { unEventMessageStreamT :: SourceT m EventMessage } + deriving stock (Show) + deriving newtype (Semigroup, Monoid) + +-- | Server-sent event messages +-- +-- 'EventMessage' gives you more control over the communication with the server +-- than 'Event'. +-- +instance MonadIO m => FromSourceIO EventStreamChunk (EventMessageStreamT m) where + fromSourceIO src = + EventMessageStreamT + . mapStepT (eventMessagesFromLines . eventLinesFromChunks) + <$> fromSourceIO src + +-- | Server-sent event stream (SSE) +-- +-- See for more details. +-- +newtype EventStreamT m = EventStreamT + { unEventStreamT :: SourceT m (Event ByteString.ByteString) } + deriving stock (Show) + deriving newtype (Semigroup, Monoid) + +-- | Server-sent events +instance MonadIO m => FromSourceIO EventStreamChunk (EventStreamT m) where + fromSourceIO input = do + src :: EventMessageStreamT m <- fromSourceIO input + pure $ + -- 'coerce' is used in place of unpacking and repacking 'EventStreamT' + coerce (mapStepT eventsFromMessages) src + +-- | Try to parse event data to JSON. +jsonEventsFromEvents + :: (Functor m, Aeson.FromJSON a) + => StepT m (Event ByteString.ByteString) + -> StepT m (Event a) +jsonEventsFromEvents = + foreachYieldStep $ \(Event name datas) next -> + either + Error + (\value -> Yield (Event name value) next) + (Aeson.eitherDecode (ByteString.Lazy.fromStrict datas)) + +-- | Server-sent event stream (SSE) for JSON values +newtype JsonEventStreamT m a = JsonEventStreamT + { unJsonEventStreamT :: SourceT m (Event a) } + deriving stock (Show, Functor) + deriving newtype (Semigroup, Monoid) + +-- | Server-sent JSON event stream +instance (MonadIO m, Aeson.FromJSON a) => FromSourceIO EventStreamChunk (JsonEventStreamT m a) where + fromSourceIO input = do + src :: EventStreamT m <- fromSourceIO input + pure $ + -- The 'coerce' efficiently unwraps the 'EventStreamT' and wraps the + -- JsonEventStreamT. + coerce + (mapStepT jsonEventsFromEvents) + src diff --git a/src/Servant/Client/Free.hs b/src/Servant/Client/Free.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Free.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Servant.Client.Free ( + client, + ClientF (..), + module Servant.Client.Core.Reexport, + ) where + +import Control.Monad.Free +import Data.Proxy + (Proxy (..)) +import Servant.Client.Core +import Servant.Client.Core.Reexport +import Servant.Client.Core.RunClient + +client :: HasClient (Free ClientF) api => Proxy api -> Client (Free ClientF) api +client api = api `clientIn` (Proxy :: Proxy (Free ClientF)) diff --git a/src/Servant/Client/Generic.hs b/src/Servant/Client/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Generic.hs @@ -0,0 +1,49 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Servant.Client.Generic ( + AsClientT, + genericClient, + genericClientHoist, + ) where + +import Data.Proxy + (Proxy (..)) + +import Servant.API.Generic +import Servant.Client.Core +import Servant.Client.Core.HasClient (AsClientT) + +-- | Generate a record of client functions. +genericClient + :: forall routes m. + ( HasClient m (ToServantApi routes) + , GenericServant routes (AsClientT m) + , Client m (ToServantApi routes) ~ ToServant routes (AsClientT m) + ) + => routes (AsClientT m) +genericClient + = fromServant + $ clientIn (Proxy :: Proxy (ToServantApi routes)) (Proxy :: Proxy m) + +-- | 'genericClient' but with 'hoistClientMonad' in between. +genericClientHoist + :: forall routes m n. + ( HasClient m (ToServantApi routes) + , GenericServant routes (AsClientT n) + , Client n (ToServantApi routes) ~ ToServant routes (AsClientT n) + ) + => (forall x. m x -> n x) -- ^ natural transformation + -> routes (AsClientT n) +genericClientHoist nt + = fromServant + $ hoistClientMonad m api nt + $ clientIn api m + where + m = Proxy :: Proxy m + api = Proxy :: Proxy (ToServantApi routes) diff --git a/test/Servant/Client/Core/Internal/BaseUrlSpec.hs b/test/Servant/Client/Core/Internal/BaseUrlSpec.hs --- a/test/Servant/Client/Core/Internal/BaseUrlSpec.hs +++ b/test/Servant/Client/Core/Internal/BaseUrlSpec.hs @@ -8,7 +8,7 @@ import Test.Hspec import Test.QuickCheck -import Servant.Client.Core.Internal.BaseUrl +import Servant.Client.Core.BaseUrl spec :: Spec spec = do diff --git a/test/Servant/Client/Core/RequestSpec.hs b/test/Servant/Client/Core/RequestSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/Client/Core/RequestSpec.hs @@ -0,0 +1,31 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE OverloadedStrings #-} +module Servant.Client.Core.RequestSpec (spec) where + + +import Prelude () +import Prelude.Compat +import Control.Monad +import Data.List (isInfixOf) +import Servant.Client.Core.Request +import Test.Hspec + +newtype DataWithRequest = DataWithRequest (RequestF RequestBody ()) + deriving Show + +spec :: Spec +spec = do + describe "Request" $ do + describe "show" $ do + it "has parenthesis correctly positioned" $ do + let d = DataWithRequest (void defaultRequest) + show d `shouldBe` "DataWithRequest (Request {requestPath = ()\ + \, requestQueryString = fromList []\ + \, requestBody = Nothing\ + \, requestAccept = fromList []\ + \, requestHeaders = fromList []\ + \, requestHttpVersion = HTTP/1.1\ + \, requestMethod = \"GET\"})" + it "redacts the authorization header" $ do + let request = void $ defaultRequest { requestHeaders = pure ("authorization", "secret") } + isInfixOf "secret" (show request) `shouldBe` False diff --git a/test/Servant/Client/Core/ServerSentEventsSpec.hs b/test/Servant/Client/Core/ServerSentEventsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/Client/Core/ServerSentEventsSpec.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Servant.Client.Core.ServerSentEventsSpec (spec) where + +import Control.Monad.Trans.Except (runExceptT) +import qualified Data.ByteString.Lazy as ByteString +import Data.Foldable (for_) +import Data.Int (Int64) +import Servant.API.ContentTypes (EventStreamChunk (..)) +import Servant.API.Stream + (FromSourceIO (fromSourceIO)) +import Servant.Client.Core.ServerSentEvents + (Event (..), EventIgnoreReason (EventComment), + EventMessage (..), unEventMessageStreamT, unEventStreamT) +import Servant.Types.SourceT (runSourceT, source) +import Test.Hspec + (Spec, describe, it, shouldBe) + +spec :: Spec +spec = describe "Servant.Client.Core.ServerSentEvent" $ do + describe "EventMessageStreamT" $ do + it "processes chunks correctly" $ do + let allMessages = ByteString.intercalate "\n" + [ "retry: 30" + , "data: Hello World" + , "id: 1" + , "" + , "event: my_event" + , "data" + , "id: 2" + , ":Just a comment" + , "" + , "data: Bye" + ] + + for_ [1, 10, 100] $ \chunkSize -> do + src <- + fromSourceIO + $ source + $ map EventStreamChunk + $ chunkify chunkSize allMessages + + result <- + runExceptT + $ runSourceT + $ unEventMessageStreamT src + + result `shouldBe` Right + [ EventRetry 30 + , EventData "Hello World" + , EventSetLastId "1" + , EventDispatch + , EventSetName "my_event" + , EventData "" + , EventSetLastId "2" + , EventIgnore (EventComment "Just a comment") + , EventDispatch + , EventData "Bye" + , EventDispatch + ] + + describe "EventStreamT" $ do + it "processes chunks correctly" $ do + let allMessages = ByteString.intercalate "\n" + [ "retry: 30" + , "data: Hello World" + , "id: 1" + , "" + , "event: my_event" + , "data" + , "id: 2" + , ":Just a comment" + , "" + , "data: Bye" + ] + + for_ [1, 10, 100] $ \chunkSize -> do + src <- + fromSourceIO + $ source + $ map EventStreamChunk + $ chunkify chunkSize allMessages + result <- + runExceptT + $ runSourceT + $ unEventStreamT src + + result `shouldBe` Right + [ Event Nothing "Hello World" + , Event (Just "my_event") "" + , Event Nothing "Bye" + ] + +chunkify :: Int64 -> ByteString.ByteString -> [ByteString.ByteString] +chunkify chunkSize input = + if ByteString.null input then + [] + else + let (h, t) = ByteString.splitAt chunkSize input + in h : chunkify chunkSize t