servant-client 0.20 → 0.20.1
raw patch · 8 files changed
+349/−161 lines, 8 filesdep −bifunctorsdep −transformers-compatdep ~QuickCheckdep ~basedep ~kan-extensions
Dependencies removed: bifunctors, transformers-compat
Dependency ranges changed: QuickCheck, base, kan-extensions, servant-client-core, text
Files
- servant-client.cabal +136/−81
- src/Servant/Client/Internal/HttpClient.hs +24/−20
- src/Servant/Client/Internal/HttpClient/Streaming.hs +6/−5
- test/Servant/ClientTestUtils.hs +40/−3
- test/Servant/MiddlewareSpec.hs +117/−0
- test/Servant/StreamSpec.hs +0/−20
- test/Servant/SuccessSpec.hs +24/−31
- test/Servant/WrappedApiSpec.hs +2/−1
servant-client.cabal view
@@ -1,9 +1,8 @@-cabal-version: 2.2-name: servant-client-version: 0.20--synopsis: Automatic derivation of querying functions for servant-category: Servant, Web+cabal-version: 3.0+name: servant-client+version: 0.20.1+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,134 +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: 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==8.6.5, GHC==8.8.4, GHC ==8.10.7, GHC ==9.0.2, GHC ==9.2.7, GHC ==9.4.4- , GHCJS ==8.6.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 ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.4 || ==9.8.2+ 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.19- , 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.1- , stm >= 2.4.5.1 && < 2.6- , text >= 1.2.3.0 && < 2.1- , time >= 1.6.0.1 && < 1.13- , transformers >= 0.5.2.0 && < 0.7-- if !impl(ghc >= 8.2)- build-depends:- bifunctors >= 5.5.3 && < 5.7+ , base >=4.9 && <4.20+ , bytestring >=0.10.8.1 && <0.13+ , containers >=0.5.7.1 && <0.7+ , 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.13+ , transformers >=0.5.2.0 && <0.7 -- Servant dependencies. -- Strict dependency on `servant-client-core` as we re-export things. build-depends:- servant >= 0.20 && < 0.21- , servant-client-core >= 0.20 && < 0.21+ , servant >=0.20 && <0.21+ , servant-client-core >=0.20.1 && <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.14- , 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 && < 6.1- , transformers-base >= 0.4.5.2 && < 0.5- , transformers-compat >= 0.6.2 && < 0.8+ , 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+ 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+ buildable: False++ hs-source-dirs: test+ main-is: Spec.hs other-modules:- Servant.BasicAuthSpec- Servant.BrokenSpec- Servant.ClientTestUtils- Servant.ConnectionErrorSpec- Servant.FailSpec- Servant.GenAuthSpec- Servant.GenericSpec- 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 , stm , text , transformers- , transformers-compat , wai , warp -- Additional dependencies build-depends:- entropy >= 0.4.1.3 && < 0.5- , hspec >= 2.6.0 && < 2.11- , HUnit >= 1.6.0.0 && < 1.7- , network >= 2.8.0.0 && < 3.2- , QuickCheck >= 2.12.6.1 && < 2.15- , servant >= 0.20 && < 0.21- , servant-server >= 0.20 && < 0.21+ , 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.15+ , servant >=0.20 && <0.21+ , servant-server >=0.20 && <0.21 - build-tool-depends:- hspec-discover:hspec-discover >= 2.6.0 && < 2.11+ 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+ 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 ()@@ -43,14 +33,14 @@ import Data.ByteString.Builder (toLazyByteString) import qualified Data.ByteString.Lazy as BSL-import Data.Either- (either)-import Data.Foldable- (foldl',toList)+#if !MIN_VERSION_base_compat(0,14,0)+import Data.Foldable (foldl')+#endif+import Data.Foldable (toList) import Data.Functor.Alt (Alt (..)) import Data.Maybe- (maybe, maybeToList)+ (maybeToList) import Data.Proxy (Proxy (..)) import Data.Sequence@@ -63,7 +53,7 @@ import Network.HTTP.Media (renderHeader) import Network.HTTP.Types- (hContentType, renderQuery, statusIsSuccessful, urlEncode, Status)+ (hContentType, statusIsSuccessful, urlEncode, Status) import Servant.Client.Core import qualified Network.HTTP.Client as Client@@ -86,11 +76,22 @@ -- 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. --@@ -134,7 +135,7 @@ -- '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, MonadMask) @@ -153,7 +154,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)@@ -161,7 +165,7 @@ performRequest :: Maybe [Status] -> Request -> ClientM Response performRequest acceptStatus req = do- ClientEnv m burl cookieJar' createClientRequest <- ask+ ClientEnv m burl cookieJar' createClientRequest _ <- ask clientRequest <- liftIO $ createClientRequest burl req request <- case cookieJar' of Nothing -> pure clientRequest
src/Servant/Client/Internal/HttpClient/Streaming.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -32,7 +31,8 @@ (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@@ -58,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.@@ -102,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@@ -140,7 +141,7 @@ performRequest :: Maybe [Status] -> Request -> ClientM Response performRequest acceptStatus req = do -- TODO: should use Client.withResponse here too- ClientEnv m burl cookieJar' createClientRequest <- ask+ ClientEnv m burl cookieJar' createClientRequest _ <- ask clientRequest <- liftIO $ createClientRequest burl req request <- case cookieJar' of Nothing -> pure clientRequest@@ -175,7 +176,7 @@ -- | TODO: support UVerb ('acceptStatus' argument, like in 'performRequest' above). performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a performWithStreamingRequest req k = do- ClientEnv m burl cookieJar' createClientRequest <- ask+ ClientEnv m burl cookieJar' createClientRequest _ <- ask clientRequest <- liftIO $ createClientRequest burl req request <- case cookieJar' of Nothing -> pure clientRequest
test/Servant/ClientTestUtils.hs view
@@ -31,11 +31,13 @@ import Data.Aeson import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as C8 import Data.ByteString.Builder (byteString) import qualified Data.ByteString.Lazy as LazyByteString import Data.Char (chr, isPrint)+import Data.Maybe (fromMaybe) import Data.Monoid () import Data.Proxy import Data.SOP@@ -54,18 +56,20 @@ import System.IO.Unsafe (unsafePerformIO) import Test.QuickCheck+import Text.Read (readMaybe) import Web.FormUrlEncoded (FromForm, ToForm) import Servant.API ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,- BasicAuthData (..), Capture, CaptureAll, DeleteNoContent,+ BasicAuthData (..), Capture, CaptureAll, DeepQuery, DeleteNoContent, EmptyAPI, FormUrlEncoded, Fragment, FromHttpApiData (..), Get, Header, Headers, JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender), NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,- QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), UVerb, Union,- Verb, WithStatus (WithStatus), NamedRoutes, addHeader)+ QueryParams, QueryString, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..),+ UVerb, Union, Verb, WithStatus (WithStatus), NamedRoutes, addHeader) import Servant.API.Generic ((:-))+import Servant.API.QueryString (FromDeepQuery(..), ToDeepQuery(..)) import Servant.Client import qualified Servant.Client.Core.Auth as Auth import Servant.Server@@ -122,6 +126,25 @@ -- 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'))+ ]+ type Api = Get '[JSON] Person :<|> "get" :> Get '[JSON] Person@@ -140,6 +163,8 @@ :<|> "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@@ -178,6 +203,8 @@ 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@@ -206,6 +233,8 @@ :<|> getQueryParamBinary :<|> getQueryParams :<|> getQueryFlag+ :<|> getQueryString+ :<|> getDeepQuery :<|> getFragment :<|> getRawSuccess :<|> getRawSuccessPassHeaders@@ -244,6 +273,14 @@ ) :<|> (\ 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"))
+ test/Servant/MiddlewareSpec.hs view
@@ -0,0 +1,117 @@+{-# 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,12 +17,6 @@ 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@@ -45,19 +35,9 @@ (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
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 #-}@@ -22,13 +21,11 @@ import Prelude.Compat import Control.Arrow- ((+++), left)+ (left) import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TVar (newTVar, readTVar)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BL import Data.Foldable (forM_, toList) import Data.Maybe@@ -56,30 +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 describe "Servant.API.Get" $ do- it "get root endpoint" $ \(_, baseUrl) -> do- left show <$> runClient getRoot baseUrl `shouldReturn` Right carol+ it "get root endpoint" $ \(_, baseUrl) -> left show <$> runClient getRoot baseUrl `shouldReturn` Right carol - it "get simple endpoint" $ \(_, 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) -> do- left show <$> runClient getGet307 baseUrl `shouldReturn` Right "redirecting"+ 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]@@ -107,12 +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@@ -154,7 +148,7 @@ 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"@@ -173,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@@ -196,7 +189,7 @@ 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)
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