diff --git a/doc/cookbook/basic-streaming/Streaming.lhs b/doc/cookbook/basic-streaming/Streaming.lhs index 4ae7f9d0..69812a16 100644 --- a/doc/cookbook/basic-streaming/Streaming.lhs +++ b/doc/cookbook/basic-streaming/Streaming.lhs @@ -38,7 +38,7 @@ import Text.Read (readMaybe) import Servant -import Servant.Client +import Servant.Client.Streaming import qualified Servant.Types.SourceT as S import qualified Network.Wai.Handler.Warp as Warp diff --git a/doc/tutorial/Client.lhs b/doc/tutorial/Client.lhs index 34a43df0..00c2f26e 100644 --- a/doc/tutorial/Client.lhs +++ b/doc/tutorial/Client.lhs @@ -21,7 +21,8 @@ import Network.HTTP.Client (newManager, defaultManagerSettings) import Servant.API import Servant.Client import Servant.Types.SourceT (foreach) -import Control.Monad.Codensity (Codensity) + +import qualified Servant.Client.Streaming as S ``` Also, we need examples for some domain specific data types: @@ -224,6 +225,8 @@ type StreamAPI = "positionStream" :> StreamGet NewlineFraming JSON (SourceIO Pos Note that we use the same `SourceIO` type as on the server-side (this is different from `servant-0.14`). +However, we have to use different client, `Servant.Client.Streaming`, +which can stream (but has different API). In any case, here's how we write a function to query our API: @@ -231,21 +234,18 @@ In any case, here's how we write a function to query our API: streamAPI :: Proxy StreamAPI streamAPI = Proxy -posStream :: ClientM (Codensity IO (SourceIO Position)) -posStream = client streamAPI +posStream :: S.ClientM (SourceIO Position) +posStream = S.client streamAPI ``` -We'll get back a `Codensity IO (SourceIO Position)`. The wrapping in -`Codensity` is generally necessary, as `Codensity` lets us `bracket` things -properly. This is best explained by an example. To consume `ClientM (Codentity -IO ...)` we can use `withClientM` helper: the underlying HTTP connection is -open only until the inner functions exits. Inside the block we can e.g just -print out all elements from a `SourceIO`, to give some idea of how to work with -them. +We'll get back a `SourceIO Position`. Instead of `runClientM`, the streaming +client provides `withClientM`: the underlying HTTP connection is open only +until the inner functions exits. Inside the block we can e.g just print out +all elements from a `SourceIO`, to give some idea of how to work with them. ``` haskell -printSourceIO :: Show a => ClientEnv -> ClientM (Codensity IO (SourceIO a)) -> IO () -printSourceIO env c = withClientM c env $ \e -> case e of +printSourceIO :: Show a => ClientEnv -> S.ClientM (SourceIO a) -> IO () +printSourceIO env c = S.withClientM c env $ \e -> case e of Left err -> putStrLn $ "Error: " ++ show err Right rs -> foreach fail print rs ``` diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal index 92701e0a..5161d384 100644 --- a/doc/tutorial/tutorial.cabal +++ b/doc/tutorial/tutorial.cabal @@ -46,7 +46,6 @@ library , http-client , http-media , http-types - , kan-extensions , mtl , string-conversions , text diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index e4200127..ab313f15 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/servant-client-core/servant-client-core.cabal @@ -70,7 +70,6 @@ library , http-api-data >= 0.3.8.1 && < 0.4 , http-media >= 0.7.1.2 && < 0.8 , http-types >= 0.12.1 && < 0.13 - , kan-extensions >= 5.2 && < 5.3 , network-uri >= 2.6.1.0 && < 2.7 , safe >= 0.3.17 && < 0.4 diff --git a/servant-client-core/src/Servant/Client/Core.hs b/servant-client-core/src/Servant/Client/Core.hs index bcfd4127..09527eaa 100644 --- a/servant-client-core/src/Servant/Client/Core.hs +++ b/servant-client-core/src/Servant/Client/Core.hs @@ -44,6 +44,8 @@ module Servant.Client.Core , GenResponse (..) , RunClient(..) , module Servant.Client.Core.Internal.BaseUrl + -- ** Streaming + , RunStreamingClient(..) , StreamingResponse -- * Writing HasClient instances diff --git a/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs b/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs index 61737dbe..617e404e 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs @@ -36,20 +36,17 @@ import qualified Network.HTTP.Types as H import Servant.API ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData, BuildHeadersTo (..), Capture', CaptureAll, Description, - EmptyAPI, FramingUnrender (..), FromSourceIO (..), - Header', Headers (..), HttpVersion, IsSecure, - MimeRender (mimeRender), MimeUnrender (mimeUnrender), - NoContent (NoContent), QueryFlag, QueryParam', QueryParams, - Raw, ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream, - StreamBody, Summary, ToHttpApiData, Vault, Verb, - WithNamedContext, contentType, getHeadersHList, getResponse, - toQueryParam, toUrlPiece) + EmptyAPI, FramingUnrender (..), FromSourceIO (..), Header', + Headers (..), HttpVersion, IsSecure, MimeRender (mimeRender), + MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag, + QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost, + ReqBody', SBoolI, Stream, StreamBody, Summary, ToHttpApiData, + Vault, Verb, WithNamedContext, contentType, getHeadersHList, + getResponse, toQueryParam, toUrlPiece) import Servant.API.ContentTypes (contentTypes) import Servant.API.Modifiers (FoldRequired, RequiredArgument, foldRequiredArgument) -import Control.Monad.Codensity - (Codensity (..)) import qualified Servant.Types.SourceT as S import Servant.Client.Core.Internal.Auth @@ -272,25 +269,23 @@ instance {-# OVERLAPPING #-} hoistClientMonad _ _ f ma = f ma instance {-# OVERLAPPABLE #-} - ( RunClient m, MimeUnrender ct chunk, ReflectMethod method, + ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method, FramingUnrender framing, FromSourceIO chunk a ) => HasClient m (Stream method status framing ct a) where - type Client m (Stream method status framing ct a) = m (Codensity IO a) + type Client m (Stream method status framing ct a) = m a hoistClientMonad _ _ f ma = f ma - clientWithRoute _pm Proxy req = do - sresp <- streamingRequest req - { requestAccept = fromList [contentType (Proxy :: Proxy ct)] - , requestMethod = reflectMethod (Proxy :: Proxy method) - } - return $ do - let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk - framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' - gres <- sresp - return $ fromSourceIO $ framingUnrender' $ S.fromAction BS.null (responseBody gres) - + clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do + let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk + framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' + return $ fromSourceIO $ framingUnrender' $ S.fromAction BS.null (responseBody gres) + where + req' = req + { requestAccept = fromList [contentType (Proxy :: Proxy ct)] + , requestMethod = reflectMethod (Proxy :: Proxy method) + } -- | If you use a 'Header' in one of your endpoints in your API, -- the corresponding querying function will automatically take diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs index c336ffd7..a85ccaf6 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs @@ -38,8 +38,6 @@ import Network.HTTP.Media import Network.HTTP.Types (Header, HeaderName, HttpVersion, Method, QueryItem, Status, http11, methodGet) -import Control.Monad.Codensity - (Codensity (..)) import Web.HttpApiData (ToHttpApiData, toEncodedUrlPiece, toHeader) @@ -91,7 +89,7 @@ data GenResponse a = Response } deriving (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable) type Response = GenResponse LBS.ByteString -type StreamingResponse = Codensity IO (GenResponse (IO BS.ByteString)) +type StreamingResponse = GenResponse (IO BS.ByteString) -- A GET request to the top-level path defaultRequest :: Request diff --git a/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs b/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs index 171749a0..9ef71e86 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs @@ -31,9 +31,11 @@ import Servant.Client.Core.Internal.Request class Monad m => RunClient m where -- | How to make a request. runRequest :: Request -> m Response - streamingRequest :: Request -> m StreamingResponse throwServantError :: ServantError -> m a +class RunClient m => RunStreamingClient m where + withStreamingRequest :: Request -> (StreamingResponse -> IO a) -> m a + checkContentTypeHeader :: RunClient m => Response -> m MediaType checkContentTypeHeader response = case lookup "Content-Type" $ toList $ responseHeaders response of @@ -56,5 +58,10 @@ decodedAs response contentType = do instance ClientF ~ f => RunClient (Free f) where runRequest req = liftF (RunRequest req id) - streamingRequest req = liftF (StreamingRequest req id) throwServantError = liftF . Throw + +{- +Free and streaming? +instance ClientF ~ f => RunStreamingClient (Free f) where + streamingRequest req = liftF (StreamingRequest req id) +-} diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 4e55d188..8fb97116 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -33,7 +33,9 @@ source-repository head 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 diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index 59ec8cff..1ecc07db 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -7,7 +7,6 @@ module Servant.Client ( client , ClientM , runClientM - , withClientM , ClientEnv(..) , mkClientEnv , hoistClient diff --git a/servant-client/src/Servant/Client/Internal/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs index c3ca73d3..eb566d6b 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient.hs @@ -21,8 +21,6 @@ import Control.Monad.Base (MonadBase (..)) import Control.Monad.Catch (MonadCatch, MonadThrow) -import Control.Monad.Codensity - (Codensity (..)) import Control.Monad.Error.Class (MonadError (..)) import Control.Monad.Reader @@ -134,7 +132,6 @@ instance Alt ClientM where instance RunClient ClientM where runRequest = performRequest - streamingRequest = performStreamingRequest throwServantError = throwError instance ClientLike (ClientM a) (ClientM a) where @@ -143,17 +140,6 @@ instance ClientLike (ClientM a) (ClientM a) where runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a) runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm -withClientM - :: ClientM (Codensity IO a) -- ^ client with codensity result - -> ClientEnv -- ^ environment - -> (Either ServantError a -> IO b) -- ^ continuation - -> IO b -withClientM cm env k = do - e <- runExceptT (runReaderT (unClientM cm) env) - case e of - Left err -> k (Left err) - Right cod -> runCodensity cod (k . Right) - performRequest :: Request -> ClientM Response performRequest req = do ClientEnv m burl cookieJar' <- ask @@ -186,21 +172,6 @@ performRequest req = do throwError $ FailureResponse ourResponse return ourResponse -performStreamingRequest :: Request -> ClientM StreamingResponse -performStreamingRequest req = do - m <- asks manager - burl <- asks baseUrl - let request = requestToClientRequest burl req - return $ Codensity $ - \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 diff --git a/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs b/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs new file mode 100644 index 00000000..3a0014f7 --- /dev/null +++ b/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs @@ -0,0 +1,172 @@ +{-# 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.Exception +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 + +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/servant-client/src/Servant/Client/Streaming.hs b/servant-client/src/Servant/Client/Streaming.hs new file mode 100644 index 00000000..a443882d --- /dev/null +++ b/servant-client/src/Servant/Client/Streaming.hs @@ -0,0 +1,17 @@ +-- | 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 + , ClientEnv(..) + , mkClientEnv + , hoistClient + , module Servant.Client.Core.Reexport + ) where + +import Servant.Client.Core.Reexport +import Servant.Client.Internal.HttpClient.Streaming diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 2304b56f..ed375758 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -72,7 +72,7 @@ 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/servant-client/test/Servant/StreamSpec.hs b/servant-client/test/Servant/StreamSpec.hs index 53f7d14f..e41aa370 100644 --- a/servant-client/test/Servant/StreamSpec.hs +++ b/servant-client/test/Servant/StreamSpec.hs @@ -28,20 +28,21 @@ import Control.Monad.Codensity import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Except -import qualified Data.ByteString as BS +import qualified Data.ByteString as BS import Data.Proxy -import qualified Data.TDigest as TD -import qualified Network.HTTP.Client as C +import qualified Data.TDigest as TD +import qualified Network.HTTP.Client as C import Prelude () import Prelude.Compat import Servant.API ((:<|>) ((:<|>)), (:>), JSON, NetstringFraming, NewlineFraming, NoFraming, OctetStream, SourceIO, StreamGet) -import Servant.Client +import Servant.Client.Streaming import Servant.ClientSpec (Person (..)) -import qualified Servant.ClientSpec as CS +import qualified Servant.ClientSpec as CS import Servant.Server +import Servant.Test.ComprehensiveAPI import Servant.Types.SourceT import System.Entropy (getEntropy, getHardwareEntropy) @@ -59,8 +60,12 @@ 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 = @@ -71,8 +76,8 @@ type StreamApi = api :: Proxy StreamApi api = Proxy -getGetNL, getGetNS :: ClientM (Codensity IO (SourceIO Person)) -getGetALot :: ClientM (Codensity IO (SourceIO BS.ByteString)) +getGetNL, getGetNS :: ClientM (SourceIO Person) +getGetALot :: ClientM (SourceIO BS.ByteString) getGetNL :<|> getGetNS :<|> getGetALot = client api alice :: Person @@ -104,28 +109,22 @@ powerOfTwo = (2 ^) 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') -testRunSourceIO :: Codensity IO (SourceIO a) +testRunSourceIO :: SourceIO a -> IO (Either String [a]) -testRunSourceIO = runExceptT . runSourceT . joinCodensitySourceT - -joinCodensitySourceT :: Codensity m (SourceT m a) -> SourceT m a -joinCodensitySourceT cod = - SourceT $ \r -> - runCodensity cod $ \src -> - unSourceT src r +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 - testRunSourceIO res `shouldReturn` Right [alice, bob, alice] + 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 - testRunSourceIO res `shouldReturn` Right [alice, bob, alice] + withClient getGetNS baseUrl $ \(Right res) -> + testRunSourceIO res `shouldReturn` Right [alice, bob, alice] {- it "streams in constant memory" $ \(_, baseUrl) -> do diff --git a/servant-conduit/example/Main.hs b/servant-conduit/example/Main.hs index 5e02a414..85ababe0 100644 --- a/servant-conduit/example/Main.hs +++ b/servant-conduit/example/Main.hs @@ -27,7 +27,7 @@ import Text.Read import Data.Conduit import qualified Data.Conduit.Combinators as C import Servant -import Servant.Client +import Servant.Client.Streaming import Servant.Conduit () import qualified Network.Wai.Handler.Warp as Warp diff --git a/servant-docs/golden/comprehensive.md b/servant-docs/golden/comprehensive.md index 7210143f..9239726c 100644 --- a/servant-docs/golden/comprehensive.md +++ b/servant-docs/golden/comprehensive.md @@ -16,6 +16,42 @@ ``` +## GET /alternative/left + +### Response: + +- Status code 200 +- Headers: [] + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- Example (`application/json;charset=utf-8`, `application/json`): + +```javascript + +``` + +## GET /alternative/right + +### Response: + +- Status code 200 +- Headers: [] + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- Example (`application/json;charset=utf-8`, `application/json`): + +```javascript + +``` + ## GET /capture/:foo ### Captures: diff --git a/servant-machines/example/Main.hs b/servant-machines/example/Main.hs index 090c4660..3f1a0bd6 100644 --- a/servant-machines/example/Main.hs +++ b/servant-machines/example/Main.hs @@ -26,7 +26,7 @@ import Text.Read import Data.Machine import Servant -import Servant.Client +import Servant.Client.Streaming import Servant.Machines () import qualified Network.Wai.Handler.Warp as Warp diff --git a/servant-pipes/example/Main.hs b/servant-pipes/example/Main.hs index 402e786b..157ac2e7 100644 --- a/servant-pipes/example/Main.hs +++ b/servant-pipes/example/Main.hs @@ -19,18 +19,19 @@ import Network.Wai (Application) import System.Environment (getArgs, lookupEnv) -import System.IO (IOMode (..)) +import System.IO + (IOMode (..)) import Text.Read (readMaybe) import qualified Pipes as P +import Pipes.ByteString as PBS import qualified Pipes.Prelude as P import Pipes.Safe (SafeT) import qualified Pipes.Safe.Prelude as P import Servant -import Pipes.ByteString as PBS -import Servant.Client +import Servant.Client.Streaming import Servant.Pipes () import qualified Network.Wai.Handler.Warp as Warp diff --git a/servant/src/Servant/Test/ComprehensiveAPI.hs b/servant/src/Servant/Test/ComprehensiveAPI.hs index c300465d..cd643784 100644 --- a/servant/src/Servant/Test/ComprehensiveAPI.hs +++ b/servant/src/Servant/Test/ComprehensiveAPI.hs @@ -15,38 +15,64 @@ import Servant.Types.SourceT type GET = Get '[JSON] NoContent type ComprehensiveAPI = - ComprehensiveAPIWithoutRaw :<|> - "raw" :> Raw + ComprehensiveAPIWithoutStreamingOrRaw' + (EmptyEndpoint :<|> StreamingEndpoint :<|> RawEndpoint) + +type RawEndpoint = + "raw" :> Raw + +type StreamingEndpoint = + "streaming" :> StreamBody NetstringFraming JSON (SourceT IO Int) :> Stream 'GET 200 NetstringFraming JSON (SourceT IO Int) + +type EmptyEndpoint = + "empty-api" :> EmptyAPI comprehensiveAPI :: Proxy ComprehensiveAPI comprehensiveAPI = Proxy type ComprehensiveAPIWithoutRaw = - GET :<|> - "get-int" :> Get '[JSON] Int :<|> - "capture" :> Capture' '[Description "example description"] "foo" Int :> GET :<|> - "header" :> Header "foo" Int :> GET :<|> - "header-lenient" :> Header' '[Required, Lenient] "bar" Int :> GET :<|> - "http-version" :> HttpVersion :> GET :<|> - "is-secure" :> IsSecure :> GET :<|> - "param" :> QueryParam "foo" Int :> GET :<|> - "param-lenient" :> QueryParam' '[Required, Lenient] "bar" Int :> GET :<|> - "params" :> QueryParams "foo" Int :> GET :<|> - "flag" :> QueryFlag "foo" :> GET :<|> - "remote-host" :> RemoteHost :> GET :<|> - "req-body" :> ReqBody '[JSON] Int :> GET :<|> - "req-body-lenient" :> ReqBody' '[Lenient] '[JSON] Int :> GET :<|> - "res-headers" :> Get '[JSON] (Headers '[Header "foo" Int] NoContent) :<|> - "foo" :> GET :<|> - "vault" :> Vault :> GET :<|> - "post-no-content" :> Verb 'POST 204 '[JSON] NoContent :<|> - "post-int" :> Verb 'POST 204 '[JSON] Int :<|> - "streaming" :> StreamBody NetstringFraming JSON (SourceT IO Int) :> Stream 'GET 200 NetstringFraming JSON (SourceT IO Int) :<|> - "named-context" :> WithNamedContext "foo" '[] GET :<|> - "capture-all" :> CaptureAll "foo" Int :> GET :<|> - "summary" :> Summary "foo" :> GET :<|> - "description" :> Description "foo" :> GET :<|> - "empty-api" :> EmptyAPI + ComprehensiveAPIWithoutStreamingOrRaw' + (EmptyEndpoint :<|> StreamingEndpoint) comprehensiveAPIWithoutRaw :: Proxy ComprehensiveAPIWithoutRaw comprehensiveAPIWithoutRaw = Proxy + +type ComprehensiveAPIWithoutStreaming = + ComprehensiveAPIWithoutStreamingOrRaw' + (EmptyEndpoint :<|> RawEndpoint) + +comprehensiveAPIWithoutStreaming :: Proxy ComprehensiveAPIWithoutStreaming +comprehensiveAPIWithoutStreaming = Proxy + +-- | @:: API -> API@, so we have linear structure of the API. +type ComprehensiveAPIWithoutStreamingOrRaw' endpoint = + GET + :<|> "get-int" :> Get '[JSON] Int + :<|> "capture" :> Capture' '[Description "example description"] "foo" Int :> GET + :<|> "header" :> Header "foo" Int :> GET + :<|> "header-lenient" :> Header' '[Required, Lenient] "bar" Int :> GET + :<|> "http-version" :> HttpVersion :> GET + :<|> "is-secure" :> IsSecure :> GET + :<|> "param" :> QueryParam "foo" Int :> GET + :<|> "param-lenient" :> QueryParam' '[Required, Lenient] "bar" Int :> GET + :<|> "params" :> QueryParams "foo" Int :> GET + :<|> "flag" :> QueryFlag "foo" :> GET + :<|> "remote-host" :> RemoteHost :> GET + :<|> "req-body" :> ReqBody '[JSON] Int :> GET + :<|> "req-body-lenient" :> ReqBody' '[Lenient] '[JSON] Int :> GET + :<|> "res-headers" :> Get '[JSON] (Headers '[Header "foo" Int] NoContent) + :<|> "foo" :> GET + :<|> "vault" :> Vault :> GET + :<|> "post-no-content" :> Verb 'POST 204 '[JSON] NoContent + :<|> "post-int" :> Verb 'POST 204 '[JSON] Int + :<|> "named-context" :> WithNamedContext "foo" '[] GET + :<|> "capture-all" :> CaptureAll "foo" Int :> GET + :<|> "summary" :> Summary "foo" :> GET + :<|> "description" :> Description "foo" :> GET + :<|> "alternative" :> ("left" :> GET :<|> "right" :> GET) + :<|> endpoint + +type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint + +comprehensiveAPIWithoutStreamingOrRaw :: Proxy ComprehensiveAPIWithoutStreamingOrRaw +comprehensiveAPIWithoutStreamingOrRaw = Proxy diff --git a/servant/test/Servant/LinksSpec.hs b/servant/test/Servant/LinksSpec.hs index 1aa0d09e..1c448ba0 100644 --- a/servant/test/Servant/LinksSpec.hs +++ b/servant/test/Servant/LinksSpec.hs @@ -89,7 +89,7 @@ spec = describe "Servant.Links" $ do allNames ["Seneca", "Aurelius"] `shouldBeLink` "all/Seneca/Aurelius" it "can generate all links for ComprehensiveAPIWithoutRaw" $ do - let (firstLink :<|> _) = allLinks comprehensiveAPIWithoutRaw + let firstLink :<|> _ = allLinks comprehensiveAPIWithoutRaw firstLink `shouldBeLink` "" -- |