Added ToServerEvent class

servant-event-stream.cabal

@@ -31,14 +31,14 @@ library
     OverloadedStrings
 
   build-depends:
-      base             >=4.10    && <4.19
-    , binary           >=0.7     && <0.11
-    , http-media       >=0.7.1.3 && <0.9
-    , lens             >=4.17    && <5.3
-    , servant-foreign  >=0.15    && <0.17
-    , servant-server   >=0.15    && <0.21
-    , text             >=1.2.3   && <2.2
-    , wai-extra        >=3.0     && <3.2
+      base             >=4.10     && <4.19
+    , bytestring       >=0.11.1.0 && <0.13
+    , http-media       >=0.7.1.3  && <0.9
+    , lens             >=4.17     && <5.3
+    , servant-foreign  >=0.15     && <0.17
+    , servant-server   >=0.15     && <0.21
+    , text             >=1.2.3    && <2.2
+    , wai-extra        >=3.0      && <3.2
 
   hs-source-dirs:     src
   default-language:   Haskell2010

src/Servant/API/EventStream.hs

@@ -3,7 +3,6 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -16,55 +15,72 @@ module Servant.API.EventStream (
   EventSource,
   EventSourceHdr,
   eventSource,
+  ServerEvent (..),
+  ToServerEvent (..),
 )
 where
 
 import Control.Lens
-import Data.Binary.Builder (toLazyByteString)
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString.Lazy.Char8 as C8
 #if !MIN_VERSION_base(4,11,0)
 import Data.Semigroup
 #endif
+import Data.Kind (Type)
 import Data.Text (Text)
+import Data.Typeable (Typeable)
 import GHC.Generics (Generic)
 import Network.HTTP.Media (
   (//),
   (/:),
  )
-import Network.Wai.EventSource (ServerEvent (..))
-import Network.Wai.EventSource.EventStream (
-  eventToBuilder,
- )
 import Servant
 import Servant.Foreign
 import Servant.Foreign.Internal (_FunctionName)
 
-newtype ServerSentEvents
-  = ServerSentEvents (StreamGet NoFraming EventStream EventSourceHdr)
-  deriving (Generic, HasLink)
+data ServerEvent = ServerEvent
+  { eventType :: Maybe LBS.ByteString
+  , eventId :: Maybe LBS.ByteString
+  , eventData :: LBS.ByteString
+  }
+  deriving (Show, Eq, Generic)
+
+class ToServerEvent a where
+  toServerEvent :: a -> ServerEvent
+
+{- | A ServerSentEvents endpoint emits an event stream using the format described at
+  <https://developer.mozilla.org/en-US/docs/Web/API/Server-sent_events/Using_server-sent_events#event_stream_format>
+-}
+data ServerSentEvents (a :: Type)
+  deriving (Typeable, Generic)
+
+instance HasLink (ServerSentEvents a) where
+  type MkLink (ServerSentEvents a) r = r
+  toLink toA _ = toA
 
-instance HasServer ServerSentEvents context where
-  type ServerT ServerSentEvents m = ServerT (StreamGet NoFraming EventStream EventSourceHdr) m
+instance (ToServerEvent a) => HasServer (ServerSentEvents a) context where
+  type ServerT (ServerSentEvents a) m = ServerT (StreamGet ServerEventFraming EventStream (EventSourceHdr a)) m
   route Proxy =
     route
-      (Proxy :: Proxy (StreamGet NoFraming EventStream EventSourceHdr))
+      (Proxy :: Proxy (StreamGet ServerEventFraming EventStream (EventSourceHdr a)))
   hoistServerWithContext Proxy =
     hoistServerWithContext
-      (Proxy :: Proxy (StreamGet NoFraming EventStream EventSourceHdr))
+      (Proxy :: Proxy (StreamGet ServerEventFraming EventStream (EventSourceHdr a)))
 
 -- | a helper instance for <https://hackage.haskell.org/package/servant-foreign-0.15.3/docs/Servant-Foreign.html servant-foreign>
 instance
-  (HasForeignType lang ftype EventSourceHdr) =>
-  HasForeign lang ftype ServerSentEvents
+  (HasForeignType lang ftype (EventSourceHdr a)) =>
+  HasForeign lang ftype (ServerSentEvents a)
   where
-  type Foreign ftype ServerSentEvents = Req ftype
+  type Foreign ftype (ServerSentEvents a) = Req ftype
 
   foreignFor lang Proxy Proxy req =
     req
       & reqFuncName . _FunctionName %~ ("stream" :)
       & reqMethod .~ method
       & reqReturnType ?~ retType
    where
-    retType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy EventSourceHdr)
+    retType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy (EventSourceHdr a))
     method = reflectMethod (Proxy :: Proxy 'GET)
 
 {- | A type representation of an event stream. It's responsible for setting proper content-type
@@ -76,18 +92,42 @@ data EventStream
 instance Accept EventStream where
   contentType _ = "text" // "event-stream" /: ("charset", "utf-8")
 
-type EventSource = SourceIO ServerEvent
+type EventSource a = SourceIO a
 
 {- | This is mostly to guide reverse-proxies like
   <https://www.nginx.com/resources/wiki/start/topics/examples/x-accel/#x-accel-buffering nginx>
 -}
-type EventSourceHdr = Headers '[Header "X-Accel-Buffering" Text, Header "Cache-Control" Text] EventSource
+type EventSourceHdr (a :: Type) = Headers '[Header "X-Accel-Buffering" Text, Header "Cache-Control" Text] (EventSource a)
 
 {- | See details at
   https://hackage.haskell.org/package/wai-extra-3.1.6/docs/Network-Wai-EventSource-EventStream.html#v:eventToBuilder
 -}
-instance MimeRender EventStream ServerEvent where
-  mimeRender _ = maybe "" toLazyByteString . eventToBuilder
+instance (ToServerEvent a) => MimeRender EventStream a where
+  mimeRender _ = encodeServerEvent . toServerEvent
+
+instance ToServerEvent ServerEvent where
+  toServerEvent = id
 
-eventSource :: EventSource -> EventSourceHdr
+{- 1. Field names must not contain LF, CR or COLON characters.
+   2. Values must not contain LF or CR characters.
+      Multple consecutive `data:` fields will be joined with LFs on the client.
+-}
+encodeServerEvent :: ServerEvent -> LBS.ByteString
+encodeServerEvent e =
+  optional "event:" (eventType e)
+    <> optional "id:" (eventId e)
+    <> mconcat (map (field "data:") (safelines (eventData e)))
+ where
+  optional name = maybe mempty (field name)
+  field name val = name <> val <> "\n"
+
+  -- discard CR and split LFs into multiple data values
+  safelines = C8.lines . C8.filter (/= '\r')
+
+eventSource :: EventSource a -> EventSourceHdr a
 eventSource = addHeader @"X-Accel-Buffering" "no" . addHeader @"Cache-Control" "no-store"
+
+data ServerEventFraming
+
+instance FramingRender ServerEventFraming where
+  framingRender _ f = fmap (\x -> f x <> "\n")