diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,25 @@ # Revision history for servant-event-stream +## 0.3.0.0 -- 2024-09-05 + +* Breaking changes to the API. + + Event streams are implemented using servant's 'Stream' endpoint. You should + provide a handler that returns a stream of events that implements 'ToSourceIO' + where events have a 'ToServerEvent' instance. + + Example: + + > type MyApi = "books" :> ServerSentEvents (SourceIO Book) + > + > instance ToServerEvent Book where + > toServerEvent book = ... + > + > server :: Server MyApi + > server = streamBooks + > where streamBooks :: Handler (SourceIO Book) + > streamBooks = pure $ source [book1, ...] + ## 0.2.1.0 -- 2021-04-21 * Import `Data.Semigroup` for base < 4.11.0 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,17 +4,17 @@ This library adds necessary type combinators to support [Server Sent Events](https://developer.mozilla.org/en-US/docs/Web/API/Server-sent_events/Using_server-sent_events) within [Servant ecosystem](https://github.com/haskell-servant/). -Dev Environment ---------------- +Development Environment +----------------------- -Dev env is based on [Nix](https://nixos.org) and [Niv](https://github.com/nmattia/niv). +Development environment uses [Nix](https://nixos.org) flakes. To enter the dev shell, run ```bash -nix-shell +nix develop ``` You can build the project with ```bash -nix-build +nix build ``` diff --git a/servant-event-stream.cabal b/servant-event-stream.cabal --- a/servant-event-stream.cabal +++ b/servant-event-stream.cabal @@ -1,22 +1,21 @@ -cabal-version: >=1.10 -name: servant-event-stream -version: 0.2.1.0 -stability: alpha - -synopsis: Servant support for Server-Sent events -category: Servant, Web -description: This library adds necessary type combinators to support - Server Sent Events within Servant ecosystem. - -homepage: https://github.com/bflyblue/servant-event-stream -bug-reports: https://github.com/bflyblue/servant-event-stream/issues -license: BSD3 -license-file: LICENSE -author: Shaun Sharples -maintainer: shaun.sharples@gmail.com -copyright: (c) 2021 Shaun Sharples -build-type: Simple +cabal-version: >=1.10 +name: servant-event-stream +version: 0.3.0.0 +stability: alpha +synopsis: Servant support for Server-Sent events +category: Servant, Web +description: + This library adds necessary type combinators to support + Server Sent Events within Servant ecosystem. +homepage: https://github.com/bflyblue/servant-event-stream +bug-reports: https://github.com/bflyblue/servant-event-stream/issues +license: BSD3 +license-file: LICENSE +author: Shaun Sharples +maintainer: shaun.sharples@gmail.com +copyright: (c) 2024 Shaun Sharples +build-type: Simple extra-source-files: CHANGELOG.md README.md @@ -26,36 +25,30 @@ location: https://github.com/bflyblue/servant-event-stream.git library - exposed-modules: - Servant.API.EventStream - + exposed-modules: Servant.API.EventStream default-extensions: MultiParamTypeClasses OverloadedStrings build-depends: - base >= 4.9 && < 4.15 - , binary >= 0.7 && < 0.11 - , http-media >= 0.7.1.3 && < 0.9 - , lens >= 4.17 && < 4.20 - , pipes >= 4.3.9 && < 4.4 - , servant-foreign >= 0.15 && < 0.16 - , servant-js >= 0.9 && < 0.10 - , servant-pipes >= 0.15 && < 0.16 - , servant-server >= 0.15 && < 0.19 - , text >= 1.2.3 && < 1.3 - , wai-extra >= 3.0 && < 3.2 + attoparsec >=0.14 && <0.15, + base >=4.10 && <4.20, + binary >=0.8 && <0.9, + bytestring >=0.11.1.0 && <0.13, + http-media >=0.7.1.3 && <0.9, + lens >=4.17 && <5.4, + 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 - ghc-options: -Wall + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall test-suite tests-default type: exitcode-stdio-1.0 main-is: Spec.hs - hs-source-dirs: - tests - default-language: - Haskell2010 - build-depends: - base + hs-source-dirs: tests + default-language: Haskell2010 + build-depends: base diff --git a/src/Servant/API/EventStream.hs b/src/Servant/API/EventStream.hs --- a/src/Servant/API/EventStream.hs +++ b/src/Servant/API/EventStream.hs @@ -1,138 +1,170 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -module Servant.API.EventStream - ( ServerSentEvents - , EventStream - , EventSource - , EventSourceHdr - , eventSource - , jsForAPI - ) +module Servant.API.EventStream ( + ServerEvent (..), + ToServerEvent (..), + ServerSentEvents, + EventStream, + RecommendedEventSourceHeaders, + recommendedEventSourceHeaders, +) where -import Control.Lens -import Data.Binary.Builder ( toLazyByteString ) +import Control.Lens +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as C8 +import Data.Kind (Type) #if !MIN_VERSION_base(4,11,0) -import Data.Semigroup +import Data.Semigroup #endif -import Data.Text ( Text ) -import qualified Data.Text as T -import GHC.Generics ( Generic ) -import Network.HTTP.Media ( (//) - , (/:) - ) -import Network.Wai.EventSource ( ServerEvent(..) ) -import Network.Wai.EventSource.EventStream - ( eventToBuilder ) -import qualified Pipes -import Pipes ( X - , (>->) - , await - , yield - ) -import Servant -import Servant.Foreign -import Servant.Foreign.Internal ( _FunctionName ) -import Servant.JS.Internal -import Servant.Pipes ( pipesToSourceIO ) +import Data.Text (Text) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Network.HTTP.Media ( + (//), + (/:), + ) +import Servant +import Servant.Foreign +import Servant.Foreign.Internal (_FunctionName) -newtype ServerSentEvents - = ServerSentEvents (StreamGet NoFraming EventStream EventSourceHdr) - deriving (Generic, HasLink) +{- | A ServerSentEvents endpoint emits an event stream using the format described at + +-} +data ServerSentEvents (a :: Type) + deriving (Typeable, Generic) -instance HasServer ServerSentEvents context where - type ServerT ServerSentEvents m = ServerT (StreamGet NoFraming EventStream EventSourceHdr) m - route Proxy = route - (Proxy :: Proxy (StreamGet NoFraming EventStream EventSourceHdr)) - hoistServerWithContext Proxy = hoistServerWithContext - (Proxy :: Proxy (StreamGet NoFraming EventStream EventSourceHdr)) +instance HasLink (ServerSentEvents a) where + type MkLink (ServerSentEvents a) r = r + toLink toA _ = toA +-- | Represents an event sent from the server to the client in Server-Sent Events (SSE). +data ServerEvent = ServerEvent + { eventType :: !(Maybe LBS.ByteString) + -- ^ Optional field specifying the type of event. Can be used to distinguish between different kinds of events. + , eventId :: !(Maybe LBS.ByteString) + -- ^ Optional field providing an identifier for the event. Useful for clients to keep track of the last received event. + , eventData :: !LBS.ByteString + -- ^ The payload or content of the event. This is the main data sent to the client. + } + deriving (Show, Eq, Generic) + +{- | This typeclass allows you to define custom event types that can be + transformed into the 'ServerEvent' type, which is used to represent events in + the Server-Sent Events (SSE) protocol. +-} +class ToServerEvent a where + toServerEvent :: a -> ServerEvent + +instance (ToServerEvent a) => MimeRender EventStream a where + mimeRender _ = encodeServerEvent . toServerEvent + +instance ToServerEvent ServerEvent where + toServerEvent = id + +{- | Event streams are implemented using servant's 'Stream' endpoint. + You should provide a handler that returns a stream of events that implements + 'ToSourceIO' where events have a 'ToServerEvent' instance. + + Example: + + > type MyApi = "books" :> ServerSentEvents (SourceIO Book) + > + > instance ToServerEvent Book where + > toServerEvent book = ... + > + > server :: Server MyApi + > server = streamBooks + > where streamBooks :: Handler (SourceIO Book) + > streamBooks = pure $ source [book1, ...] +-} +instance {-# OVERLAPPABLE #-} (ToServerEvent chunk, ToSourceIO chunk a) => HasServer (ServerSentEvents a) context where + type ServerT (ServerSentEvents a) m = ServerT (StreamGet ServerEventFraming EventStream a) m + route Proxy = + route + (Proxy :: Proxy (StreamGet ServerEventFraming EventStream a)) + hoistServerWithContext Proxy = + hoistServerWithContext + (Proxy :: Proxy (StreamGet ServerEventFraming EventStream a)) + +instance {-# OVERLAPPING #-} (ToServerEvent chunk, ToSourceIO chunk a, GetHeaders (Headers h a)) => HasServer (ServerSentEvents (Headers h a)) context where + type ServerT (ServerSentEvents (Headers h a)) m = ServerT (StreamGet ServerEventFraming EventStream (Headers h a)) m + route Proxy = + route + (Proxy :: Proxy (StreamGet ServerEventFraming EventStream (Headers h a))) + hoistServerWithContext Proxy = + hoistServerWithContext + (Proxy :: Proxy (StreamGet ServerEventFraming EventStream (Headers h a))) + -- | a helper instance for -instance (HasForeignType lang ftype EventSourceHdr) - => HasForeign lang ftype ServerSentEvents where - type Foreign ftype ServerSentEvents = Req ftype +instance + (HasForeignType lang ftype a) => + HasForeign lang ftype (ServerSentEvents a) + where + type Foreign ftype (ServerSentEvents a) = Req ftype foreignFor lang Proxy Proxy req = req - & reqFuncName . _FunctionName %~ ("stream" :) - & reqMethod .~ method - & reqReturnType ?~ retType + & reqFuncName . _FunctionName %~ ("stream" :) + & reqMethod .~ method + & reqReturnType ?~ retType where - retType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy EventSourceHdr) - method = reflectMethod (Proxy :: Proxy 'GET) + retType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a) + method = reflectMethod (Proxy :: Proxy 'GET) --- | A type representation of an event stream. It's responsible for setting proper content-type --- and buffering headers, as well as for providing parser implementations for the streams. --- Read more on +{- | A type representation of an event stream. It's responsible for setting proper content-type + and buffering headers, as well as for providing parser implementations for the streams. + Read more on +-} data EventStream instance Accept EventStream where contentType _ = "text" // "event-stream" /: ("charset", "utf-8") -type EventSource = SourceIO ServerEvent - --- | This is mostly to guide reverse-proxies like --- -type EventSourceHdr = Headers '[Header "X-Accel-Buffering" Text] EventSource +{- | This is mostly to guide reverse-proxies like + --- | 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 + Example: -eventSource :: Pipes.Proxy X () () ServerEvent IO () -> EventSourceHdr -eventSource prod = addHeader "no" $ pipesToSourceIO (prod >-> yieldUntilClose) - where - yieldUntilClose = do - e <- await - case e of - CloseEvent -> return () - _ -> yield e >> yieldUntilClose + > type MyApi = "books" :> ServerSentEvents (RecommendedEventSourceHeaders (SourceIO Book)) + > + > server :: Server MyApi + > server = streamBooks + > where streamBooks :: Handler (RecommendedEventSourceHeaders (SourceIO Book)) + > streamBooks = pure $ recommendedEventSourceHeaders $ source [book1, ...] +-} +type RecommendedEventSourceHeaders (a :: Type) = Headers '[Header "X-Accel-Buffering" Text, Header "Cache-Control" Text] a -jsForAPI - :: ( HasForeign NoTypes NoContent api - , GenerateList NoContent (Foreign NoContent api) - ) - => Proxy api - -> Text -jsForAPI p = gen - (listFromAPI (Proxy :: Proxy NoTypes) (Proxy :: Proxy NoContent) p) - where - gen :: [Req NoContent] -> Text - gen = mconcat . map genEventSource +-- | Add the recommended headers for Server-Sent Events to the response. +recommendedEventSourceHeaders :: a -> RecommendedEventSourceHeaders a +recommendedEventSourceHeaders = addHeader @"X-Accel-Buffering" "no" . addHeader @"Cache-Control" "no-store" - genEventSource :: Req NoContent -> Text - genEventSource req = T.unlines - [ "" - , fname <> " = function(" <> argsStr <> ")" - , "{" - , " s = new EventSource(" <> url <> ", conf);" - , " Object.entries(eventListeners).forEach(([ev, cb]) => s.addEventListener(ev, cb));" - , " return s;" - , "}" - ] - where - argsStr = T.intercalate ", " args - args = captures - ++ map (view $ queryArgName . argPath) queryparams - ++ ["eventListeners = {}", "conf"] +data ServerEventFraming - captures = map (view argPath . captureArg) - . filter isCapture - $ req ^. reqUrl.path +instance FramingRender ServerEventFraming where + framingRender _ f = fmap (\x -> f x <> "\n") - queryparams = req ^.. reqUrl.queryStr.traverse +{- 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" - fname = "var " <> toValidFunctionName (camelCase $ req ^. reqFuncName) - url = if url' == "'" then "'/'" else url' - url' = "'" <> urlArgs - urlArgs = jsSegments $ req ^.. reqUrl . path . traverse + -- discard CR and split LFs into multiple data values + safelines = C8.lines . C8.filter (/= '\r')