diff --git a/servant-client.cabal b/servant-client.cabal --- a/servant-client.cabal +++ b/servant-client.cabal @@ -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 webservice. @@ -12,134 +11,190 @@ . -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 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 () @@ -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 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 #-} @@ -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 diff --git a/test/Servant/ClientTestUtils.hs b/test/Servant/ClientTestUtils.hs --- a/test/Servant/ClientTestUtils.hs +++ b/test/Servant/ClientTestUtils.hs @@ -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")) 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,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"] 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,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 diff --git a/test/Servant/SuccessSpec.hs b/test/Servant/SuccessSpec.hs --- a/test/Servant/SuccessSpec.hs +++ b/test/Servant/SuccessSpec.hs @@ -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) 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