servant-client 0.19 → 0.20
raw patch · 7 files changed
+97/−86 lines, 7 filesdep −tdigestdep ~QuickCheckdep ~basedep ~base-compat
Dependencies removed: tdigest
Dependency ranges changed: QuickCheck, base, base-compat, bifunctors, bytestring, deepseq, hspec, mtl, network, semigroupoids, servant, servant-client-core, servant-server, text, transformers
Files
- CHANGELOG.md +19/−0
- servant-client.cabal +16/−17
- src/Servant/Client/Internal/HttpClient.hs +9/−8
- src/Servant/Client/Internal/HttpClient/Streaming.hs +18/−6
- test/Servant/ClientTestUtils.hs +18/−1
- test/Servant/StreamSpec.hs +0/−48
- test/Servant/SuccessSpec.hs +17/−6
CHANGELOG.md view
@@ -3,6 +3,25 @@ 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.20+----++- Escape special chars in QueryParams. [#1584](https://github.com/haskell-servant/servant/issues/1584) [#1597](https://github.com/haskell-servant/servant/pull/1597)++ Escape special chars in QueryParam (`:@&=+$`) in servant-client. Note that this+ mean binary data will not work as is, and so reverts the functionality in+ [#1432](https://github.com/haskell-servant/servant/pull/1432).++- Handle Cookies correctly for RunStreamingClient [#1605](https://github.com/haskell-servant/servant/issues/1605) [#1606](https://github.com/haskell-servant/servant/pull/1606)++ Makes `performWithStreamingRequest` take into consideration the+ CookieJar, which it previously didn't.++- Fix the handling of multiple headers with the same name. [#1666](https://github.com/haskell-servant/servant/pull/1666)++ servant-client no longer concatenates the values of response headers with the same name.+ This fixes an issue with parsing multiple `Set-Cookie` headers.+ 0.19 ----
servant-client.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: servant-client-version: 0.19+version: 0.20 synopsis: Automatic derivation of querying functions for servant category: Servant, Web@@ -20,7 +20,7 @@ maintainer: haskell-servant-maintainers@googlegroups.com copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors build-type: Simple-tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1+tested-with: GHC==8.6.5, GHC==8.8.4, GHC ==8.10.7, GHC ==9.0.2, GHC ==9.2.7, GHC ==9.4.4 , GHCJS ==8.6.0.1 extra-source-files:@@ -41,37 +41,37 @@ -- Bundled with GHC: Lower bound to not force re-installs -- text and mtl are bundled starting with GHC-8.4 build-depends:- base >= 4.9 && < 4.16+ base >= 4.9 && < 4.19 , bytestring >= 0.10.8.1 && < 0.12 , containers >= 0.5.7.1 && < 0.7 , deepseq >= 1.4.2.0 && < 1.5- , mtl >= 2.2.2 && < 2.3+ , mtl ^>= 2.2.2 || ^>= 2.3.1 , stm >= 2.4.5.1 && < 2.6- , text >= 1.2.3.0 && < 1.3- , time >= 1.6.0.1 && < 1.10- , transformers >= 0.5.2.0 && < 0.6+ , text >= 1.2.3.0 && < 2.1+ , time >= 1.6.0.1 && < 1.13+ , transformers >= 0.5.2.0 && < 0.7 if !impl(ghc >= 8.2) build-depends:- bifunctors >= 5.5.3 && < 5.6+ bifunctors >= 5.5.3 && < 5.7 -- Servant dependencies. -- Strict dependency on `servant-client-core` as we re-export things. build-depends:- servant >= 0.18 && < 0.20- , servant-client-core >= 0.19 && < 0.19.1+ servant >= 0.20 && < 0.21+ , servant-client-core >= 0.20 && < 0.21 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. build-depends:- base-compat >= 0.10.5 && < 0.12+ base-compat >= 0.10.5 && < 0.14 , http-client >= 0.5.13.1 && < 0.8 , http-media >= 0.7.1.3 && < 0.9 , http-types >= 0.12.2 && < 0.13 , exceptions >= 0.10.0 && < 0.11 , kan-extensions >= 5.2 && < 5.3 , monad-control >= 1.0.2.3 && < 1.1- , semigroupoids >= 5.3.1 && < 5.4+ , semigroupoids >= 5.3.1 && < 6.1 , transformers-base >= 0.4.5.2 && < 0.5 , transformers-compat >= 0.6.2 && < 0.8 @@ -124,16 +124,15 @@ -- Additional dependencies build-depends: entropy >= 0.4.1.3 && < 0.5- , hspec >= 2.6.0 && < 2.9+ , hspec >= 2.6.0 && < 2.11 , HUnit >= 1.6.0.0 && < 1.7 , network >= 2.8.0.0 && < 3.2 , QuickCheck >= 2.12.6.1 && < 2.15- , servant == 0.19.*- , servant-server == 0.19.*- , tdigest >= 0.2 && < 0.3+ , servant >= 0.20 && < 0.21+ , servant-server >= 0.20 && < 0.21 build-tool-depends:- hspec-discover:hspec-discover >= 2.6.0 && < 2.9+ hspec-discover:hspec-discover >= 2.6.0 && < 2.11 test-suite readme type: exitcode-stdio-1.0
src/Servant/Client/Internal/HttpClient.hs view
@@ -24,7 +24,7 @@ import Control.Monad.Base (MonadBase (..)) import Control.Monad.Catch- (MonadCatch, MonadThrow)+ (MonadCatch, MonadThrow, MonadMask) import Control.Monad.Error.Class (MonadError (..)) import Control.Monad.IO.Class@@ -80,7 +80,7 @@ { manager :: Client.Manager , baseUrl :: BaseUrl , cookieJar :: Maybe (TVar Client.CookieJar)- , makeClientRequest :: BaseUrl -> Request -> Client.Request+ , makeClientRequest :: BaseUrl -> Request -> IO 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,@@ -136,7 +136,7 @@ { unClientM :: ReaderT ClientEnv (ExceptT ClientError IO) a } deriving ( Functor, Applicative, Monad, MonadIO, Generic , MonadReader ClientEnv, MonadError ClientError, MonadThrow- , MonadCatch)+ , MonadCatch, MonadMask) instance MonadBase IO ClientM where liftBase = ClientM . liftBase@@ -162,7 +162,7 @@ performRequest :: Maybe [Status] -> Request -> ClientM Response performRequest acceptStatus req = do ClientEnv m burl cookieJar' createClientRequest <- ask- let clientRequest = createClientRequest burl req+ clientRequest <- liftIO $ createClientRequest burl req request <- case cookieJar' of Nothing -> pure clientRequest Just cj -> liftIO $ do@@ -229,8 +229,8 @@ -- | 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+defaultMakeClientRequest :: BaseUrl -> Request -> IO Client.Request+defaultMakeClientRequest burl r = return Client.defaultRequest { Client.method = requestMethod r , Client.host = fromString $ baseUrlHost burl , Client.port = baseUrlPort burl@@ -246,7 +246,7 @@ where -- Content-Type and Accept are specified by requestBody and requestAccept headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $- toList $requestHeaders r+ toList $ requestHeaders r acceptHdr | null hs = Nothing@@ -289,7 +289,8 @@ Https -> True -- Query string builder which does not do any encoding- buildQueryString = ("?" <>) . foldl' addQueryParam mempty+ buildQueryString [] = mempty+ buildQueryString qps = "?" <> foldl' addQueryParam mempty qps addQueryParam qs (k, v) = qs <> (if BS.null qs then mempty else "&") <> urlEncode True k <> foldMap ("=" <>) v
src/Servant/Client/Internal/HttpClient/Streaming.hs view
@@ -24,7 +24,8 @@ (NFData, force) import Control.Exception (evaluate, throwIO)-import Control.Monad ()+import Control.Monad+ (unless) import Control.Monad.Base (MonadBase (..)) import Control.Monad.Codensity@@ -140,7 +141,7 @@ performRequest acceptStatus req = do -- TODO: should use Client.withResponse here too ClientEnv m burl cookieJar' createClientRequest <- ask- let clientRequest = createClientRequest burl req+ clientRequest <- liftIO $ createClientRequest burl req request <- case cookieJar' of Nothing -> pure clientRequest Just cj -> liftIO $ do@@ -174,10 +175,21 @@ -- | TODO: support UVerb ('acceptStatus' argument, like in 'performRequest' above). performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a performWithStreamingRequest req k = do- m <- asks manager- burl <- asks baseUrl- createClientRequest <- asks makeClientRequest- let request = createClientRequest burl req+ ClientEnv m burl cookieJar' createClientRequest <- ask+ clientRequest <- liftIO $ createClientRequest burl req+ request <- case cookieJar' of+ Nothing -> pure clientRequest+ Just cj -> liftIO $ do+ now <- getCurrentTime+ atomically $ do+ oldCookieJar <- readTVar cj+ let (newRequest, newCookieJar) =+ Client.insertCookiesIntoRequest+ clientRequest+ oldCookieJar+ now+ writeTVar cj newCookieJar+ pure newRequest ClientM $ lift $ lift $ Codensity $ \k1 -> Client.withResponse request m $ \res -> do let status = Client.responseStatus res
test/Servant/ClientTestUtils.hs view
@@ -107,6 +107,7 @@ carol = Person "Carol" 17 type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]+type TestSetCookieHeaders = '[Header "Set-Cookie" String, Header "Set-Cookie" String] data RecordRoutes mode = RecordRoutes { version :: mode :- "version" :> Get '[JSON] Int@@ -151,6 +152,7 @@ Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])]) :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool) :<|> "uverb-headers" :> UVerb 'GET '[JSON] '[ WithStatus 200 (Headers TestHeaders Bool), WithStatus 204 String ]+ :<|> "set-cookie-headers" :> Get '[JSON] (Headers TestSetCookieHeaders Bool) :<|> "deleteContentType" :> DeleteNoContent :<|> "redirectWithCookie" :> Raw :<|> "empty" :> EmptyAPI@@ -160,6 +162,7 @@ WithStatus 301 Text] :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person] :<|> NamedRoutes RecordRoutes+ :<|> "captureVerbatim" :> Capture "someString" Verbatim :> Get '[PlainText] Text api :: Proxy Api api = Proxy@@ -183,6 +186,7 @@ -> ClientM (String, Maybe Int, Bool, [(String, [Rational])]) getRespHeaders :: ClientM (Headers TestHeaders Bool) getUVerbRespHeaders :: ClientM (Union '[ WithStatus 200 (Headers TestHeaders Bool), WithStatus 204 String ])+getSetCookieHeaders :: ClientM (Headers TestSetCookieHeaders Bool) getDeleteContentType :: ClientM NoContent getRedirectWithCookie :: HTTP.Method -> ClientM Response uverbGetSuccessOrRedirect :: Bool@@ -209,12 +213,14 @@ :<|> getMultiple :<|> getRespHeaders :<|> getUVerbRespHeaders+ :<|> getSetCookieHeaders :<|> getDeleteContentType :<|> getRedirectWithCookie :<|> EmptyClient :<|> uverbGetSuccessOrRedirect :<|> uverbGetCreated- :<|> recordRoutes = client api+ :<|> recordRoutes+ :<|> captureVerbatim = client api server :: Application server = serve api (@@ -245,6 +251,7 @@ :<|> (\ a b c d -> return (a, b, c, d)) :<|> (return $ addHeader 1729 $ addHeader "eg2" True) :<|> (pure . Z . I . WithStatus $ addHeader 1729 $ addHeader "eg2" True)+ :<|> (return $ addHeader "cookie1" $ addHeader "cookie2" True) :<|> return NoContent :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "") :<|> emptyServer@@ -259,6 +266,7 @@ { something = pure ["foo", "bar", "pweet"] } }+ :<|> pure . decodeUtf8 . unVerbatim ) -- * api for testing failures@@ -370,3 +378,12 @@ instance FromHttpApiData UrlEncodedByteString where parseUrlPiece = pure . UrlEncodedByteString . HTTP.urlDecode True . encodeUtf8++newtype Verbatim = Verbatim { unVerbatim :: ByteString }++instance ToHttpApiData Verbatim where+ toEncodedUrlPiece = byteString . unVerbatim+ toUrlPiece = decodeUtf8 . unVerbatim++instance FromHttpApiData Verbatim where+ parseUrlPiece = pure . Verbatim . encodeUtf8
test/Servant/StreamSpec.hs view
@@ -30,7 +30,6 @@ import Control.Monad.Trans.Except import qualified Data.ByteString as BS import Data.Proxy-import qualified Data.TDigest as TD import qualified Network.HTTP.Client as C import Prelude () import Prelude.Compat@@ -134,50 +133,3 @@ where input = ["foo", "", "bar"] output = ["foo", "bar"]--{-- it "streams in constant memory" $ \(_, baseUrl) -> do- Right rs <- runClient getGetALot baseUrl- performGC- -- usage0 <- getUsage- -- putStrLn $ "Start: " ++ show usage0- tdigest <- memoryUsage $ joinCodensitySourceT rs-- -- putStrLn $ "Median: " ++ show (TD.median tdigest)- -- putStrLn $ "Mean: " ++ show (TD.mean tdigest)- -- putStrLn $ "Stddev: " ++ show (TD.stddev tdigest)-- -- forM_ [0.01, 0.1, 0.2, 0.5, 0.8, 0.9, 0.99] $ \q ->- -- putStrLn $ "q" ++ show q ++ ": " ++ show (TD.quantile q tdigest)-- let Just stddev = TD.stddev tdigest-- -- standard deviation of 100k is ok, we generate 256M of data after all.- -- On my machine deviation is 40k-50k- stddev `shouldSatisfy` (< 100000)--memoryUsage :: SourceT IO BS.ByteString -> IO (TD.TDigest 25)-memoryUsage src = unSourceT src $ loop mempty (0 :: Int)- where- loop !acc !_ Stop = return acc- loop !_ !_ (Error err) = fail err -- !- loop !acc !n (Skip s) = loop acc n s- loop !acc !n (Effect ms) = ms >>= loop acc n- loop !acc !n (Yield _bs s) = do- usage <- liftIO getUsage- -- We perform GC in between as we generate garbage.- when (n `mod` 1024 == 0) $ liftIO performGC- loop (TD.insert usage acc) (n + 1) s--getUsage :: IO Double-getUsage = fromIntegral .-#if MIN_VERSION_base(4,10,0)- gcdetails_live_bytes . gc <$> getRTSStats-#else- currentBytesUsed <$> getGCStats-#endif- memUsed `shouldSatisfy` (< megabytes 22)--megabytes :: Num a => a -> a-megabytes n = n * (1000 ^ (2 :: Int))--}
test/Servant/SuccessSpec.hs view
@@ -36,6 +36,8 @@ import Data.Monoid () import Data.Text (Text)+import Data.Text.Encoding+ (encodeUtf8) import qualified Network.HTTP.Client as C import qualified Network.HTTP.Types as HTTP import Test.Hspec@@ -99,11 +101,6 @@ 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@@ -148,6 +145,12 @@ -> getHeaders val' `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] Nothing -> assertFailure "unexpected alternative of union" + it "Returns multiple Set-Cookie headers appropriately" $ \(_, baseUrl) -> do+ res <- runClient getSetCookieHeaders baseUrl+ case res of+ Left e -> assertFailure $ show e+ Right val -> getHeaders val `shouldBe` [("Set-Cookie", "cookie1"), ("Set-Cookie", "cookie2")]+ it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do mgr <- C.newManager C.defaultManagerSettings cj <- atomically . newTVar $ C.createCookieJar []@@ -160,7 +163,8 @@ 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 createClientRequest url r = fmap (\req -> req { C.requestHeaders = [("X-Added-Header", "XXX")] })+ (defaultMakeClientRequest url r) clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest } res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv case res of@@ -196,3 +200,10 @@ case eitherResponse of Left clientError -> fail $ show clientError Right response -> matchUnion response `shouldBe` Just (WithStatus @201 carol)++ it "encodes URL pieces following ToHttpApiData instance" $ \(_, baseUrl) -> do+ let textOrig = "*"+ eitherResponse <- runClient (captureVerbatim $ Verbatim $ encodeUtf8 textOrig) baseUrl+ case eitherResponse of+ Left clientError -> fail $ show clientError+ Right textBack -> textBack `shouldBe` textOrig