servant-client 0.15 → 0.16
raw patch · 6 files changed
+260/−174 lines, 6 filesdep +bifunctorsdep −generics-sopdep ~QuickCheckdep ~basedep ~hspec
Dependencies added: bifunctors
Dependencies removed: generics-sop
Dependency ranges changed: QuickCheck, base, hspec, http-media, network, servant, servant-client-core, servant-server, stm, time
Files
- CHANGELOG.md +48/−0
- servant-client.cabal +16/−12
- src/Servant/Client/Internal/HttpClient.hs +106/−58
- src/Servant/Client/Internal/HttpClient/Streaming.hs +13/−13
- test/Servant/ClientSpec.hs +62/−86
- test/Servant/StreamSpec.hs +15/−5
CHANGELOG.md view
@@ -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 ----
servant-client.cabal view
@@ -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
src/Servant/Client/Internal/HttpClient.hs view
@@ -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)
src/Servant/Client/Internal/HttpClient/Streaming.hs view
@@ -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
test/Servant/ClientSpec.hs view
@@ -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)
test/Servant/StreamSpec.hs view
@@ -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