servant-client 0.18.3 → 0.20.3.0
raw patch · 14 files changed
Files
- CHANGELOG.md +82/−0
- README.lhs +1/−1
- README.md +1/−1
- servant-client.cabal +138/−77
- src/Servant/Client/Internal/HttpClient.hs +45/−30
- src/Servant/Client/Internal/HttpClient/Streaming.hs +26/−15
- test/Servant/BrokenSpec.hs +71/−0
- test/Servant/ClientTestUtils.hs +209/−38
- test/Servant/FailSpec.hs +3/−5
- test/Servant/GenericSpec.hs +37/−0
- test/Servant/MiddlewareSpec.hs +115/−0
- test/Servant/StreamSpec.hs +0/−68
- test/Servant/SuccessSpec.hs +49/−35
- test/Servant/WrappedApiSpec.hs +2/−1
CHANGELOG.md view
@@ -1,6 +1,88 @@ [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 ------
README.lhs view
@@ -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
README.md view
@@ -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
servant-client.cabal view
@@ -1,9 +1,8 @@-cabal-version: >=1.10-name: servant-client-version: 0.18.3--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 <http://hackage.haskell.org/package/servant servant> webservice.@@ -12,128 +11,190 @@ . <https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG> -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.4 || ==8.10.2 || ==9.0.1+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.16- , bytestring >= 0.10.8.1 && < 0.12- , containers >= 0.5.7.1 && < 0.7- , deepseq >= 1.4.2.0 && < 1.5- , mtl >= 2.2.2 && < 2.3- , stm >= 2.4.5.1 && < 2.6- , text >= 1.2.3.0 && < 1.3- , time >= 1.6.0.1 && < 1.10- , transformers >= 0.5.2.0 && < 0.6-- if !impl(ghc >= 8.2)- build-depends:- bifunctors >= 5.5.3 && < 5.6+ , 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.18.*- , servant-client-core >= 0.18.3 && <0.18.4+ , 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.8- , http-media >= 0.7.1.3 && < 0.9- , http-types >= 0.12.2 && < 0.13- , exceptions >= 0.10.0 && < 0.11- , kan-extensions >= 5.2 && < 5.3- , monad-control >= 1.0.2.3 && < 1.1- , semigroupoids >= 5.3.1 && < 5.4- , transformers-base >= 0.4.5.2 && < 0.5- , transformers-compat >= 0.6.2 && < 0.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 -- Additional dependencies build-depends:- entropy >= 0.4.1.3 && < 0.5- , hspec >= 2.6.0 && < 2.9- , HUnit >= 1.6.0.0 && < 1.7- , network >= 2.8.0.0 && < 3.2- , QuickCheck >= 2.12.6.1 && < 2.15- , servant == 0.18.*- , servant-server == 0.18.*- , 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.9+ 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
src/Servant/Client/Internal/HttpClient.hs view
@@ -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, Status)+ (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,7 +153,10 @@ a <!> b = a `catchError` \_ -> b instance RunClient ClientM where- runRequestAcceptStatus = 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)@@ -163,8 +164,8 @@ performRequest :: Maybe [Status] -> Request -> ClientM Response performRequest acceptStatus req = do- 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@@ -181,10 +182,9 @@ response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar' let status = Client.responseStatus response- status_code = statusCode status ourResponse = clientResponseToResponse id response goodStatus = case acceptStatus of- Nothing -> status_code >= 200 && status_code < 300+ Nothing -> statusIsSuccessful status Just good -> status `elem` good unless goodStatus $ do throwError $ mkFailureResponse burl req ourResponse@@ -232,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@@ -249,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@@ -290,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 =
src/Servant/Client/Internal/HttpClient/Streaming.hs view
@@ -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- (Status, 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@@ -139,8 +141,8 @@ 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,10 +165,9 @@ now' <- getCurrentTime atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now') let status = Client.responseStatus response- status_code = statusCode status ourResponse = clientResponseToResponse id response goodStatus = case acceptStatus of- Nothing -> status_code >= 200 && status_code < 300+ Nothing -> statusIsSuccessful status Just good -> status `elem` good unless goodStatus $ do throwError $ mkFailureResponse burl req ourResponse@@ -175,17 +176,27 @@ -- | 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)
+ test/Servant/BrokenSpec.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -freduction-depth=100 #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++module Servant.BrokenSpec (spec) where++import Prelude ()+import Prelude.Compat++import Data.Monoid ()+import Data.Proxy+import qualified Network.HTTP.Types as HTTP+import Test.Hspec++import Servant.API+ ((:<|>) ((:<|>)), (:>), JSON, Verb, Get, StdMethod (GET))+import Servant.Client+import Servant.ClientTestUtils+import Servant.Server++-- * api for testing inconsistencies between client and server++type Get201 = Verb 'GET 201+type Get301 = Verb 'GET 301++type BrokenAPI =+ -- the server should respond with 200, but returns 201+ "get200" :> Get201 '[JSON] ()+ -- the server should respond with 307, but returns 301+ :<|> "get307" :> Get301 '[JSON] ()++brokenApi :: Proxy BrokenAPI+brokenApi = Proxy++brokenServer :: Application+brokenServer = serve brokenApi (pure () :<|> pure ())++type PublicAPI =+ -- the client expects 200+ "get200" :> Get '[JSON] ()+ -- the client expects 307+ :<|> "get307" :> Get307 '[JSON] ()++publicApi :: Proxy PublicAPI+publicApi = Proxy++get200Client :: ClientM ()+get307Client :: ClientM ()+get200Client :<|> get307Client = client publicApi+++spec :: Spec+spec = describe "Servant.BrokenSpec" $ do+ brokenSpec++brokenSpec :: Spec+brokenSpec = beforeAll (startWaiApp brokenServer) $ afterAll endWaiApp $ do+ context "client returns errors for inconsistencies between client and server api" $ do+ it "reports FailureResponse with wrong 2xx status code" $ \(_, baseUrl) -> do+ res <- runClient get200Client baseUrl+ case res of+ Left (FailureResponse _ r) | responseStatusCode r == HTTP.status201 -> return ()+ _ -> fail $ "expected 201 broken response, but got " <> show res++ it "reports FailureResponse with wrong 3xx status code" $ \(_, baseUrl) -> do+ res <- runClient get307Client baseUrl+ case res of+ Left (FailureResponse _ r) | responseStatusCode r == HTTP.status301 -> return ()+ _ -> fail $ "expected 301 broken response, but got " <> show res
test/Servant/ClientTestUtils.hs view
@@ -1,10 +1,10 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-}@@ -22,43 +22,49 @@ 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.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.Char (chr, isPrint)+import Data.Maybe (fromMaybe) import Data.Monoid () import Data.Proxy import Data.SOP-import Data.Text- (Text)+import Data.Text (Text) import qualified Data.Text as Text-import Data.Text.Encoding- (decodeUtf8, encodeUtf8)-import GHC.Generics- (Generic)+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import qualified Generics.SOP as GSOP+import GHC.Generics (Generic) import qualified Network.HTTP.Client as C import qualified Network.HTTP.Types as HTTP import Network.Socket import qualified Network.Wai as Wai import Network.Wai.Handler.Warp-import System.IO.Unsafe- (unsafePerformIO)+import 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, Fragment, Get, Header, Headers,- JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender),+ (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, Raw, ReqBody, StdMethod (GET), UVerb, Union,- WithStatus (WithStatus), addHeader)+ QueryParams, QueryString, Raw, ReqBody, StdMethod (GET),+ ToHttpApiData (..), UVerb, Union, Verb,+ WithStatus (WithStatus), addHeader, (:<|>) ((:<|>)), (:>))+import Servant.API.Generic ((:-))+import Servant.API.MultiVerb+import Servant.API.QueryString+ (FromDeepQuery (..), ToDeepQuery (..))+import Servant.API.Range import Servant.Client import qualified Servant.Client.Core.Auth as Auth import Servant.Server@@ -100,17 +106,90 @@ 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@@ -123,6 +202,7 @@ 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@@ -131,20 +211,28 @@ 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@@ -153,22 +241,32 @@ -> 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@@ -176,42 +274,86 @@ :<|> getMultiple :<|> getRespHeaders :<|> getUVerbRespHeaders+ :<|> getSetCookieHeaders :<|> getDeleteContentType :<|> getRedirectWithCookie :<|> EmptyClient :<|> uverbGetSuccessOrRedirect- :<|> uverbGetCreated = client api+ :<|> 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+ :<|> (\ 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")+ :<|> 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")] "")+ :<|> 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@@ -222,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 @@ -310,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]
test/Servant/FailSpec.hs view
@@ -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 ()
+ test/Servant/GenericSpec.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -freduction-depth=100 #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++module Servant.GenericSpec (spec) where++import Test.Hspec++import Servant.Client ((//), (/:))+import Servant.ClientTestUtils++spec :: Spec+spec = describe "Servant.GenericSpec" $ do+ genericSpec++genericSpec :: Spec+genericSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do+ context "Record clients work as expected" $ do++ it "Client functions return expected values" $ \(_,baseUrl) -> do+ runClient (recordRoutes // version) baseUrl `shouldReturn` Right 42+ runClient (recordRoutes // echo /: "foo") baseUrl `shouldReturn` Right "foo"+ it "Clients can be nested" $ \(_,baseUrl) -> do+ runClient (recordRoutes // otherRoutes /: 42 // something) baseUrl `shouldReturn` Right ["foo", "bar", "pweet"]
+ test/Servant/MiddlewareSpec.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -freduction-depth=100 #-}++module Servant.MiddlewareSpec (spec) where++import Control.Arrow (left)+import Control.Concurrent (newEmptyMVar, putMVar, takeMVar)+import Control.Exception (Exception, throwIO, try)+import Control.Monad.IO.Class+import Data.ByteString.Builder (toLazyByteString)+import Data.IORef (modifyIORef, newIORef, readIORef)+import Data.Monoid ()+import Prelude.Compat+import Servant.Client+import Servant.Client.Core (RequestF (..))+import Servant.Client.Internal.HttpClient (ClientMiddleware)+import Servant.ClientTestUtils+import Test.Hspec+import Prelude ()++runClientWithMiddleware :: ClientM a -> ClientMiddleware -> BaseUrl -> IO (Either ClientError a)+runClientWithMiddleware x mid baseUrl' =+ runClientM x ((mkClientEnv manager' baseUrl') {middleware = mid})++data CustomException = CustomException deriving (Show, Eq)++instance Exception CustomException++spec :: Spec+spec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do+ it "Raw request and response can be accessed in middleware" $ \(_, baseUrl) -> do+ mvarReq <- newEmptyMVar+ mvarResp <- newEmptyMVar++ let mid :: ClientMiddleware+ mid oldApp req = do+ -- "Log" request+ liftIO $ putMVar mvarReq req+ -- perform request+ resp <- oldApp req+ -- "Log" response+ liftIO $ putMVar mvarResp resp+ pure resp++ -- Same as without middleware+ left show <$> runClientWithMiddleware getGet mid baseUrl `shouldReturn` Right alice++ -- Access some raw request data+ req <- takeMVar mvarReq+ toLazyByteString (requestPath req) `shouldBe` "/get"++ -- Access some raw response data+ resp <- takeMVar mvarResp+ responseBody resp `shouldBe` "{\"_age\":42,\"_name\":\"Alice\"}"++ it "errors can be thrown in middleware" $ \(_, baseUrl) -> do+ let mid :: ClientMiddleware+ mid oldApp req = do+ -- perform request+ resp <- oldApp req+ -- throw error+ _ <- liftIO $ throwIO CustomException+ pure resp++ try (runClientWithMiddleware getGet mid baseUrl) `shouldReturn` Left CustomException++ it "runs in the expected order" $ \(_, baseUrl) -> do+ ref <- newIORef []++ let mid1 :: ClientMiddleware+ mid1 oldApp req = do+ liftIO $ modifyIORef ref (\xs -> xs <> ["req1"])+ resp <- oldApp req+ liftIO $ modifyIORef ref (\xs -> xs <> ["resp1"])+ pure resp++ let mid2 :: ClientMiddleware+ mid2 oldApp req = do+ liftIO $ modifyIORef ref (\xs -> xs <> ["req2"])+ resp <- oldApp req+ liftIO $ modifyIORef ref (\xs -> xs <> ["resp2"])+ pure resp++ let mid3 :: ClientMiddleware+ mid3 oldApp req = do+ liftIO $ modifyIORef ref (\xs -> xs <> ["req3"])+ resp <- oldApp req+ liftIO $ modifyIORef ref (\xs -> xs <> ["resp3"])+ pure resp++ let mid :: ClientMiddleware+ mid = mid1 . mid2 . mid3+ -- \^ Composition in "reverse order".+ -- It is equivalent to the following, which is more intuitive:+ -- mid :: ClientMiddleware+ -- mid oldApp = mid1 (mid2 (mid3 oldApp))++ -- Same as without middleware+ left show <$> runClientWithMiddleware getGet mid baseUrl `shouldReturn` Right alice++ ref <- readIORef ref+ ref `shouldBe` ["req1", "req2", "req3", "resp3", "resp2", "resp1"]
test/Servant/StreamSpec.hs view
@@ -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))--}
test/Servant/SuccessSpec.hs view
@@ -10,7 +10,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -freduction-depth=100 #-} {-# OPTIONS_GHC -fno-warn-orphans #-}@@ -32,9 +31,10 @@ import Data.Maybe (listToMaybe) import Data.Monoid ()-import Data.SOP (NS (..), I (..)) 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@@ -43,11 +43,9 @@ import Test.QuickCheck import Servant.API- (NoContent (NoContent), WithStatus (WithStatus), 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.ClientTestUtils import Servant.Test.ComprehensiveAPI @@ -55,26 +53,23 @@ _ = 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]@@ -102,11 +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.Fragment" $ \(_, baseUrl) -> do- left id <$> runClient getFragment baseUrl `shouldReturn` Right alice+ 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@@ -134,14 +134,21 @@ res <- runClient getUVerbRespHeaders baseUrl case res of Left e -> assertFailure $ show e- Right (Z (I (WithStatus val))) ->- getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]- Right (S _) -> assertFailure "expected first alternative of union"+ 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"@@ -150,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 ->@@ -159,13 +167,12 @@ 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@@ -182,7 +189,14 @@ context "with a route that uses uverb but only has a single response" $ it "returns the expected response" $ \(_, baseUrl) -> do- eitherResponse <- runClient (uverbGetCreated) baseUrl+ eitherResponse <- runClient uverbGetCreated baseUrl case eitherResponse of Left clientError -> fail $ show clientError Right response -> matchUnion response `shouldBe` Just (WithStatus @201 carol)++ it "encodes URL pieces following ToHttpApiData instance" $ \(_, baseUrl) -> do+ let textOrig = "*"+ eitherResponse <- runClient (captureVerbatim $ Verbatim $ encodeUtf8 textOrig) baseUrl+ case eitherResponse of+ Left clientError -> fail $ show clientError+ Right textBack -> textBack `shouldBe` textOrig
test/Servant/WrappedApiSpec.hs view
@@ -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