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

Author: vapourismo

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

@@ -46,6 +46,7 @@ library
       Servant.Client.Core.Request
       Servant.Client.Core.Response
       Servant.Client.Core.RunClient
+      Servant.Client.Core.ServerSentEvents
 
   other-modules:
       Servant.Client.Core.Internal
@@ -83,6 +84,7 @@ library
     , http-types            >= 0.12.2   && < 0.13
     , network-uri           >= 2.6.1.0  && < 2.7
     , safe                  >= 0.3.17   && < 0.4
+    , attoparsec            >= 0.13.2.2 && < 0.14
 
   hs-source-dirs:      src
   default-language:    Haskell2010
@@ -97,11 +99,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

@@ -54,16 +54,21 @@ import           Servant.API
                  contentType, getHeadersHList, getResponse, toQueryParam,
                  toUrlPiece)
 import           Servant.API.ContentTypes
-                 (contentTypes)
+                 (EventStream, contentTypes)
 import           Servant.API.Modifiers
                  (FoldRequired, RequiredArgument, foldRequiredArgument)
+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
 
@@ -332,6 +337,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',