wip

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

@@ -1,9 +1,9 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -20,51 +20,65 @@ module Servant.API.EventStream (
 where
 
 import Control.Lens
-import Data.Binary.Builder (toLazyByteString)
+import qualified Data.ByteString.Lazy.Char8 as LBS
 #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 a = ServerEvent
+  { eventName :: Maybe LBS.ByteString
+  , eventId :: Maybe LBS.ByteString
+  , eventData :: [a]
+  }
+  deriving (Show, Eq, Functor, Generic)
+
+class ToServerEventData a where
+  toServerEventData :: a -> LBS.ByteString
+
+{- | 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 (ToServerEventData 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 +90,36 @@ data EventStream
 instance Accept EventStream where
   contentType _ = "text" // "event-stream" /: ("charset", "utf-8")
 
-type EventSource = SourceIO ServerEvent
+type EventSource a = SourceIO (ServerEvent 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 (ToServerEventData a) => MimeRender EventStream (ServerEvent a) where
+  mimeRender _ = encodeServerEvent
+
+-- field names can't contain LF, CR or COLON
+-- values cannot contain LF or CR
+encodeServerEvent :: (ToServerEventData a) => ServerEvent a -> LBS.ByteString
+encodeServerEvent e =
+  optional "event:" (eventName e)
+    <> optional "id:" (eventId e)
+    <> mconcat (map (field "data:") (concatMap (safelines . toServerEventData) (eventData e)))
+ where
+  optional name = maybe mempty (field name)
+  field name val = name <> val <> lf
+  lf = "\n"
+  safelines = LBS.lines . LBS.filter (/= '\r')
 
-eventSource :: EventSource -> EventSourceHdr
+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")