summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorphadej <>2020-01-23 12:16:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-01-23 12:16:00 (GMT)
commit173dc2634dc46ae36e605542c8f95498c87a3e4e (patch)
tree29bb1421ced147392051cacf50fba4048b6f14ee
parent5017cc858bce853d6b02185fff0fd551b2669d51 (diff)
version 0.170.17
-rwxr-xr-xCHANGELOG.md48
-rw-r--r--servant-client.cabal21
-rw-r--r--src/Servant/Client.hs1
-rw-r--r--src/Servant/Client/Internal/HttpClient.hs26
-rw-r--r--src/Servant/Client/Internal/HttpClient/Streaming.hs13
-rw-r--r--src/Servant/Client/Streaming.hs1
-rw-r--r--test/Servant/BasicAuthSpec.hs53
-rw-r--r--test/Servant/ClientSpec.hs514
-rw-r--r--test/Servant/ClientTestUtils.hs268
-rw-r--r--test/Servant/ConnectionErrorSpec.hs55
-rw-r--r--test/Servant/FailSpec.hs81
-rw-r--r--test/Servant/GenAuthSpec.hs54
-rw-r--r--test/Servant/HoistClientSpec.hs58
-rw-r--r--test/Servant/StreamSpec.hs7
-rw-r--r--test/Servant/SuccessSpec.hs153
-rw-r--r--test/Servant/WrappedApiSpec.hs63
16 files changed, 879 insertions, 537 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 02f7bd8..362ba56 100755
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,6 +1,54 @@
[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)
+0.17
+----
+
+### Significant changes
+
+- Add NoContentVerb [#1028](https://github.com/haskell-servant/servant/issues/1028) [#1219](https://github.com/haskell-servant/servant/pull/1219) [#1228](https://github.com/haskell-servant/servant/pull/1228)
+
+ The `NoContent` API endpoints should now use `NoContentVerb` combinator.
+ The API type changes are usually of the kind
+
+ ```diff
+ - :<|> PostNoContent '[JSON] NoContent
+ + :<|> PostNoContent
+ ```
+
+ i.e. one doesn't need to specify the content-type anymore. There is no content.
+
+- `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156)
+
+ You can specify a lenient capture as
+
+ ```haskell
+ :<|> "capture-lenient" :> Capture' '[Lenient] "foo" Int :> GET
+ ```
+
+ which will make the capture always succeed. Handlers will be of the
+ type `Either String CapturedType`, where `Left err` represents
+ the possible parse failure.
+
+- *servant-client* Added a function to create Client.Request in ClientEnv [#1213](https://github.com/haskell-servant/servant/pull/1213) [#1255](https://github.com/haskell-servant/servant/pull/1255)
+
+ The new member `makeClientRequest` of `ClientEnv` is used to create
+ `http-client` `Request` from `servant-client-core` `Request`.
+ This functionality can be used for example to set
+ dynamic timeouts for each request.
+
+### Other changes
+
+- *servant-client* *servant-client-core* *servant-http-streams* Fix Verb with headers checking content type differently [#1200](https://github.com/haskell-servant/servant/issues/1200) [#1204](https://github.com/haskell-servant/servant/pull/1204)
+
+ For `Verb`s with response `Headers`, the implementation didn't check
+ for the content-type of the response. Now it does.
+
+- *servant-client* *servant-http-streams* `HasClient` instance for `Stream` with `Headers` [#1170](https://github.com/haskell-servant/servant/issues/1170) [#1197](https://github.com/haskell-servant/servant/pull/1197)
+- *servant-client* Redact the authorization header in Show and exceptions [#1238](https://github.com/haskell-servant/servant/pull/1238)
+
+
+
0.16.0.1
--------
diff --git a/servant-client.cabal b/servant-client.cabal
index 1a91f34..bdbecc0 100644
--- a/servant-client.cabal
+++ b/servant-client.cabal
@@ -1,6 +1,6 @@
cabal-version: >=1.10
name: servant-client
-version: 0.16.0.1
+version: 0.17
synopsis: Automatic derivation of querying functions for servant
category: Servant, Web
@@ -25,7 +25,7 @@ tested-with:
|| ==8.2.2
|| ==8.4.4
|| ==8.6.5
- || ==8.8.1
+ || ==8.8.2
extra-source-files:
CHANGELOG.md
@@ -62,8 +62,8 @@ library
-- Servant dependencies.
-- Strict dependency on `servant-client-core` as we re-export things.
build-depends:
- servant == 0.16.*
- , servant-client-core >= 0.16 && <0.16.1
+ servant == 0.17.*
+ , servant-client-core >= 0.17 && <0.17.1
-- 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.
@@ -90,8 +90,15 @@ test-suite spec
hs-source-dirs: test
main-is: Spec.hs
other-modules:
- Servant.ClientSpec
+ Servant.BasicAuthSpec
+ Servant.ClientTestUtils
+ Servant.ConnectionErrorSpec
+ Servant.FailSpec
+ Servant.GenAuthSpec
+ Servant.HoistClientSpec
Servant.StreamSpec
+ Servant.SuccessSpec
+ Servant.WrappedApiSpec
-- Dependencies inherited from the library. No need to specify bounds.
build-depends:
@@ -120,8 +127,8 @@ test-suite spec
, HUnit >= 1.6.0.0 && < 1.7
, network >= 2.8.0.0 && < 3.2
, QuickCheck >= 2.12.6.1 && < 2.14
- , servant == 0.16.*
- , servant-server == 0.16.*
+ , servant == 0.17.*
+ , servant-server == 0.17.*
, tdigest >= 0.2 && < 0.3
build-tool-depends:
diff --git a/src/Servant/Client.hs b/src/Servant/Client.hs
index 1ecc07d..e0c8dab 100644
--- a/src/Servant/Client.hs
+++ b/src/Servant/Client.hs
@@ -9,6 +9,7 @@ module Servant.Client
, runClientM
, ClientEnv(..)
, mkClientEnv
+ , defaultMakeClientRequest
, hoistClient
, module Servant.Client.Core.Reexport
) where
diff --git a/src/Servant/Client/Internal/HttpClient.hs b/src/Servant/Client/Internal/HttpClient.hs
index ec8a63e..c25c8a9 100644
--- a/src/Servant/Client/Internal/HttpClient.hs
+++ b/src/Servant/Client/Internal/HttpClient.hs
@@ -72,16 +72,27 @@ import qualified Network.HTTP.Client as Client
import qualified Servant.Types.SourceT as S
-- | The environment in which a request is run.
+-- The 'baseUrl' and 'makeClientRequest' function are used to create a @http-client@ request.
+-- Cookies are then added to that request if a 'CookieJar' is set on the environment.
+-- Finally the request is executed with the 'manager'.
+-- The 'makeClientRequest' function can be used to modify the request to execute and set values which
+-- are not specified on a @servant@ 'Request' like 'responseTimeout' or 'redirectCount'
data ClientEnv
= ClientEnv
{ manager :: Client.Manager
, baseUrl :: BaseUrl
, cookieJar :: Maybe (TVar Client.CookieJar)
+ , makeClientRequest :: BaseUrl -> Request -> 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.
}
-- | 'ClientEnv' smart constructor.
mkClientEnv :: Client.Manager -> BaseUrl -> ClientEnv
-mkClientEnv mgr burl = ClientEnv mgr burl Nothing
+mkClientEnv mgr burl = ClientEnv mgr burl Nothing defaultMakeClientRequest
-- | Generates a set of client functions for an API.
--
@@ -152,8 +163,8 @@ runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm
performRequest :: Request -> ClientM Response
performRequest req = do
- ClientEnv m burl cookieJar' <- ask
- let clientRequest = requestToClientRequest burl req
+ ClientEnv m burl cookieJar' createClientRequest <- ask
+ let clientRequest = createClientRequest burl req
request <- case cookieJar' of
Nothing -> pure clientRequest
Just cj -> liftIO $ do
@@ -162,7 +173,7 @@ performRequest req = do
oldCookieJar <- readTVar cj
let (newRequest, newCookieJar) =
Client.insertCookiesIntoRequest
- (requestToClientRequest burl req)
+ clientRequest
oldCookieJar
now
writeTVar cj newCookieJar
@@ -215,8 +226,11 @@ clientResponseToResponse f r = Response
, responseHttpVersion = Client.responseVersion r
}
-requestToClientRequest :: BaseUrl -> Request -> Client.Request
-requestToClientRequest burl r = Client.defaultRequest
+-- | 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
{ Client.method = requestMethod r
, Client.host = fromString $ baseUrlHost burl
, Client.port = baseUrlPort burl
diff --git a/src/Servant/Client/Internal/HttpClient/Streaming.hs b/src/Servant/Client/Internal/HttpClient/Streaming.hs
index 449c638..2f5a1cb 100644
--- a/src/Servant/Client/Internal/HttpClient/Streaming.hs
+++ b/src/Servant/Client/Internal/HttpClient/Streaming.hs
@@ -12,7 +12,7 @@ module Servant.Client.Internal.HttpClient.Streaming (
ClientEnv (..),
mkClientEnv,
clientResponseToResponse,
- requestToClientRequest,
+ defaultMakeClientRequest,
catchConnectionError,
) where
@@ -55,7 +55,7 @@ import Servant.Client.Core
import Servant.Client.Internal.HttpClient
(ClientEnv (..), catchConnectionError,
clientResponseToResponse, mkClientEnv, mkFailureResponse,
- requestToClientRequest)
+ defaultMakeClientRequest)
import qualified Servant.Types.SourceT as S
@@ -139,8 +139,8 @@ runClientM cm env = withClientM cm env (evaluate . force)
performRequest :: Request -> ClientM Response
performRequest req = do
-- TODO: should use Client.withResponse here too
- ClientEnv m burl cookieJar' <- ask
- let clientRequest = requestToClientRequest burl req
+ ClientEnv m burl cookieJar' createClientRequest <- ask
+ let clientRequest = createClientRequest burl req
request <- case cookieJar' of
Nothing -> pure clientRequest
Just cj -> liftIO $ do
@@ -149,7 +149,7 @@ performRequest req = do
oldCookieJar <- readTVar cj
let (newRequest, newCookieJar) =
Client.insertCookiesIntoRequest
- (requestToClientRequest burl req)
+ clientRequest
oldCookieJar
now
writeTVar cj newCookieJar
@@ -173,7 +173,8 @@ performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM
performWithStreamingRequest req k = do
m <- asks manager
burl <- asks baseUrl
- let request = requestToClientRequest burl req
+ createClientRequest <- asks makeClientRequest
+ let request = createClientRequest burl req
ClientM $ lift $ lift $ Codensity $ \k1 ->
Client.withResponse request m $ \res -> do
let status = Client.responseStatus res
diff --git a/src/Servant/Client/Streaming.hs b/src/Servant/Client/Streaming.hs
index d4e8721..5800df0 100644
--- a/src/Servant/Client/Streaming.hs
+++ b/src/Servant/Client/Streaming.hs
@@ -10,6 +10,7 @@ module Servant.Client.Streaming
, runClientM
, ClientEnv(..)
, mkClientEnv
+ , defaultMakeClientRequest
, hoistClient
, module Servant.Client.Core.Reexport
) where
diff --git a/test/Servant/BasicAuthSpec.hs b/test/Servant/BasicAuthSpec.hs
new file mode 100644
index 0000000..902c4da
--- /dev/null
+++ b/test/Servant/BasicAuthSpec.hs
@@ -0,0 +1,53 @@
+{-# 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.BasicAuthSpec (spec) where
+
+import Prelude ()
+import Prelude.Compat
+
+import Control.Arrow
+ (left)
+import Data.Monoid ()
+import qualified Network.HTTP.Types as HTTP
+import Test.Hspec
+
+import Servant.API
+ (BasicAuthData (..))
+import Servant.Client
+import Servant.ClientTestUtils
+
+spec :: Spec
+spec = describe "Servant.BasicAuthSpec" $ do
+ basicAuthSpec
+
+basicAuthSpec :: Spec
+basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ do
+ context "Authentication works when requests are properly authenticated" $ do
+
+ it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
+ let getBasic = client basicAuthAPI
+ let basicAuthData = BasicAuthData "servant" "server"
+ left show <$> runClient (getBasic basicAuthData) baseUrl `shouldReturn` Right alice
+
+ context "Authentication is rejected when requests are not authenticated properly" $ do
+
+ it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
+ let getBasic = client basicAuthAPI
+ let basicAuthData = BasicAuthData "not" "password"
+ Left (FailureResponse _ r) <- runClient (getBasic basicAuthData) baseUrl
+ responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden"
diff --git a/test/Servant/ClientSpec.hs b/test/Servant/ClientSpec.hs
deleted file mode 100644
index f40fa3b..0000000
--- a/test/Servant/ClientSpec.hs
+++ /dev/null
@@ -1,514 +0,0 @@
-{-# 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 TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -freduction-depth=100 #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-
-module Servant.ClientSpec (spec, Person(..), startWaiApp, endWaiApp) where
-
-import Prelude ()
-import Prelude.Compat
-
-import Control.Arrow
- (left)
-import Control.Concurrent
- (ThreadId, forkIO, killThread)
-import Control.Concurrent.STM
- (atomically)
-import Control.Concurrent.STM.TVar
- (newTVar, readTVar)
-import Control.Exception
- (bracket, fromException)
-import Control.Monad.Error.Class
- (throwError)
-import Data.Aeson
-import Data.Char
- (chr, isPrint)
-import Data.Foldable
- (forM_, toList)
-import Data.Maybe
- (isJust, listToMaybe)
-import Data.Monoid ()
-import Data.Proxy
-import Data.Semigroup
- ((<>))
-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 Test.Hspec
-import Test.Hspec.QuickCheck
-import Test.HUnit
-import Test.QuickCheck
-import Web.FormUrlEncoded
- (FromForm, ToForm)
-
-import Servant.API
- ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,
- BasicAuthData (..), Capture, CaptureAll, Delete,
- DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,
- Headers, JSON, NoContent (NoContent), Post, Put, QueryFlag,
- QueryParam, QueryParams, Raw, ReqBody, addHeader, getHeaders)
-import Servant.Client
-import qualified Servant.Client.Core.Auth as Auth
-import qualified Servant.Client.Core.Request as Req
-import Servant.Server
-import Servant.Server.Experimental.Auth
-import Servant.Test.ComprehensiveAPI
-
--- This declaration simply checks that all instances are in place.
-_ = client comprehensiveAPIWithoutStreaming
-
-spec :: Spec
-spec = describe "Servant.Client" $ do
- sucessSpec
- failSpec
- wrappedApiSpec
- basicAuthSpec
- genAuthSpec
- hoistClientSpec
- connectionErrorSpec
-
--- * test data types
-
-data Person = Person
- { _name :: String
- , _age :: Integer
- } deriving (Eq, Show, Generic)
-
-instance ToJSON Person
-instance FromJSON Person
-
-instance ToForm Person
-instance FromForm Person
-
-instance Arbitrary Person where
- arbitrary = Person <$> arbitrary <*> arbitrary
-
-alice :: Person
-alice = Person "Alice" 42
-
-carol :: Person
-carol = Person "Carol" 17
-
-type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
-
-type Api =
- Get '[JSON] Person
- :<|> "get" :> Get '[JSON] Person
- :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent
- :<|> "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
- :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]
- :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool
- :<|> "rawSuccess" :> Raw
- :<|> "rawFailure" :> Raw
- :<|> "multiple" :>
- Capture "first" String :>
- QueryParam "second" Int :>
- QueryFlag "third" :>
- ReqBody '[JSON] [(String, [Rational])] :>
- Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
- :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
- :<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent
- :<|> "redirectWithCookie" :> Raw
- :<|> "empty" :> EmptyAPI
-
-api :: Proxy Api
-api = Proxy
-
-getRoot :: ClientM Person
-getGet :: ClientM Person
-getDeleteEmpty :: ClientM NoContent
-getCapture :: String -> ClientM Person
-getCaptureAll :: [String] -> ClientM [Person]
-getBody :: Person -> ClientM Person
-getQueryParam :: Maybe String -> ClientM Person
-getQueryParams :: [String] -> ClientM [Person]
-getQueryFlag :: Bool -> ClientM Bool
-getRawSuccess :: HTTP.Method -> ClientM Response
-getRawFailure :: HTTP.Method -> ClientM Response
-getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
- -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])
-getRespHeaders :: ClientM (Headers TestHeaders Bool)
-getDeleteContentType :: ClientM NoContent
-getRedirectWithCookie :: HTTP.Method -> ClientM Response
-
-getRoot
- :<|> getGet
- :<|> getDeleteEmpty
- :<|> getCapture
- :<|> getCaptureAll
- :<|> getBody
- :<|> getQueryParam
- :<|> getQueryParams
- :<|> getQueryFlag
- :<|> getRawSuccess
- :<|> getRawFailure
- :<|> getMultiple
- :<|> getRespHeaders
- :<|> getDeleteContentType
- :<|> getRedirectWithCookie
- :<|> EmptyClient = client api
-
-server :: Application
-server = serve api (
- return carol
- :<|> return alice
- :<|> 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" "" [])
- :<|> (\ names -> return (zipWith Person names [0..]))
- :<|> return
- :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "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 NoContent
- :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")
- :<|> emptyServer)
-
-type FailApi =
- "get" :> Raw
- :<|> "capture" :> Capture "name" String :> Raw
- :<|> "body" :> Raw
-failApi :: Proxy FailApi
-failApi = Proxy
-
-failServer :: Application
-failServer = serve failApi (
- (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")] "")
- )
-
--- * basic auth stuff
-
-type BasicAuthAPI =
- BasicAuth "foo-realm" () :> "private" :> "basic" :> Get '[JSON] Person
-
-basicAuthAPI :: Proxy BasicAuthAPI
-basicAuthAPI = Proxy
-
-basicAuthHandler :: BasicAuthCheck ()
-basicAuthHandler =
- let check (BasicAuthData username password) =
- if username == "servant" && password == "server"
- then return (Authorized ())
- else return Unauthorized
- in BasicAuthCheck check
-
-basicServerContext :: Context '[ BasicAuthCheck () ]
-basicServerContext = basicAuthHandler :. EmptyContext
-
-basicAuthServer :: Application
-basicAuthServer = serveWithContext basicAuthAPI basicServerContext (const (return alice))
-
--- * general auth stuff
-
-type GenAuthAPI =
- AuthProtect "auth-tag" :> "private" :> "auth" :> Get '[JSON] Person
-
-genAuthAPI :: Proxy GenAuthAPI
-genAuthAPI = Proxy
-
-type instance AuthServerData (AuthProtect "auth-tag") = ()
-type instance Auth.AuthClientData (AuthProtect "auth-tag") = ()
-
-genAuthHandler :: AuthHandler Wai.Request ()
-genAuthHandler =
- let handler req = case lookup "AuthHeader" (Wai.requestHeaders req) of
- Nothing -> throwError (err401 { errBody = "Missing auth header" })
- Just _ -> return ()
- in mkAuthHandler handler
-
-genAuthServerContext :: Context '[ AuthHandler Wai.Request () ]
-genAuthServerContext = genAuthHandler :. EmptyContext
-
-genAuthServer :: Application
-genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
-
-{-# NOINLINE manager' #-}
-manager' :: C.Manager
-manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings
-
-runClient :: ClientM a -> BaseUrl -> IO (Either ClientError a)
-runClient x baseUrl' = runClientM x (mkClientEnv manager' baseUrl')
-
-sucessSpec :: Spec
-sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
- it "Servant.API.Get root" $ \(_, baseUrl) -> do
- left show <$> runClient getRoot baseUrl `shouldReturn` Right carol
-
- it "Servant.API.Get" $ \(_, baseUrl) -> do
- left show <$> runClient getGet baseUrl `shouldReturn` Right alice
-
- describe "Servant.API.Delete" $ do
- it "allows empty content type" $ \(_, baseUrl) -> do
- left show <$> runClient getDeleteEmpty baseUrl `shouldReturn` Right NoContent
-
- it "allows content type" $ \(_, baseUrl) -> do
- 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.CaptureAll" $ \(_, baseUrl) -> do
- let expected = [(Person "Paula" 0), (Person "Peta" 1)]
- left show <$> runClient (getCaptureAll ["Paula", "Peta"]) baseUrl `shouldReturn` Right expected
-
- it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
- let p = Person "Clara" 42
- left show <$> runClient (getBody p) baseUrl `shouldReturn` Right p
-
- it "Servant.API FailureResponse" $ \(_, baseUrl) -> do
- left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice
- Left (FailureResponse req _) <- runClient (getQueryParam (Just "bob")) baseUrl
- Req.requestPath req `shouldBe` (baseUrl, "/param")
- toList (Req.requestQueryString req) `shouldBe` [("name", Just "bob")]
- Req.requestMethod req `shouldBe` HTTP.methodGet
-
- it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
- left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice
- Left (FailureResponse _ r) <- runClient (getQueryParam (Just "bob")) baseUrl
- responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"
-
- it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
- left show <$> runClient (getQueryParams []) baseUrl `shouldReturn` Right []
- left show <$> runClient (getQueryParams ["alice", "bob"]) baseUrl
- `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
-
- it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
- res <- runClient (getRawSuccess HTTP.methodGet) baseUrl
- case res of
- Left e -> assertFailure $ show e
- Right r -> do
- responseStatusCode r `shouldBe` HTTP.status200
- responseBody r `shouldBe` "rawSuccess"
-
- it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do
- res <- runClient (getRawFailure HTTP.methodGet) baseUrl
- case res of
- Right _ -> assertFailure "expected Left, but got Right"
- Left (FailureResponse _ r) -> do
- responseStatusCode r `shouldBe` HTTP.status400
- responseBody r `shouldBe` "rawFailure"
- Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e
-
- it "Returns headers appropriately" $ \(_, baseUrl) -> do
- res <- runClient getRespHeaders baseUrl
- case res of
- Left e -> assertFailure $ show e
- Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
-
- 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))
- cookie <- listToMaybe . C.destroyCookieJar <$> atomically (readTVar cj)
- C.cookie_name <$> cookie `shouldBe` Just "testcookie"
- C.cookie_value <$> cookie `shouldBe` Just "test"
-
- 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)
-
-
-wrappedApiSpec :: Spec
-wrappedApiSpec = describe "error status codes" $ do
- let serveW api = serve api $ throwError $ ServerError 500 "error message" "" []
- context "are correctly handled by the client" $
- let test :: (WrappedApi, String) -> Spec
- test (WrappedApi api, desc) =
- it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do
- let getResponse :: ClientM ()
- getResponse = client api
- Left (FailureResponse _ r) <- runClient getResponse baseUrl
- responseStatusCode r `shouldBe` (HTTP.Status 500 "error message")
- in mapM_ test $
- (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
- (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
- (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") :
- (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") :
- []
-
-failSpec :: Spec
-failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
-
- context "client returns errors appropriately" $ do
- it "reports FailureResponse" $ \(_, baseUrl) -> do
- 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
- Left res <- runClient (getCapture "foo") baseUrl
- case res of
- DecodeFailure _ _ -> return ()
- _ -> fail $ "expected DecodeFailure, but got " <> show res
-
- it "reports ConnectionError" $ \_ -> do
- let (getGetWrongHost :<|> _) = client api
- Left res <- runClient getGetWrongHost (BaseUrl Http "127.0.0.1" 19872 "")
- case res of
- ConnectionError _ -> return ()
- _ -> fail $ "expected ConnectionError, but got " <> show res
-
- it "reports UnsupportedContentType" $ \(_, baseUrl) -> do
- let (_ :<|> getGet :<|> _ ) = client api
- Left res <- runClient getGet baseUrl
- case res of
- UnsupportedContentType ("application/octet-stream") _ -> return ()
- _ -> fail $ "expected UnsupportedContentType, but got " <> show res
-
- it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
- let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
- Left res <- runClient (getBody alice) baseUrl
- case res of
- InvalidContentTypeHeader _ -> return ()
- _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
-
-data WrappedApi where
- WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a,
- HasClient ClientM api, Client ClientM api ~ ClientM ()) =>
- Proxy api -> WrappedApi
-
-basicAuthSpec :: Spec
-basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ do
- context "Authentication works when requests are properly authenticated" $ do
-
- it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
- let getBasic = client basicAuthAPI
- let basicAuthData = BasicAuthData "servant" "server"
- left show <$> runClient (getBasic basicAuthData) baseUrl `shouldReturn` Right alice
-
- context "Authentication is rejected when requests are not authenticated properly" $ do
-
- it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
- let getBasic = client basicAuthAPI
- let basicAuthData = BasicAuthData "not" "password"
- Left (FailureResponse _ r) <- runClient (getBasic basicAuthData) baseUrl
- responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden"
-
-genAuthSpec :: Spec
-genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
- context "Authentication works when requests are properly authenticated" $ do
-
- it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
- let getProtected = client genAuthAPI
- let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "AuthHeader" ("cool" :: String) req)
- left show <$> runClient (getProtected authRequest) baseUrl `shouldReturn` Right alice
-
- context "Authentication is rejected when requests are not authenticated properly" $ do
-
- it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
- let getProtected = client genAuthAPI
- let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "Wrong" ("header" :: String) req)
- Left (FailureResponse _ r) <- runClient (getProtected authRequest) baseUrl
- responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized")
-
--- * hoistClient
-
-type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int
-
-hoistClientAPI :: Proxy HoistClientAPI
-hoistClientAPI = Proxy
-
-hoistClientServer :: Application -- implements HoistClientAPI
-hoistClientServer = serve hoistClientAPI $ return 5 :<|> (\n -> return n)
-
-hoistClientSpec :: Spec
-hoistClientSpec = beforeAll (startWaiApp hoistClientServer) $ afterAll endWaiApp $ do
- describe "Servant.Client.hoistClient" $ do
- it "allows us to GET/POST/... requests in IO instead of ClientM" $ \(_, baseUrl) -> do
- let (getInt :<|> postInt)
- = hoistClient hoistClientAPI
- (fmap (either (error . show) id) . flip runClient baseUrl)
- (client hoistClientAPI)
-
- getInt `shouldReturn` 5
- postInt 5 `shouldReturn` 5
-
--- * ConnectionError
-type ConnectionErrorAPI = Get '[JSON] Int
-
-connectionErrorAPI :: Proxy ConnectionErrorAPI
-connectionErrorAPI = Proxy
-
-connectionErrorSpec :: Spec
-connectionErrorSpec = describe "Servant.Client.ClientError" $
- it "correctly catches ConnectionErrors when the HTTP request can't go through" $ do
- let getInt = client connectionErrorAPI
- let baseUrl' = BaseUrl Http "example.invalid" 80 ""
- let isHttpError (Left (ConnectionError e)) = isJust $ fromException @C.HttpException e
- isHttpError _ = False
- (isHttpError <$> runClient getInt baseUrl') `shouldReturn` True
-
--- * utils
-
-startWaiApp :: Application -> IO (ThreadId, BaseUrl)
-startWaiApp app = do
- (port, socket) <- openTestSocket
- let settings = setPort port $ defaultSettings
- thread <- forkIO $ runSettingsSocket settings socket app
- return (thread, BaseUrl Http "localhost" port "")
-
-
-endWaiApp :: (ThreadId, BaseUrl) -> IO ()
-endWaiApp (thread, _) = killThread thread
-
-openTestSocket :: IO (Port, Socket)
-openTestSocket = do
- s <- socket AF_INET Stream defaultProtocol
- let localhost = tupleToHostAddress (127, 0, 0, 1)
- bind s (SockAddrInet defaultPort localhost)
- listen s 1
- port <- socketPort s
- return (fromIntegral port, s)
-
-pathGen :: Gen (NonEmptyList Char)
-pathGen = fmap NonEmpty path
- where
- path = listOf1 $ elements $
- filter (not . (`elem` ("?%[]/#;" :: String))) $
- filter isPrint $
- map chr [0..127]
diff --git a/test/Servant/ClientTestUtils.hs b/test/Servant/ClientTestUtils.hs
new file mode 100644
index 0000000..6f38501
--- /dev/null
+++ b/test/Servant/ClientTestUtils.hs
@@ -0,0 +1,268 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -freduction-depth=100 #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
+module Servant.ClientTestUtils where
+
+import Prelude ()
+import Prelude.Compat
+
+import Control.Concurrent
+ (ThreadId, forkIO, killThread)
+import Control.Monad.Error.Class
+ (throwError)
+import Data.Aeson
+import Data.Char
+ (chr, isPrint)
+import Data.Monoid ()
+import Data.Proxy
+import GHC.Generics
+ (Generic)
+import qualified Network.HTTP.Client as C
+import qualified Network.HTTP.Types as HTTP
+import Network.Socket
+import qualified Network.Wai as Wai
+import Network.Wai.Handler.Warp
+import System.IO.Unsafe
+ (unsafePerformIO)
+import Test.QuickCheck
+import Web.FormUrlEncoded
+ (FromForm, ToForm)
+
+import Servant.API
+ ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,
+ BasicAuthData (..), Capture, CaptureAll,
+ DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,
+ Headers, JSON, NoContent (NoContent), Post, QueryFlag,
+ QueryParam, QueryParams, Raw, ReqBody, addHeader)
+import Servant.Client
+import qualified Servant.Client.Core.Auth as Auth
+import Servant.Server
+import Servant.Server.Experimental.Auth
+import Servant.Test.ComprehensiveAPI
+
+-- This declaration simply checks that all instances are in place.
+_ = client comprehensiveAPIWithoutStreaming
+
+-- * test data types
+
+data Person = Person
+ { _name :: String
+ , _age :: Integer
+ } deriving (Eq, Show, Generic)
+
+instance ToJSON Person
+instance FromJSON Person
+
+instance ToForm Person
+instance FromForm Person
+
+instance Arbitrary Person where
+ arbitrary = Person <$> arbitrary <*> arbitrary
+
+alice :: Person
+alice = Person "Alice" 42
+
+carol :: Person
+carol = Person "Carol" 17
+
+type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
+
+type Api =
+ Get '[JSON] Person
+ :<|> "get" :> Get '[JSON] Person
+ :<|> "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
+ :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]
+ :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool
+ :<|> "rawSuccess" :> Raw
+ :<|> "rawSuccessPassHeaders" :> Raw
+ :<|> "rawFailure" :> Raw
+ :<|> "multiple" :>
+ Capture "first" String :>
+ QueryParam "second" Int :>
+ QueryFlag "third" :>
+ ReqBody '[JSON] [(String, [Rational])] :>
+ Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
+ :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
+ :<|> "deleteContentType" :> DeleteNoContent
+ :<|> "redirectWithCookie" :> Raw
+ :<|> "empty" :> EmptyAPI
+
+api :: Proxy Api
+api = Proxy
+
+getRoot :: ClientM Person
+getGet :: ClientM Person
+getDeleteEmpty :: ClientM NoContent
+getCapture :: String -> ClientM Person
+getCaptureAll :: [String] -> ClientM [Person]
+getBody :: Person -> ClientM Person
+getQueryParam :: Maybe String -> ClientM Person
+getQueryParams :: [String] -> ClientM [Person]
+getQueryFlag :: Bool -> ClientM Bool
+getRawSuccess :: HTTP.Method -> ClientM Response
+getRawSuccessPassHeaders :: HTTP.Method -> ClientM Response
+getRawFailure :: HTTP.Method -> ClientM Response
+getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
+ -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])
+getRespHeaders :: ClientM (Headers TestHeaders Bool)
+getDeleteContentType :: ClientM NoContent
+getRedirectWithCookie :: HTTP.Method -> ClientM Response
+
+getRoot
+ :<|> getGet
+ :<|> getDeleteEmpty
+ :<|> getCapture
+ :<|> getCaptureAll
+ :<|> getBody
+ :<|> getQueryParam
+ :<|> getQueryParams
+ :<|> getQueryFlag
+ :<|> getRawSuccess
+ :<|> getRawSuccessPassHeaders
+ :<|> getRawFailure
+ :<|> getMultiple
+ :<|> getRespHeaders
+ :<|> getDeleteContentType
+ :<|> getRedirectWithCookie
+ :<|> EmptyClient = client api
+
+server :: Application
+server = serve api (
+ return carol
+ :<|> return alice
+ :<|> 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" "" [])
+ :<|> (\ names -> return (zipWith Person names [0..]))
+ :<|> return
+ :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")
+ :<|> (Tagged $ \ request respond -> (respond $ Wai.responseLBS HTTP.ok200 (Wai.requestHeaders $ request) "rawSuccess"))
+ :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")
+ :<|> (\ a b c d -> return (a, b, c, d))
+ :<|> (return $ addHeader 1729 $ addHeader "eg2" True)
+ :<|> return NoContent
+ :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")
+ :<|> emptyServer)
+
+type FailApi =
+ "get" :> Raw
+ :<|> "capture" :> Capture "name" String :> Raw
+ :<|> "body" :> Raw
+ :<|> "headers" :> Raw
+failApi :: Proxy FailApi
+failApi = Proxy
+
+failServer :: Application
+failServer = serve failApi (
+ (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")] "")
+ )
+
+-- * basic auth stuff
+
+type BasicAuthAPI =
+ BasicAuth "foo-realm" () :> "private" :> "basic" :> Get '[JSON] Person
+
+basicAuthAPI :: Proxy BasicAuthAPI
+basicAuthAPI = Proxy
+
+basicAuthHandler :: BasicAuthCheck ()
+basicAuthHandler =
+ let check (BasicAuthData username password) =
+ if username == "servant" && password == "server"
+ then return (Authorized ())
+ else return Unauthorized
+ in BasicAuthCheck check
+
+basicServerContext :: Context '[ BasicAuthCheck () ]
+basicServerContext = basicAuthHandler :. EmptyContext
+
+basicAuthServer :: Application
+basicAuthServer = serveWithContext basicAuthAPI basicServerContext (const (return alice))
+
+-- * general auth stuff
+
+type GenAuthAPI =
+ AuthProtect "auth-tag" :> "private" :> "auth" :> Get '[JSON] Person
+
+genAuthAPI :: Proxy GenAuthAPI
+genAuthAPI = Proxy
+
+type instance AuthServerData (AuthProtect "auth-tag") = ()
+type instance Auth.AuthClientData (AuthProtect "auth-tag") = ()
+
+genAuthHandler :: AuthHandler Wai.Request ()
+genAuthHandler =
+ let handler req = case lookup "AuthHeader" (Wai.requestHeaders req) of
+ Nothing -> throwError (err401 { errBody = "Missing auth header" })
+ Just _ -> return ()
+ in mkAuthHandler handler
+
+genAuthServerContext :: Context '[ AuthHandler Wai.Request () ]
+genAuthServerContext = genAuthHandler :. EmptyContext
+
+genAuthServer :: Application
+genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
+
+{-# NOINLINE manager' #-}
+manager' :: C.Manager
+manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings
+
+runClient :: ClientM a -> BaseUrl -> IO (Either ClientError a)
+runClient x baseUrl' = runClientM x (mkClientEnv manager' baseUrl')
+
+-- * utils
+
+startWaiApp :: Application -> IO (ThreadId, BaseUrl)
+startWaiApp app = do
+ (port, socket) <- openTestSocket
+ let settings = setPort port defaultSettings
+ thread <- forkIO $ runSettingsSocket settings socket app
+ return (thread, BaseUrl Http "localhost" port "")
+
+
+endWaiApp :: (ThreadId, BaseUrl) -> IO ()
+endWaiApp (thread, _) = killThread thread
+
+openTestSocket :: IO (Port, Socket)
+openTestSocket = do
+ s <- socket AF_INET Stream defaultProtocol
+ let localhost = tupleToHostAddress (127, 0, 0, 1)
+ bind s (SockAddrInet defaultPort localhost)
+ listen s 1
+ port <- socketPort s
+ return (fromIntegral port, s)
+
+pathGen :: Gen (NonEmptyList Char)
+pathGen = fmap NonEmpty path
+ where
+ path = listOf1 $ elements $
+ filter (not . (`elem` ("?%[]/#;" :: String))) $
+ filter isPrint $
+ map chr [0..127]
diff --git a/test/Servant/ConnectionErrorSpec.hs b/test/Servant/ConnectionErrorSpec.hs
new file mode 100644
index 0000000..0458f77
--- /dev/null
+++ b/test/Servant/ConnectionErrorSpec.hs
@@ -0,0 +1,55 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -freduction-depth=100 #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
+module Servant.ConnectionErrorSpec (spec) where
+
+import Prelude ()
+import Prelude.Compat
+
+import Control.Exception
+ (fromException)
+import Data.Maybe
+ (isJust)
+import Data.Monoid ()
+import Data.Proxy
+import qualified Network.HTTP.Client as C
+import Test.Hspec
+
+import Servant.API
+ (Get, JSON)
+import Servant.Client
+import Servant.ClientTestUtils
+
+
+spec :: Spec
+spec = describe "Servant.ConnectionErrorSpec" $ do
+ connectionErrorSpec
+
+type ConnectionErrorAPI = Get '[JSON] Int
+
+connectionErrorAPI :: Proxy ConnectionErrorAPI
+connectionErrorAPI = Proxy
+
+connectionErrorSpec :: Spec
+connectionErrorSpec = describe "Servant.Client.ClientError" $
+ it "correctly catches ConnectionErrors when the HTTP request can't go through" $ do
+ let getInt = client connectionErrorAPI
+ let baseUrl' = BaseUrl Http "example.invalid" 80 ""
+ let isHttpError (Left (ConnectionError e)) = isJust $ fromException @C.HttpException e
+ isHttpError _ = False
+ (isHttpError <$> runClient getInt baseUrl') `shouldReturn` True
diff --git a/test/Servant/FailSpec.hs b/test/Servant/FailSpec.hs
new file mode 100644
index 0000000..baec72b
--- /dev/null
+++ b/test/Servant/FailSpec.hs
@@ -0,0 +1,81 @@
+{-# 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.FailSpec (spec) where
+
+import Prelude ()
+import Prelude.Compat
+
+import Data.Monoid ()
+import Data.Semigroup
+ ((<>))
+import qualified Network.HTTP.Types as HTTP
+import Test.Hspec
+
+import Servant.API
+ ((:<|>) ((:<|>)))
+import Servant.Client
+import Servant.ClientTestUtils
+
+spec :: Spec
+spec = describe "Servant.FailSpec" $ do
+ failSpec
+
+failSpec :: Spec
+failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
+
+ context "client returns errors appropriately" $ do
+ it "reports FailureResponse" $ \(_, baseUrl) -> do
+ 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
+ Left res <- runClient (getCapture "foo") baseUrl
+ case res of
+ DecodeFailure _ _ -> return ()
+ _ -> fail $ "expected DecodeFailure, but got " <> show res
+
+ it "reports ConnectionError" $ \_ -> do
+ let (getGetWrongHost :<|> _) = client api
+ Left res <- runClient getGetWrongHost (BaseUrl Http "127.0.0.1" 19872 "")
+ case res of
+ ConnectionError _ -> return ()
+ _ -> fail $ "expected ConnectionError, but got " <> show res
+
+ it "reports UnsupportedContentType" $ \(_, baseUrl) -> do
+ let (_ :<|> getGet :<|> _ ) = client api
+ Left res <- runClient getGet baseUrl
+ case res of
+ UnsupportedContentType "application/octet-stream" _ -> return ()
+ _ -> fail $ "expected UnsupportedContentType, but got " <> show res
+
+ it "reports UnsupportedContentType when there are response headers" $ \(_, baseUrl) -> do
+ Left res <- runClient getRespHeaders baseUrl
+ case res of
+ UnsupportedContentType "application/x-www-form-urlencoded" _ -> return ()
+ _ -> fail $ "expected UnsupportedContentType, but got " <> show res
+
+ it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
+ let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
+ Left res <- runClient (getBody alice) baseUrl
+ case res of
+ InvalidContentTypeHeader _ -> return ()
+ _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
diff --git a/test/Servant/GenAuthSpec.hs b/test/Servant/GenAuthSpec.hs
new file mode 100644
index 0000000..13bd846
--- /dev/null
+++ b/test/Servant/GenAuthSpec.hs
@@ -0,0 +1,54 @@
+{-# 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.GenAuthSpec (spec) where
+
+import Prelude ()
+import Prelude.Compat
+
+import Control.Arrow
+ (left)
+import Data.Monoid ()
+import qualified Network.HTTP.Types as HTTP
+import Test.Hspec
+
+import Servant.Client
+import qualified Servant.Client.Core.Auth as Auth
+import qualified Servant.Client.Core.Request as Req
+import Servant.ClientTestUtils
+
+spec :: Spec
+spec = describe "Servant.GenAuthSpec" $ do
+ genAuthSpec
+
+genAuthSpec :: Spec
+genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
+ context "Authentication works when requests are properly authenticated" $ do
+
+ it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
+ let getProtected = client genAuthAPI
+ let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "AuthHeader" ("cool" :: String) req)
+ left show <$> runClient (getProtected authRequest) baseUrl `shouldReturn` Right alice
+
+ context "Authentication is rejected when requests are not authenticated properly" $ do
+
+ it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
+ let getProtected = client genAuthAPI
+ let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "Wrong" ("header" :: String) req)
+ Left (FailureResponse _ r) <- runClient (getProtected authRequest) baseUrl
+ responseStatusCode r `shouldBe` HTTP.Status 401 "Unauthorized"
+
diff --git a/test/Servant/HoistClientSpec.hs b/test/Servant/HoistClientSpec.hs
new file mode 100644
index 0000000..704329f
--- /dev/null
+++ b/test/Servant/HoistClientSpec.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# 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.HoistClientSpec (spec) where
+
+import Prelude ()
+import Prelude.Compat
+
+import Data.Monoid ()
+import Data.Proxy
+import Test.Hspec
+
+import Servant.API
+ ((:<|>) ((:<|>)), (:>), Capture,
+ Get, JSON, Post)
+import Servant.Client
+import Servant.Server
+import Servant.ClientTestUtils
+
+
+spec :: Spec
+spec = describe "Servant.HoistClientSpec" $ do
+ hoistClientSpec
+
+type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int
+
+hoistClientAPI :: Proxy HoistClientAPI
+hoistClientAPI = Proxy
+
+hoistClientServer :: Application -- implements HoistClientAPI
+hoistClientServer = serve hoistClientAPI $ return 5 :<|> return
+
+hoistClientSpec :: Spec
+hoistClientSpec = beforeAll (startWaiApp hoistClientServer) $ afterAll endWaiApp $ do
+ describe "Servant.Client.hoistClient" $ do
+ it "allows us to GET/POST/... requests in IO instead of ClientM" $ \(_, baseUrl) -> do
+ let (getInt :<|> postInt)
+ = hoistClient hoistClientAPI
+ (fmap (either (error . show) id) . flip runClient baseUrl)
+ (client hoistClientAPI)
+
+ getInt `shouldReturn` 5
+ postInt 5 `shouldReturn` 5
diff --git a/test/Servant/StreamSpec.hs b/test/Servant/StreamSpec.hs
index d0fc2a6..8501857 100644
--- a/test/Servant/StreamSpec.hs
+++ b/test/Servant/StreamSpec.hs
@@ -39,9 +39,6 @@ import Servant.API
NewlineFraming, NoFraming, OctetStream, SourceIO, StreamGet,
)
import Servant.Client.Streaming
-import Servant.ClientSpec
- (Person (..))
-import qualified Servant.ClientSpec as CS
import Servant.Server
import Servant.Test.ComprehensiveAPI
import Servant.Types.SourceT
@@ -52,6 +49,8 @@ import System.IO.Unsafe
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
@@ -120,7 +119,7 @@ testRunSourceIO :: SourceIO a
testRunSourceIO = runExceptT . runSourceT
streamSpec :: Spec
-streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do
+streamSpec = beforeAll (CT.startWaiApp server) $ afterAll CT.endWaiApp $ do
it "works with Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do
withClient getGetNL baseUrl $ \(Right res) ->
testRunSourceIO res `shouldReturn` Right [alice, bob, alice]
diff --git a/test/Servant/SuccessSpec.hs b/test/Servant/SuccessSpec.hs
new file mode 100644
index 0000000..272b607
--- /dev/null
+++ b/test/Servant/SuccessSpec.hs
@@ -0,0 +1,153 @@
+{-# 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.SuccessSpec (spec) where
+
+import Prelude ()
+import Prelude.Compat
+
+import Control.Arrow
+ (left)
+import Control.Concurrent.STM
+ (atomically)
+import Control.Concurrent.STM.TVar
+ (newTVar, readTVar)
+import Data.Foldable
+ (forM_, toList)
+import Data.Maybe
+ (listToMaybe)
+import Data.Monoid ()
+import qualified Network.HTTP.Client as C
+import qualified Network.HTTP.Types as HTTP
+import Test.Hspec
+import Test.Hspec.QuickCheck
+import Test.HUnit
+import Test.QuickCheck
+
+import Servant.API
+ (NoContent (NoContent), getHeaders)
+import Servant.Client
+import qualified Servant.Client.Core.Request as Req
+import Servant.Client.Internal.HttpClient (defaultMakeClientRequest)
+import Servant.Test.ComprehensiveAPI
+import Servant.ClientTestUtils
+
+-- This declaration simply checks that all instances are in place.
+_ = client comprehensiveAPIWithoutStreaming
+
+spec :: Spec
+spec = describe "Servant.SuccessSpec" $ do
+ 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
+
+ it "Servant.API.Get" $ \(_, baseUrl) -> do
+ left show <$> runClient getGet baseUrl `shouldReturn` Right alice
+
+ describe "Servant.API.Delete" $ do
+ it "allows empty content type" $ \(_, baseUrl) -> do
+ left show <$> runClient getDeleteEmpty baseUrl `shouldReturn` Right NoContent
+
+ it "allows content type" $ \(_, baseUrl) -> do
+ 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.CaptureAll" $ \(_, baseUrl) -> do
+ let expected = [Person "Paula" 0, Person "Peta" 1]
+ left show <$> runClient (getCaptureAll ["Paula", "Peta"]) baseUrl `shouldReturn` Right expected
+
+ it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
+ let p = Person "Clara" 42
+ left show <$> runClient (getBody p) baseUrl `shouldReturn` Right p
+
+ it "Servant.API FailureResponse" $ \(_, baseUrl) -> do
+ left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice
+ Left (FailureResponse req _) <- runClient (getQueryParam (Just "bob")) baseUrl
+ Req.requestPath req `shouldBe` (baseUrl, "/param")
+ toList (Req.requestQueryString req) `shouldBe` [("name", Just "bob")]
+ Req.requestMethod req `shouldBe` HTTP.methodGet
+
+ it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
+ left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice
+ Left (FailureResponse _ r) <- runClient (getQueryParam (Just "bob")) baseUrl
+ responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"
+
+ it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
+ left show <$> runClient (getQueryParams []) baseUrl `shouldReturn` Right []
+ left show <$> runClient (getQueryParams ["alice", "bob"]) baseUrl
+ `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
+
+ it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
+ res <- runClient (getRawSuccess HTTP.methodGet) baseUrl
+ case res of
+ Left e -> assertFailure $ show e
+ Right r -> do
+ responseStatusCode r `shouldBe` HTTP.status200
+ responseBody r `shouldBe` "rawSuccess"
+
+ it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do
+ res <- runClient (getRawFailure HTTP.methodGet) baseUrl
+ case res of
+ Right _ -> assertFailure "expected Left, but got Right"
+ Left (FailureResponse _ r) -> do
+ responseStatusCode r `shouldBe` HTTP.status400
+ responseBody r `shouldBe` "rawFailure"
+ Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e
+
+ it "Returns headers appropriately" $ \(_, baseUrl) -> do
+ res <- runClient getRespHeaders baseUrl
+ case res of
+ Left e -> assertFailure $ show e
+ Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
+
+ 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)
+ cookie <- listToMaybe . C.destroyCookieJar <$> atomically (readTVar cj)
+ C.cookie_name <$> cookie `shouldBe` Just "testcookie"
+ C.cookie_value <$> cookie `shouldBe` Just "test"
+
+ it "Can modify the outgoing Request using the ClientEnv" $ \(_, baseUrl) -> do
+ 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 }
+ res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv
+ case res of
+ Left e ->
+ assertFailure $ show e
+ 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)
diff --git a/test/Servant/WrappedApiSpec.hs b/test/Servant/WrappedApiSpec.hs
new file mode 100644
index 0000000..5172ad5
--- /dev/null
+++ b/test/Servant/WrappedApiSpec.hs
@@ -0,0 +1,63 @@
+{-# 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.WrappedApiSpec (spec) where
+
+import Prelude ()
+import Prelude.Compat
+
+import Control.Exception
+ (bracket)
+import Control.Monad.Error.Class
+ (throwError)
+import Data.Monoid ()
+import Data.Proxy
+import qualified Network.HTTP.Types as HTTP
+import Test.Hspec
+
+import Servant.API
+ (Delete, Get, JSON, Post, Put)
+import Servant.Client
+import Servant.Server
+import Servant.ClientTestUtils
+
+spec :: Spec
+spec = describe "Servant.WrappedApiSpec" $ do
+ wrappedApiSpec
+
+data WrappedApi where
+ WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a,
+ HasClient ClientM api, Client ClientM api ~ ClientM ()) =>
+ Proxy api -> WrappedApi
+
+wrappedApiSpec :: Spec
+wrappedApiSpec = describe "error status codes" $ do
+ let serveW api = serve api $ throwError $ ServerError 500 "error message" "" []
+ context "are correctly handled by the client" $
+ let test :: (WrappedApi, String) -> Spec
+ test (WrappedApi api, desc) =
+ it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do
+ let getResponse :: ClientM ()
+ getResponse = client api
+ Left (FailureResponse _ r) <- runClient getResponse baseUrl
+ responseStatusCode r `shouldBe` HTTP.Status 500 "error message"
+ in mapM_ test $
+ (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
+ (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
+ (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") :
+ (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") :
+ []