servant-client-core 0.19 → 0.20.3.0
raw patch · 13 files changed
Files
- CHANGELOG.md +48/−0
- servant-client-core.cabal +120/−71
- src/Servant/Client/Core.hs +1/−0
- src/Servant/Client/Core/Auth.hs +3/−2
- src/Servant/Client/Core/BaseUrl.hs +6/−9
- src/Servant/Client/Core/HasClient.hs +233/−82
- src/Servant/Client/Core/MultiVerb/ResponseUnrender.hs +131/−0
- src/Servant/Client/Core/Request.hs +31/−8
- src/Servant/Client/Core/Response.hs +7/−2
- src/Servant/Client/Core/RunClient.hs +1/−0
- src/Servant/Client/Core/ServerSentEvents.hs +304/−0
- src/Servant/Client/Generic.hs +1/−0
- test/Servant/Client/Core/ServerSentEventsSpec.hs +100/−0
CHANGELOG.md view
@@ -3,6 +3,54 @@ Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions. +0.20.3.0+--------++- Server-sent events (SSE) for client-side [#1811](https://github.com/haskell-servant/servant/issues/1811)++ Implement Server-sent events (SSE) for the Servant client using a new+ combinator "ServerSentEvents". The raw event messages, accumulated events and+ JSON-processed events can be exposed.++- Integrate MultiVerb [#1766](https://github.com/haskell-servant/servant/pull/1766) [#1804](https://github.com/haskell-servant/servant/pull/1804)++ Expose MultiVerb, a more ergonomic way of defining endpoints that return+ many kinds of responses. Read the cookbook https://docs.servant.dev/en/master/cookbook/multiverb/MultiVerb.html++- Add public re-export of renderCurlBasePath lens [#1706](https://github.com/haskell-servant/servant/pull/1706)+- Remove GHC <= 8.10.7 from the support window [#1778](https://github.com/haskell-servant/servant/pull/1778)+- Add Servant.API.Range type [#1805](https://github.com/haskell-servant/servant/pull/1805)+- Add missing HasLink instance for DeepQuery [#1784](https://github.com/haskell-servant/servant/issues/1784)+- Add Host API combinator [#1800](https://github.com/haskell-servant/servant/pull/1800)++ Adding a Host combinator allows servant users to select APIs according+ to the Host header provided by clients.++0.20.2+----++- Full query string helpers [#1604](https://github.com/haskell-servant/servant/pull/1604)+ This involves exporting `setQueryString` from Servant.Client.Core.Request.++0.20+----++- Escape special chars in QueryParams. [#1584](https://github.com/haskell-servant/servant/issues/1584) [#1597](https://github.com/haskell-servant/servant/pull/1597)++ Escape special chars in QueryParam (`:@&=+$`) in servant-client. Note that this+ mean binary data will not work as is, and so reverts the functionality in+ [#1432](https://github.com/haskell-servant/servant/pull/1432).++- Handle Cookies correctly for RunStreamingClient [#1605](https://github.com/haskell-servant/servant/issues/1605) [#1606](https://github.com/haskell-servant/servant/pull/1606)++ Makes `performWithStreamingRequest` take into consideration the+ CookieJar, which it previously didn't.++- Fix the handling of multiple headers with the same name. [#1666](https://github.com/haskell-servant/servant/pull/1666)++ servant-client no longer concatenates the values of response headers with the same name.+ This fixes an issue with parsing multiple `Set-Cookie` headers.+ 0.19 ----
servant-client-core.cabal view
@@ -1,111 +1,160 @@-cabal-version: 2.2-name: servant-client-core-version: 0.19+cabal-version: 3.0+name: servant-client-core+version: 0.20.3.0+synopsis:+ Core functionality and class for client function generation for servant APIs -synopsis: Core functionality and class for client function generation for servant APIs-category: Servant, Web+category: Servant, Web description: This library provides backend-agnostic generation of client functions. For more information, see the README. -homepage: http://docs.servant.dev/-bug-reports: http://github.com/haskell-servant/servant/issues-license: BSD-3-Clause-license-file: LICENSE-author: Servant Contributors-maintainer: haskell-servant-maintainers@googlegroups.com-copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors-build-type: Simple-tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1- , GHCJS ==8.6.0.1+homepage: http://docs.servant.dev/+bug-reports: http://github.com/haskell-servant/servant/issues+license: BSD-3-Clause+license-file: LICENSE+author: Servant Contributors+maintainer: haskell-servant-maintainers@googlegroups.com+copyright:+ 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors +build-type: Simple+tested-with: GHC ==9.2.8 || ==9.4.8 || ==9.6.6 || ==9.8.4 || ==9.10.1 || ==9.12.1+ extra-source-files: CHANGELOG.md README.md source-repository head- type: git- location: http://github.com/haskell-servant/servant.git+ type: git+ location: http://github.com/haskell-servant/servant.git +common extensions+ default-extensions:+ AllowAmbiguousTypes+ ConstraintKinds+ DataKinds+ DeriveAnyClass+ DeriveDataTypeable+ DeriveFunctor+ DeriveGeneric+ DerivingStrategies+ DerivingVia+ DuplicateRecordFields+ ExplicitNamespaces+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ InstanceSigs+ KindSignatures+ LambdaCase+ MultiParamTypeClasses+ NoStarIsType+ OverloadedLabels+ OverloadedStrings+ PackageImports+ PolyKinds+ RankNTypes+ RecordWildCards+ QuantifiedConstraints+ ScopedTypeVariables+ StrictData+ TupleSections+ TypeApplications+ TypeFamilies+ TypeOperators+ UndecidableInstances+ ViewPatterns++ default-language: Haskell2010++common ghc-options+ ghc-options:+ -Wall -Wcompat -Widentities -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints+ -fhide-source-paths -Wno-unused-do-bind -fdicts-strict+ -Wno-unticked-promoted-constructors -Werror=unused-imports+ -Wunused-packages+ library+ import: extensions+ import: ghc-options exposed-modules:- Servant.Client.Core- Servant.Client.Free- Servant.Client.Generic- Servant.Client.Core.Reexport- Servant.Client.Core.Auth- Servant.Client.Core.BaseUrl- Servant.Client.Core.BasicAuth- Servant.Client.Core.ClientError- Servant.Client.Core.HasClient- Servant.Client.Core.Request- Servant.Client.Core.Response- Servant.Client.Core.RunClient+ Servant.Client.Core+ Servant.Client.Core.Auth+ Servant.Client.Core.BaseUrl+ Servant.Client.Core.BasicAuth+ Servant.Client.Core.ClientError+ Servant.Client.Core.HasClient+ Servant.Client.Core.Reexport+ Servant.Client.Core.Request+ Servant.Client.Core.Response+ Servant.Client.Core.MultiVerb.ResponseUnrender+ Servant.Client.Core.RunClient+ Servant.Client.Core.ServerSentEvents+ Servant.Client.Free+ Servant.Client.Generic - other-modules:- Servant.Client.Core.Internal+ other-modules: Servant.Client.Core.Internal -- 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.9 && < 4.16- , bytestring >= 0.10.8.1 && < 0.12- , constraints >= 0.2 && < 0.14- , containers >= 0.5.7.1 && < 0.7- , deepseq >= 1.4.2.0 && < 1.5- , text >= 1.2.3.0 && < 1.3- , transformers >= 0.5.2.0 && < 0.6- , template-haskell >= 2.11.1.0 && < 2.18-- if !impl(ghc >= 8.2)- build-depends:- bifunctors >= 5.5.3 && < 5.6+ , attoparsec >= 0.13.2.2 && < 0.15+ , base >= 4.16.4.0 && < 4.22+ , bytestring >=0.11 && <0.13+ , constraints >=0.2 && <0.15+ , containers >=0.6.5.1 && <0.9+ , deepseq >=1.4.2.0 && <1.6+ , template-haskell >=2.11.1.0 && <2.24+ , text >=1.2.3.0 && <2.2 -- Servant dependencies- build-depends:- servant >= 0.19+ build-depends: servant >=0.20.2 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. build-depends:- aeson >= 1.4.1.0 && < 3- , base-compat >= 0.10.5 && < 0.12- , base64-bytestring >= 1.0.0.1 && < 1.3- , exceptions >= 0.10.0 && < 0.11- , free >= 5.1 && < 5.2- , http-media >= 0.7.1.3 && < 0.9- , http-types >= 0.12.2 && < 0.13- , network-uri >= 2.6.1.0 && < 2.7- , safe >= 0.3.17 && < 0.4- , sop-core >= 0.4.0.0 && < 0.6+ , aeson >=1.4.1.0 && <3+ , base-compat >=0.10.5 && <0.15+ , base64-bytestring >=1.0.0.1 && <1.3+ , exceptions >=0.10.0 && <0.11+ , free >=5.1 && <5.3+ , http-media >=0.7.1.3 && <0.9+ , http-types >=0.12.2 && <0.13+ , network-uri >=2.6.1.0 && <2.7+ , safe >=0.3.17 && <0.4+ , sop-core >=0.4.0.0 && <0.6 - hs-source-dirs: src- default-language: Haskell2010- ghc-options: -Wall+ hs-source-dirs: src test-suite spec- type: exitcode-stdio-1.0- ghc-options: -Wall- default-language: Haskell2010- hs-source-dirs: test- main-is: Spec.hs+ import: extensions+ import: ghc-options+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs other-modules:- Servant.Client.Core.Internal.BaseUrlSpec- Servant.Client.Core.RequestSpec+ Servant.Client.Core.Internal.BaseUrlSpec+ Servant.Client.Core.RequestSpec+ Servant.Client.Core.ServerSentEventsSpec -- Dependencies inherited from the library. No need to specify bounds. build-depends:- base+ , base , base-compat+ , bytestring+ , transformers+ , servant , servant-client-core -- Additional dependencies build-depends:- deepseq >= 1.4.2.0 && < 1.5- , hspec >= 2.6.0 && < 2.9- , QuickCheck >= 2.12.6.1 && < 2.15+ , deepseq >=1.4.2.0 && <1.6+ , hspec >=2.6.0 && <2.12+ , QuickCheck >=2.12.6.1 && <2.16 - build-tool-depends:- hspec-discover:hspec-discover >= 2.6.0 && <2.9+ build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.12
src/Servant/Client/Core.hs view
@@ -59,6 +59,7 @@ , appendToPath , setRequestBodyLBS , setRequestBody+ , encodeQueryParamValue ) where import Servant.Client.Core.Auth import Servant.Client.Core.BaseUrl
src/Servant/Client/Core/Auth.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -10,6 +9,8 @@ mkAuthenticatedRequest, ) where +import Data.Kind (Type)+ import Servant.Client.Core.Request (Request) @@ -18,7 +19,7 @@ -- to a request -- -- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE-type family AuthClientData a :: *+type family AuthClientData a :: Type -- | For better type inference and to avoid usage of a data family, we newtype -- wrap the combination of some 'AuthClientData' and a function to add authentication
src/Servant/Client/Core/BaseUrl.hs view
@@ -1,7 +1,4 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveLift #-}-{-# LANGUAGE ViewPatterns #-} module Servant.Client.Core.BaseUrl ( BaseUrl (..), Scheme (..),@@ -21,7 +18,7 @@ withText) import Data.Data (Data)-import Data.List+import qualified Data.List as List import qualified Data.Text as T import GHC.Generics import Language.Haskell.TH.Syntax@@ -57,7 +54,7 @@ where s ('/':x) = x s x = x --- | >>> traverse_ (LBS8.putStrLn . encode) $ parseBaseUrl "api.example.com"+-- | >>> traverse_ (LBS8.putStrLn . encode) (parseBaseUrl "api.example.com" :: [BaseUrl]) -- "http://api.example.com" instance ToJSON BaseUrl where toJSON = toJSON . showBaseUrl@@ -72,8 +69,8 @@ -- | >>> :{ -- traverse_ (LBS8.putStrLn . encode) $ do--- u1 <- parseBaseUrl "api.example.com"--- u2 <- parseBaseUrl "example.com"+-- u1 <- parseBaseUrl "api.example.com" :: [BaseUrl]+-- u2 <- parseBaseUrl "example.com" :: [BaseUrl] -- return $ Map.fromList [(u1, 'x'), (u2, 'y')] -- :} -- {"http://api.example.com":"x","http://example.com":"y"}@@ -91,7 +88,7 @@ showBaseUrl (BaseUrl urlscheme host port path) = schemeString ++ "//" ++ host ++ (portString </> path) where- a </> b = if "/" `isPrefixOf` b || null b then a ++ b else a ++ '/':b+ a </> b = if "/" `List.isPrefixOf` b || null b then a ++ b else a ++ '/':b schemeString = case urlscheme of Http -> "http:" Https -> "https:"@@ -128,7 +125,7 @@ return (BaseUrl Https host port path) Just (URI "https:" (Just (URIAuth "" host "")) path "" "") -> return (BaseUrl Https host 443 path)- _ -> if "://" `isInfixOf` s+ _ -> if "://" `List.isInfixOf` s then throwM (InvalidBaseUrlException $ "Invalid base URL: " ++ s) else parseBaseUrl ("http://" ++ s) where
src/Servant/Client/Core/HasClient.hs view
@@ -1,19 +1,6 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-+{-# LANGUAGE CPP #-}+{-# LANGUAGE ApplicativeDo #-}+{-# OPTIONS_GHC -Wno-missing-methods #-} module Servant.Client.Core.HasClient ( clientIn, HasClient (..),@@ -23,6 +10,7 @@ (/:), foldMapUnion, matchUnion,+ fromSomeClientResponse ) where import Prelude ()@@ -30,22 +18,22 @@ import Control.Arrow (left, (+++))+import qualified Data.Text as Text import Control.Monad (unless)-import qualified Data.ByteString as BS-import Data.ByteString.Builder- (toLazyByteString)-import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy as BSL import Data.Either (partitionEithers) import Data.Constraint (Dict(..)) import Data.Foldable (toList)-import Data.List- (foldl')+import Data.Kind+ (Type)+import qualified Data.List as List import Data.Sequence (fromList) import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8) import Network.HTTP.Media (MediaType, matches, parseAccept) import qualified Network.HTTP.Media as Media@@ -57,50 +45,59 @@ import Data.SOP.NP (NP (..), cpure_NP) import Data.SOP.NS- (NS (S))+ (NS (..)) import Data.String (fromString) import Data.Text (Text, pack)-import Data.Proxy- (Proxy (Proxy)) import GHC.TypeLits (KnownNat, KnownSymbol, TypeError, symbolVal) import Network.HTTP.Types (Status) import qualified Network.HTTP.Types as H import Servant.API- ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,- BuildHeadersTo (..), Capture', CaptureAll, Description,- EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..),- FromSourceIO (..), Header', Headers (..), HttpVersion,- IsSecure, MimeRender (mimeRender),- MimeUnrender (mimeUnrender), NoContent (NoContent),- NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,- ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,- StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,- Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,- getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)+ ((:<|>) ((:<|>)), (:>),+ BuildHeadersTo (..),+ EmptyAPI,+ FromSourceIO (..),+ IsSecure,+ MimeUnrender (mimeUnrender),+ NoContentVerb,+ ReflectMethod (..),+ StreamBody',+ Verb,+ getResponse, AuthProtect, BasicAuth, BasicAuthData, Capture', CaptureAll, DeepQuery, Description, Fragment, FramingRender (..), FramingUnrender (..), Header', Headers (..), HttpVersion, MimeRender (mimeRender), NoContent (NoContent), QueryFlag, QueryParam', QueryParams, QueryString, Raw, RawM, RemoteHost, ReqBody', SBoolI, Stream, Summary, ToHttpApiData, ToSourceIO (..), Vault, WithNamedContext, WithResource, WithStatus (..), contentType, getHeadersHList, toEncodedUrlPiece, NamedRoutes, Host) import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi , GenericServant, toServant, fromServant) import Servant.API.ContentTypes- (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))+ (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender), EventStream)+import Servant.API.QueryString (ToDeepQuery(..), generateDeepParam) import Servant.API.Status (statusFromNat)-import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)+import Servant.API.TypeLevel (FragmentUnique, AtMostOneFragment) import Servant.API.Modifiers (FoldRequired, RequiredArgument, foldRequiredArgument) import Servant.API.TypeErrors import Servant.API.UVerb (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion)+import Servant.API.ServerSentEvents+ (EventKind (JsonEvent, RawEvent), ServerSentEvents')+import Servant.API.Stream+ (NoFraming) import Servant.Client.Core.Auth import Servant.Client.Core.BasicAuth import Servant.Client.Core.ClientError import Servant.Client.Core.Request import Servant.Client.Core.Response+import Servant.Client.Core.MultiVerb.ResponseUnrender+import qualified Servant.Client.Core.Response as Response import Servant.Client.Core.RunClient+import Servant.Client.Core.ServerSentEvents+import Servant.API.MultiVerb+import qualified Network.HTTP.Media as M+import Data.Typeable -- * Accessing APIs as a Client @@ -122,7 +119,6 @@ clientIn :: HasClient m api => Proxy api -> Proxy m -> Client m api clientIn p pm = clientWithRoute pm p defaultRequest - -- | This class lets us define how each API combinator influences the creation -- of an HTTP request. --@@ -130,7 +126,7 @@ -- combinators that you want to support client-generation, you can ignore this -- class. class RunClient m => HasClient m api where- type Client (m :: * -> *) (api :: *) :: *+ type Client (m :: Type -> Type) (api :: Type) :: Type clientWithRoute :: Proxy m -> Proxy api -> Request -> Client m api hoistClientMonad :: Proxy m@@ -139,7 +135,6 @@ -> Client mon api -> Client mon' api - -- | A client querying function for @a ':<|>' b@ will actually hand you -- one function for querying @a@ and another one for querying @b@, -- stitching them together with ':<|>', which really is just like a pair.@@ -200,7 +195,7 @@ -- > getBook :: Text -> ClientM Book -- > getBook = client myApi -- > -- then you can just use "getBook" to query that endpoint-instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)+instance (ToHttpApiData a, HasClient m api) => HasClient m (Capture' mods capture a :> api) where type Client m (Capture' mods capture a :> api) =@@ -210,7 +205,7 @@ clientWithRoute pm (Proxy :: Proxy api) (appendToPath p req) - where p = (toUrlPiece val)+ where p = toEncodedUrlPiece val hoistClientMonad pm _ f cl = \a -> hoistClientMonad pm (Proxy :: Proxy api) f (cl a)@@ -235,7 +230,7 @@ -- > getSourceFile :: [Text] -> ClientM SourceFile -- > getSourceFile = client myApi -- > -- then you can use "getSourceFile" to query that endpoint-instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)+instance (ToHttpApiData a, HasClient m sublayout) => HasClient m (CaptureAll capture a :> sublayout) where type Client m (CaptureAll capture a :> sublayout) =@@ -243,9 +238,9 @@ clientWithRoute pm Proxy req vals = clientWithRoute pm (Proxy :: Proxy sublayout)- (foldl' (flip appendToPath) req ps)+ (List.foldl' (flip appendToPath) req ps) - where ps = map (toUrlPiece) vals+ where ps = map toEncodedUrlPiece vals hoistClientMonad pm _ f cl = \as -> hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)@@ -335,8 +330,8 @@ data ClientParseError = ClientParseError MediaType String | ClientStatusMismatch | ClientNoMatchingStatus deriving (Eq, Show) -class UnrenderResponse (cts :: [*]) (a :: *) where- unrenderResponse :: Seq.Seq H.Header -> BL.ByteString -> Proxy cts+class UnrenderResponse (cts :: [Type]) (a :: Type) where+ unrenderResponse :: Seq.Seq H.Header -> BSL.ByteString -> Proxy cts -> [Either (MediaType, String) a] instance {-# OVERLAPPABLE #-} AllMimeUnrender cts a => UnrenderResponse cts a where@@ -378,15 +373,13 @@ method = reflectMethod $ Proxy @method acceptStatus = statuses (Proxy @as)- response <- runRequestAcceptStatus (Just acceptStatus) request {requestMethod = method, requestAccept = accept}+ response@Response{responseBody=body, responseStatusCode=status, responseHeaders=headers}+ <- runRequestAcceptStatus (Just acceptStatus) (request {requestMethod = method, requestAccept = accept}) responseContentType <- checkContentTypeHeader response unless (any (matches responseContentType) accept) $ do throwClientError $ UnsupportedContentType responseContentType response - let status = responseStatusCode response- body = responseBody response- headers = responseHeaders response- res = tryParsers status $ mimeUnrenders (Proxy @contentTypes) headers body+ let res = tryParsers status $ mimeUnrenders (Proxy @contentTypes) headers body case res of Left errors -> throwClientError $ DecodeFailure (T.pack (show errors)) response Right x -> return x@@ -410,7 +403,7 @@ All (UnrenderResponse cts) xs => Proxy cts -> Seq.Seq H.Header ->- BL.ByteString ->+ BSL.ByteString -> NP ([] :.: Either (MediaType, String)) xs mimeUnrenders ctp headers body = cpure_NP (Proxy @(UnrenderResponse cts))@@ -427,10 +420,10 @@ hoistClientMonad _ _ f ma = f ma - clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do- let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk+ clientWithRoute _pm Proxy req = withStreamingRequest req' $ \Response{responseBody=body} -> do+ let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BSL.ByteString -> Either String chunk framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender'- return $ fromSourceIO $ framingUnrender' $ responseBody gres+ fromSourceIO $ framingUnrender' body where req' = req { requestAccept = fromList [contentType (Proxy :: Proxy ct)]@@ -447,13 +440,14 @@ hoistClientMonad _ _ f ma = f ma - clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do- let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk+ clientWithRoute _pm Proxy req = withStreamingRequest req' $ + \Response{responseBody=body, responseHeaders=headers} -> do+ let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BSL.ByteString -> Either String chunk framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender'- val = fromSourceIO $ framingUnrender' $ responseBody gres+ val <- fromSourceIO $ framingUnrender' body return $ Headers { getResponse = val- , getHeadersHList = buildHeadersTo . toList $ responseHeaders gres+ , getHeadersHList = buildHeadersTo $ toList headers } where@@ -462,6 +456,63 @@ , requestMethod = reflectMethod (Proxy :: Proxy method) } +type SseClientDelegate method status =+ Stream method status NoFraming EventStream++instance+ ( RunClient m+ , HasClient m (SseClientDelegate method status (EventMessageStreamT IO))+ )+ => HasClient m (ServerSentEvents' method status 'RawEvent EventMessage) where+ type Client m (ServerSentEvents' method status 'RawEvent EventMessage) =+ Client m (SseClientDelegate method status (EventMessageStreamT IO))++ hoistClientMonad p _ =+ hoistClientMonad+ p+ (Proxy :: Proxy (SseClientDelegate method status (EventMessageStreamT IO)))++ clientWithRoute p _ =+ clientWithRoute+ p+ (Proxy :: Proxy (SseClientDelegate method status (EventMessageStreamT IO)))++instance+ ( RunClient m+ , HasClient m (SseClientDelegate method status (EventStreamT IO))+ )+ => HasClient m (ServerSentEvents' method status 'RawEvent (Event a)) where+ type Client m (ServerSentEvents' method status 'RawEvent (Event a)) =+ Client m (SseClientDelegate method status (EventStreamT IO))++ hoistClientMonad p _ =+ hoistClientMonad+ p+ (Proxy :: Proxy (SseClientDelegate method status (EventStreamT IO)))++ clientWithRoute p _ =+ clientWithRoute+ p+ (Proxy :: Proxy (SseClientDelegate method status (EventStreamT IO)))++instance+ ( RunClient m+ , HasClient m (SseClientDelegate method status (JsonEventStreamT IO a))+ )+ => HasClient m (ServerSentEvents' method status 'JsonEvent a) where+ type Client m (ServerSentEvents' method status 'JsonEvent a) =+ Client m (SseClientDelegate method status (JsonEventStreamT IO a))++ hoistClientMonad p _ =+ hoistClientMonad+ p+ (Proxy :: Proxy (SseClientDelegate method status (JsonEventStreamT IO a)))++ clientWithRoute p _ =+ clientWithRoute+ p+ (Proxy :: Proxy (SseClientDelegate method status (JsonEventStreamT IO a)))+ -- | 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',@@ -505,6 +556,15 @@ hoistClientMonad pm _ f cl = \arg -> hoistClientMonad pm (Proxy :: Proxy api) f (cl arg) +instance (KnownSymbol sym, HasClient m api) => HasClient m (Host sym :> api) where+ type Client m (Host sym :> api) = Client m api++ clientWithRoute pm Proxy req =+ clientWithRoute pm (Proxy :: Proxy api) $+ addHeader "Host" (symbolVal (Proxy :: Proxy sym)) req++ hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)+ -- | Using a 'HttpVersion' combinator in your API doesn't affect the client -- functions. instance HasClient m api@@ -571,7 +631,7 @@ (Proxy :: Proxy mods) add (maybe req add) mparam where add :: a -> Request- add param = appendToQueryString pname (Just $ encodeQueryParam param) req+ add param = appendToQueryString pname (Just $ encodeQueryParamValue param) req pname :: Text pname = pack $ symbolVal (Proxy :: Proxy sym)@@ -579,9 +639,6 @@ hoistClientMonad pm _ f cl = \arg -> hoistClientMonad pm (Proxy :: Proxy api) f (cl arg) -encodeQueryParam :: ToHttpApiData a => a -> BS.ByteString-encodeQueryParam = BL.toStrict . toLazyByteString . toEncodedUrlPiece- -- | If you use a 'QueryParams' in one of your endpoints in your API, -- the corresponding querying function will automatically take -- an additional argument, a list of values of the type specified@@ -617,13 +674,13 @@ clientWithRoute pm Proxy req paramlist = clientWithRoute pm (Proxy :: Proxy api)- (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))+ (List.foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just)) req paramlist' ) where pname = pack $ symbolVal (Proxy :: Proxy sym)- paramlist' = map (Just . encodeQueryParam) paramlist+ paramlist' = map (Just . encodeQueryParamValue) paramlist hoistClientMonad pm _ f cl = \as -> hoistClientMonad pm (Proxy :: Proxy api) f (cl as)@@ -667,6 +724,36 @@ hoistClientMonad pm _ f cl = \b -> hoistClientMonad pm (Proxy :: Proxy api) f (cl b) +instance (HasClient m api)+ => HasClient m (QueryString :> api) where+ type Client m (QueryString :> api) =+ H.Query -> Client m api++ clientWithRoute pm Proxy req query =+ clientWithRoute pm (Proxy :: Proxy api)+ (setQueryString query req)++ hoistClientMonad pm _ f cl = \b ->+ hoistClientMonad pm (Proxy :: Proxy api) f (cl b)++instance (KnownSymbol sym, ToDeepQuery a, HasClient m api)+ => HasClient m (DeepQuery sym a :> api) where+ type Client m (DeepQuery sym a :> api) =+ a -> Client m api++ clientWithRoute pm Proxy req deepObject =+ let params = toDeepQuery deepObject+ withParams = List.foldl' addDeepParam req params+ addDeepParam r' kv =+ let (k, textV) = generateDeepParam paramname kv+ in appendToQueryString k (encodeUtf8 <$> textV) r'+ paramname = pack $ symbolVal (Proxy :: Proxy sym)+ in clientWithRoute pm (Proxy :: Proxy api)+ withParams++ hoistClientMonad pm _ f cl = \b ->+ hoistClientMonad pm (Proxy :: Proxy api) f (cl b)+ -- | Pick a 'Method' and specify where the server you want to query is. You get -- back the full `Response`. instance RunClient m => HasClient m Raw where@@ -679,6 +766,16 @@ hoistClientMonad _ _ f cl = \meth -> f (cl meth) +instance RunClient m => HasClient m RawM where+ type Client m RawM+ = H.Method -> m Response++ clientWithRoute :: Proxy m -> Proxy RawM -> Request -> Client m RawM+ clientWithRoute _pm Proxy req httpMethod = do+ runRequest req { requestMethod = httpMethod }++ hoistClientMonad _ _ f cl = \meth -> f (cl meth)+ -- | If you use a 'ReqBody' in one of your endpoints in your API, -- the corresponding querying function will automatically take -- an additional argument of the type specified by your 'ReqBody'.@@ -734,7 +831,7 @@ sourceIO = framingRender framingP- (mimeRender ctypeP :: chunk -> BL.ByteString)+ (mimeRender ctypeP :: chunk -> BSL.ByteString) (toSourceIO body) -- | Make the querying function append @path@ to the request path.@@ -745,7 +842,7 @@ clientWithRoute pm (Proxy :: Proxy api) (appendToPath p req) - where p = pack $ symbolVal (Proxy :: Proxy path)+ where p = toEncodedUrlPiece $ pack $ symbolVal (Proxy :: Proxy path) hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl @@ -781,6 +878,14 @@ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl +instance HasClient m subapi =>+ HasClient m (WithResource res :> subapi) where++ type Client m (WithResource res :> subapi) = Client m subapi+ clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi)++ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl+ instance ( HasClient m api ) => HasClient m (AuthProtect tag :> api) where type Client m (AuthProtect tag :> api)@@ -806,7 +911,7 @@ -- > getBooks = client myApi -- > -- then you can just use "getBooksBy" to query that endpoint. -- > -- 'getBooks' for all books.-instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api+instance (AtMostOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api ) => HasClient m (Fragment a :> api) where type Client m (Fragment a :> api) = Client m api@@ -827,17 +932,16 @@ hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth) -- | A type that specifies that an API record contains a client implementation.-data AsClientT (m :: * -> *)+data AsClientT (m :: Type -> Type) instance GenericMode (AsClientT m) where type AsClientT m :- api = Client m api - type GClientConstraints api m = ( GenericServant api (AsClientT m) , Client m (ToServantApi api) ~ ToServant api (AsClientT m) ) -class GClient (api :: * -> *) m where+class GClient (api :: Type -> Type) m where gClientProof :: Dict (GClientConstraints api m) instance GClientConstraints api m => GClient api m where@@ -847,6 +951,7 @@ ( forall n. GClient api n , HasClient m (ToServantApi api) , RunClient m+ , ErrorIfNoGeneric api ) => HasClient m (NamedRoutes api) where type Client m (NamedRoutes api) = api (AsClientT m)@@ -879,7 +984,7 @@ -- -- Example: ----- @@+-- @ -- type Api = NamedRoutes RootApi -- -- data RootApi mode = RootApi@@ -899,8 +1004,8 @@ -- rootClient = client api -- -- endpointClient :: ClientM Person--- endpointClient = client // subApi // endpoint--- @@+-- endpointClient = client \/\/ subApi \/\/ endpoint+-- @ (//) :: a -> (a -> b) -> b x // f = f x @@ -911,7 +1016,7 @@ -- -- Example: ----- @@+-- @ -- type Api = NamedRoutes RootApi -- -- data RootApi mode = RootApi@@ -932,15 +1037,61 @@ -- rootClient = client api -- -- hello :: String -> ClientM String--- hello name = rootClient // hello /: name+-- hello name = rootClient \/\/ hello \/: name -- -- endpointClient :: ClientM Person--- endpointClient = client // subApi /: "foobar123" // endpoint--- @@+-- endpointClient = client \/\/ subApi \/: "foobar123" \/\/ endpoint+-- @ (/:) :: (a -> b -> c) -> b -> a -> c (/:) = flip +instance+ ( ResponseListUnrender cs as,+ AllMime cs,+ ReflectMethod method,+ AsUnion as r,+ RunClient m+ ) =>+ HasClient m (MultiVerb method cs as r)+ where+ type Client m (MultiVerb method cs as r) = m r + clientWithRoute _ _ req = do+ response@Response{responseBody=body} <-+ runRequestAcceptStatus+ (Just (responseListStatuses @cs @as))+ req+ { requestMethod = method,+ requestAccept = Seq.fromList accept+ }++ c <- getResponseContentType response+ unless (any (M.matches c) accept) $ do+ throwClientError $ UnsupportedContentType c response++ -- NOTE: support streaming in the future+ let sresp =+ if BSL.null body+ then SomeClientResponse $ response {Response.responseBody = ()}+ else SomeClientResponse response+ case responseListUnrender @cs @as c sresp of+ StatusMismatch -> throwClientError (DecodeFailure "Status mismatch" response)+ UnrenderError e -> throwClientError (DecodeFailure (Text.pack e) response)+ UnrenderSuccess x -> pure (fromUnion @as x)+ where+ accept = allMime (Proxy @cs)+ method = reflectMethod (Proxy @method)++ hoistClientMonad _ _ f = f++getResponseContentType :: (RunClient m) => Response -> m M.MediaType+getResponseContentType response =+ case lookup "Content-Type" (toList (responseHeaders response)) of+ Nothing -> pure $ "application" M.// "octet-stream"+ Just t -> case M.parseAccept t of+ Nothing -> throwClientError $ InvalidContentTypeHeader response+ Just t' -> pure t'+ {- Note [Non-Empty Content Types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Rather than have@@ -971,11 +1122,11 @@ decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m) => Response -> Proxy ct -> m a-decodedAs response ct = do+decodedAs response@Response{responseBody=body} ct = do responseContentType <- checkContentTypeHeader response unless (any (matches responseContentType) accept) $ throwClientError $ UnsupportedContentType responseContentType response- case mimeUnrender ct $ responseBody response of+ case mimeUnrender ct body of Left err -> throwClientError $ DecodeFailure (T.pack err) response Right val -> return val where
+ src/Servant/Client/Core/MultiVerb/ResponseUnrender.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE ApplicativeDo #-}+module Servant.Client.Core.MultiVerb.ResponseUnrender where++import Control.Applicative+import Control.Monad+import Data.Kind (Type)+import Data.SOP+import Data.Typeable+import GHC.TypeLits+import Network.HTTP.Types.Status (Status)+import qualified Data.ByteString.Lazy as BSL+import qualified Network.HTTP.Media as M++import Servant.API.ContentTypes+import Servant.API.MultiVerb+import Servant.API.Status+import Servant.API.UVerb.Union (Union)+import Servant.Client.Core.Response (ResponseF(..))+import qualified Servant.Client.Core.Response as Response+import Servant.API.Stream (SourceIO)+import Data.ByteString (ByteString)++data SomeClientResponse = forall a. Typeable a => SomeClientResponse (ResponseF a)++fromSomeClientResponse + :: forall a m. (Alternative m, Typeable a)+ => SomeClientResponse+ -> m (ResponseF a)+fromSomeClientResponse (SomeClientResponse Response {..}) = do+ body <- maybe empty pure $ cast @_ @a responseBody+ pure $+ Response+ { responseBody = body,+ ..+ }++class ResponseUnrender cs a where+ type ResponseBody a :: Type+ type ResponseStatus a :: Nat+ responseUnrender+ :: M.MediaType+ -> ResponseF (ResponseBody a)+ -> UnrenderResult (ResponseType a)++class (Typeable as) => ResponseListUnrender cs as where+ responseListUnrender+ :: M.MediaType+ -> SomeClientResponse+ -> UnrenderResult (Union (ResponseTypes as))++ responseListStatuses :: [Status]++instance ResponseListUnrender cs '[] where+ responseListUnrender _ _ = StatusMismatch+ responseListStatuses = []++instance+ ( Typeable a,+ Typeable (ResponseBody a),+ ResponseUnrender cs a,+ ResponseListUnrender cs as,+ KnownStatus (ResponseStatus a)+ ) =>+ ResponseListUnrender cs (a ': as)+ where+ responseListUnrender c output =+ Z . I <$> (responseUnrender @cs @a c =<< fromSomeClientResponse output)+ <|> S <$> responseListUnrender @cs @as c output++ responseListStatuses = statusVal (Proxy @(ResponseStatus a)) : responseListStatuses @cs @as++instance+ ( KnownStatus s,+ MimeUnrender ct a+ ) =>+ ResponseUnrender cs (RespondAs (ct :: Type) s desc a)+ where+ type ResponseStatus (RespondAs ct s desc a) = s+ type ResponseBody (RespondAs ct s desc a) = BSL.ByteString++ responseUnrender _ output = do+ guard (responseStatusCode output == statusVal (Proxy @s))+ either UnrenderError UnrenderSuccess $+ mimeUnrender (Proxy @ct) (Response.responseBody output)++instance (KnownStatus s) => ResponseUnrender cs (RespondAs '() s desc ()) where+ type ResponseStatus (RespondAs '() s desc ()) = s+ type ResponseBody (RespondAs '() s desc ()) = ()++ responseUnrender _ output =+ guard (responseStatusCode output == statusVal (Proxy @s))++instance+ (KnownStatus s) + => ResponseUnrender cs (RespondStreaming s desc framing ct)+ where+ type ResponseStatus (RespondStreaming s desc framing ct) = s+ type ResponseBody (RespondStreaming s desc framing ct) = SourceIO ByteString++ responseUnrender _ resp = do+ guard (Response.responseStatusCode resp == statusVal (Proxy @s))+ pure $ Response.responseBody resp++instance+ (AllMimeUnrender cs a, KnownStatus s)+ => ResponseUnrender cs (Respond s desc a) where+ type ResponseStatus (Respond s desc a) = s+ type ResponseBody (Respond s desc a) = BSL.ByteString++ responseUnrender c output = do+ guard (responseStatusCode output == statusVal (Proxy @s))+ let results = allMimeUnrender (Proxy @cs)+ case lookup c results of+ Nothing -> empty+ Just f -> either UnrenderError UnrenderSuccess (f (responseBody output))++instance+ ( AsHeaders xs (ResponseType r) a,+ ServantHeaders hs xs,+ ResponseUnrender cs r+ ) =>+ ResponseUnrender cs (WithHeaders hs a r)+ where+ type ResponseStatus (WithHeaders hs a r) = ResponseStatus r+ type ResponseBody (WithHeaders hs a r) = ResponseBody r++ responseUnrender c output = do+ x <- responseUnrender @cs @r c output+ case extractHeaders @hs (responseHeaders output) of+ Nothing -> UnrenderError "Failed to parse headers"+ Just hs -> pure $ fromHeaders @xs (hs, x)
src/Servant/Client/Core/Request.hs view
@@ -17,6 +17,8 @@ addHeader, appendToPath, appendToQueryString,+ encodeQueryParamValue,+ setQueryString, setRequestBody, setRequestBodyLBS, ) where@@ -33,6 +35,8 @@ import Data.Bitraversable (Bitraversable (..), bifoldMapDefault, bimapDefault) import qualified Data.ByteString as BS+import Data.ByteString.Builder+ (Builder) import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Lazy as LBS import qualified Data.Sequence as Seq@@ -47,10 +51,10 @@ import Network.HTTP.Media (MediaType) import Network.HTTP.Types- (Header, HeaderName, HttpVersion (..), Method, QueryItem,- http11, methodGet)+ (Header, HeaderName, HttpVersion (..), Method, Query, QueryItem,+ http11, methodGet, urlEncodeBuilder) import Servant.API- (ToHttpApiData, toEncodedUrlPiece, toHeader, SourceIO)+ (ToHttpApiData, toQueryParam, toHeader, SourceIO) import Servant.Client.Core.Internal (mediaTypeRnf) @@ -111,7 +115,7 @@ rnfB Nothing = () rnfB (Just (b, mt)) = rnf b `seq` mediaTypeRnf mt -type Request = RequestF RequestBody Builder.Builder+type Request = RequestF RequestBody Builder -- | The request body. R replica of the @http-client@ @RequestBody@. data RequestBody@@ -142,18 +146,37 @@ , requestMethod = methodGet } -appendToPath :: Text -> Request -> Request+-- | Append extra path to the request being constructed.+--+-- Warning: This function assumes that the path fragment is already URL-encoded.+appendToPath :: Builder -> Request -> Request appendToPath p req- = req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p }+ = req { requestPath = requestPath req <> "/" <> p } -appendToQueryString :: Text -- ^ param name- -> Maybe BS.ByteString -- ^ param value+-- | Append a query parameter to the request being constructed.+--+appendToQueryString :: Text -- ^ query param name+ -> Maybe BS.ByteString -- ^ query param value -> Request -> Request appendToQueryString pname pvalue req = req { requestQueryString = requestQueryString req Seq.|> (encodeUtf8 pname, pvalue)} +setQueryString :: Query+ -> Request+ -> Request+setQueryString query req+ = req { requestQueryString = Seq.fromList query }++-- | Encode a query parameter value.+--+encodeQueryParamValue :: ToHttpApiData a => a -> BS.ByteString+encodeQueryParamValue = LBS.toStrict . Builder.toLazyByteString+ . urlEncodeBuilder True . encodeUtf8 . toQueryParam++-- | Add header to the request being constructed.+-- addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request addHeader name val req = req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)}
src/Servant/Client/Core/Response.hs view
@@ -1,17 +1,17 @@ {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NamedFieldPuns #-} module Servant.Client.Core.Response ( Response, StreamingResponse, ResponseF (..),+ responseToInternalResponse, ) where import Prelude ()@@ -31,6 +31,7 @@ import Servant.API.Stream (SourceIO)+import Servant.Types.Internal.Response data ResponseF a = Response { responseStatusCode :: Status@@ -51,3 +52,7 @@ type Response = ResponseF LBS.ByteString type StreamingResponse = ResponseF (SourceIO BS.ByteString)++responseToInternalResponse :: ResponseF a -> InternalResponse a+responseToInternalResponse Response{responseStatusCode, responseHeaders,responseBody} =+ InternalResponse responseStatusCode responseHeaders responseBody
src/Servant/Client/Core/RunClient.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} -- | Types for possible backends to run client-side `Request` queries module Servant.Client.Core.RunClient ( RunClient (..),
+ src/Servant/Client/Core/ServerSentEvents.hs view
@@ -0,0 +1,304 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-error=unused-imports #-}++-- | Server-sent events+--+-- See <https://www.w3.org/TR/2009/WD-eventsource-20090421/> for more details+-- on server-sent events (SSE).+--+module Servant.Client.Core.ServerSentEvents (+ EventMessage (..),+ EventIgnoreReason (..),+ Event (..),+ EventStreamT (..),+ JsonEventStreamT (..),+ EventMessageStreamT (..)+) where++import Control.Applicative (Alternative ((<|>)))+import Control.Monad.IO.Class (MonadIO)+import qualified Data.Aeson as Aeson+import qualified Data.Attoparsec.ByteString as Attoparsec+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Char8 as ByteString.Char8+import qualified Data.ByteString.Lazy as ByteString.Lazy+import Data.Char (chr)+import Data.Coerce (coerce)+import Data.Foldable (traverse_)+import Data.Functor (void)+import qualified Data.Text as Text+import Data.Text.Encoding (encodeUtf8)+import GHC.Generics (Generic)+import Numeric.Natural (Natural)+import Servant.API.ContentTypes (EventStreamChunk (..))+import Servant.API.Stream (FromSourceIO (..))+import Servant.Types.SourceT+ (SourceT, StepT (..), foreachYieldStep, mapStepT,+ transformStepWithAtto)++-- For compatibility with GHC <= 8.2+import Data.Semigroup (Semigroup (..))++-- | Line (or frame) of an event stream+newtype EventStreamLine = EventStreamLine+ { unEventStreamLine :: ByteString.ByteString }+ deriving Show++-- | Consume chunks to produce event stream lines.+eventLinesFromRawChunks+ :: Monad m+ => StepT m ByteString.ByteString+ -> StepT m EventStreamLine+eventLinesFromRawChunks =+ transformStepWithAtto eventLine++-- | Consume event stream chunks to produce event stream lines.+eventLinesFromChunks+ :: Monad m+ => StepT m EventStreamChunk+ -> StepT m EventStreamLine+eventLinesFromChunks =+ -- 'coerce' efficiently unpacks the 'EventStreamChunk'+ eventLinesFromRawChunks . fmap (coerce ByteString.Lazy.toStrict)++-- | Apply a 'Attoparsec.Parser' to each line of the event stream individually.+parseEventLines+ :: Monad m+ => Attoparsec.Parser a+ -> StepT m EventStreamLine+ -> StepT m a+parseEventLines parser =+ foreachYieldStep $ \(EventStreamLine line) next ->+ case Attoparsec.parseOnly parser line of+ Left err -> Error err+ Right value -> Yield value next++-- | A line of an event stream+eventLine :: Attoparsec.Parser EventStreamLine+eventLine = do+ Attoparsec.option () byteOrderMark -- A line may be prefixed with a byte order mark+ EventStreamLine <$> untilLineEnd <* lineEnd++-- | Byte order mark (U+FEFF) in UTF-8 representation+byteOrderMark :: Attoparsec.Parser ()+byteOrderMark =+ traverse_ Attoparsec.word8+ $ ByteString.unpack+ $ encodeUtf8+ $ Text.singleton+ $ chr 0xFEFF++-- | Event stream line ending+lineEnd :: Attoparsec.Parser ()+lineEnd =+ (cr >> lf) <|> cr <|> lf <|> Attoparsec.endOfInput+ where+ cr = void (Attoparsec.word8 0x0D)+ lf = void (Attoparsec.word8 0x0A)++-- | Consume all contents until the end of the line.+untilLineEnd :: Attoparsec.Parser ByteString.ByteString+untilLineEnd = Attoparsec.takeWhile (\w8 -> w8 /= 0x0D && w8 /= 0x0A)++-- | Structured variant of an event line of an event stream+data EventMessage+ = EventDispatch+ -- ^ Dispatch on the accumulated event.+ | EventSetName ByteString.ByteString+ -- ^ Set the name of the current event.+ | EventSetLastId ByteString.ByteString+ -- ^ Set the last event identifier.+ | EventData ByteString.ByteString+ -- ^ Append data to the event's data buffer.+ | EventRetry Natural+ -- ^ Set the event stream's reconnection time.+ | EventIgnore EventIgnoreReason+ -- ^ Ignored+ deriving (Show, Eq, Ord)++-- | Reason why a event line can be ignored+data EventIgnoreReason+ = EventFieldNameUnknown ByteString.ByteString+ | EventRetryNonNumeric ByteString.ByteString+ | EventComment ByteString.ByteString+ deriving (Show, Eq, Ord)++-- | Parse the event stream lines into more structured messages.+eventMessagesFromLines+ :: Monad m+ => StepT m EventStreamLine+ -> StepT m EventMessage+eventMessagesFromLines =+ ensureLastDispatch False . parseEventLines eventMessage+ where+ -- | Make sure the last event message is a dispatch.+ ensureLastDispatch didDispatch step = case step of+ Stop ->+ if not didDispatch then Yield EventDispatch Stop else Stop+ Yield other next ->+ Yield other $ ensureLastDispatch (other == EventDispatch) next+ Skip next ->+ Skip $ ensureLastDispatch didDispatch next+ Effect eff ->+ Effect $ ensureLastDispatch didDispatch <$> eff+ err@Error{} ->+ err++-- | Event line parser for an event message.+eventMessage :: Attoparsec.Parser EventMessage+eventMessage =+ ignore <|> field <|> dispatch+ where+ ignore = do+ _ <- Attoparsec.word8 0x3A -- ':'+ EventIgnore . EventComment <$> Attoparsec.takeByteString++ dispatch = do+ Attoparsec.endOfInput+ pure EventDispatch++ field = do+ name <- Attoparsec.takeWhile1 (/= 0x3A) -- Up to ':' or the end++ value <- Attoparsec.option ByteString.empty $ do+ _ <- Attoparsec.word8 0x3A -- ':'+ _ <- Attoparsec.option 0x20 $ Attoparsec.word8 0x20 -- Optional ' '+ Attoparsec.takeByteString++ pure $ case name of+ "event" -> EventSetName value++ "data" -> EventData value++ "id" -> EventSetLastId value++ "retry" ->+ -- The retry value consist of digits.+ if ByteString.all (\w8 -> 0x30 <= w8 && w8 <= 0x39) value then+ EventRetry (read (ByteString.Char8.unpack value))+ else+ EventIgnore (EventRetryNonNumeric value)++ _ -> EventIgnore (EventFieldNameUnknown name)++-- | Event sent by the remote+data Event a = Event+ { eventName :: Maybe ByteString.ByteString+ , eventData :: a+ }+ deriving (Show, Eq, Ord, Functor, Generic)++-- | Accumulate event messages to build individual 'Event's.+eventsFromMessages+ :: Functor m+ => StepT m EventMessage+ -> StepT m (Event ByteString.ByteString)+eventsFromMessages =+ initGo+ where+ initGo = go Nothing ByteString.Lazy.empty++ combineData dataBuffer newData =+ if ByteString.Lazy.null dataBuffer then+ ByteString.Lazy.fromStrict newData+ else+ ByteString.Lazy.concat+ [ dataBuffer+ , ByteString.Lazy.singleton 0x0A -- Line feed+ , ByteString.Lazy.fromStrict newData+ ]++ go name dataBuffer step = case step of+ Stop ->+ Stop+ Skip next ->+ go name dataBuffer next+ Effect eff ->+ Effect (go name dataBuffer <$> eff)+ Error err ->+ Error err+ Yield message next -> case message of+ EventSetName newName ->+ go (Just newName) dataBuffer next+ EventData newData ->+ go name (combineData dataBuffer newData) next+ EventDispatch ->+ Yield+ (Event name (ByteString.Lazy.toStrict dataBuffer))+ (initGo next)+ _ ->+ -- We ignore other message because they don't fit into+ -- the 'Event' type. If a user needs more fine grained+ -- control, the 'EventMessage' interface is better suited.+ go name dataBuffer next++-- | Server-sent event stream (SSE)+--+-- See <https://www.w3.org/TR/2009/WD-eventsource-20090421/> for more details.+--+newtype EventMessageStreamT m = EventMessageStreamT+ { unEventMessageStreamT :: SourceT m EventMessage }+ deriving stock (Show)+ deriving newtype (Semigroup, Monoid)++-- | Server-sent event messages+--+-- 'EventMessage' gives you more control over the communication with the server+-- than 'Event'.+--+instance MonadIO m => FromSourceIO EventStreamChunk (EventMessageStreamT m) where+ fromSourceIO src =+ EventMessageStreamT+ . mapStepT (eventMessagesFromLines . eventLinesFromChunks)+ <$> fromSourceIO src++-- | Server-sent event stream (SSE)+--+-- See <https://www.w3.org/TR/2009/WD-eventsource-20090421/> for more details.+--+newtype EventStreamT m = EventStreamT+ { unEventStreamT :: SourceT m (Event ByteString.ByteString) }+ deriving stock (Show)+ deriving newtype (Semigroup, Monoid)++-- | Server-sent events+instance MonadIO m => FromSourceIO EventStreamChunk (EventStreamT m) where+ fromSourceIO input = do+ src :: EventMessageStreamT m <- fromSourceIO input+ pure $+ -- 'coerce' is used in place of unpacking and repacking 'EventStreamT'+ coerce (mapStepT eventsFromMessages) src++-- | Try to parse event data to JSON.+jsonEventsFromEvents+ :: (Functor m, Aeson.FromJSON a)+ => StepT m (Event ByteString.ByteString)+ -> StepT m (Event a)+jsonEventsFromEvents =+ foreachYieldStep $ \(Event name datas) next ->+ either+ Error+ (\value -> Yield (Event name value) next)+ (Aeson.eitherDecode (ByteString.Lazy.fromStrict datas))++-- | Server-sent event stream (SSE) for JSON values+newtype JsonEventStreamT m a = JsonEventStreamT+ { unJsonEventStreamT :: SourceT m (Event a) }+ deriving stock (Show, Functor)+ deriving newtype (Semigroup, Monoid)++-- | Server-sent JSON event stream+instance (MonadIO m, Aeson.FromJSON a) => FromSourceIO EventStreamChunk (JsonEventStreamT m a) where+ fromSourceIO input = do+ src :: EventStreamT m <- fromSourceIO input+ pure $+ -- The 'coerce' efficiently unwraps the 'EventStreamT' and wraps the+ -- JsonEventStreamT.+ coerce+ (mapStepT jsonEventsFromEvents)+ src
src/Servant/Client/Generic.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} module Servant.Client.Generic ( AsClientT,
+ test/Servant/Client/Core/ServerSentEventsSpec.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE OverloadedStrings #-}++module Servant.Client.Core.ServerSentEventsSpec (spec) where++import Control.Monad.Trans.Except (runExceptT)+import qualified Data.ByteString.Lazy as ByteString+import Data.Foldable (for_)+import Data.Int (Int64)+import Servant.API.ContentTypes (EventStreamChunk (..))+import Servant.API.Stream+ (FromSourceIO (fromSourceIO))+import Servant.Client.Core.ServerSentEvents+ (Event (..), EventIgnoreReason (EventComment),+ EventMessage (..), unEventMessageStreamT, unEventStreamT)+import Servant.Types.SourceT (runSourceT, source)+import Test.Hspec+ (Spec, describe, it, shouldBe)++spec :: Spec+spec = describe "Servant.Client.Core.ServerSentEvent" $ do+ describe "EventMessageStreamT" $ do+ it "processes chunks correctly" $ do+ let allMessages = ByteString.intercalate "\n"+ [ "retry: 30"+ , "data: Hello World"+ , "id: 1"+ , ""+ , "event: my_event"+ , "data"+ , "id: 2"+ , ":Just a comment"+ , ""+ , "data: Bye"+ ]++ for_ [1, 10, 100] $ \chunkSize -> do+ src <-+ fromSourceIO+ $ source+ $ map EventStreamChunk+ $ chunkify chunkSize allMessages++ result <-+ runExceptT+ $ runSourceT+ $ unEventMessageStreamT src++ result `shouldBe` Right+ [ EventRetry 30+ , EventData "Hello World"+ , EventSetLastId "1"+ , EventDispatch+ , EventSetName "my_event"+ , EventData ""+ , EventSetLastId "2"+ , EventIgnore (EventComment "Just a comment")+ , EventDispatch+ , EventData "Bye"+ , EventDispatch+ ]++ describe "EventStreamT" $ do+ it "processes chunks correctly" $ do+ let allMessages = ByteString.intercalate "\n"+ [ "retry: 30"+ , "data: Hello World"+ , "id: 1"+ , ""+ , "event: my_event"+ , "data"+ , "id: 2"+ , ":Just a comment"+ , ""+ , "data: Bye"+ ]++ for_ [1, 10, 100] $ \chunkSize -> do+ src <-+ fromSourceIO+ $ source+ $ map EventStreamChunk+ $ chunkify chunkSize allMessages+ result <-+ runExceptT+ $ runSourceT+ $ unEventStreamT src++ result `shouldBe` Right+ [ Event Nothing "Hello World"+ , Event (Just "my_event") ""+ , Event Nothing "Bye"+ ]++chunkify :: Int64 -> ByteString.ByteString -> [ByteString.ByteString]+chunkify chunkSize input =+ if ByteString.null input then+ []+ else+ let (h, t) = ByteString.splitAt chunkSize input+ in h : chunkify chunkSize t