Client-side support for server-sent events (SSE) (#1811)

Co-authored-by: Ole Krüger <[email protected]>

Author: voidus

changelog.d/1317-server-sent-events

@@ -0,0 +1,11 @@
+synopsis: Server-sent events (SSE) for client-side
+prs: #1317
+issues: #1317
+
+description: {
+
+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.
+
+}

servant-client-core/servant-client-core.cabal

@@ -92,6 +92,7 @@ library
     Servant.Client.Core.Response
     Servant.Client.Core.MultiVerb.ResponseUnrender
     Servant.Client.Core.RunClient
+    Servant.Client.Core.ServerSentEvents
     Servant.Client.Free
     Servant.Client.Generic
 
@@ -102,6 +103,7 @@ library
   --
   -- note: mtl lower bound is so low because of GHC-7.8
   build-depends:
+    , attoparsec        >= 0.13.2.2 && < 0.15
     , base              >= 4.16.4.0 && < 4.22
     , bytestring        >=0.11 && <0.13
     , constraints       >=0.2      && <0.15
@@ -138,11 +140,15 @@ test-suite spec
   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

servant-client-core/src/Servant/Client/Core/HasClient.hs

@@ -71,7 +71,7 @@ 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)
@@ -81,6 +81,10 @@ import           Servant.API.Modifiers
 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
@@ -90,6 +94,7 @@ 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
@@ -451,6 +456,63 @@ instance {-# OVERLAPPING #-}
           , 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',