diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ---- diff --git a/servant-client.cabal b/servant-client.cabal --- a/servant-client.cabal +++ b/servant-client.cabal @@ -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 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 @@ -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 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 @@ -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 diff --git a/test/Servant/ClientTestUtils.hs b/test/Servant/ClientTestUtils.hs --- a/test/Servant/ClientTestUtils.hs +++ b/test/Servant/ClientTestUtils.hs @@ -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 diff --git a/test/Servant/StreamSpec.hs b/test/Servant/StreamSpec.hs --- a/test/Servant/StreamSpec.hs +++ b/test/Servant/StreamSpec.hs @@ -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)) --} diff --git a/test/Servant/SuccessSpec.hs b/test/Servant/SuccessSpec.hs --- a/test/Servant/SuccessSpec.hs +++ b/test/Servant/SuccessSpec.hs @@ -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