{-# 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 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 (dataEvent "hello")
`shouldBe` "data: hello\n"
it "encodes event with all fields" $
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")
`shouldBe` "data: line1\ndata: line2\ndata: line3\n"
it "preserves leading space in data value" $
render (serverEvent Nothing Nothing " How")
`shouldBe` "data: How\n"
it "preserves leading space in event type" $
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")
`shouldBe` "id: 42\ndata: x\n"
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")
`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")
`shouldBe` "id: 1\ndata: x\n"
it "omits id field when Nothing" $
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)