diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,37 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md) [Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) +Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions. + +0.19 +---- + +### Significant changes + +- Drop support for GHC < 8.6. +- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet). +- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)), + which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864) + related to hash collisions. +- Add `NamedRoutes` combinator, making support for records first-class in Servant + ([#1388](https://github.com/haskell-servant/servant/pull/1388)). +- Add custom type errors for partially applied combinators + ([#1289](https://github.com/haskell-servant/servant/pull/1289), + [#1486](https://github.com/haskell-servant/servant/pull/1486)). +- *servant-client* / *servant-client-core* / *servant-http-streams*: Fix + erroneous behavior, where only 2XX status codes would be considered + successful, irrelevant of the status parameter specified by the verb + combinator. ([#1469](https://github.com/haskell-servant/servant/pull/1469)) +- *servant-client* / *servant-client-core*: Fix `Show` instance for + `Servant.Client.Core.Request`. +- *servant-client* / *servant-client-core*: Allow passing arbitrary binary data + in Query parameters. + ([#1432](https://github.com/haskell-servant/servant/pull/1432)). + +### Other changes + +- Various version bumps. + 0.18.3 ------ diff --git a/servant-client.cabal b/servant-client.cabal --- a/servant-client.cabal +++ b/servant-client.cabal @@ -1,6 +1,6 @@ -cabal-version: >=1.10 +cabal-version: 2.2 name: servant-client -version: 0.18.3 +version: 0.19 synopsis: Automatic derivation of querying functions for servant category: Servant, Web @@ -14,13 +14,14 @@ homepage: http://docs.servant.dev/ bug-reports: http://github.com/haskell-servant/servant/issues -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors build-type: Simple -tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1 +tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1 + , GHCJS ==8.6.0.1 extra-source-files: CHANGELOG.md @@ -57,8 +58,8 @@ -- Servant dependencies. -- Strict dependency on `servant-client-core` as we re-export things. build-depends: - servant == 0.18.* - , servant-client-core >= 0.18.3 && <0.18.4 + servant >= 0.18 && < 0.20 + , servant-client-core >= 0.19 && < 0.19.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. @@ -72,7 +73,7 @@ , monad-control >= 1.0.2.3 && < 1.1 , semigroupoids >= 5.3.1 && < 5.4 , transformers-base >= 0.4.5.2 && < 0.5 - , transformers-compat >= 0.6.2 && < 0.7 + , transformers-compat >= 0.6.2 && < 0.8 hs-source-dirs: src default-language: Haskell2010 @@ -82,14 +83,18 @@ type: exitcode-stdio-1.0 ghc-options: -Wall -rtsopts -threaded "-with-rtsopts=-T -N2" default-language: Haskell2010 + if impl(ghcjs) + buildable: False hs-source-dirs: test main-is: Spec.hs other-modules: Servant.BasicAuthSpec + Servant.BrokenSpec Servant.ClientTestUtils Servant.ConnectionErrorSpec Servant.FailSpec Servant.GenAuthSpec + Servant.GenericSpec Servant.HoistClientSpec Servant.StreamSpec Servant.SuccessSpec @@ -123,8 +128,8 @@ , HUnit >= 1.6.0.0 && < 1.7 , network >= 2.8.0.0 && < 3.2 , QuickCheck >= 2.12.6.1 && < 2.15 - , servant == 0.18.* - , servant-server == 0.18.* + , servant == 0.19.* + , servant-server == 0.19.* , tdigest >= 0.2 && < 0.3 build-tool-depends: @@ -137,3 +142,5 @@ build-tool-depends: markdown-unlit:markdown-unlit ghc-options: -pgmL markdown-unlit default-language: Haskell2010 + if impl(ghcjs) + buildable: False diff --git a/src/Servant/Client/Internal/HttpClient.hs b/src/Servant/Client/Internal/HttpClient.hs --- a/src/Servant/Client/Internal/HttpClient.hs +++ b/src/Servant/Client/Internal/HttpClient.hs @@ -46,15 +46,13 @@ import Data.Either (either) import Data.Foldable - (toList) + (foldl',toList) import Data.Functor.Alt (Alt (..)) import Data.Maybe (maybe, maybeToList) import Data.Proxy (Proxy (..)) -import Data.Semigroup - ((<>)) import Data.Sequence (fromList) import Data.String @@ -65,7 +63,7 @@ import Network.HTTP.Media (renderHeader) import Network.HTTP.Types - (hContentType, renderQuery, statusCode, Status) + (hContentType, renderQuery, statusIsSuccessful, urlEncode, Status) import Servant.Client.Core import qualified Network.HTTP.Client as Client @@ -181,10 +179,9 @@ response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar' let status = Client.responseStatus response - status_code = statusCode status ourResponse = clientResponseToResponse id response goodStatus = case acceptStatus of - Nothing -> status_code >= 200 && status_code < 300 + Nothing -> statusIsSuccessful status Just good -> status `elem` good unless goodStatus $ do throwError $ mkFailureResponse burl req ourResponse @@ -240,7 +237,7 @@ , Client.path = BSL.toStrict $ fromString (baseUrlPath burl) <> toLazyByteString (requestPath r) - , Client.queryString = renderQuery True . toList $ requestQueryString r + , Client.queryString = buildQueryString . toList $ requestQueryString r , Client.requestHeaders = maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers , Client.requestBody = body @@ -290,6 +287,13 @@ isSecure = case baseUrlScheme burl of Http -> False Https -> True + + -- Query string builder which does not do any encoding + buildQueryString = ("?" <>) . foldl' addQueryParam mempty + + addQueryParam qs (k, v) = + qs <> (if BS.null qs then mempty else "&") <> urlEncode True k <> foldMap ("=" <>) v + catchConnectionError :: IO a -> IO (Either ClientError a) catchConnectionError action = diff --git a/src/Servant/Client/Internal/HttpClient/Streaming.hs b/src/Servant/Client/Internal/HttpClient/Streaming.hs --- a/src/Servant/Client/Internal/HttpClient/Streaming.hs +++ b/src/Servant/Client/Internal/HttpClient/Streaming.hs @@ -47,7 +47,7 @@ (getCurrentTime) import GHC.Generics import Network.HTTP.Types - (Status, statusCode) + (Status, statusIsSuccessful) import qualified Network.HTTP.Client as Client @@ -163,10 +163,9 @@ now' <- getCurrentTime atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now') let status = Client.responseStatus response - status_code = statusCode status ourResponse = clientResponseToResponse id response goodStatus = case acceptStatus of - Nothing -> status_code >= 200 && status_code < 300 + Nothing -> statusIsSuccessful status Just good -> status `elem` good unless goodStatus $ do throwError $ mkFailureResponse burl req ourResponse @@ -182,10 +181,9 @@ ClientM $ lift $ lift $ Codensity $ \k1 -> Client.withResponse request m $ \res -> do let status = Client.responseStatus res - status_code = statusCode status -- we throw FailureResponse in IO :( - unless (status_code >= 200 && status_code < 300) $ do + unless (statusIsSuccessful status) $ do b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res) throwIO $ mkFailureResponse burl req (clientResponseToResponse (const b) res) diff --git a/test/Servant/BrokenSpec.hs b/test/Servant/BrokenSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/BrokenSpec.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -freduction-depth=100 #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +module Servant.BrokenSpec (spec) where + +import Prelude () +import Prelude.Compat + +import Data.Monoid () +import Data.Proxy +import qualified Network.HTTP.Types as HTTP +import Test.Hspec + +import Servant.API + ((:<|>) ((:<|>)), (:>), JSON, Verb, Get, StdMethod (GET)) +import Servant.Client +import Servant.ClientTestUtils +import Servant.Server + +-- * api for testing inconsistencies between client and server + +type Get201 = Verb 'GET 201 +type Get301 = Verb 'GET 301 + +type BrokenAPI = + -- the server should respond with 200, but returns 201 + "get200" :> Get201 '[JSON] () + -- the server should respond with 307, but returns 301 + :<|> "get307" :> Get301 '[JSON] () + +brokenApi :: Proxy BrokenAPI +brokenApi = Proxy + +brokenServer :: Application +brokenServer = serve brokenApi (pure () :<|> pure ()) + +type PublicAPI = + -- the client expects 200 + "get200" :> Get '[JSON] () + -- the client expects 307 + :<|> "get307" :> Get307 '[JSON] () + +publicApi :: Proxy PublicAPI +publicApi = Proxy + +get200Client :: ClientM () +get307Client :: ClientM () +get200Client :<|> get307Client = client publicApi + + +spec :: Spec +spec = describe "Servant.BrokenSpec" $ do + brokenSpec + +brokenSpec :: Spec +brokenSpec = beforeAll (startWaiApp brokenServer) $ afterAll endWaiApp $ do + context "client returns errors for inconsistencies between client and server api" $ do + it "reports FailureResponse with wrong 2xx status code" $ \(_, baseUrl) -> do + res <- runClient get200Client baseUrl + case res of + Left (FailureResponse _ r) | responseStatusCode r == HTTP.status201 -> return () + _ -> fail $ "expected 201 broken response, but got " <> show res + + it "reports FailureResponse with wrong 3xx status code" $ \(_, baseUrl) -> do + res <- runClient get307Client baseUrl + case res of + Left (FailureResponse _ r) | responseStatusCode r == HTTP.status301 -> return () + _ -> fail $ "expected 301 broken response, but got " <> show res diff --git a/test/Servant/ClientTestUtils.hs b/test/Servant/ClientTestUtils.hs --- a/test/Servant/ClientTestUtils.hs +++ b/test/Servant/ClientTestUtils.hs @@ -24,9 +24,15 @@ import Control.Concurrent (ThreadId, forkIO, killThread) +import Control.Monad + (join) import Control.Monad.Error.Class (throwError) import Data.Aeson +import Data.ByteString + (ByteString) +import Data.ByteString.Builder + (byteString) import qualified Data.ByteString.Lazy as LazyByteString import Data.Char (chr, isPrint) @@ -54,11 +60,12 @@ import Servant.API ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData (..), Capture, CaptureAll, DeleteNoContent, - EmptyAPI, FormUrlEncoded, Fragment, Get, Header, Headers, + EmptyAPI, FormUrlEncoded, Fragment, FromHttpApiData (..), Get, Header, Headers, JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender), NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam, - QueryParams, Raw, ReqBody, StdMethod (GET), UVerb, Union, - WithStatus (WithStatus), addHeader) + QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), UVerb, Union, + Verb, WithStatus (WithStatus), NamedRoutes, addHeader) +import Servant.API.Generic ((:-)) import Servant.Client import qualified Servant.Client.Core.Auth as Auth import Servant.Server @@ -101,14 +108,35 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String] +data RecordRoutes mode = RecordRoutes + { version :: mode :- "version" :> Get '[JSON] Int + , echo :: mode :- "echo" :> Capture "string" String :> Get '[JSON] String + , otherRoutes :: mode :- "other" :> Capture "someParam" Int :> NamedRoutes OtherRoutes + } deriving Generic + +data OtherRoutes mode = OtherRoutes + { something :: mode :- "something" :> Get '[JSON] [String] + } deriving Generic + +-- Get for HTTP 307 Temporary Redirect +type Get307 = Verb 'GET 307 + type Api = Get '[JSON] Person :<|> "get" :> Get '[JSON] Person + -- This endpoint returns a response with status code 307 Temporary Redirect, + -- different from the ones in the 2xx successful class, to test derivation + -- of clients' api. + :<|> "get307" :> Get307 '[PlainText] Text :<|> "deleteEmpty" :> DeleteNoContent :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person] :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person + -- This endpoint makes use of a 'Raw' server because it is not currently + -- possible to handle arbitrary binary query param values with + -- @servant-server@ + :<|> "param-binary" :> QueryParam "payload" UrlEncodedByteString :> Raw :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person] :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool :<|> "fragment" :> Fragment String :> Get '[JSON] Person @@ -131,18 +159,20 @@ UVerb 'GET '[PlainText] '[WithStatus 200 Person, WithStatus 301 Text] :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person] - + :<|> NamedRoutes RecordRoutes api :: Proxy Api api = Proxy getRoot :: ClientM Person getGet :: ClientM Person +getGet307 :: ClientM Text getDeleteEmpty :: ClientM NoContent getCapture :: String -> ClientM Person getCaptureAll :: [String] -> ClientM [Person] getBody :: Person -> ClientM Person getQueryParam :: Maybe String -> ClientM Person +getQueryParamBinary :: Maybe UrlEncodedByteString -> HTTP.Method -> ClientM Response getQueryParams :: [String] -> ClientM [Person] getQueryFlag :: Bool -> ClientM Bool getFragment :: ClientM Person @@ -159,14 +189,17 @@ -> ClientM (Union '[WithStatus 200 Person, WithStatus 301 Text]) uverbGetCreated :: ClientM (Union '[WithStatus 201 Person]) +recordRoutes :: RecordRoutes (AsClientT ClientM) getRoot :<|> getGet + :<|> getGet307 :<|> getDeleteEmpty :<|> getCapture :<|> getCaptureAll :<|> getBody :<|> getQueryParam + :<|> getQueryParamBinary :<|> getQueryParams :<|> getQueryFlag :<|> getFragment @@ -180,12 +213,14 @@ :<|> getRedirectWithCookie :<|> EmptyClient :<|> uverbGetSuccessOrRedirect - :<|> uverbGetCreated = client api + :<|> uverbGetCreated + :<|> recordRoutes = client api server :: Application server = serve api ( return carol :<|> return alice + :<|> return "redirecting" :<|> return NoContent :<|> (\ name -> return $ Person name 0) :<|> (\ names -> return (zipWith Person names [0..])) @@ -194,6 +229,13 @@ Just "alice" -> return alice Just n -> throwError $ ServerError 400 (n ++ " not found") "" [] Nothing -> throwError $ ServerError 400 "missing parameter" "" []) + :<|> const (Tagged $ \request respond -> + respond . maybe (Wai.responseLBS HTTP.notFound404 [] "Missing: payload") + (Wai.responseLBS HTTP.ok200 [] . LazyByteString.fromStrict) + . join + . lookup "payload" + $ Wai.queryString request + ) :<|> (\ names -> return (zipWith Person names [0..])) :<|> return :<|> return alice @@ -210,8 +252,17 @@ then respond (WithStatus @301 ("redirecting" :: Text)) else respond (WithStatus @200 alice )) :<|> respond (WithStatus @201 carol) + :<|> RecordRoutes + { version = pure 42 + , echo = pure + , otherRoutes = \_ -> OtherRoutes + { something = pure ["foo", "bar", "pweet"] + } + } ) +-- * api for testing failures + type FailApi = "get" :> Raw :<|> "capture" :> Capture "name" String :> Raw @@ -226,7 +277,7 @@ :<|> (\ _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 @@ -310,3 +361,12 @@ filter (not . (`elem` ("?%[]/#;" :: String))) $ filter isPrint $ map chr [0..127] + +newtype UrlEncodedByteString = UrlEncodedByteString { unUrlEncodedByteString :: ByteString } + +instance ToHttpApiData UrlEncodedByteString where + toEncodedUrlPiece = byteString . HTTP.urlEncode True . unUrlEncodedByteString + toUrlPiece = decodeUtf8 . HTTP.urlEncode True . unUrlEncodedByteString + +instance FromHttpApiData UrlEncodedByteString where + parseUrlPiece = pure . UrlEncodedByteString . HTTP.urlDecode True . encodeUtf8 diff --git a/test/Servant/FailSpec.hs b/test/Servant/FailSpec.hs --- a/test/Servant/FailSpec.hs +++ b/test/Servant/FailSpec.hs @@ -21,8 +21,6 @@ import Prelude.Compat import Data.Monoid () -import Data.Semigroup - ((<>)) import qualified Network.HTTP.Types as HTTP import Test.Hspec @@ -40,14 +38,14 @@ context "client returns errors appropriately" $ do it "reports FailureResponse" $ \(_, baseUrl) -> do - let (_ :<|> _ :<|> getDeleteEmpty :<|> _) = client api + let (_ :<|> _ :<|> _ :<|> getDeleteEmpty :<|> _) = client api Left res <- runClient getDeleteEmpty baseUrl case res of FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return () _ -> fail $ "expected 404 response, but got " <> show res it "reports DecodeFailure" $ \(_, baseUrl) -> do - let (_ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api + let (_ :<|> _ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api Left res <- runClient (getCapture "foo") baseUrl case res of DecodeFailure _ _ -> return () @@ -74,7 +72,7 @@ _ -> fail $ "expected UnsupportedContentType, but got " <> show res it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do - let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api + let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api Left res <- runClient (getBody alice) baseUrl case res of InvalidContentTypeHeader _ -> return () diff --git a/test/Servant/GenericSpec.hs b/test/Servant/GenericSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/GenericSpec.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -freduction-depth=100 #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +module Servant.GenericSpec (spec) where + +import Test.Hspec + +import Servant.Client ((//), (/:)) +import Servant.ClientTestUtils + +spec :: Spec +spec = describe "Servant.GenericSpec" $ do + genericSpec + +genericSpec :: Spec +genericSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do + context "Record clients work as expected" $ do + + it "Client functions return expected values" $ \(_,baseUrl) -> do + runClient (recordRoutes // version) baseUrl `shouldReturn` Right 42 + runClient (recordRoutes // echo /: "foo") baseUrl `shouldReturn` Right "foo" + it "Clients can be nested" $ \(_,baseUrl) -> do + runClient (recordRoutes // otherRoutes /: 42 // something) baseUrl `shouldReturn` Right ["foo", "bar", "pweet"] diff --git a/test/Servant/SuccessSpec.hs b/test/Servant/SuccessSpec.hs --- a/test/Servant/SuccessSpec.hs +++ b/test/Servant/SuccessSpec.hs @@ -22,17 +22,18 @@ import Prelude.Compat import Control.Arrow - (left) + ((+++), left) import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TVar (newTVar, readTVar) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL import Data.Foldable (forM_, toList) import Data.Maybe (listToMaybe) import Data.Monoid () -import Data.SOP (NS (..), I (..)) import Data.Text (Text) import qualified Network.HTTP.Client as C @@ -43,11 +44,9 @@ import Test.QuickCheck import Servant.API - (NoContent (NoContent), WithStatus (WithStatus), getHeaders) + (NoContent (NoContent), WithStatus (WithStatus), getHeaders, Headers(..)) import Servant.Client import qualified Servant.Client.Core.Request as Req -import Servant.Client.Internal.HttpClient - (defaultMakeClientRequest) import Servant.ClientTestUtils import Servant.Test.ComprehensiveAPI @@ -60,12 +59,16 @@ successSpec :: Spec successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do - it "Servant.API.Get root" $ \(_, baseUrl) -> do - left show <$> runClient getRoot baseUrl `shouldReturn` Right carol + describe "Servant.API.Get" $ do + it "get root endpoint" $ \(_, baseUrl) -> do + left show <$> runClient getRoot baseUrl `shouldReturn` Right carol - it "Servant.API.Get" $ \(_, baseUrl) -> do - left show <$> runClient getGet baseUrl `shouldReturn` Right alice + it "get simple endpoint" $ \(_, baseUrl) -> do + left show <$> runClient getGet baseUrl `shouldReturn` Right alice + it "get redirection endpoint" $ \(_, baseUrl) -> do + left show <$> runClient getGet307 baseUrl `shouldReturn` Right "redirecting" + describe "Servant.API.Delete" $ do it "allows empty content type" $ \(_, baseUrl) -> do left show <$> runClient getDeleteEmpty baseUrl `shouldReturn` Right NoContent @@ -96,6 +99,11 @@ Left (FailureResponse _ r) <- runClient (getQueryParam (Just "bob")) baseUrl responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found" + it "Servant.API.QueryParam binary data" $ \(_, baseUrl) -> do + let payload = BS.pack [0, 1, 2, 4, 8, 16, 32, 64, 128] + apiCall = getQueryParamBinary (Just $ UrlEncodedByteString payload) HTTP.methodGet + (show +++ responseBody) <$> runClient apiCall baseUrl `shouldReturn` Right (BL.fromStrict payload) + it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do left show <$> runClient (getQueryParams []) baseUrl `shouldReturn` Right [] left show <$> runClient (getQueryParams ["alice", "bob"]) baseUrl @@ -107,6 +115,7 @@ it "Servant.API.Fragment" $ \(_, baseUrl) -> do left id <$> runClient getFragment baseUrl `shouldReturn` Right alice + it "Servant.API.Raw on success" $ \(_, baseUrl) -> do res <- runClient (getRawSuccess HTTP.methodGet) baseUrl case res of @@ -134,9 +143,10 @@ res <- runClient getUVerbRespHeaders baseUrl case res of Left e -> assertFailure $ show e - Right (Z (I (WithStatus val))) -> - getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] - Right (S _) -> assertFailure "expected first alternative of union" + Right val -> case matchUnion val of + Just (WithStatus val' :: WithStatus 200 (Headers TestHeaders Bool)) + -> getHeaders val' `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] + Nothing -> assertFailure "unexpected alternative of union" it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do mgr <- C.newManager C.defaultManagerSettings @@ -151,7 +161,7 @@ -- 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 } + clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest } res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv case res of Left e ->