servant-event-stream 0.3.2.1 → 0.4.0.0

raw patch · 5 files changed

+988/−108 lines, 5 filesdep +QuickCheckdep +aesondep +attoparsecdep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, aeson, attoparsec, servant-client-core

Dependency ranges changed: bytestring

API changes (from Hackage documentation)

Files

• CHANGELOG.md +35/−0
• README.md +79/−12
• servant-event-stream.cabal +9/−3
• src/Servant/API/EventStream.hs +437/−79
• tests/Spec.hs +428/−14

@@ -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

@@ -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) ```

@@ -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

@@ -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++<https://developer.mozilla.org/en-US/docs/Web/API/Server-sent_events/Using_server-sent_events Server-Sent Events>+(SSE) support for Servant. Stream events from your server to connected clients,+or consume third-party SSE streams (such as+<https://platform.openai.com/docs/api-reference/streaming OpenAI>) 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-  --   <https://www.nginx.com/resources/wiki/start/topics/examples/x-accel/#x-accel-buffering nginx>.-  ---  --   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-  <https://developer.mozilla.org/en-US/docs/Web/API/Server-sent_events/Using_server-sent_events#event_stream_format>+-- ---------------------------------------------------------------------------+-- 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+<https://html.spec.whatwg.org/multipage/server-sent-events.html#event-stream-interpretation WHATWG SSE spec>.+-}+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 <https://hackage.haskell.org/package/servant-foreign-0.15.3/docs/Servant-Foreign.html servant-foreign>+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 <https://hackage.haskell.org/package/servant-foreign servant-foreign> 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 <https://docs.servant.dev/en/stable/tutorial/Server.html#streaming-endpoints Servant Streaming Docs>--}-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 <https://hackage.haskell.org/package/servant-foreign servant-foreign> 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)

@@ -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)