diff --git a/.gitignore b/.gitignore index 3d95d8a..0ec1d18 100644 --- a/.gitignore +++ b/.gitignore @@ -4,4 +4,5 @@ dist-newstyle/ .stack-work/ .direnv/ # nix results -result \ No newline at end of file +result +haddocks diff --git a/CHANGELOG.md b/CHANGELOG.md index d71a16a..f5e4f04 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,17 @@ # Revision history for servant-event-stream +## 0.4.0.0 -- 2024-12-06 (in progress) + +* Support decoding of Server-Sent Events using a `FromServerEvent` typeclass. + +* Breaking changes to `ServerEvent`. + + Fields have changed from Lazy ByteString to Text to align more closely with + the [specification](https://html.spec.whatwg.org/multipage/server-sent-events.html#event-stream-interpretation) + which explicitly specify that streams *must* be UTF-8. It wasn't that + important for encoding but it makes more sense to fix this discrepancy now + that decoding support is added. + ## 0.3.0.0 -- 2024-09-05 * Breaking changes to the API. diff --git a/flake.lock b/flake.lock index fa327fb..e3ae90b 100644 --- a/flake.lock +++ b/flake.lock @@ -2,11 +2,11 @@ "nodes": { "nixpkgs": { "locked": { - "lastModified": 1725407940, - "narHash": "sha256-tiN5Rlg/jiY0tyky+soJZoRzLKbPyIdlQ77xVgREDNM=", + "lastModified": 1733220138, + "narHash": "sha256-Yh5XZ9yVurrcYdNTSWxYgW4+EJ0pcOqgM1043z9JaRc=", "owner": "nixos", "repo": "nixpkgs", - "rev": "6f6c45b5134a8ee2e465164811e451dcb5ad86e3", + "rev": "bcb68885668cccec12276bbb379f8f2557aa06ce", "type": "github" }, "original": { diff --git a/servant-event-stream.cabal b/servant-event-stream.cabal index e2968bc..73dd559 100644 --- a/servant-event-stream.cabal +++ b/servant-event-stream.cabal @@ -31,10 +31,12 @@ library OverloadedStrings build-depends: + attoparsec >=0.13.2.2 && <0.15, base >=4.10 && <4.20, bytestring >=0.11.1.0 && <0.13, http-media >=0.7.1.3 && <0.9, lens >=4.17 && <5.4, + servant >=0.15 && <0.21, servant-foreign >=0.15 && <0.17, servant-server >=0.15 && <0.21, text >=1.2.3 && <2.2 @@ -43,9 +45,19 @@ library default-language: Haskell2010 ghc-options: -Wall -test-suite tests-default +test-suite test type: exitcode-stdio-1.0 - main-is: Spec.hs hs-source-dirs: tests + main-is: Main.hs default-language: Haskell2010 - build-depends: base + build-depends: + QuickCheck, + aeson, + base >=4.10 && <4.20, + bytestring, + servant >=0.15 && <0.21, + servant-event-stream, + tasty, + tasty-hunit, + tasty-quickcheck, + text >=1.2.3 && <2.2 \ No newline at end of file diff --git a/src/Servant/API/EventStream.hs b/src/Servant/API/EventStream.hs index 27c09e5..f548c07 100644 --- a/src/Servant/API/EventStream.hs +++ b/src/Servant/API/EventStream.hs @@ -36,8 +36,10 @@ module Servant.API.EventStream ( -- > streamBooks = pure $ source [book1, ...] ServerEvent (..), ToServerEvent (..), + FromServerEvent (..), ServerSentEvents, EventStream, + ServerEventFraming, -- * Recommended headers for Server-Sent Events @@ -57,20 +59,53 @@ module Servant.API.EventStream ( ) where -import Control.Lens +import Control.Applicative (optional, (<|>)) +import Control.Lens ((%~), (&), (.~), (?~)) +import Control.Monad (void, (<=<)) +import qualified Data.Attoparsec.ByteString as AB +import qualified Data.Attoparsec.Text as AT +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy.Char8 as C8 import Data.Kind (Type) +import Data.Text.Encoding (decodeUtf8', encodeUtf8) #if !MIN_VERSION_base(4,11,0) import Data.Semigroup #endif +import Data.Bifunctor (first) import Data.Text (Text) +import qualified Data.Text as Text import Data.Typeable (Typeable) import GHC.Generics (Generic) import Network.HTTP.Media ((//), (/:)) -import Servant -import Servant.Foreign +import Servant ( + Accept (contentType), + FramingRender (..), + FramingUnrender (..), + GetHeaders, + HasLink (..), + HasServer (..), + Header, + Headers, + MimeRender (mimeRender), + MimeUnrender (mimeUnrender), + Proxy (..), + StdMethod (GET), + StreamGet, + ToSourceIO, + addHeader, + reflectMethod, + ) +import Servant.Foreign ( + HasForeign (..), + HasForeignType (..), + Req, + reqFuncName, + reqMethod, + reqReturnType, + ) import Servant.Foreign.Internal (_FunctionName) +import Servant.Types.SourceT (transformWithAtto) +import Prelude {- | A ServerSentEvents endpoint emits an event stream using the format described at @@ -84,11 +119,11 @@ instance HasLink (ServerSentEvents a) where -- | Represents an event sent from the server to the client in Server-Sent Events (SSE). data ServerEvent = ServerEvent - { eventType :: !(Maybe LBS.ByteString) + { eventType :: !(Maybe Text) -- ^ Optional field specifying the type of event. Can be used to distinguish between different kinds of events. - , eventId :: !(Maybe LBS.ByteString) + , eventId :: !(Maybe Text) -- ^ Optional field providing an identifier for the event. Useful for clients to keep track of the last received event. - , eventData :: !LBS.ByteString + , eventData :: !Text -- ^ The payload or content of the event. This is the main data sent to the client. } deriving (Show, Eq, Generic) @@ -103,6 +138,15 @@ class ToServerEvent a where instance (ToServerEvent a) => MimeRender EventStream a where mimeRender _ = encodeServerEvent . toServerEvent +{- | This typeclass allow you to define custom event types that can be interpreted +from a t'ServerEvent' type. +-} +class FromServerEvent a where + fromServerEvent :: ServerEvent -> Either String a + +instance (FromServerEvent a) => MimeUnrender EventStream a where + mimeUnrender _ = fromServerEvent <=< decodeServerEvent + {- 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. @@ -111,15 +155,64 @@ instance (ToServerEvent a) => MimeRender EventStream a where -- | Encodes a t'ServerEvent' into a 'LBS.ByteString' that can be sent to the client. encodeServerEvent :: ServerEvent -> LBS.ByteString encodeServerEvent e = - optional "event:" (eventType e) - <> optional "id:" (eventId e) + optionalField "event:" (eventType e) + <> optionalField "id:" (eventId e) <> mconcat (map (field "data:") (safelines (eventData e))) where - optional name = maybe mempty (field name) - field name val = name <> val <> "\n" + optionalField name = maybe mempty (field name) + field name val = name <> LBS.fromStrict (encodeUtf8 val) <> "\n" -- discard CR and split LFs into multiple data values - safelines = C8.lines . C8.filter (/= '\r') + safelines = Text.lines . Text.filter (/= '\r') + +decodeServerEvent :: LBS.ByteString -> Either String ServerEvent +decodeServerEvent bs = do + decodedText <- first show $ decodeUtf8' (LBS.toStrict bs) + f <- AT.parseOnly linesParser decodedText + pure $ f emptyEvent + where + emptyEvent = ServerEvent{eventType = Nothing, eventId = Nothing, eventData = ""} + + linesParser = foldr (.) id <$> AT.many' lineParser + + lineParser = do + line <- parseLine + case line of + BlankLine -> pure id + CommentLine -> pure id + FieldLine field value -> pure $ processField field value + +data Line = BlankLine | CommentLine | FieldLine !Text !Text + deriving (Show, Eq) + +endOfLine :: AT.Parser () +endOfLine = void $ AT.choice [AT.string "\r\n", AT.string "\n", AT.string "\r"] + +isEndOfLine :: Char -> Bool +isEndOfLine '\n' = True +isEndOfLine '\r' = True +isEndOfLine _ = False + +parseLine :: AT.Parser Line +parseLine = + AT.choice + [ BlankLine <$ endOfLine + , CommentLine <$ (AT.char ':' >> AT.skipWhile (not . isEndOfLine) >> endOfLine) + , FieldLine <$> AT.takeWhile1 (/= ':') <* AT.char ':' <* optional AT.space <*> AT.takeWhile (not . isEndOfLine) <* AT.endOfLine + ] + +processField :: Text -> Text -> ServerEvent -> ServerEvent +processField "event" value event = event{eventType = Just value} +processField "data" value event = event{eventData = eventData event <> value <> "\n"} +processField "id" value event + | Text.any (== '\0') value = event + | otherwise = event{eventId = Just value} +processField _ _ event = event + +{- TODO: retry + If the field value consists of only ASCII digits, then interpret the field value as an integer in base ten, and set the event stream's reconnection time to that integer. Otherwise, ignore the field. + processField "retry" value event = ? +-} instance ToServerEvent ServerEvent where toServerEvent = id @@ -180,3 +273,13 @@ data ServerEventFraming -- | Frames the server events by joining chunks with a newline. instance FramingRender ServerEventFraming where framingRender _ f = fmap (\x -> f x <> "\n") + +newlineBS :: AB.Parser BS.ByteString +newlineBS = AB.choice [AB.string "\r\n", AB.string "\n", AB.string "\r"] + +instance FramingUnrender ServerEventFraming where + framingUnrender _ f = transformWithAtto $ do + ws <- AB.manyTill AB.anyWord8 (AB.endOfInput <|> void (newlineBS >> newlineBS)) + case ws of + [] -> fail "Unexpected empty frame" + _ -> either fail pure (f (LBS.pack (ws <> [10]))) diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 index 0000000..a9129de --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + +module Main where + +import Data.Aeson +import Data.Aeson.Text +import qualified Data.ByteString.Lazy as LBS +import Data.Proxy +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Lazy as LazyText +import Servant.API.ContentTypes +import Servant.API.EventStream +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck (testProperty) + +data Order = Order + { orderId :: !Text + , orderDescription :: !Text + , orderAmount :: !Int + } + deriving (Show, Eq) + +instance ToJSON Order where + toJSON Order{..} = + object + [ "orderId" .= orderId + , "orderDescription" .= orderDescription + , "orderAmount" .= orderAmount + ] + +instance FromJSON Order where + parseJSON = + withObject "Order" $ \o -> do + orderId <- o .: "orderId" + orderDescription <- o .: "orderDescription" + orderAmount <- o .: "orderAmount" + return Order{..} + +arbitraryText :: Gen Text +arbitraryText = Text.pack <$> arbitrary + +instance Arbitrary Order where + arbitrary = do + orderId <- arbitraryText + orderDescription <- arbitraryText + orderAmount <- arbitrary + return Order{..} + +instance ToServerEvent Order where + toServerEvent order = + ServerEvent + { eventType = Just "order" + , eventId = Nothing + , eventData = LazyText.toStrict $ encodeToLazyText order + } + +instance FromServerEvent Order where + fromServerEvent ServerEvent{..} = do + case eventType of + Just "order" -> + case eitherDecodeStrictText eventData of + Right order -> Right order + Left err -> Left $ "Invalid event data: " <> err + _ -> Left "Invalid event type" + +exampleOrder :: Order +exampleOrder = Order "123" "Example order" 100 + +-- Unit tests +basicUnitTests :: TestTree +basicUnitTests = + testGroup + "Basic" + [ testCase "trivial toServerEvent" $ + toServerEvent exampleOrder + @=? ServerEvent + { eventType = Just "order" + , eventId = Nothing + , eventData = "{\"orderAmount\":100,\"orderDescription\":\"Example order\",\"orderId\":\"123\"}" + } + , testCase "trivial fromServerEvent" $ + fromServerEvent + ServerEvent + { eventType = Just "order" + , eventId = Nothing + , eventData = "{\"orderAmount\":100,\"orderDescription\":\"Example order\",\"orderId\":\"123\"}" + } + @=? Right exampleOrder + , testCase "trivial mimeUnrender" $ + mimeUnrender + (Proxy :: Proxy EventStream) + ( newlines + [ ":This is a comment" + , "event:order" + , "data:{\"orderAmount\":100,\"orderDescription\":\"Example order\",\"orderId\":\"123\"}" + , "" + ] + ) + @=? Right exampleOrder + , testCase "mixed end of lines" $ + mimeUnrender + (Proxy :: Proxy EventStream) + ":This is a comment\n\revent:order\r\ndata:{\"orderAmount\":100,\"orderDescription\":\"Example order\",\"orderId\":\"123\"}\n\n" + @=? Right exampleOrder + , testCase "space after colon" $ + mimeUnrender + (Proxy :: Proxy EventStream) + ( newlines + [ ":This is a comment" + , "event: order" + , "data: {\"orderAmount\":100,\"orderDescription\":\"Example order\",\"orderId\":\"123\"}" + , "" + ] + ) + @=? Right exampleOrder + , testCase "multiple spaces after colon" $ + mimeUnrender + @EventStream + @Order + (Proxy :: Proxy EventStream) + ( newlines + [ ":This is a comment" + , "event: order" + , "data: {\"orderAmount\":100,\"orderDescription\":\"Example order\",\"orderId\":\"123\"}" + , "" + ] + ) + @=? Left "Invalid event type" + ] + +newlines :: [LBS.ByteString] -> LBS.ByteString +newlines = LBS.intercalate "\n" + +-- Properties +basicProperties :: TestTree +basicProperties = + testGroup + "Properties" + [ testProperty "toServerEvent . fromServerEvent = id" prop_roundtrip + ] + where + prop_roundtrip :: Order -> Bool + prop_roundtrip order = + Right order == fromServerEvent (toServerEvent order) + +main :: IO () +main = do + defaultMain tests + where + tests = + testGroup + "Tests" + [ basicUnitTests + , basicProperties + ] diff --git a/tests/Spec.hs b/tests/Spec.hs deleted file mode 100644 index cd4753f..0000000 --- a/tests/Spec.hs +++ /dev/null @@ -1,2 +0,0 @@ -main :: IO () -main = putStrLn "Test suite not yet implemented"