diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,17 @@ [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.18.1 +------ + +### Significant changes + +- Union verbs + +### Other changes + +- Bump "tested-with" ghc versions + 0.18 ---- 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 name: servant-client -version: 0.18 +version: 0.18.1 synopsis: Automatic derivation of querying functions for servant category: Servant, Web @@ -20,13 +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.0.2 - || ==8.2.2 - || ==8.4.4 - || ==8.6.5 - || ==8.8.3 - || ==8.10.1 +tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2 extra-source-files: CHANGELOG.md @@ -64,7 +58,7 @@ -- Strict dependency on `servant-client-core` as we re-export things. build-depends: servant == 0.18.* - , servant-client-core >= 0.18 && <0.18.1 + , servant-client-core >= 0.18 && <0.18.2 -- 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. @@ -114,6 +108,7 @@ , kan-extensions , servant-client , servant-client-core + , sop-core , stm , text , transformers 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 @@ -65,7 +65,7 @@ import Network.HTTP.Media (renderHeader) import Network.HTTP.Types - (hContentType, renderQuery, statusCode) + (hContentType, renderQuery, statusCode, Status) import Servant.Client.Core import qualified Network.HTTP.Client as Client @@ -155,14 +155,14 @@ a b = a `catchError` \_ -> b instance RunClient ClientM where - runRequest = performRequest + runRequestAcceptStatus = performRequest throwClientError = throwError runClientM :: ClientM a -> ClientEnv -> IO (Either ClientError a) runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm -performRequest :: Request -> ClientM Response -performRequest req = do +performRequest :: Maybe [Status] -> Request -> ClientM Response +performRequest acceptStatus req = do ClientEnv m burl cookieJar' createClientRequest <- ask let clientRequest = createClientRequest burl req request <- case cookieJar' of @@ -183,8 +183,11 @@ let status = Client.responseStatus response status_code = statusCode status ourResponse = clientResponseToResponse id response - unless (status_code >= 200 && status_code < 300) $ - throwError $ mkFailureResponse burl req ourResponse + goodStatus = case acceptStatus of + Nothing -> status_code >= 200 && status_code < 300 + Just good -> status `elem` good + unless goodStatus $ do + throwError $ mkFailureResponse burl req ourResponse return ourResponse where requestWithoutCookieJar :: Client.Manager -> Client.Request -> ClientM (Client.Response BSL.ByteString) 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 - (statusCode) + (Status, statusCode) import qualified Network.HTTP.Client as Client @@ -112,7 +112,7 @@ a b = a `catchError` \_ -> b instance RunClient ClientM where - runRequest = performRequest + runRequestAcceptStatus = performRequest throwClientError = throwError instance RunStreamingClient ClientM where @@ -136,8 +136,8 @@ runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ClientError a) runClientM cm env = withClientM cm env (evaluate . force) -performRequest :: Request -> ClientM Response -performRequest req = do +performRequest :: Maybe [Status] -> Request -> ClientM Response +performRequest acceptStatus req = do -- TODO: should use Client.withResponse here too ClientEnv m burl cookieJar' createClientRequest <- ask let clientRequest = createClientRequest burl req @@ -165,10 +165,14 @@ let status = Client.responseStatus response status_code = statusCode status ourResponse = clientResponseToResponse id response - unless (status_code >= 200 && status_code < 300) $ + goodStatus = case acceptStatus of + Nothing -> status_code >= 200 && status_code < 300 + Just good -> status `elem` good + unless goodStatus $ do throwError $ mkFailureResponse burl req ourResponse return ourResponse +-- | TODO: support UVerb ('acceptStatus' argument, like in 'performRequest' above). performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a performWithStreamingRequest req k = do m <- asks manager diff --git a/test/Servant/ClientTestUtils.hs b/test/Servant/ClientTestUtils.hs --- a/test/Servant/ClientTestUtils.hs +++ b/test/Servant/ClientTestUtils.hs @@ -9,6 +9,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -26,10 +27,14 @@ import Control.Monad.Error.Class (throwError) import Data.Aeson +import qualified Data.ByteString.Lazy as LazyByteString import Data.Char (chr, isPrint) import Data.Monoid () import Data.Proxy +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Text.Encoding (encodeUtf8, decodeUtf8) import GHC.Generics (Generic) import qualified Network.HTTP.Client as C @@ -47,8 +52,11 @@ ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData (..), Capture, CaptureAll, DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header, - Headers, JSON, NoContent (NoContent), Post, QueryFlag, - QueryParam, QueryParams, Raw, ReqBody, addHeader) + Headers, JSON, MimeRender(mimeRender), + MimeUnrender(mimeUnrender), NoContent (NoContent), PlainText, + Post, QueryFlag, QueryParam, QueryParams, Raw, ReqBody, + StdMethod(GET), Union, UVerb, WithStatus(WithStatus), + addHeader) import Servant.Client import qualified Servant.Client.Core.Auth as Auth import Servant.Server @@ -63,7 +71,7 @@ data Person = Person { _name :: String , _age :: Integer - } deriving (Eq, Show, Generic) + } deriving (Eq, Show, Read, Generic) instance ToJSON Person instance FromJSON Person @@ -74,6 +82,15 @@ instance Arbitrary Person where arbitrary = Person <$> arbitrary <*> arbitrary +instance MimeRender PlainText Person where + mimeRender _ = LazyByteString.fromStrict . encodeUtf8 . Text.pack . show + +instance MimeUnrender PlainText Person where + mimeUnrender _ = + -- This does not handle any errors, but it should be fine for tests + Right . read . Text.unpack . decodeUtf8 . LazyByteString.toStrict + + alice :: Person alice = Person "Alice" 42 @@ -105,7 +122,13 @@ :<|> "deleteContentType" :> DeleteNoContent :<|> "redirectWithCookie" :> Raw :<|> "empty" :> EmptyAPI + :<|> "uverb-success-or-redirect" :> + Capture "bool" Bool :> + UVerb 'GET '[PlainText] '[WithStatus 200 Person, + WithStatus 301 Text] + :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person] + api :: Proxy Api api = Proxy @@ -126,6 +149,10 @@ getRespHeaders :: ClientM (Headers TestHeaders Bool) getDeleteContentType :: ClientM NoContent getRedirectWithCookie :: HTTP.Method -> ClientM Response +uverbGetSuccessOrRedirect :: Bool + -> ClientM (Union '[WithStatus 200 Person, + WithStatus 301 Text]) +uverbGetCreated :: ClientM (Union '[WithStatus 201 Person]) getRoot :<|> getGet @@ -143,7 +170,9 @@ :<|> getRespHeaders :<|> getDeleteContentType :<|> getRedirectWithCookie - :<|> EmptyClient = client api + :<|> EmptyClient + :<|> uverbGetSuccessOrRedirect + :<|> uverbGetCreated = client api server :: Application server = serve api ( @@ -166,7 +195,12 @@ :<|> (return $ addHeader 1729 $ addHeader "eg2" True) :<|> return NoContent :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "") - :<|> emptyServer) + :<|> emptyServer + :<|> (\shouldRedirect -> if shouldRedirect + then respond (WithStatus @301 ("redirecting" :: Text)) + else respond (WithStatus @200 alice )) + :<|> respond (WithStatus @201 carol) + ) type FailApi = "get" :> Raw diff --git a/test/Servant/SuccessSpec.hs b/test/Servant/SuccessSpec.hs --- a/test/Servant/SuccessSpec.hs +++ b/test/Servant/SuccessSpec.hs @@ -8,6 +8,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -31,6 +32,8 @@ import Data.Maybe (listToMaybe) import Data.Monoid () +import Data.Text + (Text) import qualified Network.HTTP.Client as C import qualified Network.HTTP.Types as HTTP import Test.Hspec @@ -39,7 +42,7 @@ import Test.QuickCheck import Servant.API - (NoContent (NoContent), getHeaders) + (NoContent (NoContent), WithStatus(WithStatus), getHeaders) import Servant.Client import qualified Servant.Client.Core.Request as Req import Servant.Client.Internal.HttpClient (defaultMakeClientRequest) @@ -151,3 +154,23 @@ result <- left show <$> runClient (getMultiple cap num flag body) baseUrl return $ result === Right (cap, num, flag, body) + + context "With a route that can either return success or redirect" $ do + it "Redirects when appropriate" $ \(_, baseUrl) -> do + eitherResponse <- runClient (uverbGetSuccessOrRedirect True) baseUrl + case eitherResponse of + Left clientError -> fail $ show clientError + Right response -> matchUnion response `shouldBe` Just (WithStatus @301 @Text "redirecting") + + it "Returns a proper response when appropriate" $ \(_, baseUrl) -> do + eitherResponse <- runClient (uverbGetSuccessOrRedirect False) baseUrl + case eitherResponse of + Left clientError -> fail $ show clientError + Right response -> matchUnion response `shouldBe` Just (WithStatus @200 alice) + + context "with a route that uses uverb but only has a single response" $ + it "returns the expected response" $ \(_, baseUrl) -> do + eitherResponse <- runClient (uverbGetCreated) baseUrl + case eitherResponse of + Left clientError -> fail $ show clientError + Right response -> matchUnion response `shouldBe` Just (WithStatus @201 carol)