Hello!\<\/div\>\")
+@
+
+If the client accepts none of them, the stream is sent uncompressed. Use
+'sseResponseWithStrategy' to control negotiation with a 'CompressionStrategy'
+(e.g. prefer the client's order, or force a single encoding).
+
=== Module guide
* "Hypermedia.Datastar.PatchElements" — send HTML to morph into the DOM
* "Hypermedia.Datastar.PatchSignals" — update the browser's reactive signals
* "Hypermedia.Datastar.ExecuteScript" — run JavaScript in the browser
* "Hypermedia.Datastar.WAI" — SSE streaming, signal decoding, request helpers
+* "Hypermedia.Datastar.Compression.Brotli", "Hypermedia.Datastar.Compression.Zlib" — @Content-Encoding@ compressors
* "Hypermedia.Datastar.Types" — protocol types and defaults
=== Further reading
@@ -75,8 +96,19 @@
, readSignals
, isDatastarRequest
+ -- * Compression
+ --
+ -- | Negotiate @Content-Encoding@ for an SSE stream. Pass one or more
+ -- compressors from "Hypermedia.Datastar.Compression.Brotli" or
+ -- "Hypermedia.Datastar.Compression.Zlib". 'sseResponseWith' uses
+ -- 'ServerPriority'; 'sseResponseWithStrategy' lets you choose.
+ , Compressor
+ , CompressionStrategy (..)
+ , sseResponseWith
+ , sseResponseWithStrategy
+
-- * Logger
- , DatastarLogger (..)
+ , DatastarLogger
, nullLogger
, stderrLogger
)
@@ -88,11 +120,15 @@
import Hypermedia.Datastar.PatchSignals (PatchSignals (..), patchSignals)
import Hypermedia.Datastar.Types (ElementNamespace (..), ElementPatchMode (..), EventType (..))
import Hypermedia.Datastar.WAI
- ( ServerSentEventGenerator
+ ( CompressionStrategy (..)
+ , Compressor
+ , ServerSentEventGenerator
, isDatastarRequest
, readSignals
, sendExecuteScript
, sendPatchElements
, sendPatchSignals
, sseResponse
+ , sseResponseWith
+ , sseResponseWithStrategy
)
diff --git a/src/Hypermedia/Datastar/Compression/Brotli.hs b/src/Hypermedia/Datastar/Compression/Brotli.hs
new file mode 100644
--- /dev/null
+++ b/src/Hypermedia/Datastar/Compression/Brotli.hs
@@ -0,0 +1,68 @@
+module Hypermedia.Datastar.Compression.Brotli
+ ( brotli
+ , brotliWith
+ , defaultBrotliParams
+ )
+where
+
+import Codec.Compression.Brotli qualified as B
+import Data.ByteString qualified as BS
+import Data.ByteString.Builder qualified as BSB
+import Data.ByteString.Lazy qualified as BL
+import Control.Concurrent.MVar
+
+import Hypermedia.Datastar.WAI (Compressor (..))
+
+brotli :: Compressor
+brotli = brotliWith defaultBrotliParams
+
+brotliWith :: B.CompressParams -> Compressor
+brotliWith params = Compressor "br" wrap
+ where
+ wrap rawWrite rawFlush = do
+ csM <- B.compressIO params >>= newMVar
+
+ let write builder = do
+ let bs = BL.toStrict $ BSB.toLazyByteString builder
+ if BS.null bs
+ then pure ()
+ else modifyMVar_ csM $ \case
+ B.CompressInputRequired _ supply ->
+ supply bs >>= doRawWrites rawWrite
+ other -> pure other
+
+ flush = do
+ modifyMVar_ csM $ \case
+ B.CompressInputRequired doFlush _ ->
+ doFlush >>= doRawWrites rawWrite
+ other -> pure other
+ rawFlush
+
+ finish = do
+ modifyMVar_ csM $ \case
+ B.CompressInputRequired _ supply ->
+ supply BS.empty >>= doRawWrites rawWrite
+ other -> pure other
+ rawFlush
+
+ return (write, flush, finish)
+
+doRawWrites
+ :: (BSB.Builder -> IO ())
+ -> B.CompressStream IO
+ -> IO (B.CompressStream IO)
+doRawWrites rawWrite cs = case cs of
+ B.CompressOutputAvailable chunk nextAction -> do
+ rawWrite $ BSB.byteString chunk
+ cs' <- nextAction
+ doRawWrites rawWrite cs'
+ _ -> pure cs
+
+defaultBrotliParams :: B.CompressParams
+defaultBrotliParams =
+ B.defaultCompressParams
+ { B.compressMode = B.CompressionModeText
+ , B.compressLevel = B.CompressionLevel5
+ , B.compressWindowSize = B.CompressionWindowBits24
+ }
+
diff --git a/src/Hypermedia/Datastar/Compression/Zlib.hs b/src/Hypermedia/Datastar/Compression/Zlib.hs
new file mode 100644
--- /dev/null
+++ b/src/Hypermedia/Datastar/Compression/Zlib.hs
@@ -0,0 +1,68 @@
+module Hypermedia.Datastar.Compression.Zlib
+ ( gzip
+ , gzipWith
+ , deflate
+ , deflateWith
+ , defaultCompressionLevel
+ )
+where
+
+import Control.Exception (throwIO)
+
+import Data.ByteString qualified as BS
+import Data.ByteString.Builder qualified as BSB
+import Data.ByteString.Lazy qualified as BL
+
+import Data.Streaming.Zlib
+ ( PopperRes (..)
+ , WindowBits (..)
+ , feedDeflate
+ , finishDeflate
+ , flushDeflate
+ , initDeflate
+ )
+
+import Hypermedia.Datastar.WAI (Compressor (..))
+
+defaultCompressionLevel :: Int
+defaultCompressionLevel = 6
+
+-- | A gzip 'Compressor' (@Content-Encoding: gzip@) at 'defaultCompressionLevel'.
+gzip :: Compressor
+gzip = gzipWith defaultCompressionLevel
+
+-- | A gzip 'Compressor' at an explicit zlib level (0–9).
+gzipWith :: Int -> Compressor
+gzipWith level = zlibCompressor "gzip" level (WindowBits 31)
+
+-- | A zlib/deflate 'Compressor' (@Content-Encoding: deflate@) at 'defaultCompressionLevel'.
+deflate :: Compressor
+deflate = deflateWith defaultCompressionLevel
+
+-- | A zlib/deflate 'Compressor' at an explicit zlib level (0–9).
+deflateWith :: Int -> Compressor
+deflateWith level = zlibCompressor "deflate" level (WindowBits 15)
+
+-- WindowBits 31 selects gzip framing, 15 selects zlib/deflate framing.
+zlibCompressor :: BS.ByteString -> Int -> WindowBits -> Compressor
+zlibCompressor enc level wbits = Compressor enc wrap
+ where
+ wrap rawWrite rawFlush = do
+ def <- initDeflate level wbits
+
+ let drain popper = do
+ res <- popper
+ case res of
+ PRDone -> pure ()
+ PRNext bs -> rawWrite (BSB.byteString bs) >> drain popper
+ PRError e -> throwIO e
+
+ write builder = do
+ popper <- feedDeflate def $ BL.toStrict $ BSB.toLazyByteString builder
+ drain popper
+
+ flush = drain (flushDeflate def) >> rawFlush
+
+ finish = drain (finishDeflate def) >> rawFlush
+
+ pure (write, flush, finish)
diff --git a/src/Hypermedia/Datastar/Compression/Zstd.hs b/src/Hypermedia/Datastar/Compression/Zstd.hs
new file mode 100644
--- /dev/null
+++ b/src/Hypermedia/Datastar/Compression/Zstd.hs
@@ -0,0 +1,131 @@
+{- |
+A 'Compressor' that compresses an SSE stream with zstd (@Content-Encoding: zstd@),
+driving libzstd's streaming API directly so each event can be flushed.
+-}
+module Hypermedia.Datastar.Compression.Zstd
+ ( zstd
+ , zstdWith
+ , defaultZstdLevel
+ )
+where
+
+import Control.Exception (Exception, throwIO)
+import Control.Monad (unless, when)
+
+import Data.ByteString qualified as BS
+import Data.ByteString.Builder qualified as BSB
+import Data.ByteString.Lazy qualified as BL
+import Data.ByteString.Unsafe qualified as BU
+import Data.Word (Word8)
+
+import Foreign.ForeignPtr
+ ( ForeignPtr
+ , finalizeForeignPtr
+ , mallocForeignPtrBytes
+ , newForeignPtr
+ , withForeignPtr
+ )
+import Foreign.Marshal.Alloc (finalizerFree, malloc)
+import Foreign.Ptr (Ptr, castPtr, nullPtr)
+import Foreign.Storable (peek, poke)
+
+import Codec.Compression.Zstd.FFI
+ ( Buffer (..)
+ , In
+ , Out
+ , compressStream
+ , createCStream
+ , cstreamOutSize
+ , endStream
+ , flushStream
+ , getErrorName
+ , initCStream
+ , isError
+ , p_freeCStream
+ )
+
+import Hypermedia.Datastar.WAI (Compressor (..))
+
+newtype ZstdError = ZstdError String
+ deriving (Show)
+
+instance Exception ZstdError
+
+-- | zstd's default compression level (3).
+defaultZstdLevel :: Int
+defaultZstdLevel = 3
+
+-- | A zstd 'Compressor' (@Content-Encoding: zstd@) at 'defaultZstdLevel'.
+zstd :: Compressor
+zstd = zstdWith defaultZstdLevel
+
+-- | A zstd 'Compressor' at an explicit compression level (1–22).
+zstdWith :: Int -> Compressor
+zstdWith level =
+ Compressor
+ { compressorEncoding = "zstd"
+ , compressorWrap = \rawWrite rawFlush -> do
+ let out = rawWrite . BSB.byteString
+ outSize = fromIntegral cstreamOutSize :: Int
+
+ csPtr <- createCStream
+ when (csPtr == nullPtr) $ throwIO (ZstdError "ZSTD_createCStream returned NULL")
+ initRet <- initCStream csPtr (fromIntegral level)
+ when (isError initRet) $
+ throwIO (ZstdError ("ZSTD_initCStream: " <> getErrorName initRet))
+ csFp <- newForeignPtr p_freeCStream csPtr
+
+ inFp <- newForeignPtr finalizerFree =<< (malloc :: IO (Ptr (Buffer In)))
+ outFp <- newForeignPtr finalizerFree =<< (malloc :: IO (Ptr (Buffer Out)))
+ scratchFp <- mallocForeignPtrBytes outSize :: IO (ForeignPtr Word8)
+
+ let
+ drainOut outBuf scratch = do
+ produced <- fromIntegral . bufPos <$> peek outBuf
+ when (produced > 0) $
+ out =<< BS.packCStringLen (castPtr scratch, produced)
+
+ resetOut outBuf scratch =
+ poke outBuf (Buffer scratch (fromIntegral outSize) 0)
+
+ checkRet ctx ret =
+ when (isError ret) $ throwIO (ZstdError (ctx <> ": " <> getErrorName ret))
+
+ write builder =
+ let bs = BL.toStrict (BSB.toLazyByteString builder)
+ in unless (BS.null bs) $
+ BU.unsafeUseAsCStringLen bs $ \(srcPtr, len) ->
+ withForeignPtr csFp $ \cs ->
+ withForeignPtr inFp $ \inBuf ->
+ withForeignPtr outFp $ \outBuf ->
+ withForeignPtr scratchFp $ \scratch -> do
+ poke inBuf (Buffer (castPtr srcPtr) (fromIntegral len) 0)
+ let loop = do
+ resetOut outBuf scratch
+ checkRet "ZSTD_compressStream" =<< compressStream cs outBuf inBuf
+ drainOut outBuf scratch
+ consumed <- fromIntegral . bufPos <$> peek inBuf
+ when (consumed < len) loop
+ loop
+
+ pump name op =
+ withForeignPtr csFp $ \cs ->
+ withForeignPtr outFp $ \outBuf ->
+ withForeignPtr scratchFp $ \scratch -> do
+ let loop = do
+ resetOut outBuf scratch
+ remaining <- op cs outBuf
+ checkRet name remaining
+ drainOut outBuf scratch
+ when (remaining > 0) loop
+ loop
+
+ flush = pump "ZSTD_flushStream" flushStream >> rawFlush
+
+ finish = do
+ pump "ZSTD_endStream" endStream
+ finalizeForeignPtr csFp
+ rawFlush
+
+ pure (write, flush, finish)
+ }
diff --git a/src/Hypermedia/Datastar/WAI.hs b/src/Hypermedia/Datastar/WAI.hs
--- a/src/Hypermedia/Datastar/WAI.hs
+++ b/src/Hypermedia/Datastar/WAI.hs
@@ -47,8 +47,14 @@
import Data.Aeson (FromJSON)
import Data.Aeson qualified as A
+import Data.ByteString qualified as BS
import Data.ByteString.Builder qualified as BSB
+import Data.ByteString.Char8 qualified as BS8
+import Data.List (find)
+import Data.Maybe (listToMaybe)
+
+
import Network.HTTP.Types qualified as WAI
import Network.Wai qualified as WAI
@@ -58,7 +64,75 @@
import Hypermedia.Datastar.Logger qualified as Logger
import Hypermedia.Datastar.PatchElements qualified as PE
import Hypermedia.Datastar.PatchSignals qualified as PS
+data Compressor = Compressor
+ { compressorEncoding :: BS.ByteString
+ -- ^ The @Content-Encoding@ token, e.g. @"br"@ for Brotli compression.
+ , compressorWrap :: (BSB.Builder -> IO ())
+ -> IO ()
+ -> IO (BSB.Builder -> IO (), IO (), IO ())
+ -- ^ @compressorWrap rawWrite rawFlush@ returns @(write, flush, finish)@.
+ --
+ -- * @write@ compresses and forwards bytes for an event;
+ -- * @flush@ flushes the compression encoded and then the underlying raw transport;
+ -- * @finish@ closes the compression stream.
+ }
+
+data CompressionStrategy
+ = ServerPriority
+ | ClientPriority
+ | Forced
+ deriving (Eq, Show)
+
+-- | Faithful port of the Go reference parser: split on ',', trim surrounding
+-- whitespace, take the token before ';', drop empties. No q-value handling,
+-- no case folding, no wildcard logic.
+parseEncodings :: BS.ByteString -> [BS.ByteString]
+parseEncodings header =
+ [ token
+ | part <- BS8.split ',' header
+ , let token = BS8.takeWhile (/= ';') (strip part)
+ , not (BS8.null token)
+ ]
+ where
+ strip = BS8.dropWhile isOWS . BS8.dropWhileEnd isOWS
+ isOWS c = c == ' ' || c == '\t'
+
+-- | The encoding tokens of a request's @Accept-Encoding@ header, in order.
+-- An absent or empty header yields [].
+clientEncodings :: WAI.Request -> [BS.ByteString]
+clientEncodings req
+ = maybe
+ []
+ parseEncodings
+ (lookup WAI.hAcceptEncoding $ WAI.requestHeaders req)
+
+{- | Pick a compressor for a request's @Accept-Encoding@ header using the given
+'CompressionStrategy', or 'Nothing' if none applies. Token matching is exact
+(case-sensitive), mirroring the Go reference.
+-}
+negotiateWith :: CompressionStrategy -> [Compressor] -> WAI.Request -> Maybe Compressor
+negotiateWith strategy compressors req =
+ case strategy of
+ ServerPriority ->
+ -- first server compressor whose token the client sent
+ find (\c -> compressorEncoding c `elem` accepted) compressors
+
+ ClientPriority ->
+ -- first client token (header order) that the server offers
+ listToMaybe
+ [ c
+ | enc <- accepted
+ , c <- compressors
+ , compressorEncoding c == enc
+ ]
+
+ Forced ->
+ -- first configured compressor, regardless of Accept-Encoding
+ listToMaybe compressors
+ where
+ accepted = clientEncodings req
+
{- | An opaque handle for sending SSE events to the browser.
Obtain one from the callback passed to 'sseResponse'. The handle is
@@ -86,7 +160,32 @@
@
-}
sseResponse :: Logger.DatastarLogger -> (ServerSentEventGenerator -> IO ()) -> WAI.Response
-sseResponse logger callback =
+sseResponse logger = sseResponse' logger Nothing
+
+sseResponseWith
+ :: Logger.DatastarLogger
+ -> [Compressor]
+ -> WAI.Request
+ -> (ServerSentEventGenerator -> IO ())
+ -> WAI.Response
+sseResponseWith = sseResponseWithStrategy ServerPriority
+
+sseResponseWithStrategy
+ :: CompressionStrategy
+ -> Logger.DatastarLogger
+ -> [Compressor]
+ -> WAI.Request
+ -> (ServerSentEventGenerator -> IO ())
+ -> WAI.Response
+sseResponseWithStrategy strategy logger compressors req =
+ sseResponse' logger (negotiateWith strategy compressors req)
+
+sseResponse'
+ :: Logger.DatastarLogger
+ -> Maybe Compressor
+ -> (ServerSentEventGenerator -> IO ())
+ -> WAI.Response
+sseResponse' logger chosen callback =
WAI.responseStream
WAI.status200
headers
@@ -97,16 +196,29 @@
, ("Content-Type", "text/event-stream")
, ("Connection", "keep-alive")
]
+ <> case chosen of
+ Just c -> [("Content-Encoding", compressorEncoding c)]
+ Nothing -> []
- action write flush = do
+ action rawWrite rawFlush = do
+ (write, flush, finish) <- case chosen of
+ Nothing -> pure (rawWrite, rawFlush, pure ())
+ Just c -> compressorWrap c rawWrite rawFlush
lock <- newMVar ()
- callback $
- ServerSentEventGenerator
- { sseWrite = write
- , sseFlush = flush
- , sseLock = lock
- , sseLogger = logger
- }
+ let gen =
+ ServerSentEventGenerator
+ { sseWrite = write
+ , sseFlush = flush
+ , sseLock = lock
+ , sseLogger = logger
+ }
+ callback gen `finally` ignoreIOErrors finish
+
+ignoreIOErrors :: IO () -> IO ()
+ignoreIOErrors act = act `catch` handler
+ where
+ handler :: IOException -> IO ()
+ handler _ = pure ()
send :: ServerSentEventGenerator -> DatastarEvent -> IO ()
send gen event = do
diff --git a/test/Hypermedia/Datastar/Compression/BrotliSpec.hs b/test/Hypermedia/Datastar/Compression/BrotliSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hypermedia/Datastar/Compression/BrotliSpec.hs
@@ -0,0 +1,107 @@
+module Hypermedia.Datastar.Compression.BrotliSpec (spec) where
+
+import Test.Hspec
+
+import Codec.Compression.Brotli qualified as B
+import Data.ByteString.Builder qualified as BSB
+import Data.ByteString.Lazy qualified as BL
+import Data.IORef
+
+import Network.Wai (defaultRequest, requestHeaders)
+import Network.Wai.Internal (Response (..))
+
+import Hypermedia.Datastar
+import Hypermedia.Datastar.Compression.Brotli (brotli)
+import Hypermedia.Datastar.Logger (nullLogger)
+import Hypermedia.Datastar.WAI (Compressor (..), compressorWrap, negotiateWith)
+
+-- | Drive a streaming WAI response to completion, returning its response headers
+-- and the full raw body.
+runStream (ResponseStream _status headers body) = do
+ ref <- newIORef mempty
+ body (\chunk -> modifyIORef' ref (<> chunk)) (pure ())
+ bytes <- BSB.toLazyByteString <$> readIORef ref
+ pure (headers, bytes)
+runStream _ = error "expected a streaming response"
+
+-- | A compressor that only carries an encoding token, for negotiation tests.
+-- Its 'compressorWrap' is never invoked by 'negotiateWith'.
+fakeCompressor :: BL.ByteString -> Compressor
+fakeCompressor enc = Compressor (BL.toStrict enc) (\_ _ -> error "unused")
+
+spec :: Spec
+spec = describe "Hypermedia.Datastar.Compression.Brotli" $ do
+ let sendEvents gen = do
+ sendPatchElements gen (patchElements "
1
")
+ sendPatchElements gen (patchElements "
2
")
+ sendPatchSignals gen (patchSignals "{\"count\":42}")
+ withAccept enc = defaultRequest {requestHeaders = [("Accept-Encoding", enc)]}
+
+ it "round-trips: the br stream decompresses to the uncompressed stream" $ do
+ (_, reference) <- runStream (sseResponse nullLogger sendEvents)
+ (headers, compressed) <-
+ runStream (sseResponseWith nullLogger [brotli] (withAccept "br") sendEvents)
+
+ headers `shouldSatisfy` elem ("Content-Encoding", "br")
+ B.decompress compressed `shouldBe` reference
+
+ it "declines compression when the client does not accept br" $ do
+ (_, reference) <- runStream (sseResponse nullLogger sendEvents)
+ (headers, body) <-
+ runStream (sseResponseWith nullLogger [brotli] (withAccept "gzip") sendEvents)
+
+ filter ((== "Content-Encoding") . fst) headers `shouldBe` []
+ body `shouldBe` reference
+
+ it "emits output incrementally on flush, not buffered until finish" $ do
+ ref <- newIORef mempty
+ let rawWrite c = modifyIORef' ref (<> c)
+ sizeSoFar = fromIntegral . BL.length . BSB.toLazyByteString <$> readIORef ref
+ (write, flush, finish) <- compressorWrap brotli rawWrite (pure ())
+
+ write (BSB.byteString "event: datastar-patch-elements\ndata: elements
1
\n\n")
+ flush
+ afterFirst <- sizeSoFar
+
+ write (BSB.byteString "event: datastar-patch-elements\ndata: elements
2
\n\n")
+ flush
+ afterSecond <- sizeSoFar
+
+ finish
+ afterFinish <- sizeSoFar
+
+ -- Each flush must push bytes onto the wire; a compressor that buffered
+ -- everything until finish would leave afterFirst == afterSecond == 0.
+ afterFirst `shouldSatisfy` (> (0 :: Int))
+ afterSecond `shouldSatisfy` (> afterFirst)
+ afterFinish `shouldSatisfy` (>= afterSecond)
+
+ -- And the accumulated stream is still a valid, complete brotli stream.
+ whole <- BSB.toLazyByteString <$> readIORef ref
+ B.decompress whole
+ `shouldBe` "event: datastar-patch-elements\ndata: elements
1
\n\n\
+ \event: datastar-patch-elements\ndata: elements
2
\n\n"
+
+ describe "negotiateWith" $ do
+ let br = fakeCompressor "br"
+ gz = fakeCompressor "gzip"
+ enc = fmap compressorEncoding
+ req h = defaultRequest {requestHeaders = [("Accept-Encoding", h)]}
+
+ it "ServerPriority picks the first server compressor the client accepts" $
+ enc (negotiateWith ServerPriority [br, gz] (req "gzip, br")) `shouldBe` Just "br"
+
+ it "ClientPriority picks the client's most-preferred offered encoding" $
+ enc (negotiateWith ClientPriority [br, gz] (req "gzip, br")) `shouldBe` Just "gzip"
+
+ it "Forced ignores Accept-Encoding entirely" $
+ enc (negotiateWith Forced [br, gz] (req "identity")) `shouldBe` Just "br"
+
+ it "ignores q-value params and whitespace around each token" $
+ enc (negotiateWith ClientPriority [br, gz] (req " gzip;q=0.1 , br ")) `shouldBe` Just "gzip"
+
+ it "returns Nothing when no server encoding is accepted" $
+ enc (negotiateWith ServerPriority [br, gz] (req "deflate")) `shouldBe` Nothing
+
+ it "returns Nothing when the Accept-Encoding header is absent" $
+ enc (negotiateWith ServerPriority [br, gz] defaultRequest) `shouldBe` Nothing
diff --git a/test/Hypermedia/Datastar/Compression/ZlibSpec.hs b/test/Hypermedia/Datastar/Compression/ZlibSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hypermedia/Datastar/Compression/ZlibSpec.hs
@@ -0,0 +1,109 @@
+module Hypermedia.Datastar.Compression.ZlibSpec (spec) where
+
+import Test.Hspec
+
+import Control.Monad (forM_)
+
+import Codec.Compression.GZip qualified as GZip
+import Codec.Compression.Zlib qualified as Zlib
+import Data.ByteString qualified as BS
+import Data.ByteString.Builder qualified as BSB
+import Data.ByteString.Char8 qualified as BS8
+import Data.ByteString.Lazy qualified as BL
+import Data.IORef
+
+import Network.Wai (defaultRequest, requestHeaders)
+import Network.Wai.Internal (Response (..))
+
+import Hypermedia.Datastar
+import Hypermedia.Datastar.Compression.Zlib (deflate, gzip)
+import Hypermedia.Datastar.Logger (nullLogger)
+import Hypermedia.Datastar.WAI (compressorWrap)
+
+-- | Drive a streaming WAI response to completion, returning its response headers
+-- and the full raw body.
+runStream (ResponseStream _status headers body) = do
+ ref <- newIORef mempty
+ body (\chunk -> modifyIORef' ref (<> chunk)) (pure ())
+ bytes <- BSB.toLazyByteString <$> readIORef ref
+ pure (headers, bytes)
+runStream _ = error "expected a streaming response"
+
+spec :: Spec
+spec = describe "Hypermedia.Datastar.Compression.Zlib" $ do
+ let sendEvents gen = do
+ sendPatchElements gen (patchElements "
1
")
+ sendPatchElements gen (patchElements "
2
")
+ sendPatchSignals gen (patchSignals "{\"count\":42}")
+ withAccept enc = defaultRequest {requestHeaders = [("Accept-Encoding", enc)]}
+
+ -- (encoding token, compressor, matching decompressor)
+ codecs :: [(BS.ByteString, Compressor, BL.ByteString -> BL.ByteString)]
+ codecs =
+ [ ("gzip", gzip, GZip.decompress)
+ , ("deflate", deflate, Zlib.decompress)
+ ]
+
+ forM_ codecs $ \(enc, comp, decompress) -> do
+ let name = BS8.unpack enc
+
+ it (name <> ": round-trips to the uncompressed stream") $ do
+ (_, reference) <- runStream (sseResponse nullLogger sendEvents)
+ (headers, compressed) <-
+ runStream (sseResponseWith nullLogger [comp] (withAccept enc) sendEvents)
+ headers `shouldSatisfy` elem ("Content-Encoding", enc)
+ decompress compressed `shouldBe` reference
+
+ it (name <> ": emits output incrementally on flush, not buffered until finish") $ do
+ ref <- newIORef mempty
+ let rawWrite c = modifyIORef' ref (<> c)
+ sizeSoFar = fromIntegral . BL.length . BSB.toLazyByteString <$> readIORef ref
+ (write, flush, finish) <- compressorWrap comp rawWrite (pure ())
+
+ write (BSB.byteString "event: datastar-patch-elements\ndata: elements
1
\n\n")
+ flush
+ afterFirst <- sizeSoFar
+
+ write (BSB.byteString "event: datastar-patch-elements\ndata: elements
2
\n\n")
+ flush
+ afterSecond <- sizeSoFar
+
+ finish
+ afterFinish <- sizeSoFar
+
+ -- Each flush must push bytes onto the wire; a compressor that buffered
+ -- everything until finish would leave afterFirst == afterSecond == 0.
+ afterFirst `shouldSatisfy` (> (0 :: Int))
+ afterSecond `shouldSatisfy` (> afterFirst)
+ afterFinish `shouldSatisfy` (>= afterSecond)
+
+ -- And the accumulated stream is still a valid, complete stream.
+ whole <- BSB.toLazyByteString <$> readIORef ref
+ decompress whole
+ `shouldBe` "event: datastar-patch-elements\ndata: elements
1
\n\n\
+ \event: datastar-patch-elements\ndata: elements
2
\n\n"
+
+ it "declines when the client accepts neither" $ do
+ (_, reference) <- runStream (sseResponse nullLogger sendEvents)
+ (headers, body) <-
+ runStream (sseResponseWith nullLogger [gzip, deflate] (withAccept "br") sendEvents)
+ filter ((== "Content-Encoding") . fst) headers `shouldBe` []
+ body `shouldBe` reference
+
+ -- With several server compressors offered and a client that accepts all of
+ -- them, ServerPriority (the default for sseResponseWith) picks the *server's*
+ -- first — so list order, not header order, decides. Verified end-to-end via
+ -- the chosen Content-Encoding and that the matching codec decompresses it.
+ it "picks the server's first compressor when the client accepts several (gzip first)" $ do
+ (_, reference) <- runStream (sseResponse nullLogger sendEvents)
+ (headers, compressed) <-
+ runStream (sseResponseWith nullLogger [gzip, deflate] (withAccept "deflate, gzip") sendEvents)
+ headers `shouldSatisfy` elem ("Content-Encoding", "gzip")
+ GZip.decompress compressed `shouldBe` reference
+
+ it "picks the server's first compressor when the client accepts several (deflate first)" $ do
+ (_, reference) <- runStream (sseResponse nullLogger sendEvents)
+ (headers, compressed) <-
+ runStream (sseResponseWith nullLogger [deflate, gzip] (withAccept "deflate, gzip") sendEvents)
+ headers `shouldSatisfy` elem ("Content-Encoding", "deflate")
+ Zlib.decompress compressed `shouldBe` reference
diff --git a/test/Hypermedia/Datastar/Compression/ZstdSpec.hs b/test/Hypermedia/Datastar/Compression/ZstdSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Hypermedia/Datastar/Compression/ZstdSpec.hs
@@ -0,0 +1,83 @@
+module Hypermedia.Datastar.Compression.ZstdSpec (spec) where
+
+import Test.Hspec
+
+import Codec.Compression.Zstd.Lazy qualified as Zstd
+import Data.ByteString.Builder qualified as BSB
+import Data.ByteString.Lazy qualified as BL
+import Data.IORef
+
+import Network.Wai (defaultRequest, requestHeaders)
+import Network.Wai.Internal (Response (..))
+
+import Hypermedia.Datastar
+import Hypermedia.Datastar.Compression.Zlib (gzip)
+import Hypermedia.Datastar.Compression.Zstd (zstd)
+import Hypermedia.Datastar.Logger (nullLogger)
+import Hypermedia.Datastar.WAI (compressorWrap)
+
+-- | Drive a streaming WAI response to completion, returning its response headers
+-- and the full raw body.
+runStream (ResponseStream _status headers body) = do
+ ref <- newIORef mempty
+ body (\chunk -> modifyIORef' ref (<> chunk)) (pure ())
+ bytes <- BSB.toLazyByteString <$> readIORef ref
+ pure (headers, bytes)
+runStream _ = error "expected a streaming response"
+
+spec :: Spec
+spec = describe "Hypermedia.Datastar.Compression.Zstd" $ do
+ let sendEvents gen = do
+ sendPatchElements gen (patchElements "
1
")
+ sendPatchElements gen (patchElements "
2
")
+ sendPatchSignals gen (patchSignals "{\"count\":42}")
+ withAccept enc = defaultRequest {requestHeaders = [("Accept-Encoding", enc)]}
+
+ it "round-trips to the uncompressed stream" $ do
+ (_, reference) <- runStream (sseResponse nullLogger sendEvents)
+ (headers, compressed) <-
+ runStream (sseResponseWith nullLogger [zstd] (withAccept "zstd") sendEvents)
+ headers `shouldSatisfy` elem ("Content-Encoding", "zstd")
+ Zstd.decompress compressed `shouldBe` reference
+
+ it "declines when the client does not accept zstd" $ do
+ (_, reference) <- runStream (sseResponse nullLogger sendEvents)
+ (headers, body) <-
+ runStream (sseResponseWith nullLogger [zstd] (withAccept "gzip") sendEvents)
+ filter ((== "Content-Encoding") . fst) headers `shouldBe` []
+ body `shouldBe` reference
+
+ it "is chosen ahead of gzip when offered first and both are accepted" $ do
+ (_, reference) <- runStream (sseResponse nullLogger sendEvents)
+ (headers, compressed) <-
+ runStream (sseResponseWith nullLogger [zstd, gzip] (withAccept "gzip, zstd") sendEvents)
+ headers `shouldSatisfy` elem ("Content-Encoding", "zstd")
+ Zstd.decompress compressed `shouldBe` reference
+
+ it "emits output incrementally on flush, not buffered until finish" $ do
+ ref <- newIORef mempty
+ let rawWrite c = modifyIORef' ref (<> c)
+ sizeSoFar = fromIntegral . BL.length . BSB.toLazyByteString <$> readIORef ref
+ (write, flush, finish) <- compressorWrap zstd rawWrite (pure ())
+
+ write (BSB.byteString "event: datastar-patch-elements\ndata: elements
1
\n\n")
+ flush
+ afterFirst <- sizeSoFar
+
+ write (BSB.byteString "event: datastar-patch-elements\ndata: elements
2
\n\n")
+ flush
+ afterSecond <- sizeSoFar
+
+ finish
+ afterFinish <- sizeSoFar
+
+ -- Each flush must push bytes onto the wire; a compressor that buffered
+ -- everything until finish would leave afterFirst == afterSecond == 0.
+ afterFirst `shouldSatisfy` (> (0 :: Int))
+ afterSecond `shouldSatisfy` (> afterFirst)
+ afterFinish `shouldSatisfy` (>= afterSecond)
+
+ whole <- BSB.toLazyByteString <$> readIORef ref
+ Zstd.decompress whole
+ `shouldBe` "event: datastar-patch-elements\ndata: elements
1
\n\n\
+ \event: datastar-patch-elements\ndata: elements
2
\n\n"
diff --git a/test/Main.hs b/test/Main.hs
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -1,8 +1,14 @@
+{-# LANGUAGE CPP #-}
+
module Main where
import Test.Hspec
-import Hypermedia.Datastar qualified
+import Hypermedia.Datastar.Compression.BrotliSpec qualified
+import Hypermedia.Datastar.Compression.ZlibSpec qualified
+#ifdef ZSTD
+import Hypermedia.Datastar.Compression.ZstdSpec qualified
+#endif
import Hypermedia.Datastar.ExecuteScriptSpec qualified
import Hypermedia.Datastar.PatchElementsSpec qualified
import Hypermedia.Datastar.PatchSignalsSpec qualified
@@ -10,6 +16,11 @@
main :: IO ()
main = hspec $ do
+ Hypermedia.Datastar.Compression.BrotliSpec.spec
+ Hypermedia.Datastar.Compression.ZlibSpec.spec
+#ifdef ZSTD
+ Hypermedia.Datastar.Compression.ZstdSpec.spec
+#endif
Hypermedia.Datastar.ExecuteScriptSpec.spec
Hypermedia.Datastar.PatchElementsSpec.spec
Hypermedia.Datastar.PatchSignalsSpec.spec