diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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.16 +---- + +- Rename `ServantError` to `ClientError`, `ServantErr` to `ServerError` + [#1131](https://github.com/haskell-servant/servant/pull/1131) + +- *servant-client-core* Rearrange modules. No more `Internal` modules, whole + API is versioned. + [#1130](https://github.com/haskell-servant/servant/pull/1130) + +- *servant-client-core* `RequestBody` is now + + ```haskell + = RequestBodyLBS LBS.ByteString + | RequestBodyBS BS.ByteString + | RequestBodySource (SourceIO LBS.ByteString) + ``` + + i.e. no more replicates `http-client`s API. + [#1117](https://github.com/haskell-servant/servant/pull/1117) + +- *servant-client-core* Keep structured exceptions in `ConnectionError` + constructor of `ClientError` + [#1115](https://github.com/haskell-servant/servant/pull/1115) + + ```diff + -| ConnectionError Text + +| ConnectionError SomeException + ``` + +- *servant-client-core* Preserve failing request in `FailureResponse` + constructor of `ClientError` + [#1114](https://github.com/haskell-servant/servant/pull/1114) + + ```diff + -FailureResponse Response + +-- | The server returned an error response including the + +-- failing request. 'requestPath' includes the 'BaseUrl' and the + +-- path of the request. + +FailureResponse (RequestF () (BaseUrl, BS.ByteString)) Response + ``` + +- *servant-client* Fix (implement) `StreamBody` instance + [#1110](https://github.com/haskell-servant/servant/pull/1110) + +- *servant-client* Update CookieJar with intermediate request/responses (redirects) + [#1104](https://github.com/haskell-servant/servant/pull/1104) + 0.15 ---- 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.15 +version: 0.16 synopsis: Automatic derivation of querying functions for servant category: Servant, Web @@ -18,13 +18,13 @@ license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com -copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors +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.2 + || ==8.6.3 extra-source-files: CHANGELOG.md @@ -54,17 +54,21 @@ , time >= 1.6.0.1 && < 1.9 , transformers >= 0.5.2.0 && < 0.6 + if !impl(ghc >= 8.2) + build-depends: + bifunctors >= 5.5.3 && < 5.6 + -- Servant dependencies. -- Strict dependency on `servant-client-core` as we re-export things. build-depends: - servant == 0.15.* - , servant-client-core >= 0.15 && <0.15.1 + servant == 0.16.* + , servant-client-core >= 0.16 && <0.16.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. build-depends: base-compat >= 0.10.5 && < 0.11 - , http-client >= 0.5.13.1 && < 0.6 + , http-client >= 0.5.13.1 && < 0.7 , http-media >= 0.7.1.3 && < 0.8 , http-types >= 0.12.2 && < 0.13 , exceptions >= 0.10.0 && < 0.11 @@ -101,6 +105,7 @@ , kan-extensions , servant-client , servant-client-core + , stm , text , transformers , transformers-compat @@ -110,17 +115,16 @@ -- Additonal dependencies build-depends: entropy >= 0.4.1.3 && < 0.5 - , generics-sop >= 0.4.0.1 && < 0.5 - , hspec >= 2.6.0 && < 2.7 + , hspec >= 2.6.0 && < 2.8 , HUnit >= 1.6.0.0 && < 1.7 - , network >= 2.8.0.0 && < 2.9 + , network >= 2.8.0.0 && < 3.1 , QuickCheck >= 2.12.6.1 && < 2.13 - , servant == 0.15.* - , servant-server == 0.15.* + , servant == 0.16.* + , servant-server == 0.16.* , tdigest >= 0.2 && < 0.3 build-tool-depends: - hspec-discover:hspec-discover >= 2.6.0 && < 2.7 + hspec-discover:hspec-discover >= 2.6.0 && < 2.8 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 @@ -14,6 +14,9 @@ import Prelude () import Prelude.Compat +import Control.Concurrent.MVar + (modifyMVar, newMVar) +import qualified Data.ByteString as BS import Control.Concurrent.STM.TVar import Control.Exception import Control.Monad @@ -23,21 +26,27 @@ (MonadCatch, MonadThrow) import Control.Monad.Error.Class (MonadError (..)) +import Control.Monad.IO.Class + (liftIO) import Control.Monad.Reader import Control.Monad.STM - (atomically) + (STM, atomically) import Control.Monad.Trans.Control (MonadBaseControl (..)) import Control.Monad.Trans.Except +import Data.Bifunctor + (bimap) import Data.ByteString.Builder (toLazyByteString) import qualified Data.ByteString.Lazy as BSL +import Data.Either + (either) import Data.Foldable - (for_, toList) + (toList) import Data.Functor.Alt (Alt (..)) import Data.Maybe - (maybeToList) + (maybe, maybeToList) import Data.Proxy (Proxy (..)) import Data.Semigroup @@ -46,9 +55,8 @@ (fromList) import Data.String (fromString) -import qualified Data.Text as T import Data.Time.Clock - (getCurrentTime) + (UTCTime, getCurrentTime) import GHC.Generics import Network.HTTP.Media (renderHeader) @@ -56,6 +64,7 @@ (hContentType, renderQuery, statusCode) import Servant.Client.Core +import qualified Servant.Types.SourceT as S import qualified Network.HTTP.Client as Client -- | The environment in which a request is run. @@ -111,16 +120,16 @@ -- | @ClientM@ is the monad in which client functions run. Contains the -- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment. newtype ClientM a = ClientM - { unClientM :: ReaderT ClientEnv (ExceptT ServantError IO) a } + { unClientM :: ReaderT ClientEnv (ExceptT ClientError IO) a } deriving ( Functor, Applicative, Monad, MonadIO, Generic - , MonadReader ClientEnv, MonadError ServantError, MonadThrow + , MonadReader ClientEnv, MonadError ClientError, MonadThrow , MonadCatch) instance MonadBase IO ClientM where liftBase = ClientM . liftBase instance MonadBaseControl IO ClientM where - type StM ClientM a = Either ServantError a + type StM ClientM a = Either ClientError a liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . unClientM))) @@ -132,12 +141,9 @@ instance RunClient ClientM where runRequest = performRequest - throwServantError = throwError - -instance ClientLike (ClientM a) (ClientM a) where - mkClient = id + throwClientError = throwError -runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a) +runClientM :: ClientM a -> ClientEnv -> IO (Either ClientError a) runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm performRequest :: Request -> ClientM Response @@ -158,42 +164,67 @@ writeTVar cj newCookieJar pure newRequest - eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m - case eResponse of - Left err -> throwError err - Right response -> do - for_ cookieJar' $ \cj -> liftIO $ do - now' <- getCurrentTime - atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now') - let status = Client.responseStatus response - status_code = statusCode status - ourResponse = clientResponseToResponse response - unless (status_code >= 200 && status_code < 300) $ - throwError $ FailureResponse ourResponse - return ourResponse + response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar' + 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 + return ourResponse + where + requestWithoutCookieJar :: Client.Manager -> Client.Request -> ClientM (Client.Response BSL.ByteString) + requestWithoutCookieJar m' request' = do + eResponse <- liftIO . catchConnectionError $ Client.httpLbs request' m' + either throwError return eResponse -clientResponseToResponse :: Client.Response a -> GenResponse a -clientResponseToResponse r = Response - { responseStatusCode = Client.responseStatus r - , responseBody = Client.responseBody r - , responseHeaders = fromList $ Client.responseHeaders r - , responseHttpVersion = Client.responseVersion r - } + requestWithCookieJar :: Client.Manager -> Client.Request -> TVar Client.CookieJar -> ClientM (Client.Response BSL.ByteString) + requestWithCookieJar m' request' cj = do + eResponse <- liftIO . catchConnectionError . Client.withResponseHistory request' m' $ updateWithResponseCookies cj + either throwError return eResponse + updateWithResponseCookies :: TVar Client.CookieJar -> Client.HistoriedResponse Client.BodyReader -> IO (Client.Response BSL.ByteString) + updateWithResponseCookies cj responses = do + now <- getCurrentTime + bss <- Client.brConsume $ Client.responseBody fRes + let fRes' = fRes { Client.responseBody = BSL.fromChunks bss } + allResponses = Client.hrRedirects responses <> [(fReq, fRes')] + atomically $ mapM_ (updateCookieJar now) allResponses + return fRes' + where + updateCookieJar :: UTCTime -> (Client.Request, Client.Response BSL.ByteString) -> STM () + updateCookieJar now' (req', res') = modifyTVar' cj (fst . Client.updateCookieJar res' req' now') + + fReq = Client.hrFinalRequest responses + fRes = Client.hrFinalResponse responses + +mkFailureResponse :: BaseUrl -> Request -> ResponseF BSL.ByteString -> ClientError +mkFailureResponse burl request = + FailureResponse (bimap (const ()) f request) + where + f b = (burl, BSL.toStrict $ toLazyByteString b) + +clientResponseToResponse :: (a -> b) -> Client.Response a -> ResponseF b +clientResponseToResponse f r = Response + { responseStatusCode = Client.responseStatus r + , responseBody = f (Client.responseBody r) + , responseHeaders = fromList $ Client.responseHeaders r + , responseHttpVersion = Client.responseVersion r + } + requestToClientRequest :: BaseUrl -> Request -> Client.Request requestToClientRequest burl r = Client.defaultRequest - { Client.method = requestMethod r - , Client.host = fromString $ baseUrlHost burl - , Client.port = baseUrlPort burl - , Client.path = BSL.toStrict - $ fromString (baseUrlPath burl) - <> toLazyByteString (requestPath r) - , Client.queryString = renderQuery True . toList $ requestQueryString r - , Client.requestHeaders = - maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers - , Client.requestBody = body - , Client.secure = isSecure - } + { Client.method = requestMethod r + , Client.host = fromString $ baseUrlHost burl + , Client.port = baseUrlPort burl + , Client.path = BSL.toStrict + $ fromString (baseUrlPath burl) + <> toLazyByteString (requestPath r) + , Client.queryString = renderQuery True . toList $ requestQueryString r + , Client.requestHeaders = + maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers + , Client.requestBody = body + , Client.secure = isSecure + } where -- Content-Type and Accept are specified by requestBody and requestAccept headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $ @@ -206,23 +237,40 @@ hs = toList $ requestAccept r convertBody bd = case bd of - RequestBodyLBS body' -> Client.RequestBodyLBS body' - RequestBodyBS body' -> Client.RequestBodyBS body' - RequestBodyBuilder size body' -> Client.RequestBodyBuilder size body' - RequestBodyStream size body' -> Client.RequestBodyStream size body' - RequestBodyStreamChunked body' -> Client.RequestBodyStreamChunked body' - RequestBodyIO body' -> Client.RequestBodyIO (convertBody <$> body') + RequestBodyLBS body' -> Client.RequestBodyLBS body' + RequestBodyBS body' -> Client.RequestBodyBS body' + RequestBodySource sourceIO -> Client.RequestBodyStreamChunked givesPopper + where + givesPopper :: (IO BS.ByteString -> IO ()) -> IO () + givesPopper needsPopper = S.unSourceT sourceIO $ \step0 -> do + ref <- newMVar step0 + -- Note sure we need locking, but it's feels safer. + let popper :: IO BS.ByteString + popper = modifyMVar ref nextBs + + needsPopper popper + + nextBs S.Stop = return (S.Stop, BS.empty) + nextBs (S.Error err) = fail err + nextBs (S.Skip s) = nextBs s + nextBs (S.Effect ms) = ms >>= nextBs + nextBs (S.Yield lbs s) = case BSL.toChunks lbs of + [] -> nextBs s + (x:xs) | BS.null x -> nextBs step' + | otherwise -> return (step', x) + where + step' = S.Yield (BSL.fromChunks xs) s + (body, contentTypeHdr) = case requestBody r of - Nothing -> (Client.RequestBodyLBS "", Nothing) - Just (body', typ) - -> (convertBody body', Just (hContentType, renderHeader typ)) + Nothing -> (Client.RequestBodyBS "", Nothing) + Just (body', typ) -> (convertBody body', Just (hContentType, renderHeader typ)) isSecure = case baseUrlScheme burl of - Http -> False - Https -> True + Http -> False + Https -> True -catchConnectionError :: IO a -> IO (Either ServantError a) +catchConnectionError :: IO a -> IO (Either ClientError a) catchConnectionError action = catch (Right <$> action) $ \e -> - pure . Left . ConnectionError . T.pack $ show (e :: Client.HttpException) + pure . Left . ConnectionError $ SomeException (e :: Client.HttpException) 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 @@ -35,6 +35,7 @@ import Control.Monad.STM (atomically) import Control.Monad.Trans.Except +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import Data.Foldable (for_) @@ -53,7 +54,9 @@ import Servant.Client.Core import Servant.Client.Internal.HttpClient (ClientEnv (..), catchConnectionError, - clientResponseToResponse, mkClientEnv, requestToClientRequest) + clientResponseToResponse, mkClientEnv, mkFailureResponse, + requestToClientRequest) +import qualified Servant.Types.SourceT as S -- | Generates a set of client functions for an API. @@ -97,9 +100,9 @@ -- | @ClientM@ is the monad in which client functions run. Contains the -- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment. newtype ClientM a = ClientM - { unClientM :: ReaderT ClientEnv (ExceptT ServantError (Codensity IO)) a } + { unClientM :: ReaderT ClientEnv (ExceptT ClientError (Codensity IO)) a } deriving ( Functor, Applicative, Monad, MonadIO, Generic - , MonadReader ClientEnv, MonadError ServantError) + , MonadReader ClientEnv, MonadError ClientError) instance MonadBase IO ClientM where liftBase = ClientM . liftIO @@ -110,15 +113,12 @@ instance RunClient ClientM where runRequest = performRequest - throwServantError = throwError + throwClientError = throwError instance RunStreamingClient ClientM where withStreamingRequest = performWithStreamingRequest -instance ClientLike (ClientM a) (ClientM a) where - mkClient = id - -withClientM :: ClientM a -> ClientEnv -> (Either ServantError a -> IO b) -> IO b +withClientM :: ClientM a -> ClientEnv -> (Either ClientError a -> IO b) -> IO b withClientM cm env k = let Codensity f = runExceptT $ flip runReaderT env $ unClientM cm in f k @@ -133,7 +133,7 @@ -- /Note:/ we 'force' the result, so the likehood of accidentally leaking a -- connection is smaller. Use with care. -- -runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ServantError a) +runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ClientError a) runClientM cm env = withClientM cm env (evaluate . force) performRequest :: Request -> ClientM Response @@ -164,9 +164,9 @@ atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now') let status = Client.responseStatus response status_code = statusCode status - ourResponse = clientResponseToResponse response + ourResponse = clientResponseToResponse id response unless (status_code >= 200 && status_code < 300) $ - throwError $ FailureResponse ourResponse + throwError $ mkFailureResponse burl req ourResponse return ourResponse performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a @@ -182,7 +182,7 @@ -- we throw FailureResponse in IO :( unless (status_code >= 200 && status_code < 300) $ do b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res) - throwIO $ FailureResponse $ clientResponseToResponse res { Client.responseBody = b } + throwIO $ mkFailureResponse burl req (clientResponseToResponse (const b) res) - x <- k (clientResponseToResponse res) + x <- k (clientResponseToResponse (S.fromAction BS.null) res) k1 x diff --git a/test/Servant/ClientSpec.hs b/test/Servant/ClientSpec.hs --- a/test/Servant/ClientSpec.hs +++ b/test/Servant/ClientSpec.hs @@ -12,6 +12,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -28,26 +29,31 @@ (left) import Control.Concurrent (ThreadId, forkIO, killThread) +import Control.Concurrent.STM + (atomically) +import Control.Concurrent.STM.TVar + (newTVar, readTVar) import Control.Exception - (bracket) + (bracket, fromException) import Control.Monad.Error.Class (throwError) import Data.Aeson import Data.Char (chr, isPrint) import Data.Foldable - (forM_) + (forM_, toList) +import Data.Maybe + (isJust, listToMaybe) import Data.Monoid () import Data.Proxy import Data.Semigroup ((<>)) -import qualified Generics.SOP as SOP import GHC.Generics (Generic) -import qualified Network.HTTP.Client as C -import qualified Network.HTTP.Types as HTTP +import qualified Network.HTTP.Client as C +import qualified Network.HTTP.Types as HTTP import Network.Socket -import qualified Network.Wai as Wai +import qualified Network.Wai as Wai import Network.Wai.Handler.Warp import System.IO.Unsafe (unsafePerformIO) @@ -64,12 +70,12 @@ DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header, Headers, JSON, NoContent (NoContent), Post, Put, QueryFlag, QueryParam, QueryParams, Raw, ReqBody, addHeader, getHeaders) -import Servant.Test.ComprehensiveAPI import Servant.Client -import qualified Servant.Client.Core.Internal.Auth as Auth -import qualified Servant.Client.Core.Internal.Request as Req +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 @@ -81,8 +87,8 @@ wrappedApiSpec basicAuthSpec genAuthSpec - genericClientSpec hoistClientSpec + connectionErrorSpec -- * test data types @@ -128,6 +134,7 @@ 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 @@ -148,6 +155,7 @@ -> ClientM (String, Maybe Int, Bool, [(String, [Rational])]) getRespHeaders :: ClientM (Headers TestHeaders Bool) getDeleteContentType :: ClientM NoContent +getRedirectWithCookie :: HTTP.Method -> ClientM Response getRoot :<|> getGet @@ -163,6 +171,7 @@ :<|> getMultiple :<|> getRespHeaders :<|> getDeleteContentType + :<|> getRedirectWithCookie :<|> EmptyClient = client api server :: Application @@ -175,8 +184,8 @@ :<|> return :<|> (\ name -> case name of Just "alice" -> return alice - Just n -> throwError $ ServantErr 400 (n ++ " not found") "" [] - Nothing -> throwError $ ServantErr 400 "missing parameter" "" []) + 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") @@ -184,9 +193,9 @@ :<|> (\ 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 @@ -247,58 +256,11 @@ genAuthServer :: Application genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice)) --- * generic client stuff - -type GenericClientAPI - = QueryParam "sqr" Int :> Get '[JSON] Int - :<|> Capture "foo" String :> NestedAPI1 - -data GenericClient = GenericClient - { getSqr :: Maybe Int -> ClientM Int - , mkNestedClient1 :: String -> NestedClient1 - } deriving Generic -instance SOP.Generic GenericClient -instance (Client ClientM GenericClientAPI ~ client) => ClientLike client GenericClient - -type NestedAPI1 - = QueryParam "int" Int :> NestedAPI2 - :<|> QueryParam "id" Char :> Get '[JSON] Char - -data NestedClient1 = NestedClient1 - { mkNestedClient2 :: Maybe Int -> NestedClient2 - , idChar :: Maybe Char -> ClientM Char - } deriving Generic -instance SOP.Generic NestedClient1 -instance (Client ClientM NestedAPI1 ~ client) => ClientLike client NestedClient1 - -type NestedAPI2 - = "sum" :> Capture "first" Int :> Capture "second" Int :> Get '[JSON] Int - :<|> "void" :> Post '[JSON] () - -data NestedClient2 = NestedClient2 - { getSum :: Int -> Int -> ClientM Int - , doNothing :: ClientM () - } deriving Generic -instance SOP.Generic NestedClient2 -instance (Client ClientM NestedAPI2 ~ client) => ClientLike client NestedClient2 - -genericClientServer :: Application -genericClientServer = serve (Proxy :: Proxy GenericClientAPI) ( - (\ mx -> case mx of - Just x -> return (x*x) - Nothing -> throwError $ ServantErr 400 "missing parameter" "" [] - ) - :<|> nestedServer1 - ) - where - nestedServer1 _str = nestedServer2 :<|> (maybe (throwError $ ServantErr 400 "missing parameter" "" []) return) - nestedServer2 _int = (\ x y -> return (x + y)) :<|> return () - {-# NOINLINE manager' #-} manager' :: C.Manager manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings -runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a) +runClient :: ClientM a -> BaseUrl -> IO (Either ClientError a) runClient x baseUrl' = runClientM x (mkClientEnv manager' baseUrl') sucessSpec :: Spec @@ -327,9 +289,16 @@ 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 + Left (FailureResponse _ r) <- runClient (getQueryParam (Just "bob")) baseUrl responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found" it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do @@ -353,7 +322,7 @@ res <- runClient (getRawFailure HTTP.methodGet) baseUrl case res of Right _ -> assertFailure "expected Left, but got Right" - Left (FailureResponse r) -> do + Left (FailureResponse _ r) -> do responseStatusCode r `shouldBe` HTTP.status400 responseBody r `shouldBe` "rawFailure" Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e @@ -364,6 +333,14 @@ 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 -> @@ -375,14 +352,14 @@ wrappedApiSpec :: Spec wrappedApiSpec = describe "error status codes" $ do - let serveW api = serve api $ throwError $ ServantErr 500 "error message" "" [] + 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 + Left (FailureResponse _ r) <- runClient getResponse baseUrl responseStatusCode r `shouldBe` (HTTP.Status 500 "error message") in mapM_ test $ (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") : @@ -399,7 +376,7 @@ let (_ :<|> _ :<|> getDeleteEmpty :<|> _) = client api Left res <- runClient getDeleteEmpty baseUrl case res of - FailureResponse r | responseStatusCode r == HTTP.status404 -> return () + FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return () _ -> fail $ "expected 404 response, but got " <> show res it "reports DecodeFailure" $ \(_, baseUrl) -> do @@ -449,7 +426,7 @@ 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 + Left (FailureResponse _ r) <- runClient (getBasic basicAuthData) baseUrl responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden" genAuthSpec :: Spec @@ -466,25 +443,9 @@ 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 + Left (FailureResponse _ r) <- runClient (getProtected authRequest) baseUrl responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized") -genericClientSpec :: Spec -genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWaiApp $ do - describe "Servant.Client.Generic" $ do - - let GenericClient{..} = mkClient (client (Proxy :: Proxy GenericClientAPI)) - NestedClient1{..} = mkNestedClient1 "example" - NestedClient2{..} = mkNestedClient2 (Just 42) - - it "works for top-level client inClientM function" $ \(_, baseUrl) -> do - left show <$> runClient (getSqr (Just 5)) baseUrl `shouldReturn` Right 25 - - it "works for nested clients" $ \(_, baseUrl) -> do - left show <$> runClient (idChar (Just 'c')) baseUrl `shouldReturn` Right 'c' - left show <$> runClient (getSum 3 4) baseUrl `shouldReturn` Right 7 - left show <$> runClient doNothing baseUrl `shouldReturn` Right () - -- * hoistClient type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int @@ -507,6 +468,21 @@ 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) @@ -523,8 +499,8 @@ openTestSocket :: IO (Port, Socket) openTestSocket = do s <- socket AF_INET Stream defaultProtocol - localhost <- inet_addr "127.0.0.1" - bind s (SockAddrInet aNY_PORT localhost) + let localhost = tupleToHostAddress (127, 0, 0, 1) + bind s (SockAddrInet defaultPort localhost) listen s 1 port <- socketPort s return (fromIntegral port, s) diff --git a/test/Servant/StreamSpec.hs b/test/Servant/StreamSpec.hs --- a/test/Servant/StreamSpec.hs +++ b/test/Servant/StreamSpec.hs @@ -35,8 +35,9 @@ import Prelude () import Prelude.Compat import Servant.API - ((:<|>) ((:<|>)), (:>), JSON, NetstringFraming, - NewlineFraming, NoFraming, OctetStream, SourceIO, StreamGet) + ((:<|>) ((:<|>)), (:>), JSON, NetstringFraming, StreamBody, + NewlineFraming, NoFraming, OctetStream, SourceIO, StreamGet, + ) import Servant.Client.Streaming import Servant.ClientSpec (Person (..)) @@ -72,13 +73,15 @@ "streamGetNewline" :> StreamGet NewlineFraming JSON (SourceIO Person) :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (SourceIO Person) :<|> "streamALot" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString) + :<|> "streamBody" :> StreamBody NoFraming OctetStream (SourceIO BS.ByteString) :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString) api :: Proxy StreamApi api = Proxy getGetNL, getGetNS :: ClientM (SourceIO Person) getGetALot :: ClientM (SourceIO BS.ByteString) -getGetNL :<|> getGetNS :<|> getGetALot = client api +getStreamBody :: SourceT IO BS.ByteString -> ClientM (SourceIO BS.ByteString) +getGetNL :<|> getGetNS :<|> getGetALot :<|> getStreamBody = client api alice :: Person alice = Person "Alice" 42 @@ -90,9 +93,9 @@ server = serve api $ return (source [alice, bob, alice]) :<|> return (source [alice, bob, alice]) - -- 2 ^ (18 + 10) = 256M :<|> return (SourceT ($ lots (powerOfTwo 18))) + :<|> return where lots n | n < 0 = Stop @@ -109,7 +112,7 @@ manager' :: C.Manager manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings -withClient :: ClientM a -> BaseUrl -> (Either ServantError a -> IO r) -> IO r +withClient :: ClientM a -> BaseUrl -> (Either ClientError a -> IO r) -> IO r withClient x baseUrl' = withClientM x (mkClientEnv manager' baseUrl') testRunSourceIO :: SourceIO a @@ -125,6 +128,13 @@ it "works with Servant.API.StreamGet.Netstring" $ \(_, baseUrl) -> do withClient getGetNS baseUrl $ \(Right res) -> testRunSourceIO res `shouldReturn` Right [alice, bob, alice] + + it "works with Servant.API.StreamBody" $ \(_, baseUrl) -> do + withClient (getStreamBody (source input)) baseUrl $ \(Right res) -> + testRunSourceIO res `shouldReturn` Right output + where + input = ["foo", "", "bar"] + output = ["foo", "bar"] {- it "streams in constant memory" $ \(_, baseUrl) -> do