servant-client 0.16.0.1 → 0.17
raw patch · 16 files changed
+879/−537 lines, 16 filesdep ~servantdep ~servant-client-coredep ~servant-server
Dependency ranges changed: servant, servant-client-core, servant-server
Files
- CHANGELOG.md +48/−0
- servant-client.cabal +14/−7
- src/Servant/Client.hs +1/−0
- src/Servant/Client/Internal/HttpClient.hs +20/−6
- src/Servant/Client/Internal/HttpClient/Streaming.hs +7/−6
- src/Servant/Client/Streaming.hs +1/−0
- test/Servant/BasicAuthSpec.hs +53/−0
- test/Servant/ClientSpec.hs +0/−514
- test/Servant/ClientTestUtils.hs +268/−0
- test/Servant/ConnectionErrorSpec.hs +55/−0
- test/Servant/FailSpec.hs +81/−0
- test/Servant/GenAuthSpec.hs +54/−0
- test/Servant/HoistClientSpec.hs +58/−0
- test/Servant/StreamSpec.hs +3/−4
- test/Servant/SuccessSpec.hs +153/−0
- test/Servant/WrappedApiSpec.hs +63/−0
CHANGELOG.md view
@@ -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 --------
servant-client.cabal view
@@ -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 @@ || ==8.2.2 || ==8.4.4 || ==8.6.5- || ==8.8.1+ || ==8.8.2 extra-source-files: CHANGELOG.md@@ -62,8 +62,8 @@ -- 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 @@ 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 @@ , 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:
src/Servant/Client.hs view
@@ -9,6 +9,7 @@ , runClientM , ClientEnv(..) , mkClientEnv+ , defaultMakeClientRequest , hoistClient , module Servant.Client.Core.Reexport ) where
src/Servant/Client/Internal/HttpClient.hs view
@@ -72,16 +72,27 @@ 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 @@ 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 @@ oldCookieJar <- readTVar cj let (newRequest, newCookieJar) = Client.insertCookiesIntoRequest- (requestToClientRequest burl req)+ clientRequest oldCookieJar now writeTVar cj newCookieJar@@ -215,8 +226,11 @@ , 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
src/Servant/Client/Internal/HttpClient/Streaming.hs view
@@ -12,7 +12,7 @@ ClientEnv (..), mkClientEnv, clientResponseToResponse,- requestToClientRequest,+ defaultMakeClientRequest, catchConnectionError, ) where @@ -55,7 +55,7 @@ import Servant.Client.Internal.HttpClient (ClientEnv (..), catchConnectionError, clientResponseToResponse, mkClientEnv, mkFailureResponse,- requestToClientRequest)+ defaultMakeClientRequest) import qualified Servant.Types.SourceT as S @@ -139,8 +139,8 @@ 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 @@ oldCookieJar <- readTVar cj let (newRequest, newCookieJar) = Client.insertCookiesIntoRequest- (requestToClientRequest burl req)+ clientRequest oldCookieJar now writeTVar cj newCookieJar@@ -173,7 +173,8 @@ 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
src/Servant/Client/Streaming.hs view
@@ -10,6 +10,7 @@ , runClientM , ClientEnv(..) , mkClientEnv+ , defaultMakeClientRequest , hoistClient , module Servant.Client.Core.Reexport ) where
+ test/Servant/BasicAuthSpec.hs view
@@ -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"
− test/Servant/ClientSpec.hs
@@ -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]
+ test/Servant/ClientTestUtils.hs view
@@ -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]
+ test/Servant/ConnectionErrorSpec.hs view
@@ -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
+ test/Servant/FailSpec.hs view
@@ -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
+ test/Servant/GenAuthSpec.hs view
@@ -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"+
+ test/Servant/HoistClientSpec.hs view
@@ -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
test/Servant/StreamSpec.hs view
@@ -39,9 +39,6 @@ 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.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 = 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]
+ test/Servant/SuccessSpec.hs view
@@ -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)
+ test/Servant/WrappedApiSpec.hs view
@@ -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") :+ []