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

Author: vapourismo

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

@@ -41,6 +41,7 @@ library
       Servant.Client.Core.Request
       Servant.Client.Core.Response
       Servant.Client.Core.RunClient
+      Servant.Client.Core.ServerSentEvents
 
   other-modules:
       Servant.Client.Core.Internal
@@ -50,7 +51,8 @@ library
   --
   -- note: mtl lower bound is so low because of GHC-7.8
   build-depends:
-      base                  >= 4.9      && < 4.16
+      attoparsec            >= 0.13.2.2 && < 0.15
+    , base                  >= 4.9      && < 4.16
     , bytestring            >= 0.10.8.1 && < 0.12
     , constraints           >= 0.2      && < 0.14
     , containers            >= 0.5.7.1  && < 0.7
@@ -94,11 +96,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

@@ -85,7 +85,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.Status
                  (statusFromNat)
 import           Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
@@ -94,13 +94,18 @@ 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
 import           Servant.Client.Core.ClientError
 import           Servant.Client.Core.Request
 import           Servant.Client.Core.Response
 import           Servant.Client.Core.RunClient
+import           Servant.Client.Core.ServerSentEvents
 
 -- * Accessing APIs as a Client
 
@@ -462,6 +467,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',