diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,126 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md) [Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) +Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions. + +0.20.3.0 +-------- + +- Server-sent events (SSE) for client-side [#1811](https://github.com/haskell-servant/servant/issues/1811) + + Implement Server-sent events (SSE) for the Servant client using a new + combinator "ServerSentEvents". The raw event messages, accumulated events and + JSON-processed events can be exposed. + +- Integrate MultiVerb [#1766](https://github.com/haskell-servant/servant/pull/1766) [#1804](https://github.com/haskell-servant/servant/pull/1804) + + Expose MultiVerb, a more ergonomic way of defining endpoints that return + many kinds of responses. Read the cookbook https://docs.servant.dev/en/master/cookbook/multiverb/MultiVerb.html + +- Add public re-export of renderCurlBasePath lens [#1706](https://github.com/haskell-servant/servant/pull/1706) +- Remove GHC <= 8.10.7 from the support window [#1778](https://github.com/haskell-servant/servant/pull/1778) +- Add Servant.API.Range type [#1805](https://github.com/haskell-servant/servant/pull/1805) +- Add missing HasLink instance for DeepQuery [#1784](https://github.com/haskell-servant/servant/issues/1784) [#1814](https://github.com/haskell-servant/servant/pull/1814) +- Add Host API combinator [#1800](https://github.com/haskell-servant/servant/pull/1800) + + Adding a Host combinator allows servant users to select APIs according + to the Host header provided by clients. + +0.20.2 +------ + +- Client Middleware [#1720](https://github.com/haskell-servant/servant/pull/1720) + + Clients now support real middleware of type `(Request -> ClientM Response) -> Request -> ClientM Response` which can be configured in `ClientEnv`. + This allows access to raw request and response data. It can also be used to control how/when/if actual requests are performed. + Middleware can be chained with function composition `mid1 . mid2 . mid3`. + +0.20 +---- + +- Escape special chars in QueryParams. [#1584](https://github.com/haskell-servant/servant/issues/1584) [#1597](https://github.com/haskell-servant/servant/pull/1597) + + Escape special chars in QueryParam (`:@&=+$`) in servant-client. Note that this + mean binary data will not work as is, and so reverts the functionality in + [#1432](https://github.com/haskell-servant/servant/pull/1432). + +- Handle Cookies correctly for RunStreamingClient [#1605](https://github.com/haskell-servant/servant/issues/1605) [#1606](https://github.com/haskell-servant/servant/pull/1606) + + Makes `performWithStreamingRequest` take into consideration the + CookieJar, which it previously didn't. + +- Fix the handling of multiple headers with the same name. [#1666](https://github.com/haskell-servant/servant/pull/1666) + + servant-client no longer concatenates the values of response headers with the same name. + This fixes an issue with parsing multiple `Set-Cookie` headers. + +0.19 +---- + +### Significant changes + +- Drop support for GHC < 8.6. +- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet). +- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)), + which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864) + related to hash collisions. +- Add `NamedRoutes` combinator, making support for records first-class in Servant + ([#1388](https://github.com/haskell-servant/servant/pull/1388)). +- Add custom type errors for partially applied combinators + ([#1289](https://github.com/haskell-servant/servant/pull/1289), + [#1486](https://github.com/haskell-servant/servant/pull/1486)). +- *servant-client* / *servant-client-core* / *servant-http-streams*: Fix + erroneous behavior, where only 2XX status codes would be considered + successful, irrelevant of the status parameter specified by the verb + combinator. ([#1469](https://github.com/haskell-servant/servant/pull/1469)) +- *servant-client* / *servant-client-core*: Fix `Show` instance for + `Servant.Client.Core.Request`. +- *servant-client* / *servant-client-core*: Allow passing arbitrary binary data + in Query parameters. + ([#1432](https://github.com/haskell-servant/servant/pull/1432)). + +### Other changes + +- Various version bumps. + +0.18.3 +------ + +### Significant changes + +- Add response header support to UVerb (#1420) + +### Other changes + +- Support GHC-9.0.1. +- Bump `bytestring`, `hspec`, `http-client` and `QuickCheck` dependencies. + +0.18.2 +------ + +### Significant changes + +- Support `Fragment` combinator. + +0.18.1 +------ + +### Significant changes + +- Union verbs + +### Other changes + +- Bump "tested-with" ghc versions + +0.18 +---- + +### Significant changes + +- Support for ghc8.8 (#1318, #1326, #1327) + + 0.17 ---- @@ -198,7 +318,7 @@ - *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 in, we also have `hoistClient` for changing the monad + 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)) diff --git a/README.lhs b/README.lhs --- a/README.lhs +++ b/README.lhs @@ -11,7 +11,7 @@ {-# LANGUAGE TypeOperators #-} import Data.Proxy -import Data.Text +import Data.Text (Text) import Network.HTTP.Client (newManager, defaultManagerSettings) import Servant.API import Servant.Client diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -11,7 +11,7 @@ {-# LANGUAGE TypeOperators #-} import Data.Proxy -import Data.Text +import Data.Text (Text) import Network.HTTP.Client (newManager, defaultManagerSettings) import Servant.API import Servant.Client diff --git a/servant-client.cabal b/servant-client.cabal --- a/servant-client.cabal +++ b/servant-client.cabal @@ -1,9 +1,8 @@ -cabal-version: >=1.10 -name: servant-client -version: 0.17 - -synopsis: Automatic derivation of querying functions for servant -category: Servant, Web +cabal-version: 3.0 +name: servant-client +version: 0.20.3.0 +synopsis: Automatic derivation of querying functions for servant +category: Servant, Web description: This library lets you derive automatically Haskell functions that let you query each endpoint of a webservice. @@ -12,132 +11,190 @@ . -homepage: http://docs.servant.dev/ -bug-reports: http://github.com/haskell-servant/servant/issues -license: BSD3 -license-file: LICENSE -author: Servant Contributors -maintainer: haskell-servant-maintainers@googlegroups.com -copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors -build-type: Simple -tested-with: - GHC ==8.0.2 - || ==8.2.2 - || ==8.4.4 - || ==8.6.5 - || ==8.8.2 +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: CHANGELOG.md README.md source-repository head - type: git + type: git location: http://github.com/haskell-servant/servant.git +common extensions + default-extensions: + AllowAmbiguousTypes + ConstraintKinds + DataKinds + DeriveAnyClass + DeriveDataTypeable + DeriveFunctor + DeriveGeneric + DerivingStrategies + DerivingVia + DuplicateRecordFields + ExplicitNamespaces + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + NoStarIsType + OverloadedLabels + OverloadedStrings + PackageImports + PolyKinds + QuantifiedConstraints + RankNTypes + RecordWildCards + ScopedTypeVariables + StrictData + TupleSections + TypeApplications + TypeFamilies + TypeOperators + UndecidableInstances + ViewPatterns + + default-language: Haskell2010 + +common ghc-options + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + -fhide-source-paths -Wno-unused-do-bind -fdicts-strict + -Wno-unticked-promoted-constructors -Werror=unused-imports + -Wunused-packages + library + import: extensions + import: ghc-options exposed-modules: Servant.Client - Servant.Client.Streaming Servant.Client.Internal.HttpClient Servant.Client.Internal.HttpClient.Streaming + Servant.Client.Streaming -- Bundled with GHC: Lower bound to not force re-installs -- text and mtl are bundled starting with GHC-8.4 build-depends: - base >= 4.9 && < 4.14 - , bytestring >= 0.10.8.1 && < 0.11 - , containers >= 0.5.7.1 && < 0.7 - , deepseq >= 1.4.2.0 && < 1.5 - , mtl >= 2.2.2 && < 2.3 - , stm >= 2.4.5.1 && < 2.6 - , text >= 1.2.3.0 && < 1.3 - , time >= 1.6.0.1 && < 1.10 - , transformers >= 0.5.2.0 && < 0.6 - - if !impl(ghc >= 8.2) - build-depends: - bifunctors >= 5.5.3 && < 5.6 + , base >= 4.16.4.0 && < 4.22 + , bytestring >=0.11 && <0.13 + , containers >=0.6.5.1 && <0.9 + , deepseq >=1.4.2.0 && <1.6 + , mtl ^>=2.2.2 || ^>=2.3.1 + , stm >=2.4.5.1 && <2.6 + , time >=1.6.0.1 && <1.15 + , transformers >=0.5.2.0 && <0.7 -- Servant dependencies. -- Strict dependency on `servant-client-core` as we re-export things. build-depends: - servant == 0.17.* - , servant-client-core >= 0.17 && <0.17.1 + , servant >=0.20.2 && <0.21 + , servant-client-core >=0.20.2 && <0.21 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. build-depends: - base-compat >= 0.10.5 && < 0.12 - , http-client >= 0.5.13.1 && < 0.7 - , http-media >= 0.7.1.3 && < 0.9 - , http-types >= 0.12.2 && < 0.13 - , exceptions >= 0.10.0 && < 0.11 - , kan-extensions >= 5.2 && < 5.3 - , monad-control >= 1.0.2.3 && < 1.1 - , semigroupoids >= 5.3.1 && < 5.4 - , transformers-base >= 0.4.5.2 && < 0.5 - , transformers-compat >= 0.6.2 && < 0.7 + , base-compat >=0.10.5 && <0.15 + , exceptions >=0.10.0 && <0.11 + , http-client >=0.5.13.1 && <0.8 + , http-media >=0.7.1.3 && <0.9 + , http-types >=0.12.2 && <0.13 + , kan-extensions >=5.2 && <5.3 + , monad-control >=1.0.2.3 && <1.1 + , semigroupoids >=5.3.1 && <6.1 + , transformers-base >=0.4.5.2 && <0.5 - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall -Wno-redundant-constraints + hs-source-dirs: src test-suite spec - type: exitcode-stdio-1.0 - ghc-options: -Wall -rtsopts -threaded "-with-rtsopts=-T -N2" - default-language: Haskell2010 - hs-source-dirs: test - main-is: Spec.hs + import: extensions + import: ghc-options + type: exitcode-stdio-1.0 + ghc-options: -Wall -rtsopts -threaded "-with-rtsopts=-T -N2" + + if impl(ghcjs) + buildable: False + + hs-source-dirs: test + main-is: Spec.hs other-modules: - Servant.BasicAuthSpec - Servant.ClientTestUtils - Servant.ConnectionErrorSpec - Servant.FailSpec - Servant.GenAuthSpec - Servant.HoistClientSpec - Servant.StreamSpec - Servant.SuccessSpec - Servant.WrappedApiSpec + Servant.BasicAuthSpec + Servant.BrokenSpec + Servant.ClientTestUtils + Servant.ConnectionErrorSpec + Servant.FailSpec + Servant.GenAuthSpec + Servant.GenericSpec + Servant.HoistClientSpec + Servant.MiddlewareSpec + Servant.StreamSpec + Servant.SuccessSpec + Servant.WrappedApiSpec -- Dependencies inherited from the library. No need to specify bounds. build-depends: - base , aeson + , base , base-compat , bytestring , http-api-data , http-client , http-types , mtl - , kan-extensions , servant-client , servant-client-core + , sop-core + , generics-sop , stm , text , transformers - , transformers-compat , wai , warp - -- Additonal dependencies + -- Additional dependencies build-depends: - entropy >= 0.4.1.3 && < 0.5 - , hspec >= 2.6.0 && < 2.8 - , HUnit >= 1.6.0.0 && < 1.7 - , network >= 2.8.0.0 && < 3.2 - , QuickCheck >= 2.12.6.1 && < 2.14 - , servant == 0.17.* - , servant-server == 0.17.* - , tdigest >= 0.2 && < 0.3 + , entropy >=0.4.1.3 && <0.5 + , hspec >=2.6.0 && <2.12 + , HUnit >=1.6.0.0 && <1.7 + , network >=2.8.0.0 && <3.3 + , QuickCheck >=2.12.6.1 && <2.16 + , servant >=0.20.2 && <0.21 + , servant-server >=0.20.2 && <0.21 - build-tool-depends: - hspec-discover:hspec-discover >= 2.6.0 && < 2.8 + build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.12 test-suite readme - type: exitcode-stdio-1.0 - main-is: README.lhs - build-depends: base, servant, http-client, text, servant-client, markdown-unlit + import: extensions + import: ghc-options + type: exitcode-stdio-1.0 + main-is: README.lhs + build-depends: + , base + , http-client + , markdown-unlit + , servant + , servant-client + , text + build-tool-depends: markdown-unlit:markdown-unlit - ghc-options: -pgmL markdown-unlit - default-language: Haskell2010 + ghc-options: -pgmL markdown-unlit + + if impl(ghcjs) + buildable: False diff --git a/src/Servant/Client/Internal/HttpClient.hs b/src/Servant/Client/Internal/HttpClient.hs --- a/src/Servant/Client/Internal/HttpClient.hs +++ b/src/Servant/Client/Internal/HttpClient.hs @@ -1,14 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} module Servant.Client.Internal.HttpClient where import Prelude () @@ -24,7 +14,7 @@ import Control.Monad.Base (MonadBase (..)) import Control.Monad.Catch - (MonadCatch, MonadThrow) + (MonadCatch, MonadThrow, MonadMask) import Control.Monad.Error.Class (MonadError (..)) import Control.Monad.IO.Class @@ -43,18 +33,15 @@ import Data.ByteString.Builder (toLazyByteString) import qualified Data.ByteString.Lazy as BSL -import Data.Either - (either) +import qualified Data.List as List import Data.Foldable (toList) import Data.Functor.Alt (Alt (..)) import Data.Maybe - (maybe, maybeToList) + (maybeToList) import Data.Proxy (Proxy (..)) -import Data.Semigroup - ((<>)) import Data.Sequence (fromList) import Data.String @@ -65,7 +52,7 @@ import Network.HTTP.Media (renderHeader) import Network.HTTP.Types - (hContentType, renderQuery, statusCode) + (hContentType, statusIsSuccessful, urlEncode, Status) import Servant.Client.Core import qualified Network.HTTP.Client as Client @@ -82,17 +69,28 @@ { manager :: Client.Manager , baseUrl :: BaseUrl , cookieJar :: Maybe (TVar Client.CookieJar) - , makeClientRequest :: BaseUrl -> Request -> Client.Request + , makeClientRequest :: BaseUrl -> Request -> IO Client.Request -- ^ this function can be used to customize the creation of @http-client@ requests from @servant@ requests. Default value: 'defaultMakeClientRequest' -- Note that: -- 1. 'makeClientRequest' exists to allow overriding operational semantics e.g. 'responseTimeout' per request, -- If you need global modifications, you should use 'managerModifyRequest' -- 2. the 'cookieJar', if defined, is being applied after 'makeClientRequest' is called. + , middleware :: ClientMiddleware } +type ClientApplication = Request -> ClientM Response + +type ClientMiddleware = ClientApplication -> ClientApplication + -- | 'ClientEnv' smart constructor. mkClientEnv :: Client.Manager -> BaseUrl -> ClientEnv -mkClientEnv mgr burl = ClientEnv mgr burl Nothing defaultMakeClientRequest +mkClientEnv manager baseUrl = ClientEnv + { manager + , baseUrl + , cookieJar = Nothing + , makeClientRequest = defaultMakeClientRequest + , middleware = id + } -- | Generates a set of client functions for an API. -- @@ -136,9 +134,9 @@ -- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment. newtype ClientM a = ClientM { unClientM :: ReaderT ClientEnv (ExceptT ClientError IO) a } - deriving ( Functor, Applicative, Monad, MonadIO, Generic + deriving newtype ( Functor, Applicative, Monad, MonadIO, Generic , MonadReader ClientEnv, MonadError ClientError, MonadThrow - , MonadCatch) + , MonadCatch, MonadMask) instance MonadBase IO ClientM where liftBase = ClientM . liftBase @@ -155,16 +153,19 @@ a b = a `catchError` \_ -> b instance RunClient ClientM where - runRequest = performRequest + runRequestAcceptStatus statuses req = do + ClientEnv {middleware} <- ask + let oldApp = performRequest statuses + middleware oldApp req throwClientError = throwError runClientM :: ClientM a -> ClientEnv -> IO (Either ClientError a) runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm -performRequest :: Request -> ClientM Response -performRequest req = do - ClientEnv m burl cookieJar' createClientRequest <- ask - let clientRequest = createClientRequest burl req +performRequest :: Maybe [Status] -> Request -> ClientM Response +performRequest acceptStatus req = do + ClientEnv m burl cookieJar' createClientRequest _ <- ask + clientRequest <- liftIO $ createClientRequest burl req request <- case cookieJar' of Nothing -> pure clientRequest Just cj -> liftIO $ do @@ -181,10 +182,12 @@ response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar' let status = Client.responseStatus response - status_code = statusCode status ourResponse = clientResponseToResponse id response - unless (status_code >= 200 && status_code < 300) $ - throwError $ mkFailureResponse burl req ourResponse + goodStatus = case acceptStatus of + Nothing -> statusIsSuccessful status + Just good -> status `elem` good + unless goodStatus $ do + throwError $ mkFailureResponse burl req ourResponse return ourResponse where requestWithoutCookieJar :: Client.Manager -> Client.Request -> ClientM (Client.Response BSL.ByteString) @@ -229,15 +232,22 @@ -- | Create a @http-client@ 'Client.Request' from a @servant@ 'Request' -- The 'Client.host', 'Client.path' and 'Client.port' fields are extracted from the 'BaseUrl' -- otherwise the body, headers and query string are derived from the @servant@ 'Request' -defaultMakeClientRequest :: BaseUrl -> Request -> Client.Request -defaultMakeClientRequest burl r = Client.defaultRequest +-- +-- Note that @Applicative@ dependency is not really needed for this function +-- implementation. But in the past the return type was wrapped into @IO@ +-- without a necessity breaking the API backward-compatibility. In order to not +-- break the API again it was changed to @Applicative@ so that you can just use +-- something like @Data.Functor.Identity@ without a need to involve @IO@ but +-- still keeping it compatible with the code written when it was typed as @IO@. +defaultMakeClientRequest :: Applicative f => BaseUrl -> Request -> f Client.Request +defaultMakeClientRequest burl r = pure Client.defaultRequest { Client.method = requestMethod r , Client.host = fromString $ baseUrlHost burl , Client.port = baseUrlPort burl , Client.path = BSL.toStrict $ fromString (baseUrlPath burl) <> toLazyByteString (requestPath r) - , Client.queryString = renderQuery True . toList $ requestQueryString r + , Client.queryString = buildQueryString . toList $ requestQueryString r , Client.requestHeaders = maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers , Client.requestBody = body @@ -246,7 +256,7 @@ where -- Content-Type and Accept are specified by requestBody and requestAccept headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $ - toList $requestHeaders r + toList $ requestHeaders r acceptHdr | null hs = Nothing @@ -287,6 +297,14 @@ isSecure = case baseUrlScheme burl of Http -> False Https -> True + + -- Query string builder which does not do any encoding + buildQueryString [] = mempty + buildQueryString qps = "?" <> List.foldl' addQueryParam mempty qps + + addQueryParam qs (k, v) = + qs <> (if BS.null qs then mempty else "&") <> urlEncode True k <> foldMap ("=" <>) v + catchConnectionError :: IO a -> IO (Either ClientError a) catchConnectionError action = diff --git a/src/Servant/Client/Internal/HttpClient/Streaming.hs b/src/Servant/Client/Internal/HttpClient/Streaming.hs --- a/src/Servant/Client/Internal/HttpClient/Streaming.hs +++ b/src/Servant/Client/Internal/HttpClient/Streaming.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -24,14 +23,16 @@ (NFData, force) import Control.Exception (evaluate, throwIO) -import Control.Monad () +import Control.Monad + (unless) import Control.Monad.Base (MonadBase (..)) import Control.Monad.Codensity (Codensity (..)) import Control.Monad.Error.Class (MonadError (..)) -import Control.Monad.Reader +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Reader (MonadReader(..), ReaderT(..)) import Control.Monad.STM (atomically) import Control.Monad.Trans.Except @@ -47,7 +48,7 @@ (getCurrentTime) import GHC.Generics import Network.HTTP.Types - (statusCode) + (Status, statusIsSuccessful) import qualified Network.HTTP.Client as Client @@ -57,6 +58,7 @@ clientResponseToResponse, mkClientEnv, mkFailureResponse, defaultMakeClientRequest) import qualified Servant.Types.SourceT as S +import Control.Monad.Trans.Class (MonadTrans(..)) -- | Generates a set of client functions for an API. @@ -101,7 +103,7 @@ -- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment. newtype ClientM a = ClientM { unClientM :: ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a } - deriving ( Functor, Applicative, Monad, MonadIO, Generic + deriving newtype ( Functor, Applicative, Monad, MonadIO, Generic , MonadReader ClientEnv, MonadError ClientError) instance MonadBase IO ClientM where @@ -112,7 +114,7 @@ a b = a `catchError` \_ -> b instance RunClient ClientM where - runRequest = performRequest + runRequestAcceptStatus = performRequest throwClientError = throwError instance RunStreamingClient ClientM where @@ -130,17 +132,17 @@ -- streaming response types ('SourceT', 'Conduit', pipes 'Proxy' or 'Machine'). -- For those you have to use 'withClientM'. -- --- /Note:/ we 'force' the result, so the likehood of accidentally leaking a +-- /Note:/ we 'force' the result, so the likelihood of accidentally leaking a -- connection is smaller. Use with care. -- runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ClientError a) runClientM cm env = withClientM cm env (evaluate . force) -performRequest :: Request -> ClientM Response -performRequest req = do +performRequest :: Maybe [Status] -> Request -> ClientM Response +performRequest acceptStatus req = do -- TODO: should use Client.withResponse here too - ClientEnv m burl cookieJar' createClientRequest <- ask - let clientRequest = createClientRequest burl req + ClientEnv m burl cookieJar' createClientRequest _ <- ask + clientRequest <- liftIO $ createClientRequest burl req request <- case cookieJar' of Nothing -> pure clientRequest Just cj -> liftIO $ do @@ -163,25 +165,38 @@ now' <- getCurrentTime atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now') let status = Client.responseStatus response - status_code = statusCode status ourResponse = clientResponseToResponse id response - unless (status_code >= 200 && status_code < 300) $ + goodStatus = case acceptStatus of + Nothing -> statusIsSuccessful status + Just good -> status `elem` good + unless goodStatus $ do throwError $ mkFailureResponse burl req ourResponse return ourResponse +-- | TODO: support UVerb ('acceptStatus' argument, like in 'performRequest' above). performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a performWithStreamingRequest req k = do - m <- asks manager - burl <- asks baseUrl - createClientRequest <- asks makeClientRequest - let request = createClientRequest burl req + ClientEnv m burl cookieJar' createClientRequest _ <- ask + clientRequest <- liftIO $ createClientRequest burl req + request <- case cookieJar' of + Nothing -> pure clientRequest + Just cj -> liftIO $ do + now <- getCurrentTime + atomically $ do + oldCookieJar <- readTVar cj + let (newRequest, newCookieJar) = + Client.insertCookiesIntoRequest + clientRequest + oldCookieJar + now + writeTVar cj newCookieJar + pure newRequest ClientM $ lift $ lift $ Codensity $ \k1 -> Client.withResponse request m $ \res -> do let status = Client.responseStatus res - status_code = statusCode status -- we throw FailureResponse in IO :( - unless (status_code >= 200 && status_code < 300) $ do + unless (statusIsSuccessful status) $ do b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res) throwIO $ mkFailureResponse burl req (clientResponseToResponse (const b) res) diff --git a/test/Servant/BrokenSpec.hs b/test/Servant/BrokenSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/BrokenSpec.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -freduction-depth=100 #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +module Servant.BrokenSpec (spec) where + +import Prelude () +import Prelude.Compat + +import Data.Monoid () +import Data.Proxy +import qualified Network.HTTP.Types as HTTP +import Test.Hspec + +import Servant.API + ((:<|>) ((:<|>)), (:>), JSON, Verb, Get, StdMethod (GET)) +import Servant.Client +import Servant.ClientTestUtils +import Servant.Server + +-- * api for testing inconsistencies between client and server + +type Get201 = Verb 'GET 201 +type Get301 = Verb 'GET 301 + +type BrokenAPI = + -- the server should respond with 200, but returns 201 + "get200" :> Get201 '[JSON] () + -- the server should respond with 307, but returns 301 + :<|> "get307" :> Get301 '[JSON] () + +brokenApi :: Proxy BrokenAPI +brokenApi = Proxy + +brokenServer :: Application +brokenServer = serve brokenApi (pure () :<|> pure ()) + +type PublicAPI = + -- the client expects 200 + "get200" :> Get '[JSON] () + -- the client expects 307 + :<|> "get307" :> Get307 '[JSON] () + +publicApi :: Proxy PublicAPI +publicApi = Proxy + +get200Client :: ClientM () +get307Client :: ClientM () +get200Client :<|> get307Client = client publicApi + + +spec :: Spec +spec = describe "Servant.BrokenSpec" $ do + brokenSpec + +brokenSpec :: Spec +brokenSpec = beforeAll (startWaiApp brokenServer) $ afterAll endWaiApp $ do + context "client returns errors for inconsistencies between client and server api" $ do + it "reports FailureResponse with wrong 2xx status code" $ \(_, baseUrl) -> do + res <- runClient get200Client baseUrl + case res of + Left (FailureResponse _ r) | responseStatusCode r == HTTP.status201 -> return () + _ -> fail $ "expected 201 broken response, but got " <> show res + + it "reports FailureResponse with wrong 3xx status code" $ \(_, baseUrl) -> do + res <- runClient get307Client baseUrl + case res of + Left (FailureResponse _ r) | responseStatusCode r == HTTP.status301 -> return () + _ -> fail $ "expected 301 broken response, but got " <> show res diff --git a/test/Servant/ClientTestUtils.hs b/test/Servant/ClientTestUtils.hs --- a/test/Servant/ClientTestUtils.hs +++ b/test/Servant/ClientTestUtils.hs @@ -1,17 +1,18 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -freduction-depth=100 #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} @@ -21,36 +22,51 @@ import Prelude () import Prelude.Compat -import Control.Concurrent - (ThreadId, forkIO, killThread) -import Control.Monad.Error.Class - (throwError) +import Control.Concurrent (ThreadId, forkIO, killThread) +import Control.Monad (join) +import Control.Monad.Error.Class (throwError) import Data.Aeson -import Data.Char - (chr, isPrint) +import Data.ByteString (ByteString) +import Data.ByteString.Builder (byteString) +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Lazy as LazyByteString +import Data.Char (chr, isPrint) +import Data.Maybe (fromMaybe) import Data.Monoid () import Data.Proxy -import GHC.Generics - (Generic) -import qualified Network.HTTP.Client as C -import qualified Network.HTTP.Types as HTTP +import Data.SOP +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import qualified Generics.SOP as GSOP +import GHC.Generics (Generic) +import qualified Network.HTTP.Client as C +import qualified Network.HTTP.Types as HTTP import Network.Socket -import qualified Network.Wai as Wai +import qualified Network.Wai as Wai import Network.Wai.Handler.Warp -import System.IO.Unsafe - (unsafePerformIO) +import System.IO.Unsafe (unsafePerformIO) import Test.QuickCheck -import Web.FormUrlEncoded - (FromForm, ToForm) +import Text.Read (readMaybe) +import Web.FormUrlEncoded (FromForm, ToForm) import Servant.API - ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, - BasicAuthData (..), Capture, CaptureAll, - DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header, - Headers, JSON, NoContent (NoContent), Post, QueryFlag, - QueryParam, QueryParams, Raw, ReqBody, addHeader) + (AuthProtect, BasicAuth, BasicAuthData (..), Capture, + CaptureAll, DeepQuery, DeleteNoContent, EmptyAPI, + FormUrlEncoded, Fragment, FromHttpApiData (..), Get, Header, + Headers, Host, JSON, MimeRender (mimeRender), + MimeUnrender (mimeUnrender), NamedRoutes, + NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam, + QueryParams, QueryString, Raw, ReqBody, StdMethod (GET), + ToHttpApiData (..), UVerb, Union, Verb, + WithStatus (WithStatus), addHeader, (:<|>) ((:<|>)), (:>)) +import Servant.API.Generic ((:-)) +import Servant.API.MultiVerb +import Servant.API.QueryString + (FromDeepQuery (..), ToDeepQuery (..)) +import Servant.API.Range import Servant.Client -import qualified Servant.Client.Core.Auth as Auth +import qualified Servant.Client.Core.Auth as Auth import Servant.Server import Servant.Server.Experimental.Auth import Servant.Test.ComprehensiveAPI @@ -63,7 +79,7 @@ data Person = Person { _name :: String , _age :: Integer - } deriving (Eq, Show, Generic) + } deriving (Eq, Show, Read, Generic) instance ToJSON Person instance FromJSON Person @@ -74,6 +90,15 @@ instance Arbitrary Person where arbitrary = Person <$> arbitrary <*> arbitrary +instance MimeRender PlainText Person where + mimeRender _ = LazyByteString.fromStrict . encodeUtf8 . Text.pack . show + +instance MimeUnrender PlainText Person where + mimeUnrender _ = + -- This does not handle any errors, but it should be fine for tests + Right . read . Text.unpack . decodeUtf8 . LazyByteString.toStrict + + alice :: Person alice = Person "Alice" 42 @@ -81,17 +106,91 @@ carol = Person "Carol" 17 type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String] +type TestSetCookieHeaders = '[Header "Set-Cookie" String, Header "Set-Cookie" String] +data RecordRoutes mode = RecordRoutes + { version :: mode :- "version" :> Get '[JSON] Int + , echo :: mode :- "echo" :> Capture "string" String :> Get '[JSON] String + , otherRoutes :: mode :- "other" :> Capture "someParam" Int :> NamedRoutes OtherRoutes + } deriving Generic + +newtype OtherRoutes mode = OtherRoutes + { something :: mode :- "something" :> Get '[JSON] [String] + } deriving Generic + +-- Get for HTTP 307 Temporary Redirect +type Get307 = Verb 'GET 307 + +data Filter = Filter + { ageFilter :: Integer + , nameFilter :: String + } + deriving Show + +instance FromDeepQuery Filter where + fromDeepQuery params = do + let maybeToRight l = maybe (Left l) Right + age' <- maybeToRight "missing age" $ readMaybe . Text.unpack =<< join (lookup ["age"] params) + name' <- maybeToRight "missing name" $ join $ lookup ["name"] params + return $ Filter age' (Text.unpack name') + +instance ToDeepQuery Filter where + toDeepQuery (Filter age' name') = + [ (["age"], Just (Text.pack $ show age')) + , (["name"], Just (Text.pack name')) + ] + +----------------------------- +-- MultiVerb test endpoint -- +----------------------------- + +-- This is the list of all possible responses +type MultipleChoicesIntResponses = + '[ RespondEmpty 400 "Negative" + , Respond 200 "Even number" Bool + , Respond 200 "Odd number" Int + ] + +data MultipleChoicesIntResult + = NegativeNumber + | Even Bool + | Odd Int + deriving stock (Generic) + deriving (AsUnion MultipleChoicesIntResponses) + via GenericAsUnion MultipleChoicesIntResponses MultipleChoicesIntResult + +instance GSOP.Generic MultipleChoicesIntResult + +-- This is our endpoint description +type MultipleChoicesInt = + Capture "int" Int + :> MultiVerb + 'GET + '[JSON] + MultipleChoicesIntResponses + MultipleChoicesIntResult + type Api = Get '[JSON] Person :<|> "get" :> Get '[JSON] Person + -- This endpoint returns a response with status code 307 Temporary Redirect, + -- different from the ones in the 2xx successful class, to test derivation + -- of clients' api. + :<|> "get307" :> Get307 '[PlainText] Text :<|> "deleteEmpty" :> DeleteNoContent :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person] :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person + -- This endpoint makes use of a 'Raw' server because it is not currently + -- possible to handle arbitrary binary query param values with + -- @servant-server@ + :<|> "param-binary" :> QueryParam "payload" UrlEncodedByteString :> Raw :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person] :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool + :<|> "query-string" :> QueryString :> Get '[JSON] Person + :<|> "deep-query" :> DeepQuery "filter" Filter :> Get '[JSON] Person + :<|> "fragment" :> Fragment String :> Get '[JSON] Person :<|> "rawSuccess" :> Raw :<|> "rawSuccessPassHeaders" :> Raw :<|> "rawFailure" :> Raw @@ -102,72 +201,159 @@ ReqBody '[JSON] [(String, [Rational])] :> Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])]) :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool) + :<|> "uverb-headers" :> UVerb 'GET '[JSON] '[ WithStatus 200 (Headers TestHeaders Bool), WithStatus 204 String ] + :<|> "set-cookie-headers" :> Get '[JSON] (Headers TestSetCookieHeaders Bool) :<|> "deleteContentType" :> DeleteNoContent :<|> "redirectWithCookie" :> Raw :<|> "empty" :> EmptyAPI + :<|> "uverb-success-or-redirect" :> + Capture "bool" Bool :> + UVerb 'GET '[PlainText] '[WithStatus 200 Person, + WithStatus 301 Text] + :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person] + :<|> NamedRoutes RecordRoutes + :<|> "multiple-choices-int" :> MultipleChoicesInt + :<|> "captureVerbatim" :> Capture "someString" Verbatim :> Get '[PlainText] Text + :<|> "host-test" :> Host "servant.example" :> Get '[JSON] Bool + :<|> PaginatedAPI api :: Proxy Api api = Proxy getRoot :: ClientM Person getGet :: ClientM Person +getGet307 :: ClientM Text getDeleteEmpty :: ClientM NoContent getCapture :: String -> ClientM Person getCaptureAll :: [String] -> ClientM [Person] getBody :: Person -> ClientM Person getQueryParam :: Maybe String -> ClientM Person +getQueryParamBinary :: Maybe UrlEncodedByteString -> HTTP.Method -> ClientM Response getQueryParams :: [String] -> ClientM [Person] getQueryFlag :: Bool -> ClientM Bool +getQueryString :: [(ByteString, Maybe ByteString)] -> ClientM Person +getDeepQuery :: Filter -> ClientM Person +getFragment :: ClientM Person getRawSuccess :: HTTP.Method -> ClientM Response getRawSuccessPassHeaders :: HTTP.Method -> ClientM Response getRawFailure :: HTTP.Method -> ClientM Response getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> ClientM (String, Maybe Int, Bool, [(String, [Rational])]) getRespHeaders :: ClientM (Headers TestHeaders Bool) +getUVerbRespHeaders :: ClientM (Union '[ WithStatus 200 (Headers TestHeaders Bool), WithStatus 204 String ]) +getSetCookieHeaders :: ClientM (Headers TestSetCookieHeaders Bool) getDeleteContentType :: ClientM NoContent getRedirectWithCookie :: HTTP.Method -> ClientM Response +uverbGetSuccessOrRedirect :: Bool + -> ClientM (Union '[WithStatus 200 Person, + WithStatus 301 Text]) +uverbGetCreated :: ClientM (Union '[WithStatus 201 Person]) +recordRoutes :: RecordRoutes (AsClientT ClientM) +multiChoicesInt :: Int -> ClientM MultipleChoicesIntResult +captureVerbatim :: Verbatim -> ClientM Text +getHost :: ClientM Bool +getPaginatedPerson :: Maybe (Range 1 100) -> ClientM [Person] getRoot :<|> getGet + :<|> getGet307 :<|> getDeleteEmpty :<|> getCapture :<|> getCaptureAll :<|> getBody :<|> getQueryParam + :<|> getQueryParamBinary :<|> getQueryParams :<|> getQueryFlag + :<|> getQueryString + :<|> getDeepQuery + :<|> getFragment :<|> getRawSuccess :<|> getRawSuccessPassHeaders :<|> getRawFailure :<|> getMultiple :<|> getRespHeaders + :<|> getUVerbRespHeaders + :<|> getSetCookieHeaders :<|> getDeleteContentType :<|> getRedirectWithCookie - :<|> EmptyClient = client api + :<|> EmptyClient + :<|> uverbGetSuccessOrRedirect + :<|> uverbGetCreated + :<|> recordRoutes + :<|> multiChoicesInt + :<|> captureVerbatim + :<|> getHost + :<|> getPaginatedPerson = client api server :: Application server = serve api ( return carol :<|> return alice + :<|> return "redirecting" :<|> return NoContent :<|> (\ name -> return $ Person name 0) :<|> (\ names -> return (zipWith Person names [0..])) :<|> return - :<|> (\ name -> case name of - Just "alice" -> return alice - Just n -> throwError $ ServerError 400 (n ++ " not found") "" [] - Nothing -> throwError $ ServerError 400 "missing parameter" "" []) + :<|> (\case + Just "alice" -> return alice + Just n -> throwError $ ServerError 400 (n ++ " not found") "" [] + Nothing -> throwError $ ServerError 400 "missing parameter" "" []) + :<|> const (Tagged $ \request respond -> + respond . maybe (Wai.responseLBS HTTP.notFound404 [] "Missing: payload") + (Wai.responseLBS HTTP.ok200 [] . LazyByteString.fromStrict) + . join + . lookup "payload" + $ Wai.queryString request + ) :<|> (\ names -> return (zipWith Person names [0..])) :<|> return - :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess") - :<|> (Tagged $ \ request respond -> (respond $ Wai.responseLBS HTTP.ok200 (Wai.requestHeaders $ request) "rawSuccess")) - :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure") + :<|> (\ q -> return alice { _name = maybe mempty C8.unpack $ join (lookup "name" q) + , _age = fromMaybe 0 (readMaybe . C8.unpack =<< join (lookup "age" q)) + } + ) + :<|> (\ filter' -> return alice { _name = nameFilter filter' + , _age = ageFilter filter' + } + ) + :<|> return alice + :<|> Tagged (\ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess") + :<|> Tagged (\ request respond -> respond $ Wai.responseLBS HTTP.ok200 (Wai.requestHeaders request) "rawSuccess") + :<|> Tagged (\ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure") :<|> (\ a b c d -> return (a, b, c, d)) - :<|> (return $ addHeader 1729 $ addHeader "eg2" True) + :<|> return (addHeader 1729 $ addHeader "eg2" True) + :<|> (pure . Z . I . WithStatus $ addHeader 1729 $ addHeader "eg2" True) + :<|> return (addHeader "cookie1" $ addHeader "cookie2" True) :<|> return NoContent - :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "") - :<|> emptyServer) + :<|> Tagged (\ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "") + :<|> emptyServer + :<|> (\shouldRedirect -> if shouldRedirect + then respond (WithStatus @301 ("redirecting" :: Text)) + else respond (WithStatus @200 alice )) + :<|> respond (WithStatus @201 carol) + :<|> RecordRoutes + { version = pure 42 + , echo = pure + , otherRoutes = const OtherRoutes + { something = pure ["foo", "bar", "pweet"] + } + } + :<|> (\param -> + if param < 0 + then pure NegativeNumber + else + if even param + then pure $ Odd 3 + else pure $ Even True + ) + :<|> pure . decodeUtf8 . unVerbatim + :<|> pure True + :<|> usersServer + ) + +-- * api for testing failures + type FailApi = "get" :> Raw :<|> "capture" :> Capture "name" String :> Raw @@ -178,11 +364,11 @@ failServer :: Application failServer = serve failApi ( - (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "") + Tagged (\ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "") :<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "") - :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "") - :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/x-www-form-urlencoded"), ("X-Example1", "1"), ("X-Example2", "foo")] "") - ) + :<|> Tagged (\_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "") + :<|> Tagged (\_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/x-www-form-urlencoded"), ("X-Example1", "1"), ("X-Example2", "foo")] "") + ) -- * basic auth stuff @@ -266,3 +452,32 @@ filter (not . (`elem` ("?%[]/#;" :: String))) $ filter isPrint $ map chr [0..127] + +newtype UrlEncodedByteString = UrlEncodedByteString { unUrlEncodedByteString :: ByteString } + +instance ToHttpApiData UrlEncodedByteString where + toEncodedUrlPiece = byteString . HTTP.urlEncode True . unUrlEncodedByteString + toUrlPiece = decodeUtf8 . HTTP.urlEncode True . unUrlEncodedByteString + +instance FromHttpApiData UrlEncodedByteString where + parseUrlPiece = pure . UrlEncodedByteString . HTTP.urlDecode True . encodeUtf8 + +newtype Verbatim = Verbatim { unVerbatim :: ByteString } + +instance ToHttpApiData Verbatim where + toEncodedUrlPiece = byteString . unVerbatim + toUrlPiece = decodeUtf8 . unVerbatim + +instance FromHttpApiData Verbatim where + parseUrlPiece = pure . Verbatim . encodeUtf8 + +-- * range type example + +type PaginatedAPI = + "users" :> QueryParam "page" (Range 1 100) :> Get '[JSON] [Person] + +usersServer :: Maybe (Range 1 100) -> Handler [Person] +usersServer mpage = do + let pageNum = maybe 1 unRange mpage + -- pageNum is guaranteed to be between 1 and 100 + return [Person "Example" $ fromIntegral pageNum] diff --git a/test/Servant/FailSpec.hs b/test/Servant/FailSpec.hs --- a/test/Servant/FailSpec.hs +++ b/test/Servant/FailSpec.hs @@ -21,8 +21,6 @@ import Prelude.Compat import Data.Monoid () -import Data.Semigroup - ((<>)) import qualified Network.HTTP.Types as HTTP import Test.Hspec @@ -40,14 +38,14 @@ context "client returns errors appropriately" $ do it "reports FailureResponse" $ \(_, baseUrl) -> do - let (_ :<|> _ :<|> getDeleteEmpty :<|> _) = client api + let (_ :<|> _ :<|> _ :<|> getDeleteEmpty :<|> _) = client api Left res <- runClient getDeleteEmpty baseUrl case res of FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return () _ -> fail $ "expected 404 response, but got " <> show res it "reports DecodeFailure" $ \(_, baseUrl) -> do - let (_ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api + let (_ :<|> _ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api Left res <- runClient (getCapture "foo") baseUrl case res of DecodeFailure _ _ -> return () @@ -74,7 +72,7 @@ _ -> fail $ "expected UnsupportedContentType, but got " <> show res it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do - let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api + let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api Left res <- runClient (getBody alice) baseUrl case res of InvalidContentTypeHeader _ -> return () diff --git a/test/Servant/GenericSpec.hs b/test/Servant/GenericSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/GenericSpec.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -freduction-depth=100 #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +module Servant.GenericSpec (spec) where + +import Test.Hspec + +import Servant.Client ((//), (/:)) +import Servant.ClientTestUtils + +spec :: Spec +spec = describe "Servant.GenericSpec" $ do + genericSpec + +genericSpec :: Spec +genericSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do + context "Record clients work as expected" $ do + + it "Client functions return expected values" $ \(_,baseUrl) -> do + runClient (recordRoutes // version) baseUrl `shouldReturn` Right 42 + runClient (recordRoutes // echo /: "foo") baseUrl `shouldReturn` Right "foo" + it "Clients can be nested" $ \(_,baseUrl) -> do + runClient (recordRoutes // otherRoutes /: 42 // something) baseUrl `shouldReturn` Right ["foo", "bar", "pweet"] diff --git a/test/Servant/MiddlewareSpec.hs b/test/Servant/MiddlewareSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/MiddlewareSpec.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -freduction-depth=100 #-} + +module Servant.MiddlewareSpec (spec) where + +import Control.Arrow (left) +import Control.Concurrent (newEmptyMVar, putMVar, takeMVar) +import Control.Exception (Exception, throwIO, try) +import Control.Monad.IO.Class +import Data.ByteString.Builder (toLazyByteString) +import Data.IORef (modifyIORef, newIORef, readIORef) +import Data.Monoid () +import Prelude.Compat +import Servant.Client +import Servant.Client.Core (RequestF (..)) +import Servant.Client.Internal.HttpClient (ClientMiddleware) +import Servant.ClientTestUtils +import Test.Hspec +import Prelude () + +runClientWithMiddleware :: ClientM a -> ClientMiddleware -> BaseUrl -> IO (Either ClientError a) +runClientWithMiddleware x mid baseUrl' = + runClientM x ((mkClientEnv manager' baseUrl') {middleware = mid}) + +data CustomException = CustomException deriving (Show, Eq) + +instance Exception CustomException + +spec :: Spec +spec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do + it "Raw request and response can be accessed in middleware" $ \(_, baseUrl) -> do + mvarReq <- newEmptyMVar + mvarResp <- newEmptyMVar + + let mid :: ClientMiddleware + mid oldApp req = do + -- "Log" request + liftIO $ putMVar mvarReq req + -- perform request + resp <- oldApp req + -- "Log" response + liftIO $ putMVar mvarResp resp + pure resp + + -- Same as without middleware + left show <$> runClientWithMiddleware getGet mid baseUrl `shouldReturn` Right alice + + -- Access some raw request data + req <- takeMVar mvarReq + toLazyByteString (requestPath req) `shouldBe` "/get" + + -- Access some raw response data + resp <- takeMVar mvarResp + responseBody resp `shouldBe` "{\"_age\":42,\"_name\":\"Alice\"}" + + it "errors can be thrown in middleware" $ \(_, baseUrl) -> do + let mid :: ClientMiddleware + mid oldApp req = do + -- perform request + resp <- oldApp req + -- throw error + _ <- liftIO $ throwIO CustomException + pure resp + + try (runClientWithMiddleware getGet mid baseUrl) `shouldReturn` Left CustomException + + it "runs in the expected order" $ \(_, baseUrl) -> do + ref <- newIORef [] + + let mid1 :: ClientMiddleware + mid1 oldApp req = do + liftIO $ modifyIORef ref (\xs -> xs <> ["req1"]) + resp <- oldApp req + liftIO $ modifyIORef ref (\xs -> xs <> ["resp1"]) + pure resp + + let mid2 :: ClientMiddleware + mid2 oldApp req = do + liftIO $ modifyIORef ref (\xs -> xs <> ["req2"]) + resp <- oldApp req + liftIO $ modifyIORef ref (\xs -> xs <> ["resp2"]) + pure resp + + let mid3 :: ClientMiddleware + mid3 oldApp req = do + liftIO $ modifyIORef ref (\xs -> xs <> ["req3"]) + resp <- oldApp req + liftIO $ modifyIORef ref (\xs -> xs <> ["resp3"]) + pure resp + + let mid :: ClientMiddleware + mid = mid1 . mid2 . mid3 + -- \^ Composition in "reverse order". + -- It is equivalent to the following, which is more intuitive: + -- mid :: ClientMiddleware + -- mid oldApp = mid1 (mid2 (mid3 oldApp)) + + -- Same as without middleware + left show <$> runClientWithMiddleware getGet mid baseUrl `shouldReturn` Right alice + + ref <- readIORef ref + ref `shouldBe` ["req1", "req2", "req3", "resp3", "resp2", "resp1"] diff --git a/test/Servant/StreamSpec.hs b/test/Servant/StreamSpec.hs --- a/test/Servant/StreamSpec.hs +++ b/test/Servant/StreamSpec.hs @@ -1,17 +1,13 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -21,16 +17,9 @@ module Servant.StreamSpec (spec) where -import Control.Monad - (when) -import Control.Monad.Codensity - (Codensity (..)) -import Control.Monad.IO.Class - (MonadIO (..)) import Control.Monad.Trans.Except import qualified Data.ByteString as BS import Data.Proxy -import qualified Data.TDigest as TD import qualified Network.HTTP.Client as C import Prelude () import Prelude.Compat @@ -46,20 +35,10 @@ (getEntropy, getHardwareEntropy) import System.IO.Unsafe (unsafePerformIO) -import System.Mem - (performGC) import Test.Hspec import Servant.ClientTestUtils (Person(..)) import qualified Servant.ClientTestUtils as CT -#if MIN_VERSION_base(4,10,0) -import GHC.Stats - (gc, gcdetails_live_bytes, getRTSStats) -#else -import GHC.Stats - (currentBytesUsed, getGCStats) -#endif - -- This declaration simply checks that all instances are in place. -- Note: this is streaming client _ = client comprehensiveAPI @@ -134,50 +113,3 @@ where input = ["foo", "", "bar"] output = ["foo", "bar"] - -{- - it "streams in constant memory" $ \(_, baseUrl) -> do - Right rs <- runClient getGetALot baseUrl - performGC - -- usage0 <- getUsage - -- putStrLn $ "Start: " ++ show usage0 - tdigest <- memoryUsage $ joinCodensitySourceT rs - - -- putStrLn $ "Median: " ++ show (TD.median tdigest) - -- putStrLn $ "Mean: " ++ show (TD.mean tdigest) - -- putStrLn $ "Stddev: " ++ show (TD.stddev tdigest) - - -- forM_ [0.01, 0.1, 0.2, 0.5, 0.8, 0.9, 0.99] $ \q -> - -- putStrLn $ "q" ++ show q ++ ": " ++ show (TD.quantile q tdigest) - - let Just stddev = TD.stddev tdigest - - -- standard deviation of 100k is ok, we generate 256M of data after all. - -- On my machine deviation is 40k-50k - stddev `shouldSatisfy` (< 100000) - -memoryUsage :: SourceT IO BS.ByteString -> IO (TD.TDigest 25) -memoryUsage src = unSourceT src $ loop mempty (0 :: Int) - where - loop !acc !_ Stop = return acc - loop !_ !_ (Error err) = fail err -- ! - loop !acc !n (Skip s) = loop acc n s - loop !acc !n (Effect ms) = ms >>= loop acc n - loop !acc !n (Yield _bs s) = do - usage <- liftIO getUsage - -- We perform GC in between as we generate garbage. - when (n `mod` 1024 == 0) $ liftIO performGC - loop (TD.insert usage acc) (n + 1) s - -getUsage :: IO Double -getUsage = fromIntegral . -#if MIN_VERSION_base(4,10,0) - gcdetails_live_bytes . gc <$> getRTSStats -#else - currentBytesUsed <$> getGCStats -#endif - memUsed `shouldSatisfy` (< megabytes 22) - -megabytes :: Num a => a -> a -megabytes n = n * (1000 ^ (2 :: Int)) --} diff --git a/test/Servant/SuccessSpec.hs b/test/Servant/SuccessSpec.hs --- a/test/Servant/SuccessSpec.hs +++ b/test/Servant/SuccessSpec.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -freduction-depth=100 #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} @@ -31,45 +31,45 @@ import Data.Maybe (listToMaybe) import Data.Monoid () -import qualified Network.HTTP.Client as C -import qualified Network.HTTP.Types as HTTP +import Data.Text + (Text) +import Data.Text.Encoding + (encodeUtf8) +import qualified Network.HTTP.Client as C +import qualified Network.HTTP.Types as HTTP import Test.Hspec import Test.Hspec.QuickCheck import Test.HUnit import Test.QuickCheck import Servant.API - (NoContent (NoContent), getHeaders) + (NoContent (NoContent), WithStatus (WithStatus), getHeaders, Headers(..)) import Servant.Client -import qualified Servant.Client.Core.Request as Req -import Servant.Client.Internal.HttpClient (defaultMakeClientRequest) -import Servant.Test.ComprehensiveAPI +import qualified Servant.Client.Core.Request as Req import Servant.ClientTestUtils +import Servant.Test.ComprehensiveAPI -- This declaration simply checks that all instances are in place. _ = client comprehensiveAPIWithoutStreaming spec :: Spec -spec = describe "Servant.SuccessSpec" $ do - successSpec +spec = describe "Servant.SuccessSpec" $ successSpec successSpec :: Spec successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do - it "Servant.API.Get root" $ \(_, baseUrl) -> do - left show <$> runClient getRoot baseUrl `shouldReturn` Right carol + describe "Servant.API.Get" $ do + it "get root endpoint" $ \(_, baseUrl) -> left show <$> runClient getRoot baseUrl `shouldReturn` Right carol - it "Servant.API.Get" $ \(_, baseUrl) -> do - left show <$> runClient getGet baseUrl `shouldReturn` Right alice + it "get simple endpoint" $ \(_, baseUrl) -> left show <$> runClient getGet baseUrl `shouldReturn` Right alice + it "get redirection endpoint" $ \(_, baseUrl) -> left show <$> runClient getGet307 baseUrl `shouldReturn` Right "redirecting" + describe "Servant.API.Delete" $ do - it "allows empty content type" $ \(_, baseUrl) -> do - left show <$> runClient getDeleteEmpty baseUrl `shouldReturn` Right NoContent + it "allows empty content type" $ \(_, baseUrl) -> left show <$> runClient getDeleteEmpty baseUrl `shouldReturn` Right NoContent - it "allows content type" $ \(_, baseUrl) -> do - left show <$> runClient getDeleteContentType baseUrl `shouldReturn` Right NoContent + it "allows content type" $ \(_, baseUrl) -> left show <$> runClient getDeleteContentType baseUrl `shouldReturn` Right NoContent - it "Servant.API.Capture" $ \(_, baseUrl) -> do - left show <$> runClient (getCapture "Paula") baseUrl `shouldReturn` Right (Person "Paula" 0) + it "Servant.API.Capture" $ \(_, baseUrl) -> left show <$> runClient (getCapture "Paula") baseUrl `shouldReturn` Right (Person "Paula" 0) it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do let expected = [Person "Paula" 0, Person "Peta" 1] @@ -97,9 +97,16 @@ `shouldReturn` Right [Person "alice" 0, Person "bob" 1] context "Servant.API.QueryParam.QueryFlag" $ - forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do - left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag + forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag + it "Servant.API.QueryParam.QueryString" $ \(_, baseUrl) -> do + let qs = [("name", Just "bob"), ("age", Just "1")] + left show <$> runClient (getQueryString qs) baseUrl `shouldReturn` Right (Person "bob" 1) + + it "Servant.API.QueryParam.DeepQuery" $ \(_, baseUrl) -> left show <$> runClient (getDeepQuery $ Filter 1 "bob") baseUrl `shouldReturn` (Right (Person "bob" 1)) + + it "Servant.API.Fragment" $ \(_, baseUrl) -> left id <$> runClient getFragment baseUrl `shouldReturn` Right alice + it "Servant.API.Raw on success" $ \(_, baseUrl) -> do res <- runClient (getRawSuccess HTTP.methodGet) baseUrl case res of @@ -123,10 +130,25 @@ Left e -> assertFailure $ show e Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] + it "Returns headers on UVerb requests" $ \(_, baseUrl) -> do + res <- runClient getUVerbRespHeaders baseUrl + case res of + Left e -> assertFailure $ show e + Right val -> case matchUnion val of + Just (WithStatus val' :: WithStatus 200 (Headers TestHeaders Bool)) + -> getHeaders val' `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] + Nothing -> assertFailure "unexpected alternative of union" + + it "Returns multiple Set-Cookie headers appropriately" $ \(_, baseUrl) -> do + res <- runClient getSetCookieHeaders baseUrl + case res of + Left e -> assertFailure $ show e + Right val -> getHeaders val `shouldBe` [("Set-Cookie", "cookie1"), ("Set-Cookie", "cookie2")] + it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do mgr <- C.newManager C.defaultManagerSettings cj <- atomically . newTVar $ C.createCookieJar [] - _ <- runClientM (getRedirectWithCookie HTTP.methodGet) (ClientEnv mgr baseUrl (Just cj) defaultMakeClientRequest) + _ <- runClientM (getRedirectWithCookie HTTP.methodGet) (ClientEnv mgr baseUrl (Just cj) defaultMakeClientRequest id) cookie <- listToMaybe . C.destroyCookieJar <$> atomically (readTVar cj) C.cookie_name <$> cookie `shouldBe` Just "testcookie" C.cookie_value <$> cookie `shouldBe` Just "test" @@ -135,8 +157,9 @@ mgr <- C.newManager C.defaultManagerSettings -- In proper situation, extra headers should probably be visible in API type. -- However, testing for response timeout is difficult, so we test with something which is easy to observe - let createClientRequest url r = (defaultMakeClientRequest url r) { C.requestHeaders = [("X-Added-Header", "XXX")] } - let clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest } + let createClientRequest url r = fmap (\req -> req { C.requestHeaders = [("X-Added-Header", "XXX")] }) + (defaultMakeClientRequest url r) + clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest } res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv case res of Left e -> @@ -144,10 +167,36 @@ Right r -> ("X-Added-Header", "XXX") `elem` toList (responseHeaders r) `shouldBe` True - modifyMaxSuccess (const 20) $ do - it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) -> - property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> - ioProperty $ do - result <- left show <$> runClient (getMultiple cap num flag body) baseUrl - return $ - result === Right (cap, num, flag, body) + modifyMaxSuccess (const 20) $ it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) -> + property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> + ioProperty $ do + result <- left show <$> runClient (getMultiple cap num flag body) baseUrl + return $ + result === Right (cap, num, flag, body) + + context "With a route that can either return success or redirect" $ do + it "Redirects when appropriate" $ \(_, baseUrl) -> do + eitherResponse <- runClient (uverbGetSuccessOrRedirect True) baseUrl + case eitherResponse of + Left clientError -> fail $ show clientError + Right response -> matchUnion response `shouldBe` Just (WithStatus @301 @Text "redirecting") + + it "Returns a proper response when appropriate" $ \(_, baseUrl) -> do + eitherResponse <- runClient (uverbGetSuccessOrRedirect False) baseUrl + case eitherResponse of + Left clientError -> fail $ show clientError + Right response -> matchUnion response `shouldBe` Just (WithStatus @200 alice) + + context "with a route that uses uverb but only has a single response" $ + it "returns the expected response" $ \(_, baseUrl) -> do + eitherResponse <- runClient uverbGetCreated baseUrl + case eitherResponse of + Left clientError -> fail $ show clientError + Right response -> matchUnion response `shouldBe` Just (WithStatus @201 carol) + + it "encodes URL pieces following ToHttpApiData instance" $ \(_, baseUrl) -> do + let textOrig = "*" + eitherResponse <- runClient (captureVerbatim $ Verbatim $ encodeUtf8 textOrig) baseUrl + case eitherResponse of + Left clientError -> fail $ show clientError + Right textBack -> textBack `shouldBe` textOrig diff --git a/test/Servant/WrappedApiSpec.hs b/test/Servant/WrappedApiSpec.hs --- a/test/Servant/WrappedApiSpec.hs +++ b/test/Servant/WrappedApiSpec.hs @@ -20,6 +20,7 @@ import Prelude () import Prelude.Compat +import Data.Kind (Type) import Control.Exception (bracket) import Control.Monad.Error.Class @@ -40,7 +41,7 @@ wrappedApiSpec data WrappedApi where - WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a, + WrappedApi :: (HasServer (api :: Type) '[], Server api ~ Handler a, HasClient ClientM api, Client ClientM api ~ ClientM ()) => Proxy api -> WrappedApi