servant-client-core 0.20.2 → 0.20.3.0

raw patch · 7 files changed

+724/−36 lines, 7 filesdep +attoparsecdep +transformersdep ~QuickCheckdep ~basedep ~bytestringnew-uploaderPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: attoparsec, transformers

Dependency ranges changed: QuickCheck, base, bytestring, containers, servant

API changes (from Hackage documentation)

Files

• CHANGELOG.md +23/−0
• servant-client-core.cabal +13/−7
• src/Servant/Client/Core/HasClient.hs +146/−27
• src/Servant/Client/Core/MultiVerb/ResponseUnrender.hs +131/−0
• src/Servant/Client/Core/Response.hs +7/−2
• src/Servant/Client/Core/ServerSentEvents.hs +304/−0
• test/Servant/Client/Core/ServerSentEventsSpec.hs +100/−0

@@ -3,6 +3,29 @@  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 ---- 

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               servant-client-core-version:            0.20.2+version:            0.20.3.0 synopsis:   Core functionality and class for client function generation for servant APIs @@ -19,8 +19,7 @@   2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors  build-type:         Simple-tested-with:-  GHC ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.4 || ==9.8.2 || ==9.10.1+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@@ -91,7 +90,9 @@     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 @@ -102,12 +103,13 @@   --   -- note: mtl lower bound is so low because of GHC-7.8   build-depends:-    , base              >=4.14     && <4.21-    , bytestring        >=0.10.8.1 && <0.13+    , 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.5.7.1  && <0.8+    , containers        >=0.6.5.1  && <0.9     , deepseq           >=1.4.2.0  && <1.6-    , template-haskell  >=2.11.1.0 && <2.23+    , template-haskell  >=2.11.1.0 && <2.24     , text              >=1.2.3.0  && <2.2    -- Servant dependencies@@ -138,11 +140,15 @@   other-modules:     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-compat+    , bytestring+    , transformers+    , servant     , servant-client-core    -- Additional dependencies

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE ApplicativeDo #-} {-# OPTIONS_GHC -Wno-missing-methods #-} module Servant.Client.Core.HasClient (     clientIn,@@ -8,7 +9,8 @@     (//),     (/:),     foldMapUnion,-    matchUnion+    matchUnion,+    fromSomeClientResponse     ) where  import           Prelude ()@@ -16,9 +18,10 @@  import           Control.Arrow                  (left, (+++))+import qualified Data.Text as Text import           Control.Monad                  (unless)-import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy as BSL import           Data.Either                  (partitionEithers) import           Data.Constraint (Dict(..))@@ -42,13 +45,11 @@ 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@@ -65,12 +66,12 @@                  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)+                 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)@@ -80,13 +81,23 @@ 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 @@ -108,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. --@@ -125,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.@@ -322,7 +331,7 @@   deriving (Eq, Show)  class UnrenderResponse (cts :: [Type]) (a :: Type) where-  unrenderResponse :: Seq.Seq H.Header -> BL.ByteString -> Proxy cts+  unrenderResponse :: Seq.Seq H.Header -> BSL.ByteString -> Proxy cts                    -> [Either (MediaType, String) a]  instance {-# OVERLAPPABLE #-} AllMimeUnrender cts a => UnrenderResponse cts a where@@ -364,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@@ -396,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))@@ -413,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'-      fromSourceIO $ framingUnrender' $ responseBody gres+      fromSourceIO $ framingUnrender' body     where       req' = req           { requestAccept = fromList [contentType (Proxy :: Proxy ct)]@@ -433,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@@ -448,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',@@ -491,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@@ -757,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.@@ -862,7 +936,6 @@ 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)@@ -972,7 +1045,53 @@ (/:) :: (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@@ -1003,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

@@ -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)

@@ -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

@@ -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

@@ -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