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.13 +---- + +- Streaming endpoint support. + ([#836](https://github.com/haskell-servant/servant/pull/836)) +- *servant* Add `Servant.API.Modifiers` + ([#873](https://github.com/haskell-servant/servant/pull/873)) +- *servant-client* Support `http-client`’s `CookieJar` + ([#897](https://github.com/haskell-servant/servant/pull/897) + [#883](https://github.com/haskell-servant/servant/pull/883)) + 0.12.0.1 -------- diff --git a/servant-client.cabal b/servant-client.cabal --- a/servant-client.cabal +++ b/servant-client.cabal @@ -1,5 +1,5 @@ name: servant-client -version: 0.12.0.1 +version: 0.13 synopsis: automatical derivation of querying functions for servant webservices description: This library lets you derive automatically Haskell functions that @@ -20,7 +20,7 @@ GHC==7.8.4 GHC==7.10.3 GHC==8.0.2 - GHC==8.2.1 + GHC==8.2.2 homepage: http://haskell-servant.readthedocs.org/ Bug-reports: http://github.com/haskell-servant/servant/issues extra-source-files: @@ -35,26 +35,44 @@ exposed-modules: Servant.Client Servant.Client.Internal.HttpClient + + -- Bundled with GHC: Lower bound to not force re-installs + -- text and mtl are bundled starting with GHC-8.4 + -- + -- note: mtl lower bound is so low because of GHC-7.8 build-depends: base >= 4.7 && < 4.11 - , base-compat >= 0.9.1 && < 0.10 - , bytestring >= 0.10 && < 0.11 - , aeson >= 0.7 && < 1.3 - , attoparsec >= 0.12 && < 0.14 - , containers >= 0.5 && < 0.6 - , http-client >= 0.4.30 && < 0.6 - , http-client-tls >= 0.2.2 && < 0.4 - , http-media >= 0.6.2 && < 0.8 - , http-types >= 0.8.6 && < 0.11 - , exceptions >= 0.8 && < 0.9 - , monad-control >= 1.0.0.4 && < 1.1 + , bytestring >= 0.10.4.0 && < 0.11 + , containers >= 0.5.5.1 && < 0.6 , mtl >= 2.1 && < 2.3 - , semigroupoids >= 4.3 && < 5.3 - , servant-client-core == 0.12.* - , text >= 1.2 && < 1.3 - , transformers >= 0.3 && < 0.6 + , text >= 1.2.3.0 && < 1.3 + , time >= 1.4.2 && < 1.9 + , transformers >= 0.3.0.0 && < 0.6 + + if !impl(ghc >= 8.0) + build-depends: semigroups >=0.18.3 && <0.19 + + -- Servant dependencies + build-depends: + servant-client-core == 0.13.* + + -- 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: + aeson >= 1.2.3.0 && < 1.3 + , base-compat >= 0.9.3 && < 0.10 + , attoparsec >= 0.13.2.0 && < 0.14 + , http-client >= 0.5.7.1 && < 0.6 + , http-client-tls >= 0.3.5.1 && < 0.4 + , http-media >= 0.7.1.1 && < 0.8 + , http-types >= 0.12 && < 0.13 + , exceptions >= 0.8.3 && < 0.9 + , monad-control >= 1.0.0.4 && < 1.1 + , semigroupoids >= 5.2.1 && < 5.3 + , stm >= 2.4.4.1 && < 2.5 , transformers-base >= 0.4.4 && < 0.5 - , transformers-compat >= 0.4 && < 0.6 + , transformers-compat >= 0.5.1 && < 0.6 + hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall @@ -68,33 +86,40 @@ default-language: Haskell2010 hs-source-dirs: test main-is: Spec.hs - build-tool-depends: - hspec-discover:hspec-discover other-modules: Servant.ClientSpec + Servant.StreamSpec + + -- Dependencies inherited from the library. No need to specify bounds. build-depends: - base == 4.* + base , aeson , base-compat , bytestring , containers - , deepseq - , hspec == 2.* , http-api-data , http-client , http-media , http-types - , HUnit , mtl - , network >= 2.6 - , QuickCheck >= 2.7 - , servant , servant-client , servant-client-core - , servant-server == 0.12.* , text , transformers , transformers-compat , wai , warp - , generics-sop + + -- Additonal dependencies + build-depends: + deepseq >= 1.3.0.2 && < 1.5 + , generics-sop >= 0.3.1.0 && < 0.4 + , hspec >= 2.4.4 && < 2.5 + , HUnit >= 1.6 && < 1.7 + , network >= 2.6.3.2 && < 2.7 + , QuickCheck >= 2.10.1 && < 2.12 + , servant == 0.13.* + , servant-server == 0.13.* + + build-tool-depends: + hspec-discover:hspec-discover >= 2.4.4 && < 2.5 diff --git a/src/Servant/Client.hs b/src/Servant/Client.hs --- a/src/Servant/Client.hs +++ b/src/Servant/Client.hs @@ -1,3 +1,5 @@ + + -- | This module provides 'client' which can automatically generate -- querying functions for each endpoint just from the type representing your -- API. @@ -6,8 +8,9 @@ , ClientM , runClientM , ClientEnv(..) + , mkClientEnv , module Servant.Client.Core.Reexport ) where -import Servant.Client.Internal.HttpClient import Servant.Client.Core.Reexport +import Servant.Client.Internal.HttpClient 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 @@ -8,32 +8,32 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} - --- | @http-client@-based client requests executor module Servant.Client.Internal.HttpClient where - import Prelude () import Prelude.Compat +import Control.Concurrent.STM.TVar import Control.Exception import Control.Monad import Control.Monad.Base (MonadBase (..)) import Control.Monad.Catch (MonadCatch, MonadThrow) import Control.Monad.Error.Class (MonadError (..)) import Control.Monad.Reader +import Control.Monad.STM (atomically) import Control.Monad.Trans.Control (MonadBaseControl (..)) import Control.Monad.Trans.Except import Data.ByteString.Builder (toLazyByteString) import qualified Data.ByteString.Lazy as BSL -import Data.Foldable (toList) +import Data.Foldable (toList, for_) import Data.Functor.Alt (Alt (..)) import Data.Maybe (maybeToList) -import Data.Monoid ((<>)) +import Data.Semigroup ((<>)) import Data.Proxy (Proxy (..)) import Data.Sequence (fromList) import Data.String (fromString) import qualified Data.Text as T +import Data.Time.Clock (getCurrentTime) import GHC.Generics import Network.HTTP.Media (renderHeader) import Network.HTTP.Types (hContentType, renderQuery, @@ -47,8 +47,13 @@ = ClientEnv { manager :: Client.Manager , baseUrl :: BaseUrl + , cookieJar :: Maybe (TVar Client.CookieJar) } +-- | 'ClientEnv' smart constructor. +mkClientEnv :: Client.Manager -> BaseUrl -> ClientEnv +mkClientEnv mgr burl = ClientEnv mgr burl Nothing + -- | Generates a set of client functions for an API. -- -- Example: @@ -68,7 +73,7 @@ -- | @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 - { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a } + { unClientM :: ReaderT ClientEnv (ExceptT ServantError IO) a } deriving ( Functor, Applicative, Monad, MonadIO, Generic , MonadReader ClientEnv, MonadError ServantError, MonadThrow , MonadCatch) @@ -79,7 +84,7 @@ instance MonadBaseControl IO ClientM where type StM ClientM a = Either ServantError a - liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . runClientM'))) + liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . unClientM))) restoreM st = ClientM (restoreM st) @@ -89,6 +94,7 @@ instance RunClient ClientM where runRequest = performRequest + streamingRequest = performStreamingRequest throwServantError = throwError catchServantError = catchError @@ -96,28 +102,57 @@ mkClient = id runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a) -runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm - +runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm performRequest :: Request -> ClientM Response performRequest req = do - m <- asks manager - burl <- asks baseUrl - let request = requestToClientRequest burl req + ClientEnv m burl cookieJar' <- ask + let clientRequest = requestToClientRequest 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 + (requestToClientRequest burl req) + oldCookieJar + now + writeTVar cj newCookieJar + pure newRequest eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m case eResponse of - Left err -> throwError $ err + 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 = clientResponseToReponse response + ourResponse = clientResponseToResponse response unless (status_code >= 200 && status_code < 300) $ throwError $ FailureResponse ourResponse return ourResponse -clientResponseToReponse :: Client.Response BSL.ByteString -> Response -clientResponseToReponse r = Response +performStreamingRequest :: Request -> ClientM StreamingResponse +performStreamingRequest req = do + m <- asks manager + burl <- asks baseUrl + let request = requestToClientRequest burl req + return $ StreamingResponse $ + \k -> Client.withResponse request m $ + \r -> do + let status = Client.responseStatus r + status_code = statusCode status + unless (status_code >= 200 && status_code < 300) $ do + b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody r) + throw $ FailureResponse $ clientResponseToResponse r { Client.responseBody = b } + k (clientResponseToResponse r) + +clientResponseToResponse :: Client.Response a -> GenResponse a +clientResponseToResponse r = Response { responseStatusCode = Client.responseStatus r , responseBody = Client.responseBody r , responseHeaders = fromList $ Client.responseHeaders r diff --git a/test/Servant/ClientSpec.hs b/test/Servant/ClientSpec.hs --- a/test/Servant/ClientSpec.hs +++ b/test/Servant/ClientSpec.hs @@ -24,7 +24,7 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} #include "overlapping-compat.h" -module Servant.ClientSpec (spec) where +module Servant.ClientSpec (spec, Person(..), startWaiApp, endWaiApp) where import Prelude () import Prelude.Compat @@ -302,7 +302,7 @@ manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a) -runClient x baseUrl' = runClientM x (ClientEnv manager' baseUrl') +runClient x baseUrl' = runClientM x (mkClientEnv manager' baseUrl') sucessSpec :: Spec sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do diff --git a/test/Servant/StreamSpec.hs b/test/Servant/StreamSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/StreamSpec.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -freduction-depth=100 #-} +#else +{-# OPTIONS_GHC -fcontext-stack=100 #-} +#endif +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +#include "overlapping-compat.h" +module Servant.StreamSpec (spec) where + +import Prelude () +import Prelude.Compat +import Data.Proxy +import qualified Network.HTTP.Client as C +import System.IO.Unsafe (unsafePerformIO) +import Test.Hspec + +import Servant.API ((:<|>) ((:<|>)), + (:>), + EmptyAPI, JSON, + StreamGet, + NewlineFraming, + NetstringFraming, + ResultStream(..), + StreamGenerator(..)) +import Servant.Client +import Servant.Server +import qualified Servant.ClientSpec as CS +import Servant.ClientSpec (Person(..)) + + +spec :: Spec +spec = describe "Servant.Stream" $ do + streamSpec + +type StreamApi f = + "streamGetNewline" :> StreamGet NewlineFraming JSON (f Person) + :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (f Person) + :<|> EmptyAPI + + +capi :: Proxy (StreamApi ResultStream) +capi = Proxy + +sapi :: Proxy (StreamApi StreamGenerator) +sapi = Proxy + + +getGetNL :<|> getGetNS :<|> EmptyClient = client capi + + +getGetNL :: ClientM (ResultStream Person) +getGetNS :: ClientM (ResultStream Person) + +alice :: Person +alice = Person "Alice" 42 + +bob :: Person +bob = Person "Bob" 25 + +server :: Application +server = serve sapi ( + (return (StreamGenerator (\f r -> f alice >> r bob >> r alice)) + :: Handler (StreamGenerator Person)) + :<|> + (return (StreamGenerator (\f r -> f alice >> r bob >> r alice)) + :: Handler (StreamGenerator Person)) + :<|> + emptyServer) + + +{-# NOINLINE manager' #-} +manager' :: C.Manager +manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings + +runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a) +runClient x baseUrl' = runClientM x (mkClientEnv manager' baseUrl') + +runResultStream :: ResultStream a -> IO (Maybe (Either String a), Maybe (Either String a), Maybe (Either String a), Maybe (Either String a)) +runResultStream (ResultStream k) = k $ \act -> (,,,) <$> act <*> act <*> act <*> act + +streamSpec :: Spec +streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do + + it "Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do + Right res <- runClient getGetNL baseUrl + let jra = Just (Right alice) + jrb = Just (Right bob) + runResultStream res `shouldReturn` (jra, jrb, jra, Nothing) + + it "Servant.API.StreamGet.Netstring" $ \(_, baseUrl) -> do + Right res <- runClient getGetNS baseUrl + let jra = Just (Right alice) + jrb = Just (Right bob) + runResultStream res `shouldReturn` (jra, jrb, jra, Nothing)