diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,72 @@ [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.15 +---- + +- Streaming refactoring. + [#991](https://github.com/haskell-servant/servant/pull/991) + [#1076](https://github.com/haskell-servant/servant/pull/1076) + [#1077](https://github.com/haskell-servant/servant/pull/1077) + + The streaming functionality (`Servant.API.Stream`) is refactored to use + `servant`'s own `SourceIO` type (see `Servant.Types.SourceT` documentation), + which replaces both `StreamGenerator` and `ResultStream` types. + + New conversion type-classes are `ToSourceIO` and `FromSourceIO` + (replacing `ToStreamGenerator` and `BuildFromStream`). + There are instances for *conduit*, *pipes* and *machines* in new packages: + [servant-conduit](https://hackage.haskell.org/package/servant-conduit) + [servant-pipes](https://hackage.haskell.org/package/servant-pipes) and + [servant-machines](https://hackage.haskell.org/package/servant-machines) + respectively. + + Writing new framing strategies is simpler. Check existing strategies for examples. + + This change shouldn't affect you, if you don't use streaming endpoints. + +- *servant-client* Separate streaming client. + [#1066](https://github.com/haskell-servant/servant/pull/1066) + + We now have two `http-client` based clients, + in `Servant.Client` and `Servant.Client.Streaming`. + + Their API is the same, except for + - `Servant.Client` **cannot** request `Stream` endpoints. + - `Servant.Client` is *run* by direct + `runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)` + - `Servant.Client.Streaming` **can** request `Stream` endpoints. + - `Servant.Client.Streaming` is *used* by CPSised + `withClientM :: ClientM a -> ClientEnv -> (Either ServantError a -> IO b) -> IO b` + + To access `Stream` endpoints use `Servant.Client.Streaming` with + `withClientM`; otherwise you can continue using `Servant.Client` with `runClientM`. + You can use both too, `ClientEnv` and `BaseUrl` types are same for both. + + **Note:** `Servant.Client.Streaming` doesn't *stream* non-`Stream` endpoints. + Requesting ordinary `Verb` endpoints (e.g. `Get`) will block until + the whole response is received. + + There is `Servant.Client.Streaming.runClientM` function, but it has + restricted type. `NFData a` constraint prevents using it with + `SourceT`, `Conduit` etc. response types. + + ```haskell + runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ServantError a) + ``` + + This change shouldn't affect you, if you don't use streaming endpoints. + +- Drop support for GHC older than 8.0 + [#1008](https://github.com/haskell-servant/servant/pull/1008) + [#1009](https://github.com/haskell-servant/servant/pull/1009) + +- *servant-client-core* Add `NFData (GenResponse a)` and `NFData ServantError` instances. + [#1076](https://github.com/haskell-servant/servant/pull/1076) + + *servant-client-core* Add `aeson` and `Lift BaseUrl` instances + [#1037](https://github.com/haskell-servant/servant/pull/1037) + 0.14 ---- diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors +Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors All rights reserved. diff --git a/include/overlapping-compat.h b/include/overlapping-compat.h deleted file mode 100644 --- a/include/overlapping-compat.h +++ /dev/null @@ -1,8 +0,0 @@ -#if __GLASGOW_HASKELL__ >= 710 -#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} -#define OVERLAPPING_ {-# OVERLAPPING #-} -#else -{-# LANGUAGE OverlappingInstances #-} -#define OVERLAPPABLE_ -#define OVERLAPPING_ -#endif diff --git a/servant-client.cabal b/servant-client.cabal --- a/servant-client.cabal +++ b/servant-client.cabal @@ -1,6 +1,9 @@ +cabal-version: >=1.10 name: servant-client -version: 0.14 -synopsis: automatical derivation of querying functions for servant webservices +version: 0.15 + +synopsis: Automatic derivation of querying functions for servant +category: Servant, Web description: This library lets you derive automatically Haskell functions that let you query each endpoint of a webservice. @@ -8,26 +11,25 @@ See . . + +homepage: http://haskell-servant.readthedocs.org/ +bug-reports: http://github.com/haskell-servant/servant/issues license: BSD3 license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com -copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2017 Servant Contributors -category: Servant, Web +copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors build-type: Simple -cabal-version: >=1.10 tested-with: - GHC==7.8.4 - GHC==7.10.3 - GHC==8.0.2 - GHC==8.2.2 - GHC==8.4.3 -homepage: http://haskell-servant.readthedocs.org/ -Bug-reports: http://github.com/haskell-servant/servant/issues + GHC ==8.0.2 + || ==8.2.2 + || ==8.4.4 + || ==8.6.2 + extra-source-files: - include/*.h CHANGELOG.md README.md + source-repository head type: git location: http://github.com/haskell-servant/servant.git @@ -35,52 +37,50 @@ library exposed-modules: Servant.Client + Servant.Client.Streaming Servant.Client.Internal.HttpClient + Servant.Client.Internal.HttpClient.Streaming -- 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.12 - , bytestring >= 0.10.4.0 && < 0.11 - , containers >= 0.5.5.1 && < 0.6 - , mtl >= 2.1 && < 2.3 + base >= 4.9 && < 4.13 + , bytestring >= 0.10.8.1 && < 0.11 + , containers >= 0.5.7.1 && < 0.7 + , deepseq >= 1.4.2.0 && < 1.5 + , mtl >= 2.2.2 && < 2.3 + , stm >= 2.4.5.1 && < 2.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.4 && <0.19 + , time >= 1.6.0.1 && < 1.9 + , transformers >= 0.5.2.0 && < 0.6 - -- Servant dependencies + -- Servant dependencies. + -- Strict dependency on `servant-client-core` as we re-export things. build-depends: - servant-client-core == 0.14.* + servant == 0.15.* + , servant-client-core >= 0.15 && <0.15.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.1 && < 0.11 - , http-client >= 0.5.12 && < 0.6 - , http-media >= 0.7.1.2 && < 0.8 - , http-types >= 0.12.1 && < 0.13 + base-compat >= 0.10.5 && < 0.11 + , http-client >= 0.5.13.1 && < 0.6 + , http-media >= 0.7.1.3 && < 0.8 + , 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.2.2 && < 5.3 - , stm >= 2.4.5.0 && < 2.5 + , semigroupoids >= 5.3.1 && < 5.4 , transformers-base >= 0.4.5.2 && < 0.5 , transformers-compat >= 0.6.2 && < 0.7 hs-source-dirs: src default-language: Haskell2010 - ghc-options: -Wall - if impl(ghc >= 8.0) - ghc-options: -Wno-redundant-constraints - include-dirs: include + ghc-options: -Wall -Wno-redundant-constraints test-suite spec type: exitcode-stdio-1.0 - ghc-options: -Wall -rtsopts -with-rtsopts=-T + ghc-options: -Wall -rtsopts -threaded "-with-rtsopts=-T -N2" default-language: Haskell2010 hs-source-dirs: test main-is: Spec.hs @@ -98,6 +98,7 @@ , http-client , http-types , mtl + , kan-extensions , servant-client , servant-client-core , text @@ -106,22 +107,20 @@ , wai , warp - if !impl(ghc >= 8.0) - build-depends: - semigroups - -- Additonal dependencies build-depends: - generics-sop >= 0.3.2.0 && < 0.4 - , hspec >= 2.5.1 && < 2.6 - , HUnit >= 1.6 && < 1.7 - , network >= 2.6.3.2 && < 2.8 - , QuickCheck >= 2.10.1 && < 2.12 - , servant == 0.14.* - , servant-server == 0.14.* + entropy >= 0.4.1.3 && < 0.5 + , generics-sop >= 0.4.0.1 && < 0.5 + , hspec >= 2.6.0 && < 2.7 + , HUnit >= 1.6.0.0 && < 1.7 + , network >= 2.8.0.0 && < 2.9 + , QuickCheck >= 2.12.6.1 && < 2.13 + , servant == 0.15.* + , servant-server == 0.15.* + , tdigest >= 0.2 && < 0.3 build-tool-depends: - hspec-discover:hspec-discover >= 2.5.1 && < 2.6 + hspec-discover:hspec-discover >= 2.6.0 && < 2.7 test-suite readme type: exitcode-stdio-1.0 diff --git a/src/Servant/Client.hs b/src/Servant/Client.hs --- a/src/Servant/Client.hs +++ b/src/Servant/Client.hs @@ -13,5 +13,5 @@ , module Servant.Client.Core.Reexport ) where -import Servant.Client.Core.Reexport -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 @@ -11,34 +11,49 @@ {-# LANGUAGE TypeFamilies #-} module Servant.Client.Internal.HttpClient where -import Prelude () +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.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.STM + (atomically) +import Control.Monad.Trans.Control + (MonadBaseControl (..)) import Control.Monad.Trans.Except -import Data.ByteString.Builder (toLazyByteString) +import Data.ByteString.Builder + (toLazyByteString) import qualified Data.ByteString.Lazy as BSL -import Data.Foldable (toList, for_) -import Data.Functor.Alt (Alt (..)) -import Data.Maybe (maybeToList) -import Data.Semigroup ((<>)) -import Data.Proxy (Proxy (..)) -import Data.Sequence (fromList) -import Data.String (fromString) +import Data.Foldable + (for_, toList) +import Data.Functor.Alt + (Alt (..)) +import Data.Maybe + (maybeToList) +import Data.Proxy + (Proxy (..)) +import Data.Semigroup + ((<>)) +import Data.Sequence + (fromList) +import Data.String + (fromString) import qualified Data.Text as T -import Data.Time.Clock (getCurrentTime) +import Data.Time.Clock + (getCurrentTime) import GHC.Generics -import Network.HTTP.Media (renderHeader) -import Network.HTTP.Types (hContentType, renderQuery, - statusCode) +import Network.HTTP.Media + (renderHeader) +import Network.HTTP.Types + (hContentType, renderQuery, statusCode) import Servant.Client.Core import qualified Network.HTTP.Client as Client @@ -117,7 +132,6 @@ instance RunClient ClientM where runRequest = performRequest - streamingRequest = performStreamingRequest throwServantError = throwError instance ClientLike (ClientM a) (ClientM a) where @@ -157,21 +171,6 @@ unless (status_code >= 200 && status_code < 300) $ throwError $ FailureResponse ourResponse return ourResponse - -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 diff --git a/src/Servant/Client/Internal/HttpClient/Streaming.hs b/src/Servant/Client/Internal/HttpClient/Streaming.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Internal/HttpClient/Streaming.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Servant.Client.Internal.HttpClient.Streaming ( + module Servant.Client.Internal.HttpClient.Streaming, + ClientEnv (..), + mkClientEnv, + clientResponseToResponse, + requestToClientRequest, + catchConnectionError, + ) where + +import Prelude () +import Prelude.Compat + +import Control.Concurrent.STM.TVar +import Control.DeepSeq + (NFData, force) +import Control.Exception + (evaluate, throwIO) +import Control.Monad () +import Control.Monad.Base + (MonadBase (..)) +import Control.Monad.Codensity + (Codensity (..)) +import Control.Monad.Error.Class + (MonadError (..)) +import Control.Monad.Reader +import Control.Monad.STM + (atomically) +import Control.Monad.Trans.Except +import qualified Data.ByteString.Lazy as BSL +import Data.Foldable + (for_) +import Data.Functor.Alt + (Alt (..)) +import Data.Proxy + (Proxy (..)) +import Data.Time.Clock + (getCurrentTime) +import GHC.Generics +import Network.HTTP.Types + (statusCode) + +import qualified Network.HTTP.Client as Client + +import Servant.Client.Core +import Servant.Client.Internal.HttpClient + (ClientEnv (..), catchConnectionError, + clientResponseToResponse, mkClientEnv, requestToClientRequest) + + +-- | Generates a set of client functions for an API. +-- +-- Example: +-- +-- > type API = Capture "no" Int :> Get '[JSON] Int +-- > :<|> Get '[JSON] [Bool] +-- > +-- > api :: Proxy API +-- > api = Proxy +-- > +-- > getInt :: Int -> ClientM Int +-- > getBools :: ClientM [Bool] +-- > getInt :<|> getBools = client api +client :: HasClient ClientM api => Proxy api -> Client ClientM api +client api = api `clientIn` (Proxy :: Proxy ClientM) + +-- | Change the monad the client functions live in, by +-- supplying a conversion function +-- (a natural transformation to be precise). +-- +-- For example, assuming you have some @manager :: 'Manager'@ and +-- @baseurl :: 'BaseUrl'@ around: +-- +-- > type API = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int +-- > api :: Proxy API +-- > api = Proxy +-- > getInt :: IO Int +-- > postInt :: Int -> IO Int +-- > getInt :<|> postInt = hoistClient api (flip runClientM cenv) (client api) +-- > where cenv = mkClientEnv manager baseurl +hoistClient + :: HasClient ClientM api + => Proxy api + -> (forall a. m a -> n a) + -> Client m api + -> Client n api +hoistClient = hoistClientMonad (Proxy :: Proxy ClientM) + +-- | @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 } + deriving ( Functor, Applicative, Monad, MonadIO, Generic + , MonadReader ClientEnv, MonadError ServantError) + +instance MonadBase IO ClientM where + liftBase = ClientM . liftIO + +-- | Try clients in order, last error is preserved. +instance Alt ClientM where + a b = a `catchError` \_ -> b + +instance RunClient ClientM where + runRequest = performRequest + throwServantError = 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 cm env k = + let Codensity f = runExceptT $ flip runReaderT env $ unClientM cm + in f k + +-- | A 'runClientM' variant for streaming client. +-- +-- It allows using this module's 'ClientM' in a direct style. +-- The 'NFData' constraint however prevents using this function with genuine +-- streaming response types ('SourceT', 'Conduit', pipes 'Proxy' or 'Machine'). +-- For those you have to use 'withClientM'. +-- +-- /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 cm env = withClientM cm env (evaluate . force) + +performRequest :: Request -> ClientM Response +performRequest req = do + -- TODO: should use Client.withResponse here too + 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 + 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 + +performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a +performWithStreamingRequest req k = do + m <- asks manager + burl <- asks baseUrl + let request = requestToClientRequest burl req + ClientM $ lift $ lift $ Codensity $ \k1 -> + Client.withResponse request m $ \res -> do + let status = Client.responseStatus res + status_code = statusCode status + + -- 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 } + + x <- k (clientResponseToResponse res) + k1 x diff --git a/src/Servant/Client/Streaming.hs b/src/Servant/Client/Streaming.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Streaming.hs @@ -0,0 +1,18 @@ +-- | This module provides 'client' which can automatically generate +-- querying functions for each endpoint just from the type representing your +-- API. +-- +-- This client supports streaming operations. +module Servant.Client.Streaming + ( client + , ClientM + , withClientM + , runClientM + , ClientEnv(..) + , mkClientEnv + , hoistClient + , module Servant.Client.Core.Reexport + ) where + +import Servant.Client.Core.Reexport +import Servant.Client.Internal.HttpClient.Streaming diff --git a/test/Servant/ClientSpec.hs b/test/Servant/ClientSpec.hs --- a/test/Servant/ClientSpec.hs +++ b/test/Servant/ClientSpec.hs @@ -15,72 +15,64 @@ {-# 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.ClientSpec (spec, Person(..), startWaiApp, endWaiApp) where -import Prelude () +import Prelude () import Prelude.Compat -import Control.Arrow (left) -import Control.Concurrent (ThreadId, forkIO, - killThread) -import Control.Exception (bracket) -import Control.Monad.Error.Class (throwError) +import Control.Arrow + (left) +import Control.Concurrent + (ThreadId, forkIO, killThread) +import Control.Exception + (bracket) +import Control.Monad.Error.Class + (throwError) import Data.Aeson -import Data.Char (chr, isPrint) -import Data.Foldable (forM_) -import Data.Semigroup ((<>)) -import Data.Monoid () +import Data.Char + (chr, isPrint) +import Data.Foldable + (forM_) +import Data.Monoid () import Data.Proxy +import Data.Semigroup + ((<>)) import qualified Generics.SOP as SOP -import GHC.Generics (Generic) +import GHC.Generics + (Generic) import qualified Network.HTTP.Client as C import qualified Network.HTTP.Types as HTTP import Network.Socket import qualified Network.Wai as Wai import Network.Wai.Handler.Warp -import System.IO.Unsafe (unsafePerformIO) +import System.IO.Unsafe + (unsafePerformIO) import Test.Hspec import Test.Hspec.QuickCheck import Test.HUnit import Test.QuickCheck -import Web.FormUrlEncoded (FromForm, ToForm) +import Web.FormUrlEncoded + (FromForm, ToForm) -import Servant.API ((:<|>) ((:<|>)), - (:>), AuthProtect, - BasicAuth, - BasicAuthData (..), - Capture, - CaptureAll, Delete, - DeleteNoContent, - EmptyAPI, addHeader, - FormUrlEncoded, - Get, Header, - Headers, JSON, - NoContent (NoContent), - Post, Put, Raw, - QueryFlag, - QueryParam, - QueryParams, - ReqBody, - getHeaders) -import Servant.API.Internal.Test.ComprehensiveAPI +import Servant.API + ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, + BasicAuthData (..), Capture, CaptureAll, Delete, + 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.Request as Req -import qualified Servant.Client.Core.Internal.Auth as Auth +import qualified Servant.Client.Core.Internal.Auth as Auth +import qualified Servant.Client.Core.Internal.Request as Req import Servant.Server import Servant.Server.Experimental.Auth -- This declaration simply checks that all instances are in place. -_ = client comprehensiveAPI +_ = client comprehensiveAPIWithoutStreaming spec :: Spec spec = describe "Servant.Client" $ do diff --git a/test/Servant/StreamSpec.hs b/test/Servant/StreamSpec.hs --- a/test/Servant/StreamSpec.hs +++ b/test/Servant/StreamSpec.hs @@ -15,63 +15,70 @@ {-# 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 Control.Monad (replicateM_, void) -import qualified Data.ByteString as BS +import Control.Monad + (when) +import Control.Monad.Codensity + (Codensity (..)) +import Control.Monad.IO.Class + (MonadIO (..)) +import Control.Monad.Trans.Except +import qualified Data.ByteString as BS import Data.Proxy -import qualified Network.HTTP.Client as C -import Prelude () +import qualified Data.TDigest as TD +import qualified Network.HTTP.Client as C +import Prelude () import Prelude.Compat -import System.IO (IOMode (ReadMode), withFile) -import System.IO.Unsafe (unsafePerformIO) -import Test.Hspec -import Test.QuickCheck - -import Servant.API ((:<|>) ((:<|>)), (:>), JSON, - NetstringFraming, NewlineFraming, - OctetStream, ResultStream (..), - StreamGenerator (..), StreamGet, - NoFraming) -import Servant.Client -import Servant.ClientSpec (Person (..)) -import qualified Servant.ClientSpec as CS +import Servant.API + ((:<|>) ((:<|>)), (:>), JSON, NetstringFraming, + NewlineFraming, NoFraming, OctetStream, SourceIO, StreamGet) +import Servant.Client.Streaming +import Servant.ClientSpec + (Person (..)) +import qualified Servant.ClientSpec as CS import Servant.Server +import Servant.Test.ComprehensiveAPI +import Servant.Types.SourceT +import System.Entropy + (getEntropy, getHardwareEntropy) +import System.IO.Unsafe + (unsafePerformIO) +import System.Mem + (performGC) +import Test.Hspec #if MIN_VERSION_base(4,10,0) -import GHC.Stats (gcdetails_mem_in_use_bytes, gc, getRTSStats) +import GHC.Stats + (gc, gcdetails_live_bytes, getRTSStats) #else -import GHC.Stats (currentBytesUsed, getGCStats) +import GHC.Stats + (currentBytesUsed, getGCStats) #endif +-- This declaration simply checks that all instances are in place. +-- Note: this is streaming client +_ = client comprehensiveAPI + spec :: Spec -spec = describe "Servant.Stream" $ do +spec = describe "Servant.Client.Streaming" $ do streamSpec -type StreamApi f = - "streamGetNewline" :> StreamGet NewlineFraming JSON (f Person) - :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (f Person) - :<|> "streamALot" :> StreamGet NoFraming OctetStream (f BS.ByteString) - - -capi :: Proxy (StreamApi ResultStream) -capi = Proxy +type StreamApi = + "streamGetNewline" :> StreamGet NewlineFraming JSON (SourceIO Person) + :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (SourceIO Person) + :<|> "streamALot" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString) -sapi :: Proxy (StreamApi StreamGenerator) -sapi = Proxy +api :: Proxy StreamApi +api = Proxy -getGetNL, getGetNS :: ClientM (ResultStream Person) -getGetALot :: ClientM (ResultStream BS.ByteString) -getGetNL :<|> getGetNS :<|> getGetALot = client capi +getGetNL, getGetNS :: ClientM (SourceIO Person) +getGetALot :: ClientM (SourceIO BS.ByteString) +getGetNL :<|> getGetNS :<|> getGetALot = client api alice :: Person alice = Person "Alice" 42 @@ -80,66 +87,88 @@ bob = Person "Bob" 25 server :: Application -server = serve sapi - $ return (StreamGenerator (\f r -> f alice >> r bob >> r alice)) - :<|> return (StreamGenerator (\f r -> f alice >> r bob >> r alice)) - :<|> return (StreamGenerator lotsGenerator) - where - lotsGenerator f r = do - void $ f "" - void $ withFile "/dev/urandom" ReadMode $ - \handle -> streamFiveMBNTimes handle 1000 r - return () - - streamFiveMBNTimes handle left sink - | left <= (0 :: Int) = return () - | otherwise = do - msg <- BS.hGet handle (megabytes 5) - _ <- sink msg - streamFiveMBNTimes handle (left - 1) sink +server = serve api + $ return (source [alice, bob, alice]) + :<|> return (source [alice, bob, alice]) + -- 2 ^ (18 + 10) = 256M + :<|> return (SourceT ($ lots (powerOfTwo 18))) + where + lots n + | n < 0 = Stop + | otherwise = Effect $ do + let size = powerOfTwo 10 + mbs <- getHardwareEntropy size + bs <- maybe (getEntropy size) pure mbs + return (Yield bs (lots (n - 1))) +powerOfTwo :: Int -> Int +powerOfTwo = (2 ^) {-# 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') +withClient :: ClientM a -> BaseUrl -> (Either ServantError a -> IO r) -> IO r +withClient x baseUrl' = withClientM 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 +testRunSourceIO :: SourceIO a + -> IO (Either String [a]) +testRunSourceIO = runExceptT . runSourceT streamSpec :: Spec streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do - it "works with 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) + withClient getGetNL baseUrl $ \(Right res) -> + testRunSourceIO res `shouldReturn` Right [alice, bob, alice] it "works with 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) + withClient getGetNS baseUrl $ \(Right res) -> + testRunSourceIO res `shouldReturn` Right [alice, bob, alice] +{- it "streams in constant memory" $ \(_, baseUrl) -> do - Right (ResultStream res) <- runClient getGetALot baseUrl - let consumeNChunks n = replicateM_ n (res void) - consumeNChunks 900 + 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) - memUsed <- gcdetails_mem_in_use_bytes . gc <$> getRTSStats + gcdetails_live_bytes . gc <$> getRTSStats #else - memUsed <- currentBytesUsed <$> getGCStats + currentBytesUsed <$> getGCStats #endif memUsed `shouldSatisfy` (< megabytes 22) megabytes :: Num a => a -> a megabytes n = n * (1000 ^ (2 :: Int)) +-}