servant-client 0.14 → 0.15
raw patch · 10 files changed
+495/−212 lines, 10 filesdep +deepseqdep +entropydep +kan-extensionsdep −semigroupsdep ~HUnitdep ~QuickCheckdep ~base
Dependencies added: deepseq, entropy, kan-extensions, tdigest
Dependencies removed: semigroups
Dependency ranges changed: HUnit, QuickCheck, base, base-compat, bytestring, containers, generics-sop, hspec, http-client, http-media, http-types, mtl, network, semigroupoids, servant, servant-client-core, servant-server, stm, time, transformers
Files
- CHANGELOG.md +66/−0
- LICENSE +1/−1
- include/overlapping-compat.h +0/−8
- servant-client.cabal +48/−49
- src/Servant/Client.hs +2/−2
- src/Servant/Client/Internal/HttpClient.hs +33/−34
- src/Servant/Client/Internal/HttpClient/Streaming.hs +188/−0
- src/Servant/Client/Streaming.hs +18/−0
- test/Servant/ClientSpec.hs +32/−40
- test/Servant/StreamSpec.hs +107/−78
CHANGELOG.md view
@@ -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 ----
LICENSE view
@@ -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.
− include/overlapping-compat.h
@@ -1,8 +0,0 @@-#if __GLASGOW_HASKELL__ >= 710-#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}-#define OVERLAPPING_ {-# OVERLAPPING #-}-#else-{-# LANGUAGE OverlappingInstances #-}-#define OVERLAPPABLE_-#define OVERLAPPING_-#endif
servant-client.cabal view
@@ -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 <http://hackage.haskell.org/package/servant servant> webservice.@@ -8,26 +11,25 @@ See <http://haskell-servant.readthedocs.org/en/stable/tutorial/Client.html the client section of the tutorial>. . <https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG>++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
src/Servant/Client.hs view
@@ -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
src/Servant/Client/Internal/HttpClient.hs view
@@ -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
+ src/Servant/Client/Internal/HttpClient/Streaming.hs view
@@ -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
+ src/Servant/Client/Streaming.hs view
@@ -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
test/Servant/ClientSpec.hs view
@@ -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
test/Servant/StreamSpec.hs view
@@ -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))+-}