diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,81 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client-core/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. + +- *servant-client-core* Related to the previous: + `streamingResponse` is removed from `RunClient`. + We have a new type-class: + + ```haskell + class RunClient m => RunStreamingClient m where + withStreamingRequest :: Request -> (StreamingResponse -> IO a) -> m a + ``` + +- 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.1 ------ diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2017, Servant Contributors +Copyright (c) 2017-2018, Servant Contributors All rights reserved. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple +import Distribution.Simple main = defaultMain 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-core.cabal b/servant-client-core.cabal --- a/servant-client-core.cabal +++ b/servant-client-core.cabal @@ -1,29 +1,30 @@ +cabal-version: >=1.10 name: servant-client-core -version: 0.14.1 +version: 0.15 + synopsis: Core functionality and class for client function generation for servant APIs +category: Servant, Web description: This library provides backend-agnostic generation of client functions. For more information, see the README. + +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 -homepage: http://haskell-servant.readthedocs.org/ -bug-reports: http://github.com/haskell-servant/servant/issues -cabal-version: >=1.10 -copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2017 Servant Contributors -category: Web +copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2018 Servant Contributors build-type: Simple +tested-with: + GHC ==8.0.2 + || ==8.2.2 + || ==8.4.4 + || ==8.6.2 + extra-source-files: - include/*.h CHANGELOG.md README.md -tested-with: - GHC==7.8.4 - GHC==7.10.3 - GHC==8.0.2 - GHC==8.2.2 - GHC==8.4.3 source-repository head type: git @@ -49,37 +50,35 @@ -- -- 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 + 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 , text >= 1.2.3.0 && < 1.3 - - if !impl(ghc >= 8.0) - build-depends: - semigroups >=0.18.4 && <0.19 + , transformers >= 0.5.2.0 && < 0.6 + , template-haskell >= 2.11.1.0 && < 2.15 -- Servant dependencies build-depends: - servant >= 0.14.1 && <0.15 + servant >= 0.15 && <0.16 -- 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 + aeson >= 1.4.1.0 && < 1.5 + , base-compat >= 0.10.5 && < 0.11 , base64-bytestring >= 1.0.0.1 && < 1.1 , exceptions >= 0.10.0 && < 0.11 - , free >= 5.0.2 && < 5.2 - , generics-sop >= 0.3.2.0 && < 0.4 - , http-api-data >= 0.3.8.1 && < 0.4 - , http-media >= 0.7.1.2 && < 0.8 - , http-types >= 0.12.1 && < 0.13 + , free >= 5.1 && < 5.2 + , generics-sop >= 0.4.0.1 && < 0.5 + , http-media >= 0.7.1.3 && < 0.8 + , http-types >= 0.12.2 && < 0.13 , network-uri >= 2.6.1.0 && < 2.7 , safe >= 0.3.17 && < 0.4 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall - include-dirs: include test-suite spec type: exitcode-stdio-1.0 @@ -98,9 +97,9 @@ -- Additonal dependencies build-depends: - deepseq >= 1.3.0.2 && <1.5 - , hspec >= 2.4.1 && <2.6 - , QuickCheck >= 2.11.3 && < 2.12 + deepseq >= 1.4.2.0 && < 1.5 + , hspec >= 2.6.0 && < 2.7 + , QuickCheck >= 2.12.6.1 && < 2.13 build-tool-depends: - hspec-discover:hspec-discover >= 2.5.1 && <2.6 + hspec-discover:hspec-discover >= 2.6.0 && <2.7 diff --git a/src/Servant/Client/Core.hs b/src/Servant/Client/Core.hs --- a/src/Servant/Client/Core.hs +++ b/src/Servant/Client/Core.hs @@ -44,7 +44,9 @@ , GenResponse (..) , RunClient(..) , module Servant.Client.Core.Internal.BaseUrl - , StreamingResponse(..) + -- ** Streaming + , RunStreamingClient(..) + , StreamingResponse -- * Writing HasClient instances -- | These functions need not be re-exported by backend libraries. @@ -55,13 +57,11 @@ , setRequestBody ) where import Servant.Client.Core.Internal.Auth -import Servant.Client.Core.Internal.BaseUrl (BaseUrl (..), - InvalidBaseUrlException, - Scheme (..), - parseBaseUrl, - showBaseUrl) +import Servant.Client.Core.Internal.BaseUrl + (BaseUrl (..), InvalidBaseUrlException, Scheme (..), + parseBaseUrl, showBaseUrl) import Servant.Client.Core.Internal.BasicAuth -import Servant.Client.Core.Internal.HasClient import Servant.Client.Core.Internal.Generic +import Servant.Client.Core.Internal.HasClient import Servant.Client.Core.Internal.Request import Servant.Client.Core.Internal.RunClient diff --git a/src/Servant/Client/Core/Internal/Auth.hs b/src/Servant/Client/Core/Internal/Auth.hs --- a/src/Servant/Client/Core/Internal/Auth.hs +++ b/src/Servant/Client/Core/Internal/Auth.hs @@ -6,7 +6,8 @@ module Servant.Client.Core.Internal.Auth where -import Servant.Client.Core.Internal.Request (Request) +import Servant.Client.Core.Internal.Request + (Request) -- | For a resource protected by authentication (e.g. AuthProtect), we need -- to provide the client with some data used to add authentication data diff --git a/src/Servant/Client/Core/Internal/BaseUrl.hs b/src/Servant/Client/Core/Internal/BaseUrl.hs --- a/src/Servant/Client/Core/Internal/BaseUrl.hs +++ b/src/Servant/Client/Core/Internal/BaseUrl.hs @@ -1,13 +1,25 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} {-# LANGUAGE ViewPatterns #-} module Servant.Client.Core.Internal.BaseUrl where -import Control.Monad.Catch (Exception, MonadThrow, throwM) +import Control.Monad.Catch + (Exception, MonadThrow, throwM) +import Data.Aeson + (FromJSON (..), FromJSONKey (..), ToJSON (..), ToJSONKey (..)) +import Data.Aeson.Types + (FromJSONKeyFunction (..), contramapToJSONKeyFunction, + withText) +import Data.Data + (Data) import Data.List -import Data.Typeable +import qualified Data.Text as T import GHC.Generics -import Network.URI hiding (path) +import Language.Haskell.TH.Syntax + (Lift) +import Network.URI hiding + (path) import Safe import Text.Read @@ -15,16 +27,18 @@ data Scheme = Http -- ^ http:// | Https -- ^ https:// - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, Lift, Data) -- | Simple data type to represent the target of HTTP requests -- for servant's automatically-generated clients. data BaseUrl = BaseUrl - { baseUrlScheme :: Scheme -- ^ URI scheme to use + { baseUrlScheme :: Scheme -- ^ URI scheme to use , baseUrlHost :: String -- ^ host (eg "haskell.org") , baseUrlPort :: Int -- ^ port (eg 80) , baseUrlPath :: String -- ^ path (eg "/a/b/c") - } deriving (Show, Ord, Generic) + } deriving (Show, Ord, Generic, Lift, Data) +-- TODO: Ord is more precise than Eq +-- TODO: Add Hashable instance? instance Eq BaseUrl where BaseUrl a b c path == BaseUrl a' b' c' path' @@ -32,6 +46,36 @@ where s ('/':x) = x s x = x +-- | >>> traverse_ (LBS8.putStrLn . encode) $ parseBaseUrl "api.example.com" +-- "http://api.example.com" +instance ToJSON BaseUrl where + toJSON = toJSON . showBaseUrl + toEncoding = toEncoding . showBaseUrl + +-- | >>> parseBaseUrl "api.example.com" >>= decode . encode :: Maybe BaseUrl +-- Just (BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = ""}) +instance FromJSON BaseUrl where + parseJSON = withText "BaseUrl" $ \t -> case parseBaseUrl (T.unpack t) of + Just u -> return u + Nothing -> fail $ "Invalid base url: " ++ T.unpack t + +-- | >>> :{ +-- traverse_ (LBS8.putStrLn . encode) $ do +-- u1 <- parseBaseUrl "api.example.com" +-- u2 <- parseBaseUrl "example.com" +-- return $ Map.fromList [(u1, 'x'), (u2, 'y')] +-- :} +-- {"http://api.example.com":"x","http://example.com":"y"} +instance ToJSONKey BaseUrl where + toJSONKey = contramapToJSONKeyFunction showBaseUrl toJSONKey + +instance FromJSONKey BaseUrl where + fromJSONKey = FromJSONKeyTextParser $ \t -> case parseBaseUrl (T.unpack t) of + Just u -> return u + Nothing -> fail $ "Invalid base url: " ++ T.unpack t + +-- | >>> showBaseUrl <$> parseBaseUrl "api.example.com" +-- "http://api.example.com" showBaseUrl :: BaseUrl -> String showBaseUrl (BaseUrl urlscheme host port path) = schemeString ++ "//" ++ host ++ (portString path) @@ -45,9 +89,22 @@ (Https, 443) -> "" _ -> ":" ++ show port -data InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show, Typeable) +newtype InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show) instance Exception InvalidBaseUrlException +-- | +-- +-- >>> parseBaseUrl "api.example.com" +-- BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = ""} +-- +-- /Note:/ trailing slash is removed +-- +-- >>> parseBaseUrl "api.example.com/" +-- BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = ""} +-- +-- >>> parseBaseUrl "api.example.com/dir/" +-- BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = "/dir"} +-- parseBaseUrl :: MonadThrow m => String -> m BaseUrl parseBaseUrl s = case parseURI (removeTrailingSlash s) of -- This is a rather hacky implementation and should be replaced with something @@ -67,3 +124,10 @@ removeTrailingSlash str = case lastMay str of Just '/' -> init str _ -> str + +-- $setup +-- +-- >>> import Data.Aeson +-- >>> import Data.Foldable (traverse_) +-- >>> import qualified Data.ByteString.Lazy.Char8 as LBS8 +-- >>> import qualified Data.Map.Strict as Map diff --git a/src/Servant/Client/Core/Internal/BasicAuth.hs b/src/Servant/Client/Core/Internal/BasicAuth.hs --- a/src/Servant/Client/Core/Internal/BasicAuth.hs +++ b/src/Servant/Client/Core/Internal/BasicAuth.hs @@ -6,11 +6,16 @@ module Servant.Client.Core.Internal.BasicAuth where -import Data.ByteString.Base64 (encode) -import Data.Monoid ((<>)) -import Data.Text.Encoding (decodeUtf8) -import Servant.API.BasicAuth (BasicAuthData (BasicAuthData)) -import Servant.Client.Core.Internal.Request (Request, addHeader) +import Data.ByteString.Base64 + (encode) +import Data.Monoid + ((<>)) +import Data.Text.Encoding + (decodeUtf8) +import Servant.API.BasicAuth + (BasicAuthData (BasicAuthData)) +import Servant.Client.Core.Internal.Request + (Request, addHeader) -- | Authenticate a request using Basic Authentication basicAuthReq :: BasicAuthData -> Request -> Request diff --git a/src/Servant/Client/Core/Internal/ClientF.hs b/src/Servant/Client/Core/Internal/ClientF.hs --- a/src/Servant/Client/Core/Internal/ClientF.hs +++ b/src/Servant/Client/Core/Internal/ClientF.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveFunctor #-} module Servant.Client.Core.Internal.ClientF where -import Servant.Client.Core.Internal.Request +import Servant.Client.Core.Internal.Request data ClientF a = RunRequest Request (Response -> a) diff --git a/src/Servant/Client/Core/Internal/Generic.hs b/src/Servant/Client/Core/Internal/Generic.hs --- a/src/Servant/Client/Core/Internal/Generic.hs +++ b/src/Servant/Client/Core/Internal/Generic.hs @@ -1,19 +1,18 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -#include "overlapping-compat.h" +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module Servant.Client.Core.Internal.Generic where -import Generics.SOP (Code, Generic, I(..), NP(..), NS(Z), SOP(..), to) -import Servant.API ((:<|>)(..)) +import Generics.SOP + (Code, Generic, I (..), NP (..), NS (Z), SOP (..), to) +import Servant.API + ((:<|>) (..)) -- | This class allows us to match client structure with client functions -- produced with 'client' without explicit pattern-matching. @@ -140,7 +139,7 @@ => GClientList (a :<|> b) acc where gClientList (a :<|> b) acc = gClientList a (gClientList b acc) -instance OVERLAPPABLE_ (ClientList client acc ~ (client ': acc)) +instance {-# OVERLAPPABLE #-} (ClientList client acc ~ (client ': acc)) => GClientList client acc where gClientList c acc = I c :* acc diff --git a/src/Servant/Client/Core/Internal/HasClient.hs b/src/Servant/Client/Core/Internal/HasClient.hs --- a/src/Servant/Client/Core/Internal/HasClient.hs +++ b/src/Servant/Client/Core/Internal/HasClient.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -12,56 +11,43 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#include "overlapping-compat.h" module Servant.Client.Core.Internal.HasClient where -import Prelude () +import Prelude () import Prelude.Compat -import Control.Concurrent (newMVar, modifyMVar) -import Data.Foldable (toList) +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL -import Data.List (foldl') -import Data.Proxy (Proxy (Proxy)) -import Data.Semigroup ((<>)) -import Data.Sequence (fromList) -import Data.String (fromString) -import Data.Text (Text, pack) -import GHC.TypeLits (KnownSymbol, symbolVal) +import Data.Foldable + (toList) +import Data.List + (foldl') +import Data.Proxy + (Proxy (Proxy)) +import Data.Sequence + (fromList) +import Data.String + (fromString) +import Data.Text + (Text, pack) +import GHC.TypeLits + (KnownSymbol, symbolVal) import qualified Network.HTTP.Types as H -import Servant.API ((:<|>) ((:<|>)), (:>), - AuthProtect, BasicAuth, - BasicAuthData, - BuildHeadersTo (..), - BuildFromStream (..), - ByteStringParser (..), - Capture', CaptureAll, - Description, EmptyAPI, - FramingUnrender (..), - Header', Headers (..), - HttpVersion, IsSecure, - MimeRender (mimeRender), - MimeUnrender (mimeUnrender), - NoContent (NoContent), - QueryFlag, QueryParam', - QueryParams, Raw, - ReflectMethod (..), - RemoteHost, ReqBody', - ResultStream(..), - SBoolI, - Stream, - Summary, ToHttpApiData, - Vault, Verb, - WithNamedContext, - contentType, - getHeadersHList, - getResponse, - toQueryParam, - toUrlPiece) -import Servant.API.ContentTypes (contentTypes) -import Servant.API.Modifiers (FoldRequired, - RequiredArgument, - foldRequiredArgument) +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) +import Servant.API.ContentTypes + (contentTypes) +import Servant.API.Modifiers + (FoldRequired, RequiredArgument, foldRequiredArgument) +import qualified Servant.Types.SourceT as S import Servant.Client.Core.Internal.Auth import Servant.Client.Core.Internal.BasicAuth @@ -216,7 +202,7 @@ hoistClientMonad pm _ f cl = \as -> hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as) -instance OVERLAPPABLE_ +instance {-# OVERLAPPABLE #-} -- Note [Non-Empty Content Types] ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) ) => HasClient m (Verb method status cts' a) where @@ -233,7 +219,7 @@ hoistClientMonad _ _ f ma = f ma -instance OVERLAPPING_ +instance {-# OVERLAPPING #-} ( RunClient m, ReflectMethod method ) => HasClient m (Verb method status cts NoContent) where type Client m (Verb method status cts NoContent) @@ -245,7 +231,7 @@ hoistClientMonad _ _ f ma = f ma -instance OVERLAPPING_ +instance {-# OVERLAPPING #-} -- Note [Non-Empty Content Types] ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls , ReflectMethod method, cts' ~ (ct ': cts) @@ -268,7 +254,7 @@ hoistClientMonad _ _ f ma = f ma -instance OVERLAPPING_ +instance {-# OVERLAPPING #-} ( RunClient m, BuildHeadersTo ls, ReflectMethod method ) => HasClient m (Verb method status cts (Headers ls NoContent)) where type Client m (Verb method status cts (Headers ls NoContent)) @@ -282,56 +268,25 @@ hoistClientMonad _ _ f ma = f ma -instance OVERLAPPABLE_ - ( RunClient m, MimeUnrender ct a, ReflectMethod method, - FramingUnrender framing a, BuildFromStream a (f a) - ) => HasClient m (Stream method status framing ct (f a)) where - - type Client m (Stream method status framing ct (f a)) = m (f a) - - clientWithRoute _pm Proxy req = do - sresp <- streamingRequest req - { requestAccept = fromList [contentType (Proxy :: Proxy ct)] - , requestMethod = reflectMethod (Proxy :: Proxy method) - } - return . buildFromStream $ ResultStream $ \k -> - runStreamingResponse sresp $ \gres -> do - let reader = responseBody gres - let unrender = unrenderFrames (Proxy :: Proxy framing) (Proxy :: Proxy a) - loop bs = do - res <- BL.fromStrict <$> reader - if BL.null res - then return $ parseEOF unrender res - else let sofar = (bs <> res) - in case parseIncremental unrender sofar of - Just x -> return x - Nothing -> loop sofar - (frameParser, remainder) <- loop BL.empty - state <- newMVar remainder - let frameLoop bs = do - res <- BL.fromStrict <$> reader - let addIsEmptyInfo (a, r) = (r, (a, BL.null r && BL.null res)) - if BL.null res - then if BL.null bs - then return ("", (Right "", True)) - else return . addIsEmptyInfo $ parseEOF frameParser bs - else let sofar = (bs <> res) - in case parseIncremental frameParser sofar of - Just x -> return $ addIsEmptyInfo x - Nothing -> frameLoop sofar +instance {-# OVERLAPPABLE #-} + ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method, + FramingUnrender framing, FromSourceIO chunk a + ) => HasClient m (Stream method status framing ct a) where - go = processResult <$> modifyMVar state frameLoop - processResult (Right bs,isDone) = - if BL.null bs && isDone - then Nothing - else Just $ case mimeUnrender (Proxy :: Proxy ct) bs :: Either String a of - Left err -> Left err - Right x -> Right x - processResult (Left err, _) = Just (Left err) - k go + type Client m (Stream method status framing ct a) = m a hoistClientMonad _ _ f ma = f ma + 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 -- an additional argument of the type specified by your 'Header', @@ -581,6 +536,18 @@ hoistClientMonad pm _ f cl = \a -> hoistClientMonad pm (Proxy :: Proxy api) f (cl a) + +instance + ( HasClient m api + ) => HasClient m (StreamBody' mods framing ctype a :> api) + where + + type Client m (StreamBody' mods framing ctype a :> api) = a -> Client m api + + hoistClientMonad pm _ f cl = \a -> + hoistClientMonad pm (Proxy :: Proxy api) f (cl a) + + clientWithRoute _pm Proxy _req _body = error "HasClient @StreamBody" -- | Make the querying function append @path@ to the request path. instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where diff --git a/src/Servant/Client/Core/Internal/Request.hs b/src/Servant/Client/Core/Internal/Request.hs --- a/src/Servant/Client/Core/Internal/Request.hs +++ b/src/Servant/Client/Core/Internal/Request.hs @@ -12,26 +12,36 @@ module Servant.Client.Core.Internal.Request where -import Prelude () +import Prelude () import Prelude.Compat -import Control.Monad.Catch (Exception) +import Control.DeepSeq + (NFData (..)) +import Control.Monad.Catch + (Exception) import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Lazy as LBS -import Data.Int (Int64) -import Data.Semigroup ((<>)) +import Data.Int + (Int64) +import Data.Semigroup + ((<>)) import qualified Data.Sequence as Seq -import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) -import Data.Typeable (Typeable) -import GHC.Generics (Generic) -import Network.HTTP.Media (MediaType) -import Network.HTTP.Types (Header, HeaderName, HttpVersion, - Method, QueryItem, Status, http11, - methodGet) -import Web.HttpApiData (ToHttpApiData, toEncodedUrlPiece, - toHeader) +import Data.Text + (Text) +import Data.Text.Encoding + (encodeUtf8) +import Data.Typeable + (Typeable) +import GHC.Generics + (Generic) +import Network.HTTP.Media + (MediaType, mainType, parameters, subType) +import Network.HTTP.Types + (Header, HeaderName, HttpVersion (..), Method, QueryItem, + Status (..), http11, methodGet) +import Servant.API + (ToHttpApiData, toEncodedUrlPiece, toHeader) -- | A type representing possible errors in a request -- @@ -51,6 +61,20 @@ instance Exception ServantError +instance NFData ServantError where + rnf (FailureResponse res) = rnf res + rnf (DecodeFailure err res) = rnf err `seq` rnf res + rnf (UnsupportedContentType mt' res) = + mediaTypeRnf mt' `seq` + rnf res + where + mediaTypeRnf mt = + rnf (mainType mt) `seq` + rnf (subType mt) `seq` + rnf (parameters mt) + rnf (InvalidContentTypeHeader res) = rnf res + rnf (ConnectionError err) = rnf err + data RequestF a = Request { requestPath :: a , requestQueryString :: Seq.Seq QueryItem @@ -80,8 +104,18 @@ , responseBody :: a } deriving (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable) +instance NFData a => NFData (GenResponse a) where + rnf (Response sc hs hv body) = + rnfStatus sc `seq` + rnf hs `seq` + rnfHttpVersion hv `seq` + rnf body + where + rnfStatus (Status code msg) = rnf code `seq` rnf msg + rnfHttpVersion (HttpVersion _ _) = () -- HttpVersion fields are strict + type Response = GenResponse LBS.ByteString -newtype StreamingResponse = StreamingResponse { runStreamingResponse :: forall a. (GenResponse (IO BS.ByteString) -> IO a) -> IO a } +type StreamingResponse = GenResponse (IO BS.ByteString) -- A GET request to the top-level path defaultRequest :: Request diff --git a/src/Servant/Client/Core/Internal/RunClient.hs b/src/Servant/Client/Core/Internal/RunClient.hs --- a/src/Servant/Client/Core/Internal/RunClient.hs +++ b/src/Servant/Client/Core/Internal/RunClient.hs @@ -6,31 +6,36 @@ -- | Types for possible backends to run client-side `Request` queries module Servant.Client.Core.Internal.RunClient where -import Prelude () +import Prelude () import Prelude.Compat -import Control.Monad (unless) -import Control.Monad.Free (Free (..), liftF) -import Data.Foldable (toList) -import Data.Proxy (Proxy) +import Control.Monad + (unless) +import Control.Monad.Free + (Free (..), liftF) +import Data.Foldable + (toList) +import Data.Proxy + (Proxy) import qualified Data.Text as T -import Network.HTTP.Media (MediaType, matches, - parseAccept, (//)) -import Servant.API (MimeUnrender, - contentTypes, - mimeUnrender) +import Network.HTTP.Media + (MediaType, matches, parseAccept, (//)) +import Servant.API + (MimeUnrender, contentTypes, mimeUnrender) -import Servant.Client.Core.Internal.Request (Request, Response, GenResponse (..), - StreamingResponse (..), - ServantError (..)) import Servant.Client.Core.Internal.ClientF +import Servant.Client.Core.Internal.Request + (GenResponse (..), Request, Response, ServantError (..), + StreamingResponse) 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 @@ -53,5 +58,10 @@ 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/src/Servant/Client/Core/Reexport.hs b/src/Servant/Client/Core/Reexport.hs --- a/src/Servant/Client/Core/Reexport.hs +++ b/src/Servant/Client/Core/Reexport.hs @@ -28,6 +28,6 @@ import Servant.Client.Core.Internal.BaseUrl -import Servant.Client.Core.Internal.HasClient import Servant.Client.Core.Internal.Generic +import Servant.Client.Core.Internal.HasClient import Servant.Client.Core.Internal.Request diff --git a/src/Servant/Client/Free.hs b/src/Servant/Client/Free.hs --- a/src/Servant/Client/Free.hs +++ b/src/Servant/Client/Free.hs @@ -1,15 +1,18 @@ -{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, GADTs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} module Servant.Client.Free ( client, ClientF (..), module Servant.Client.Core.Reexport, ) where -import Data.Proxy (Proxy (..)) -import Control.Monad.Free -import Servant.Client.Core -import Servant.Client.Core.Reexport -import Servant.Client.Core.Internal.ClientF +import Control.Monad.Free +import Data.Proxy + (Proxy (..)) +import Servant.Client.Core +import Servant.Client.Core.Internal.ClientF +import Servant.Client.Core.Reexport client :: HasClient (Free ClientF) api => Proxy api -> Client (Free ClientF) api client api = api `clientIn` (Proxy :: Proxy (Free ClientF))