diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,40 @@ # Revision history for servant-event-stream +## 0.4.0.0 -- 2026-02-27 + +* **Breaking**: Add `eventComment` and `eventRetry` fields to `ServerEvent`. + Existing code using the `ServerEvent` constructor must add the new fields, + e.g. `ServerEvent typ eid dat Nothing Nothing`. +* **Breaking**: Drop `charset=utf-8` from the `Accept` instance. The content + type is now `text/event-stream` (no parameters), matching the WHATWG spec. +* **New dependency**: `aeson` (for JSON helpers). +* **New dependency**: `servant-client-core` (for `HasClient` instances). +* Add `serverEvent` convenience constructor matching the old 3-field API for easy migration. +* Add `dataEvent` convenience constructor for simple data-only events. +* Add `commentEvent` convenience constructor for heartbeat keepalives. +* Add `retryEvent` convenience constructor for setting client reconnection delay. +* Export `encodeServerEvent` for direct use outside of Servant. +* Add `FromServerEvent` typeclass and `decodeServerEvent` for parsing SSE events. +* Add `MimeUnrender EventStream` and `FramingUnrender ServerEventFraming` instances + for consuming SSE streams. +* Add `HasClient` instances for `ServerSentEvents` and `PostServerSentEvents`, + enabling client-side SSE consumption via `servant-client`. +* Add `PostServerSentEvents` combinator for POST SSE endpoints (e.g. OpenAI's + streaming API), with `HasServer`, `HasClient`, and `HasForeign` instances. +* Add `JsonData` newtype for deriving `ToServerEvent` and `FromServerEvent` via + JSON encoding using `DerivingVia`. +* Add `jsonEvent` helper to construct events with JSON-encoded data payloads. +* Add `jsonData` helper to decode JSON from an event's data field. +* Strip leading UTF-8 BOM from SSE input, per the WHATWG spec. +* Export `ServerEventFraming` (needed for `StreamPost` SSE endpoints). +* Always emit at least one `data:` field, even when `eventData` is empty. + Previously, empty data produced no output and the event was silently + dropped by clients. +* Sanitize `eventType`, `eventId`, and `eventComment` by stripping CR and LF + characters to prevent malformed SSE output. +* Strip NULL characters from `eventId` (the SSE spec silently ignores ids + containing NULL). + ## 0.3.2.1 -- 2026-02-27 * Add guard space after colon in SSE field encoding. Without it, field values diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,20 +1,87 @@ -servant-event-stream -==================== +# servant-event-stream -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/). +[Server-Sent Events](https://developer.mozilla.org/en-US/docs/Web/API/Server-sent_events/Using_server-sent_events) (SSE) support for [Servant](https://github.com/haskell-servant/). Stream events from your server to connected clients, or consume third-party SSE streams (such as [OpenAI](https://platform.openai.com/docs/api-reference/streaming)) from Haskell. -Development Environment ------------------------ +## Quick start -Development environment uses [Nix](https://nixos.org) flakes. +Define a domain type and a `ToServerEvent` instance. Use `jsonEvent` to JSON-encode the data payload, or `serverEvent` for raw bytestrings: -To enter the dev shell, run -```bash -nix develop +```haskell +data ChatEvent + = ContentDelta Text + | ContentDone Text + | ChatDone + +type MyApi = "chat" :> ServerSentEvents (SourceIO ChatEvent) + +instance ToServerEvent ChatEvent where + toServerEvent (ContentDelta d) = jsonEvent (Just "response.content.delta") Nothing d + toServerEvent (ContentDone t) = jsonEvent (Just "response.content.done") Nothing t + toServerEvent ChatDone = jsonEvent (Just "response.done") Nothing () + +server :: Server MyApi +server = pure $ source + [ContentDelta "Hel", ContentDelta "lo!", ContentDone "Hello!", ChatDone] ``` -You can build the project with +For POST endpoints (e.g. OpenAI chat completions), use `PostServerSentEvents`: + +```haskell +type MyApi = "chat" :> ReqBody '[JSON] ChatRequest + :> PostServerSentEvents (SourceIO ChatEvent) +``` + +To consume an SSE stream, provide a `FromServerEvent` instance. Use `jsonData` to decode JSON from the data field: + +```haskell +instance FromServerEvent ChatEvent where + fromServerEvent ev = case eventType ev of + Just "response.content.delta" -> ContentDelta <$> jsonData ev + Just "response.content.done" -> ContentDone <$> jsonData ev + Just "response.done" -> Right ChatDone + _ -> Left "unknown event" +``` + +For types that serialise entirely as JSON (no event type dispatch), use `DerivingVia`: + +```haskell +data Temperature = Temperature { celsius :: Double } + deriving (Generic, ToJSON, FromJSON) + deriving (ToServerEvent, FromServerEvent) via JsonData Temperature +``` + +See the [Haddock documentation](https://hackage.haskell.org/package/servant-event-stream/docs/Servant-API-EventStream.html) for the full API reference, or the [upgrading guide](docs/upgrading-from-0.3.md) if you're coming from 0.3. + +## Coming from servant's built-in SSE + +Servant 0.20.3.0 introduced its own `ServerSentEvents` type in +`Servant.API.ServerSentEvents`. If you'd like to try this library instead, +here's how the concepts map: + +| servant built-in | servant-event-stream | +|---|---| +| `Servant.API.ServerSentEvents` | `Servant.API.EventStream` | +| `ServerSentEvents 'JsonEvent MyEvent` | `ServerSentEvents (SourceIO MyEvent)` | +| `EventKind` (`RawEvent` / `JsonEvent`) | `ToServerEvent` / `FromServerEvent` typeclasses | + +This library takes a typeclass approach: `ToServerEvent` and `FromServerEvent` +control how your domain types map to SSE fields, giving you access to event +names, ids, comments, and retry directives in a single `ServerEvent` record. +It also provides `PostServerSentEvents` for POST endpoints, and JSON helpers +(`jsonEvent`, `jsonData`, `JsonData`) for APIs that encode payloads as JSON. + +The built-in module focuses on client-side consumption (`HasClient` instances), +while this library provides both `HasServer` and `HasClient` instances. +See the [side-by-side examples](docs/coming-from-servant-sse.md) for a more +detailed walkthrough. + +## Development + +Uses [Nix](https://nixos.org) flakes for the development environment. + ```bash -nix build +nix develop # enter dev shell +nix build # full build +nix flake check # CI-equivalent check +cabal test # run tests (inside dev shell) ``` diff --git a/servant-event-stream.cabal b/servant-event-stream.cabal --- a/servant-event-stream.cabal +++ b/servant-event-stream.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: servant-event-stream -version: 0.3.2.1 +version: 0.4.0.0 stability: alpha synopsis: Servant support for Server-Sent events category: Servant, Web @@ -32,10 +32,14 @@ OverloadedStrings build-depends: + aeson >=1.4 && <2.3, + attoparsec >=0.13 && <0.15, base >=4.12 && <4.22, - bytestring >=0.11.1.0 && <0.13, + bytestring >=0.10.8 && <0.13, http-media >=0.7.1.3 && <0.9, lens >=4.17 && <5.4, + servant >=0.15 && <0.21, + servant-client-core >=0.15 && <0.21, servant-foreign >=0.15 && <0.17, servant-server >=0.15 && <0.21, text >=1.2.3 && <2.2 @@ -52,8 +56,10 @@ hs-source-dirs: tests default-language: Haskell2010 build-depends: + aeson >=1.4 && <2.3, base >=4.12 && <4.22, - bytestring >=0.11.1.0 && <0.13, + bytestring >=0.10.8 && <0.13, hspec >=2.7 && <2.12, + QuickCheck >=2.12 && <2.16, servant >=0.15 && <0.21, servant-event-stream 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 @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -11,68 +12,149 @@ {- | Module: Servant.API.EventStream -Description: Server Sent Events for Servant Streams +Description: Server-Sent Events for Servant Copyright: (c) 2026 Shaun Sharples License: BSD3 Stability: alpha + + +(SSE) support for Servant. Stream events from your server to connected clients, +or consume third-party SSE streams (such as +) from +Haskell. + +== Sending events + +Define a domain type for your events and a 'ToServerEvent' instance that maps +each constructor to an SSE event. Many streaming APIs encode the @data:@ field +as JSON — use 'jsonEvent' for this, or 'serverEvent' for raw bytestrings: + +> data ChatEvent +> = ContentDelta Text -- ^ incremental text chunk +> | ContentDone Text -- ^ final assembled text +> | ChatDone -- ^ stream finished +> +> type MyApi = "chat" :> ServerSentEvents (SourceIO ChatEvent) +> +> instance ToServerEvent ChatEvent where +> toServerEvent (ContentDelta d) = jsonEvent (Just "response.content.delta") Nothing d +> toServerEvent (ContentDone t) = jsonEvent (Just "response.content.done") Nothing t +> toServerEvent ChatDone = jsonEvent (Just "response.done") Nothing () +> +> server :: Server MyApi +> server = pure $ source +> [ContentDelta "Hel", ContentDelta "lo!", ContentDone "Hello!", ChatDone] + +Some APIs accept a request body and respond with an event stream (e.g. OpenAI +chat completions). Use 'PostServerSentEvents' for these @POST@ endpoints: + +> type MyApi = "chat" :> ReqBody '[JSON] ChatRequest :> PostServerSentEvents (SourceIO ChatEvent) + +== Receiving events + +To consume an SSE stream, provide a 'FromServerEvent' instance. Dispatch on +'eventType' to determine which constructor to use, and 'jsonData' to decode +JSON from the @data:@ field: + +> instance FromServerEvent ChatEvent where +> fromServerEvent ev = case eventType ev of +> Just "response.content.delta" -> ContentDelta <$> jsonData ev +> Just "response.content.done" -> ContentDone <$> jsonData ev +> Just "response.done" -> Right ChatDone +> _ -> Left "unknown event" + +== JSON via DerivingVia + +When every event carries the same JSON structure (no @event:@ type dispatch), +t'JsonData' derives both 'ToServerEvent' and 'FromServerEvent' automatically: + +> data Temperature = Temperature { celsius :: Double } +> deriving (Generic, ToJSON, FromJSON) +> deriving (ToServerEvent, FromServerEvent) via JsonData Temperature + +== Reverse-proxy headers + +Reverse proxies like nginx buffer responses by default, which prevents events +from reaching the client in real time. Wrap your stream in +'RecommendedEventSourceHeaders' to disable buffering: + +> type MyApi = "chat" :> ServerSentEvents (RecommendedEventSourceHeaders (SourceIO ChatEvent)) -} module Servant.API.EventStream ( - -- * Server-Sent Events + -- * API combinator + ServerSentEvents, + PostServerSentEvents, + EventStream, - -- | 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, ...] + -- * Events ServerEvent (..), + serverEvent, + dataEvent, + commentEvent, + retryEvent, + + -- * Sending events ToServerEvent (..), - ServerSentEvents, - EventStream, + encodeServerEvent, - -- * Recommended headers for Server-Sent Events + -- * Receiving events + FromServerEvent (..), + decodeServerEvent, - -- | This is mostly to guide reverse-proxies like - -- . - -- - -- Example: - -- - -- > type MyApi = "books" :> ServerSentEvents (RecommendedEventSourceHeaders (SourceIO Book)) - -- > - -- > server :: Server MyApi - -- > server = streamBooks - -- > where streamBooks :: Handler (RecommendedEventSourceHeaders (SourceIO Book)) - -- > streamBooks = pure $ recommendedEventSourceHeaders $ source [book1, ...] + -- * JSON helpers + JsonData (..), + jsonEvent, + jsonData, + + -- * Recommended headers RecommendedEventSourceHeaders, recommendedEventSourceHeaders, + + -- * Framing + ServerEventFraming, ) where -import Control.Lens +import Control.Lens ((%~), (&), (.~), (?~)) +import Control.Monad ((<=<)) +import qualified Data.Aeson as Aeson +import qualified Data.Attoparsec.ByteString.Char8 as A +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C8S import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.Char8 as C8 +import Data.Char (digitToInt, isDigit) import Data.Kind (Type) +#if !MIN_VERSION_base(4,20,0) +import Data.List (foldl') +#endif #if !MIN_VERSION_base(4,11,0) import Data.Semigroup #endif import Data.Text (Text) import GHC.Generics (Generic) -import Network.HTTP.Media ((//), (/:)) +import Network.HTTP.Media ((//)) + import qualified Servant as S -import qualified Servant.Foreign as S +import qualified Servant.Client.Core as SC +import qualified Servant.Foreign as SF import qualified Servant.Foreign.Internal as SFI +import Servant.Types.SourceT (transformWithAtto) -{- | A ServerSentEvents endpoint emits an event stream using the format described at - +-- --------------------------------------------------------------------------- +-- Content type + +-- | The @text\/event-stream@ content type. +data EventStream + +instance S.Accept EventStream where + contentType _ = "text" // "event-stream" + +-- --------------------------------------------------------------------------- +-- API combinator + +{- | Use this in place of a @Verb@ in your API type to define an SSE endpoint. +Streams events to clients over a long-lived HTTP connection. -} data ServerSentEvents (a :: Type) deriving (Generic) @@ -81,48 +163,269 @@ type MkLink (ServerSentEvents a) r = r toLink toA _ = toA --- | Represents an event sent from the server to the client in Server-Sent Events (SSE). +{- | Like 'ServerSentEvents' but for @POST@ endpoints. Use this when the +client sends a request body and the server responds with an event stream +(e.g. OpenAI's streaming API). +-} +data PostServerSentEvents (a :: Type) + deriving (Generic) + +instance S.HasLink (PostServerSentEvents a) where + type MkLink (PostServerSentEvents a) r = r + toLink toA _ = toA + +-- --------------------------------------------------------------------------- +-- Events + +-- | A single SSE event — the intermediate representation between your domain types and the wire format. data ServerEvent = ServerEvent { eventType :: !(Maybe LBS.ByteString) - -- ^ Optional field specifying the type of event. Can be used to distinguish between different kinds of events. + -- ^ The @event:@ field, used by clients to dispatch via @addEventListener@. , eventId :: !(Maybe LBS.ByteString) - -- ^ Optional field providing an identifier for the event. Useful for clients to keep track of the last received event. + -- ^ The @id:@ field. Sent as @Last-Event-ID@ on reconnection. , eventData :: !LBS.ByteString - -- ^ The payload or content of the event. This is the main data sent to the client. + -- ^ The @data:@ payload. Multi-line values are split across multiple @data:@ fields on the wire. + , eventComment :: !(Maybe LBS.ByteString) + -- ^ A @:@ comment line. Commonly used as a keepalive heartbeat. + , eventRetry :: !(Maybe Word) + -- ^ The @retry:@ field — reconnection delay in milliseconds. } deriving (Show, Eq, Generic) -{- | This typeclass allows you to define custom event types that can be - transformed into the t'ServerEvent' type, which is used to represent events in - the Server-Sent Events (SSE) protocol. +{- | Construct an event with a type, id, and data payload. +Mirrors the pre-0.4 @ServerEvent@ constructor for easy migration. -} +serverEvent :: Maybe LBS.ByteString -> Maybe LBS.ByteString -> LBS.ByteString -> ServerEvent +serverEvent typ eid dat = ServerEvent typ eid dat Nothing Nothing + +-- | An event carrying only a data payload, with no event type or id. +dataEvent :: LBS.ByteString -> ServerEvent +dataEvent dat = ServerEvent Nothing Nothing dat Nothing Nothing + +-- | Construct a comment-only event, useful as a keepalive heartbeat. +commentEvent :: LBS.ByteString -> ServerEvent +commentEvent c = ServerEvent Nothing Nothing "" (Just c) Nothing + +-- | Construct a retry event that sets the client's reconnection delay in milliseconds. +retryEvent :: Word -> ServerEvent +retryEvent ms = ServerEvent Nothing Nothing "" Nothing (Just ms) + +-- --------------------------------------------------------------------------- +-- Sending events + +-- | Convert a domain type to a t'ServerEvent' for sending over the wire. class ToServerEvent a where toServerEvent :: a -> ServerEvent +instance ToServerEvent ServerEvent where + toServerEvent = id + instance (ToServerEvent a) => S.MimeRender EventStream a where mimeRender _ = encodeServerEvent . toServerEvent -{- 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. --} - --- | Encodes a t'ServerEvent' into a 'LBS.ByteString' that can be sent to the client. +-- | Encode a t'ServerEvent' to its wire format. Called automatically by 'S.MimeRender'; use directly only for custom encoding needs. encodeServerEvent :: ServerEvent -> LBS.ByteString encodeServerEvent e = - optional "event:" (eventType e) - <> optional "id:" (eventId e) - <> mconcat (map (field "data:") (safelines (eventData e))) + optional ":" (sanitize <$> eventComment e) + <> maybe mempty (\ms -> "retry: " <> C8.pack (show ms) <> "\n") (eventRetry e) + <> optional "event:" (sanitize <$> eventType e) + <> optional "id:" (sanitizeId <$> eventId e) + <> mconcat (map (field "data:") (safedata (eventData e))) where optional name = maybe mempty (field name) field name val = name <> " " <> val <> "\n" - -- discard CR and split LFs into multiple data values + sanitize = C8.filter (\c -> c /= '\r' && c /= '\n') + sanitizeId = C8.filter (\c -> c /= '\r' && c /= '\n' && c /= '\0') + + safedata bs = case safelines bs of + [] -> [""] + xs -> xs safelines = C8.lines . C8.filter (/= '\r') -instance ToServerEvent ServerEvent where - toServerEvent = id +-- --------------------------------------------------------------------------- +-- Receiving events +-- | Parse a received t'ServerEvent' back into a domain type. +class FromServerEvent a where + fromServerEvent :: ServerEvent -> Either String a + +instance FromServerEvent ServerEvent where + fromServerEvent = Right + +instance (FromServerEvent a) => S.MimeUnrender EventStream a where + mimeUnrender _ = fromServerEvent <=< decodeServerEvent + +{- | Decode a single SSE event block from its wire format. Called automatically +by 'S.MimeUnrender'; use directly only for custom decoding needs. + +Parsing follows the +. +-} +decodeServerEvent :: LBS.ByteString -> Either String ServerEvent +decodeServerEvent input = + let ls = splitLines (stripBOM (LBS.toStrict input)) + (typ, eid, dataParts, comment, retry) = foldl' processLine (Nothing, Nothing, [], Nothing, Nothing) ls + dat = case dataParts of + [] -> "" + _ -> LBS.fromStrict (BS.intercalate "\n" (reverse dataParts)) + in Right + ServerEvent + { eventType = LBS.fromStrict <$> typ + , eventId = LBS.fromStrict <$> eid + , eventData = dat + , eventComment = LBS.fromStrict <$> comment + , eventRetry = retry + } + where + processLine acc@(typ, eid, dataParts, comment, retry) line + | BS.null line = acc -- skip empty lines + | C8S.head line == ':' = + let val = stripOneSpace (BS.drop 1 line) + in (typ, eid, dataParts, Just val, retry) + | otherwise = + let (name, val) = case C8S.elemIndex ':' line of + Just i -> (BS.take i line, stripOneSpace (BS.drop (i + 1) line)) + Nothing -> (line, "") + in if + | name == "event" -> (Just val, eid, dataParts, comment, retry) + | name == "data" -> (typ, eid, val : dataParts, comment, retry) + | name == "id" -> + if C8S.elem '\0' val + then acc + else (typ, Just val, dataParts, comment, retry) + | name == "retry" -> + if BS.null val || not (C8S.all isDigit val) + then acc + else (typ, eid, dataParts, comment, Just (parseWord val)) + | otherwise -> acc + + stripOneSpace bs + | not (BS.null bs) && C8S.head bs == ' ' = BS.drop 1 bs + | otherwise = bs + + parseWord = C8S.foldl' (\n c -> n * 10 + fromIntegral (digitToInt c)) 0 + + splitLines bs = map stripCR (C8S.split '\n' bs) + where + stripCR s + | BS.null s = s + | C8S.last s == '\r' = BS.init s + | otherwise = s + +-- --------------------------------------------------------------------------- +-- JSON helpers + +{- | Derive 'ToServerEvent' and 'FromServerEvent' for types that serialise +entirely as JSON in the @data:@ field, with no @event:@ type or @id:@. + +For sum types that dispatch on 'eventType', write manual instances using +'jsonEvent' and 'jsonData' instead. + +@ +data Temperature = Temperature { celsius :: Double } + deriving (ToJSON, FromJSON) + deriving (ToServerEvent, FromServerEvent) via JsonData Temperature +@ +-} +newtype JsonData a = JsonData {unJsonData :: a} + +instance (Aeson.ToJSON a) => ToServerEvent (JsonData a) where + toServerEvent (JsonData a) = jsonEvent Nothing Nothing a + +instance (Aeson.FromJSON a) => FromServerEvent (JsonData a) where + fromServerEvent = fmap JsonData . jsonData + +{- | Construct a t'ServerEvent' with a JSON-encoded @data:@ payload. +The encoding counterpart to 'jsonData'. + +@ +instance ToServerEvent ChatEvent where + toServerEvent (ContentDelta d) = jsonEvent (Just \"response.content.delta\") Nothing d + toServerEvent ChatDone = jsonEvent (Just \"response.done\") Nothing () +@ +-} +jsonEvent :: (Aeson.ToJSON a) => Maybe LBS.ByteString -> Maybe LBS.ByteString -> a -> ServerEvent +jsonEvent typ eid a = serverEvent typ eid (Aeson.encode a) + +{- | Decode the 'eventData' field as JSON. +The decoding counterpart to 'jsonEvent'. + +@ +instance FromServerEvent ChatEvent where + fromServerEvent ev = case eventType ev of + Just \"response.content.delta\" -> ContentDelta \<$\> jsonData ev + Just \"response.done\" -> Right ChatDone + _ -> Left \"unknown event\" +@ +-} +jsonData :: (Aeson.FromJSON a) => ServerEvent -> Either String a +jsonData = Aeson.eitherDecode . eventData + +-- | Strip a leading UTF-8 BOM (@\\xEF\\xBB\\xBF@) if present, per the WHATWG SSE spec. +stripBOM :: BS.ByteString -> BS.ByteString +stripBOM bs + | "\xEF\xBB\xBF" `BS.isPrefixOf` bs = BS.drop 3 bs + | otherwise = bs + +-- --------------------------------------------------------------------------- +-- Recommended headers + +{- | Adds @X-Accel-Buffering: no@ and @Cache-Control: no-store@ headers to +prevent reverse proxies (e.g. nginx) from buffering the event stream. + +> type MyApi = "events" :> ServerSentEvents (RecommendedEventSourceHeaders (SourceIO Event)) +> +> server :: Server MyApi +> server = pure $ recommendedEventSourceHeaders $ source [event1, event2] +-} +type RecommendedEventSourceHeaders (a :: Type) = S.Headers '[S.Header "X-Accel-Buffering" Text, S.Header "Cache-Control" Text] a + +-- | Wrap a streaming response with the recommended headers. See 'RecommendedEventSourceHeaders'. +recommendedEventSourceHeaders :: a -> RecommendedEventSourceHeaders a +recommendedEventSourceHeaders = S.addHeader @"X-Accel-Buffering" "no" . S.addHeader @"Cache-Control" "no-store" + +-- --------------------------------------------------------------------------- +-- Framing + +-- | SSE framing strategy. Applied automatically by 'ServerSentEvents' and 'PostServerSentEvents'. +data ServerEventFraming + +instance S.FramingRender ServerEventFraming where + framingRender _ f = fmap (\x -> f x <> "\n") + +instance S.FramingUnrender ServerEventFraming where + framingUnrender _ f = transformWithAtto (eventParser f) + +eventParser :: (LBS.ByteString -> Either String a) -> A.Parser a +eventParser f = do + ls <- collectLines + case ls of + [] -> fail "empty event" + _ -> do + let block = stripBOM (BS.intercalate "\n" ls <> "\n") + case f (LBS.fromStrict block) of + Left err -> fail err + Right a -> pure a + where + collectLines = do + atEnd <- A.atEnd + if atEnd + then pure [] + else do + line <- A.takeWhile (\c -> c /= '\n' && c /= '\r') + -- consume line ending: CRLF, CR, or LF + _ <- A.option () (A.char '\r' *> pure ()) + _ <- A.option () (A.char '\n' *> pure ()) + if BS.null line + then pure [] + else do + rest <- collectLines + pure (line : rest) + +-- --------------------------------------------------------------------------- +-- Servant integration + instance {-# OVERLAPPABLE #-} (ToServerEvent chunk, S.ToSourceIO chunk a) => S.HasServer (ServerSentEvents a) context where type ServerT (ServerSentEvents a) m = S.ServerT (S.StreamGet ServerEventFraming EventStream a) m route S.Proxy = @@ -141,10 +444,72 @@ S.hoistServerWithContext (S.Proxy :: S.Proxy (S.StreamGet ServerEventFraming EventStream (S.Headers h a))) --- | a helper instance for +instance {-# OVERLAPPABLE #-} (ToServerEvent chunk, S.ToSourceIO chunk a) => S.HasServer (PostServerSentEvents a) context where + type ServerT (PostServerSentEvents a) m = S.ServerT (S.StreamPost ServerEventFraming EventStream a) m + route S.Proxy = + S.route + (S.Proxy :: S.Proxy (S.StreamPost ServerEventFraming EventStream a)) + hoistServerWithContext S.Proxy = + S.hoistServerWithContext + (S.Proxy :: S.Proxy (S.StreamPost ServerEventFraming EventStream a)) + +instance {-# OVERLAPPING #-} (ToServerEvent chunk, S.ToSourceIO chunk a, S.GetHeaders (S.Headers h a)) => S.HasServer (PostServerSentEvents (S.Headers h a)) context where + type ServerT (PostServerSentEvents (S.Headers h a)) m = S.ServerT (S.StreamPost ServerEventFraming EventStream (S.Headers h a)) m + route S.Proxy = + S.route + (S.Proxy :: S.Proxy (S.StreamPost ServerEventFraming EventStream (S.Headers h a))) + hoistServerWithContext S.Proxy = + S.hoistServerWithContext + (S.Proxy :: S.Proxy (S.StreamPost ServerEventFraming EventStream (S.Headers h a))) + +instance {-# OVERLAPPABLE #-} (FromServerEvent chunk, SC.RunStreamingClient m, S.FromSourceIO chunk a) => SC.HasClient m (ServerSentEvents a) where + type Client m (ServerSentEvents a) = SC.Client m (S.StreamGet ServerEventFraming EventStream a) + clientWithRoute pm S.Proxy = + SC.clientWithRoute + pm + (S.Proxy :: S.Proxy (S.StreamGet ServerEventFraming EventStream a)) + hoistClientMonad pm S.Proxy = + SC.hoistClientMonad + pm + (S.Proxy :: S.Proxy (S.StreamGet ServerEventFraming EventStream a)) + +instance {-# OVERLAPPING #-} (FromServerEvent chunk, SC.RunStreamingClient m, S.FromSourceIO chunk a, S.BuildHeadersTo h) => SC.HasClient m (ServerSentEvents (S.Headers h a)) where + type Client m (ServerSentEvents (S.Headers h a)) = SC.Client m (S.StreamGet ServerEventFraming EventStream (S.Headers h a)) + clientWithRoute pm S.Proxy = + SC.clientWithRoute + pm + (S.Proxy :: S.Proxy (S.StreamGet ServerEventFraming EventStream (S.Headers h a))) + hoistClientMonad pm S.Proxy = + SC.hoistClientMonad + pm + (S.Proxy :: S.Proxy (S.StreamGet ServerEventFraming EventStream (S.Headers h a))) + +instance {-# OVERLAPPABLE #-} (FromServerEvent chunk, SC.RunStreamingClient m, S.FromSourceIO chunk a) => SC.HasClient m (PostServerSentEvents a) where + type Client m (PostServerSentEvents a) = SC.Client m (S.StreamPost ServerEventFraming EventStream a) + clientWithRoute pm S.Proxy = + SC.clientWithRoute + pm + (S.Proxy :: S.Proxy (S.StreamPost ServerEventFraming EventStream a)) + hoistClientMonad pm S.Proxy = + SC.hoistClientMonad + pm + (S.Proxy :: S.Proxy (S.StreamPost ServerEventFraming EventStream a)) + +instance {-# OVERLAPPING #-} (FromServerEvent chunk, SC.RunStreamingClient m, S.FromSourceIO chunk a, S.BuildHeadersTo h) => SC.HasClient m (PostServerSentEvents (S.Headers h a)) where + type Client m (PostServerSentEvents (S.Headers h a)) = SC.Client m (S.StreamPost ServerEventFraming EventStream (S.Headers h a)) + clientWithRoute pm S.Proxy = + SC.clientWithRoute + pm + (S.Proxy :: S.Proxy (S.StreamPost ServerEventFraming EventStream (S.Headers h a))) + hoistClientMonad pm S.Proxy = + SC.hoistClientMonad + pm + (S.Proxy :: S.Proxy (S.StreamPost ServerEventFraming EventStream (S.Headers h a))) + +-- | Enables code generation, prefixing function names with \"stream\". instance - (S.HasForeignType lang ftype a) => - S.HasForeign lang ftype (ServerSentEvents a) + (SF.HasForeignType lang ftype a) => + SF.HasForeign lang ftype (ServerSentEvents a) where type Foreign ftype (ServerSentEvents a) = SFI.Req ftype @@ -157,25 +522,18 @@ retType = SFI.typeFor lang (S.Proxy :: S.Proxy ftype) (S.Proxy :: S.Proxy a) method = S.reflectMethod (S.Proxy :: S.Proxy S.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 --} -data EventStream - -instance S.Accept EventStream where - contentType _ = "text" // "event-stream" /: ("charset", "utf-8") - --- | Recommended headers for Server-Sent Events. -type RecommendedEventSourceHeaders (a :: Type) = S.Headers '[S.Header "X-Accel-Buffering" Text, S.Header "Cache-Control" Text] a - --- | Add the recommended headers for Server-Sent Events to the response. -recommendedEventSourceHeaders :: a -> RecommendedEventSourceHeaders a -recommendedEventSourceHeaders = S.addHeader @"X-Accel-Buffering" "no" . S.addHeader @"Cache-Control" "no-store" - --- | A framing strategy for Server-Sent Events. -data ServerEventFraming +-- | Enables code generation for 'PostServerSentEvents'. +instance + (SF.HasForeignType lang ftype a) => + SF.HasForeign lang ftype (PostServerSentEvents a) + where + type Foreign ftype (PostServerSentEvents a) = SFI.Req ftype --- | Frames the server events by joining chunks with a newline. -instance S.FramingRender ServerEventFraming where - framingRender _ f = fmap (\x -> f x <> "\n") + foreignFor lang S.Proxy S.Proxy req = + req + & SFI.reqFuncName . SFI._FunctionName %~ ("stream" :) + & SFI.reqMethod .~ method + & SFI.reqReturnType ?~ retType + where + retType = SFI.typeFor lang (S.Proxy :: S.Proxy ftype) (S.Proxy :: S.Proxy a) + method = S.reflectMethod (S.Proxy :: S.Proxy S.POST) diff --git a/tests/Spec.hs b/tests/Spec.hs --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -1,55 +1,469 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Main (main) where +import Data.Aeson (FromJSON, ToJSON) import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as C8 import Data.Proxy (Proxy (..)) -import Servant.API.ContentTypes (mimeRender) +import GHC.Generics (Generic) +import Servant.API.ContentTypes (mimeRender, mimeUnrender) import Servant.API.EventStream import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck +-- A domain type mirroring the haddock usage example. +data ChatEvent + = ContentDelta LBS.ByteString + | ContentDone LBS.ByteString + | ChatDone + deriving (Show, Eq) + +instance ToServerEvent ChatEvent where + toServerEvent (ContentDelta d) = + serverEvent (Just "response.content.delta") Nothing d + toServerEvent (ContentDone t) = + serverEvent (Just "response.content.done") Nothing t + toServerEvent ChatDone = + serverEvent (Just "response.done") Nothing "" + +instance FromServerEvent ChatEvent where + fromServerEvent ev = case eventType ev of + Just "response.content.delta" -> Right (ContentDelta (eventData ev)) + Just "response.content.done" -> Right (ContentDone (eventData ev)) + Just "response.done" -> Right ChatDone + _ -> Left "unknown event" + +-- A simple type using DerivingVia for JSON-based SSE. +data Temperature = Temperature {celsius :: Double} + deriving (Show, Eq, Generic) + deriving (ToJSON, FromJSON) + deriving (ToServerEvent, FromServerEvent) via JsonData Temperature + +-- Arbitrary instance for roundtrip property testing. +-- Generates "canonical" ServerEvent values that survive encode/decode: +-- - no CR or LF in single-line fields (type, id, comment) +-- - no NULL in id (spec says to ignore id fields containing NULL) +-- - no CR in data, no trailing LF in data +-- Includes non-ASCII bytes (128-255) to exercise the full byte range. +instance Arbitrary ServerEvent where + arbitrary = + ServerEvent + <$> genMaybe genSafeLine + <*> genMaybe genSafeId + <*> genSafeData + <*> genMaybe genSafeLine + <*> arbitrary + shrink (ServerEvent typ eid dat com ret) = + concat + [ [ServerEvent Nothing eid dat com ret | Just _ <- [typ]] + , [ServerEvent typ Nothing dat com ret | Just _ <- [eid]] + , [ServerEvent typ eid "" com ret | dat /= ""] + , [ServerEvent typ eid dat Nothing ret | Just _ <- [com]] + , [ServerEvent typ eid dat com Nothing | Just _ <- [ret]] + ] + +genMaybe :: Gen a -> Gen (Maybe a) +genMaybe g = frequency [(1, pure Nothing), (3, Just <$> g)] + +-- | Generate an arbitrary byte that is not CR (0x0D), LF (0x0A), or NULL (0x00). +genSafeByte :: Gen Char +genSafeByte = + frequency + [ (10, elements ['a' .. 'z']) + , (3, pure ' ') + , (2, pure ':') + , (1, elements "!@#$%^&*") + , (4, toEnum <$> choose (128, 255)) + ] + +{- | Single-line value with no CR or LF (safe for type and comment fields). +May contain NULL and non-ASCII bytes. +-} +genSafeLine :: Gen LBS.ByteString +genSafeLine = C8.pack <$> listOf genSafeByte + +-- | Single-line value with no CR, LF, or NULL (safe for the id field). +genSafeId :: Gen LBS.ByteString +genSafeId = C8.pack <$> listOf (genSafeByte `suchThat` (/= '\0')) + +{- | Multi-line data: no CR, no trailing LF. +Lines may contain non-ASCII bytes and NULL. +-} +genSafeData :: Gen LBS.ByteString +genSafeData = + frequency + [ (1, pure "") + , + ( 5 + , do + leading <- listOf genSafeLine + final <- genSafeLine `suchThat` (not . LBS.null) + pure (C8.intercalate "\n" (leading ++ [final])) + ) + ] + render :: ServerEvent -> LBS.ByteString render = mimeRender (Proxy :: Proxy EventStream) +decode :: LBS.ByteString -> Either String ServerEvent +decode = mimeUnrender (Proxy :: Proxy EventStream) + +-- | UTF-8 Byte Order Mark (U+FEFF), encoded as 3 bytes: @EF BB BF@. +bom :: LBS.ByteString +bom = "\xEF\xBB\xBF" + main :: IO () main = hspec $ do describe "MimeRender EventStream ServerEvent" $ do it "encodes data-only event" $ - render (ServerEvent Nothing Nothing "hello") + render (dataEvent "hello") `shouldBe` "data: hello\n" it "encodes event with all fields" $ - render (ServerEvent (Just "update") (Just "1") "payload") - `shouldBe` "event: update\nid: 1\ndata: payload\n" + render (ServerEvent (Just "update") (Just "1") "payload" (Just "note") (Just 5000)) + `shouldBe` ": note\nretry: 5000\nevent: update\nid: 1\ndata: payload\n" it "encodes multi-line data as multiple data fields" $ - render (ServerEvent Nothing Nothing "line1\nline2\nline3") + render (serverEvent Nothing Nothing "line1\nline2\nline3") `shouldBe` "data: line1\ndata: line2\ndata: line3\n" it "preserves leading space in data value" $ - render (ServerEvent Nothing Nothing " How") + render (serverEvent Nothing Nothing " How") `shouldBe` "data: How\n" it "preserves leading space in event type" $ - render (ServerEvent (Just " custom") Nothing "x") + render (serverEvent (Just " custom") Nothing "x") `shouldBe` "event: custom\ndata: x\n" it "preserves leading space in event id" $ - render (ServerEvent Nothing (Just " 42") "x") + render (serverEvent Nothing (Just " 42") "x") `shouldBe` "id: 42\ndata: x\n" - it "encodes empty data as empty output" $ - render (ServerEvent Nothing Nothing "") - `shouldBe` "" + it "encodes empty data as a single data field" $ + render (serverEvent Nothing Nothing "") + `shouldBe` "data: \n" + it "encodes empty data with event type" $ + render (serverEvent (Just "ping") Nothing "") + `shouldBe` "event: ping\ndata: \n" + + it "handles trailing newline in data" $ + render (dataEvent "hello\n") + `shouldBe` "data: hello\n" + + it "handles data that is only a newline" $ + render (dataEvent "\n") + `shouldBe` "data: \n" + + it "handles data that is only CR" $ + render (dataEvent "\r") + `shouldBe` "data: \n" + it "strips CR characters from data" $ - render (ServerEvent Nothing Nothing "hello\r\nworld") + render (serverEvent Nothing Nothing "hello\r\nworld") `shouldBe` "data: hello\ndata: world\n" + it "emits empty event type" $ + render (serverEvent (Just "") Nothing "x") + `shouldBe` "event: \ndata: x\n" + + it "emits empty event id" $ + render (serverEvent Nothing (Just "") "x") + `shouldBe` "id: \ndata: x\n" + it "omits event field when Nothing" $ - render (ServerEvent Nothing (Just "1") "x") + render (serverEvent Nothing (Just "1") "x") `shouldBe` "id: 1\ndata: x\n" it "omits id field when Nothing" $ - render (ServerEvent (Just "ping") Nothing "x") + render (serverEvent (Just "ping") Nothing "x") `shouldBe` "event: ping\ndata: x\n" + + describe "comment support" $ do + it "encodes a comment-only event" $ + render (commentEvent "keepalive") + `shouldBe` ": keepalive\ndata: \n" + + it "encodes comment with data" $ + render (ServerEvent Nothing Nothing "hello" (Just "debug") Nothing) + `shouldBe` ": debug\ndata: hello\n" + + it "encodes empty comment" $ + render (commentEvent "") + `shouldBe` ": \ndata: \n" + + it "strips CR and LF from comment" $ + render (commentEvent "line1\r\nline2") + `shouldBe` ": line1line2\ndata: \n" + + describe "retry support" $ do + it "encodes a retry-only event" $ + render (retryEvent 3000) + `shouldBe` "retry: 3000\ndata: \n" + + it "encodes retry zero" $ + render (retryEvent 0) + `shouldBe` "retry: 0\ndata: \n" + + it "encodes retry with data" $ + render (ServerEvent Nothing Nothing "hello" Nothing (Just 1000)) + `shouldBe` "retry: 1000\ndata: hello\n" + + describe "field sanitization" $ do + it "strips LF from event type" $ + render (serverEvent (Just "bad\ntype") Nothing "x") + `shouldBe` "event: badtype\ndata: x\n" + + it "strips CR from event type" $ + render (serverEvent (Just "bad\rtype") Nothing "x") + `shouldBe` "event: badtype\ndata: x\n" + + it "strips CRLF from event id" $ + render (serverEvent Nothing (Just "bad\r\nid") "x") + `shouldBe` "id: badid\ndata: x\n" + + it "strips NULL from event id" $ + render (serverEvent Nothing (Just "abc\0def") "x") + `shouldBe` "id: abcdef\ndata: x\n" + + describe "convenience constructors" $ do + it "dataEvent is equivalent to serverEvent Nothing Nothing" $ + dataEvent "hello" `shouldBe` serverEvent Nothing Nothing "hello" + + it "commentEvent sets comment field" $ + commentEvent "hi" `shouldBe` ServerEvent Nothing Nothing "" (Just "hi") Nothing + + it "retryEvent sets retry field" $ + retryEvent 5000 `shouldBe` ServerEvent Nothing Nothing "" Nothing (Just 5000) + + describe "decodeServerEvent" $ do + it "decodes data-only event" $ + decode "data: hello\n" + `shouldBe` Right (dataEvent "hello") + + it "decodes event with all fields" $ + decode ": note\nretry: 5000\nevent: update\nid: 1\ndata: payload\n" + `shouldBe` Right (ServerEvent (Just "update") (Just "1") "payload" (Just "note") (Just 5000)) + + it "decodes multi-line data" $ + decode "data: line1\ndata: line2\ndata: line3\n" + `shouldBe` Right (dataEvent "line1\nline2\nline3") + + it "strips exactly one leading space from values" $ + decode "data: hello\n" + `shouldBe` Right (dataEvent "hello") + + it "handles no space after colon" $ + decode "data:hello\n" + `shouldBe` Right (dataEvent "hello") + + it "preserves leading space beyond the first" $ + decode "data: How\n" + `shouldBe` Right (dataEvent " How") + + it "decodes comment" $ + decode ": keepalive\ndata: x\n" + `shouldBe` Right (ServerEvent Nothing Nothing "x" (Just "keepalive") Nothing) + + it "decodes comment with space stripping" $ + decode ":keepalive\n" + `shouldBe` Right (ServerEvent Nothing Nothing "" (Just "keepalive") Nothing) + + it "decodes retry" $ + decode "retry: 3000\ndata: x\n" + `shouldBe` Right (ServerEvent Nothing Nothing "x" Nothing (Just 3000)) + + it "ignores retry with non-digit value" $ + decode "retry: abc\ndata: x\n" + `shouldBe` Right (dataEvent "x") + + it "ignores retry with empty value" $ + decode "retry:\ndata: x\n" + `shouldBe` Right (dataEvent "x") + + it "ignores id containing NULL" $ + decode "id: abc\0def\ndata: x\n" + `shouldBe` Right (dataEvent "x") + + it "decodes CRLF line endings" $ + decode "data: hello\r\ndata: world\r\n" + `shouldBe` Right (dataEvent "hello\nworld") + + it "decodes empty data" $ + decode "data: \n" + `shouldBe` Right (dataEvent "") + + it "decodes empty data without space" $ + decode "data:\n" + `shouldBe` Right (dataEvent "") + + it "decodes event type" $ + decode "event: update\ndata: x\n" + `shouldBe` Right (serverEvent (Just "update") Nothing "x") + + it "decodes event id" $ + decode "id: 42\ndata: x\n" + `shouldBe` Right (serverEvent Nothing (Just "42") "x") + + it "ignores unknown fields" $ + decode "foo: bar\ndata: hello\n" + `shouldBe` Right (dataEvent "hello") + + it "handles field name with no colon as empty value" $ + decode "data\n" + `shouldBe` Right (dataEvent "") + + it "uses last comment when multiple present" $ + decode ": first\n: second\ndata: x\n" + `shouldBe` Right (ServerEvent Nothing Nothing "x" (Just "second") Nothing) + + it "uses last event type when multiple present" $ + decode "event: a\nevent: b\ndata: x\n" + `shouldBe` Right (serverEvent (Just "b") Nothing "x") + + it "decodes empty input as empty event" $ + decode "" + `shouldBe` Right (ServerEvent Nothing Nothing "" Nothing Nothing) + + describe "BOM handling" $ do + it "strips UTF-8 BOM from input" $ + decode (bom <> "data: hello\n") + `shouldBe` Right (dataEvent "hello") + + it "strips BOM with event fields" $ + decode (bom <> "event: update\ndata: x\n") + `shouldBe` Right (serverEvent (Just "update") Nothing "x") + + it "handles input that is only a BOM" $ + decode bom + `shouldBe` Right (ServerEvent Nothing Nothing "" Nothing Nothing) + + describe "roundtrip (encode then decode)" $ do + it "roundtrips data-only event" $ + decode (render (dataEvent "hello")) + `shouldBe` Right (dataEvent "hello") + + it "roundtrips event with type and id" $ + decode (render (serverEvent (Just "update") (Just "1") "payload")) + `shouldBe` Right (serverEvent (Just "update") (Just "1") "payload") + + it "roundtrips event with all fields" $ + let e = ServerEvent (Just "update") (Just "1") "payload" (Just "note") (Just 5000) + in decode (render e) `shouldBe` Right e + + it "roundtrips multi-line data" $ + decode (render (dataEvent "line1\nline2\nline3")) + `shouldBe` Right (dataEvent "line1\nline2\nline3") + + it "roundtrips comment event" $ + decode (render (commentEvent "keepalive")) + `shouldBe` Right (commentEvent "keepalive") + + it "roundtrips retry event" $ + decode (render (retryEvent 3000)) + `shouldBe` Right (retryEvent 3000) + + it "roundtrips empty data" $ + decode (render (dataEvent "")) + `shouldBe` Right (dataEvent "") + + it "roundtrips event with leading space in data" $ + decode (render (dataEvent " hello")) + `shouldBe` Right (dataEvent " hello") + + describe "custom type (ToServerEvent / FromServerEvent)" $ do + let renderC :: ChatEvent -> LBS.ByteString + renderC = mimeRender (Proxy :: Proxy EventStream) + decodeC :: LBS.ByteString -> Either String ChatEvent + decodeC = mimeUnrender (Proxy :: Proxy EventStream) + + it "encodes ContentDelta" $ + renderC (ContentDelta "Hel") + `shouldBe` "event: response.content.delta\ndata: Hel\n" + + it "encodes ContentDone" $ + renderC (ContentDone "Hello!") + `shouldBe` "event: response.content.done\ndata: Hello!\n" + + it "encodes ChatDone" $ + renderC ChatDone + `shouldBe` "event: response.done\ndata: \n" + + it "decodes ContentDelta" $ + decodeC "event: response.content.delta\ndata: Hel\n" + `shouldBe` Right (ContentDelta "Hel") + + it "decodes ContentDone" $ + decodeC "event: response.content.done\ndata: Hello!\n" + `shouldBe` Right (ContentDone "Hello!") + + it "decodes ChatDone" $ + decodeC "event: response.done\ndata: \n" + `shouldBe` Right ChatDone + + it "roundtrips ContentDelta" $ + decodeC (renderC (ContentDelta "Hel")) + `shouldBe` Right (ContentDelta "Hel") + + it "roundtrips ContentDone" $ + decodeC (renderC (ContentDone "Hello!")) + `shouldBe` Right (ContentDone "Hello!") + + it "roundtrips ChatDone" $ + decodeC (renderC ChatDone) `shouldBe` Right ChatDone + + it "rejects unknown event type" $ + decodeC "event: other\ndata: hello\n" + `shouldBe` Left "unknown event" + + it "rejects missing event type" $ + decodeC "data: hello\n" + `shouldBe` Left "unknown event" + + describe "JSON helpers" $ do + let renderT :: Temperature -> LBS.ByteString + renderT = mimeRender (Proxy :: Proxy EventStream) + decodeT :: LBS.ByteString -> Either String Temperature + decodeT = mimeUnrender (Proxy :: Proxy EventStream) + + it "encodes via JsonData" $ + renderT (Temperature 36.6) + `shouldBe` "data: {\"celsius\":36.6}\n" + + it "decodes via JsonData" $ + decodeT "data: {\"celsius\":36.6}\n" + `shouldBe` Right (Temperature 36.6) + + it "roundtrips via JsonData" $ + decodeT (renderT (Temperature 100.0)) + `shouldBe` Right (Temperature 100.0) + + it "jsonData decodes event data as JSON" $ + jsonData (serverEvent (Just "update") Nothing "{\"celsius\":20.0}") + `shouldBe` Right (Temperature 20.0) + + it "jsonData reports JSON parse errors" $ + (jsonData (dataEvent "not json") :: Either String Temperature) + `shouldSatisfy` \case Left _ -> True; Right _ -> False + + it "jsonEvent sets event type and JSON-encodes data" $ + jsonEvent (Just "update") Nothing (Temperature 25.5) + `shouldBe` serverEvent (Just "update") Nothing "{\"celsius\":25.5}" + + it "jsonEvent sets event id" $ + jsonEvent Nothing (Just "42") (Temperature 25.5) + `shouldBe` serverEvent Nothing (Just "42") "{\"celsius\":25.5}" + + it "jsonEvent roundtrips with jsonData" $ + let ev = jsonEvent (Just "update") (Just "1") (Temperature 37.0) + in jsonData ev `shouldBe` Right (Temperature 37.0) + + describe "roundtrip properties" $ do + prop "encode then decode is identity for canonical ServerEvent" $ \e -> + decode (render e) === Right (e :: ServerEvent)