diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Changelog + +## 0.1.0.0 + +* Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2026 Carlo Hamalainen + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/datastar-hs.cabal b/datastar-hs.cabal new file mode 100644 --- /dev/null +++ b/datastar-hs.cabal @@ -0,0 +1,60 @@ +cabal-version: 3.0 +name: datastar-hs +version: 0.1.0.0 +synopsis: Haskell bindings for Datastar +description: + Server-side SDK for building real-time hypermedia applications with + . Stream HTML fragments, reactive + signal updates, and scripts to the browser over server-sent events + (SSE). Built on WAI so it works with Warp, Scotty, Servant, Yesod, + and any other WAI-compatible framework. +homepage: https://github.com/carlohamalainen/datastar-hs +bug-reports: https://github.com/carlohamalainen/datastar-hs/issues +license: MIT +license-file: LICENSE +author: Carlo Hamalainen +maintainer: carlo@carlo-hamalainen.net +category: Web, Hypermedia +build-type: Simple +extra-doc-files: CHANGELOG.md + +library + exposed-modules: + Hypermedia.Datastar + Hypermedia.Datastar.ExecuteScript + Hypermedia.Datastar.Logger + Hypermedia.Datastar.PatchElements + Hypermedia.Datastar.PatchSignals + Hypermedia.Datastar.Types + Hypermedia.Datastar.WAI + hs-source-dirs: src + default-language: Haskell2010 + default-extensions: + ImportQualifiedPost + OverloadedStrings + build-depends: + , base >= 4.14 && < 5 + , aeson >= 2.0 && < 3 + , bytestring >= 0.10 && < 1 + , http-types >= 0.12 && < 1 + , text >= 1.2 && < 3 + , wai >= 3.2 && < 4 + +test-suite datastar-hs-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: + Hypermedia.Datastar.PatchElementsSpec + Hypermedia.Datastar.SSESpec + build-depends: + , base + , bytestring + , datastar-hs + , hspec + , text + , wai + default-language: Haskell2010 + default-extensions: + ImportQualifiedPost + OverloadedStrings diff --git a/src/Hypermedia/Datastar.hs b/src/Hypermedia/Datastar.hs new file mode 100644 --- /dev/null +++ b/src/Hypermedia/Datastar.hs @@ -0,0 +1,92 @@ +-- | +-- Module : Hypermedia.Datastar +-- Description : Haskell SDK for building real-time hypermedia apps with Datastar +-- +-- is a hypermedia framework: instead of +-- building a JSON API and a JavaScript SPA, you write HTML on the server and +-- let Datastar handle the interactivity. The browser sends requests, the +-- server holds the connection open as a server-sent event (SSE) stream, and +-- pushes HTML fragments, signal updates, or scripts back to the browser as +-- things change. +-- +-- This SDK provides the server-side Haskell API. It builds on +-- so it works with Warp, Scotty, +-- Servant, Yesod, or any other WAI-compatible framework. +-- +-- === Minimal example +-- +-- @ +-- import Hypermedia.Datastar +-- import Network.Wai (Application, responseLBS, requestMethod, pathInfo) +-- import Network.Wai.Handler.Warp qualified as Warp +-- import Network.HTTP.Types (status404) +-- +-- app :: Application +-- app req respond = +-- case (requestMethod req, pathInfo req) of +-- (\"GET\", [\"hello\"]) -> +-- respond $ sseResponse $ \\gen -> +-- sendPatchElements gen (patchElements \"\
Hello!\<\/div\>\") +-- _ -> +-- respond $ responseLBS status404 [] \"Not found\" +-- +-- main :: IO () +-- main = Warp.run 3000 app +-- @ +-- +-- === 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.Types" — protocol types and defaults +-- +-- === Further reading +-- +-- * — guides, reference, and examples +-- * — full working Haskell examples +-- * — excellent Datastar walkthrough that applies across SDKs +module Hypermedia.Datastar + ( -- * Types + EventType (..) + , ElementPatchMode (..) + , ElementNamespace (..) + + -- * Patch Elements + , PatchElements (..) + , patchElements + , removeElements + + -- * Patch Signals + , PatchSignals (..) + , patchSignals + + -- * Execute Script + , ExecuteScript (..) + , executeScript + + -- * WAI + , ServerSentEventGenerator + , sseResponse + , sendPatchElements + , sendPatchSignals + , sendExecuteScript + , readSignals + , isDatastarRequest + ) +where + +import Hypermedia.Datastar.ExecuteScript (ExecuteScript (..), executeScript) +import Hypermedia.Datastar.PatchElements (PatchElements (..), patchElements, removeElements) +import Hypermedia.Datastar.PatchSignals (PatchSignals (..), patchSignals) +import Hypermedia.Datastar.Types (ElementNamespace (..), ElementPatchMode (..), EventType (..)) +import Hypermedia.Datastar.WAI + ( ServerSentEventGenerator + , isDatastarRequest + , readSignals + , sendExecuteScript + , sendPatchElements + , sendPatchSignals + , sseResponse + ) diff --git a/src/Hypermedia/Datastar/ExecuteScript.hs b/src/Hypermedia/Datastar/ExecuteScript.hs new file mode 100644 --- /dev/null +++ b/src/Hypermedia/Datastar/ExecuteScript.hs @@ -0,0 +1,103 @@ +-- | +-- Module : Hypermedia.Datastar.ExecuteScript +-- Description : Execute JavaScript in the browser via SSE +-- +-- Sometimes you need a one-shot browser-side effect that doesn't fit neatly +-- into DOM patching or signal updates — redirecting to another page, focusing +-- an input, triggering a download, or calling a browser API. +-- 'executeScript' lets the server push arbitrary JavaScript to the browser. +-- +-- Under the hood, Datastar appends a @\@ tag to @\@. By default +-- the script tag removes itself from the DOM after executing (see 'esAutoRemove'). +-- +-- Note: per the Datastar protocol, script execution uses the +-- @datastar-patch-elements@ event type — there is no separate event type for +-- scripts. +-- +-- @ +-- sendExecuteScript gen (executeScript \"window.location = \\\"/dashboard\\\"\") +-- @ +-- +-- To add attributes to the generated @\@ tag: +-- +-- @ +-- sendExecuteScript gen +-- (executeScript \"import(\\\"/modules\/chart.js\\\").then(m => m.render())\") +-- { esAttributes = [\"type=\\\"module\\\"\"] } +-- @ +module Hypermedia.Datastar.ExecuteScript where + +import Data.Text (Text) +import Data.Text qualified as T +import Hypermedia.Datastar.Types + +-- | Configuration for executing a script in the browser. +-- +-- Construct values with 'executeScript', then customise with record updates. +data ExecuteScript = ExecuteScript + { esScript :: Text + -- ^ The JavaScript code to execute. + , esAutoRemove :: Bool + -- ^ Whether the @\@ tag should remove itself from the DOM after + -- executing. Default: 'True'. Set to 'False' if the script defines + -- functions or variables that need to persist in the page. + , esAttributes :: [Text] + -- ^ Extra attributes to add to the @\@ tag. For example, + -- @[\"type=\\\"module\\\"\"]@ to use ES module imports, or + -- @[\"nonce=\\\"abc123\\\"\"]@ for CSP compliance. + , esEventId :: Maybe Text + -- ^ Optional SSE event ID for reconnection. + , esRetryDuration :: Int + -- ^ SSE retry interval in milliseconds. Default: @1000@. + } + deriving (Eq, Show) + +-- | Build an 'ExecuteScript' event with sensible defaults. +-- +-- The argument is the JavaScript source code to run in the browser. +-- +-- @ +-- executeScript \"document.getElementById(\\\"name\\\").focus()\" +-- @ +executeScript :: Text -> ExecuteScript +executeScript js = + ExecuteScript + { esScript = js + , esAutoRemove = defaultAutoRemove + , esAttributes = [] + , esEventId = Nothing + , esRetryDuration = defaultRetryDuration + } + +toDatastarEvent :: ExecuteScript -> DatastarEvent +toDatastarEvent es = + DatastarEvent + { eventType = EventPatchElements -- Correct, there is no EventExecuteScript, see the ADR + , eventId = esEventId es + , retry = esRetryDuration es + , dataLines = + [ "selector body" + , "mode append" + ] + <> buildScriptLines es + } + +buildScriptLines :: ExecuteScript -> [Text] +buildScriptLines es = + case T.lines (esScript es) of + [] -> ["elements " <> openTag <> closeTag] + [single] -> ["elements " <> openTag <> single <> closeTag] + multiple -> + ["elements " <> openTag] + <> map ("elements " <>) multiple + <> ["elements " <> closeTag] + where + openTag :: Text + openTag = + " (if esAutoRemove es then " data-effect=\"el.remove()\"" else "") + <> foldMap (" " <>) (esAttributes es) + <> ">" + + closeTag :: Text + closeTag = "" diff --git a/src/Hypermedia/Datastar/Logger.hs b/src/Hypermedia/Datastar/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Hypermedia/Datastar/Logger.hs @@ -0,0 +1,38 @@ +module Hypermedia.Datastar.Logger + ( DatastarLogger (..) + , nullLogger + , stderrLogger + ) +where + +import Data.Text (Text) +import Data.Text qualified as T +import System.IO (hPutStrLn, stderr) + +data DatastarLogger = DatastarLogger + { logDebug :: Text -> IO () + , logInfo :: Text -> IO () + , logWarn :: Text -> IO () + , logError :: Text -> IO () + } + +nullLogger :: DatastarLogger +nullLogger = + DatastarLogger + { logDebug = const (pure ()) + , logInfo = const (pure ()) + , logWarn = const (pure ()) + , logError = const (pure ()) + } + +stderrLogger :: DatastarLogger +stderrLogger = + DatastarLogger + { logDebug = logAt "DEBUG" + , logInfo = logAt "INFO" + , logWarn = logAt "WARN" + , logError = logAt "ERROR" + } + where + logAt :: Text -> Text -> IO () + logAt level msg = hPutStrLn stderr $ T.unpack ("[datastar] [" <> level <> "] " <> msg) diff --git a/src/Hypermedia/Datastar/PatchElements.hs b/src/Hypermedia/Datastar/PatchElements.hs new file mode 100644 --- /dev/null +++ b/src/Hypermedia/Datastar/PatchElements.hs @@ -0,0 +1,128 @@ +-- | +-- Module : Hypermedia.Datastar.PatchElements +-- Description : Send HTML fragments to patch the browser DOM +-- +-- \"Patch elements\" is Datastar's primary mechanism for updating the page: the +-- server sends an HTML fragment and the browser morphs it into the DOM. The +-- morphing algorithm preserves focus, scroll position, and CSS transitions, +-- so partial page updates feel seamless. +-- +-- The simplest case — send HTML and let Datastar match elements by @id@ — +-- needs only 'patchElements': +-- +-- @ +-- sendPatchElements gen (patchElements "\
42\<\/div\>") +-- @ +-- +-- To customise the patching behaviour, use record update syntax on the result +-- of 'patchElements': +-- +-- @ +-- sendPatchElements gen +-- (patchElements "\new item\<\/li\>") +-- { peSelector = Just \"#todo-list\" +-- , peMode = Append +-- } +-- @ +-- +-- To remove elements from the DOM, use 'removeElements' with a CSS selector: +-- +-- @ +-- sendPatchElements gen (removeElements \"#flash-message\") +-- @ +module Hypermedia.Datastar.PatchElements where + +import Data.Text (Text) +import Data.Text qualified as T +import Hypermedia.Datastar.Types + +-- | Configuration for a @datastar-patch-elements@ SSE event. +-- +-- Construct values with 'patchElements' or 'removeElements', then customise +-- with record updates. +data PatchElements = PatchElements + { peElements :: Maybe Text + -- ^ The HTML fragment to patch into the DOM. 'Nothing' when removing + -- elements (see 'removeElements'). + , peSelector :: Maybe Text + -- ^ CSS selector for the target element. When 'Nothing' (the default), + -- Datastar matches by the @id@ attribute of the root element in + -- 'peElements'. + , peMode :: ElementPatchMode + -- ^ How to apply the patch. Default: 'Outer' (replace the matched + -- element and its contents via morphing). + , peUseViewTransition :: Bool + -- ^ Whether to wrap the DOM update in a + -- . + -- Default: 'False'. + , peNamespace :: ElementNamespace + -- ^ XML namespace for the patched elements. Default: 'HtmlNs'. Use + -- 'SvgNs' or 'MathmlNs' when patching inline SVG or MathML. + , peEventId :: Maybe Text + -- ^ Optional SSE event ID. The browser uses this for reconnection — + -- after a dropped connection it sends @Last-Event-ID@ so the server can + -- resume from the right point. + , peRetryDuration :: Int + -- ^ SSE retry interval in milliseconds. Default: @1000@. + } + deriving (Eq, Show) + +-- | Build a 'PatchElements' event with sensible defaults. +-- +-- The HTML is sent as-is and Datastar matches target elements by their @id@ +-- attribute. +-- +-- @ +-- patchElements "\
Hello!\<\/div\>" +-- @ +patchElements :: Text -> PatchElements +patchElements html = + PatchElements + { peElements = if T.null html then Nothing else Just html + , peSelector = Nothing + , peMode = defaultPatchMode + , peUseViewTransition = defaultUseViewTransition + , peNamespace = defaultNamespace + , peEventId = Nothing + , peRetryDuration = defaultRetryDuration + } + +-- | Remove elements from the DOM matching a CSS selector. +-- +-- @ +-- removeElements \"#notification\" +-- removeElements \".stale-row\" +-- @ +removeElements :: Text -> PatchElements +removeElements sel = + PatchElements + { peElements = Nothing + , peSelector = Just sel + , peMode = Remove + , peUseViewTransition = defaultUseViewTransition + , peNamespace = defaultNamespace + , peEventId = Nothing + , peRetryDuration = defaultRetryDuration + } + +toDatastarEvent :: PatchElements -> DatastarEvent +toDatastarEvent pe = + DatastarEvent + { eventType = EventPatchElements + , eventId = peEventId pe + , retry = peRetryDuration pe + , dataLines = + concat + [ maybe [] (\s -> ["selector " <> s]) (peSelector pe) + , [ "mode " <> patchModeToText (peMode pe) + | peMode pe /= defaultPatchMode + ] + , [ "useViewTransition true" + | peUseViewTransition pe + ] + , [ "namespace " <> namespaceToText (peNamespace pe) + | peNamespace pe /= defaultNamespace + ] + , maybe [] (map ("elements " <>) . T.lines) (peElements pe) + ] + } diff --git a/src/Hypermedia/Datastar/PatchSignals.hs b/src/Hypermedia/Datastar/PatchSignals.hs new file mode 100644 --- /dev/null +++ b/src/Hypermedia/Datastar/PatchSignals.hs @@ -0,0 +1,75 @@ +-- | +-- Module : Hypermedia.Datastar.PatchSignals +-- Description : Update the browser's reactive signal store +-- +-- Signals are Datastar's reactive state — key-value pairs that live in the +-- browser and drive the UI. The server can update signals at any time by +-- sending a @datastar-patch-signals@ event. +-- +-- Signal patching uses JSON Merge Patch semantics: set a key to update it, +-- set a key to @null@ to remove it, and omit a key to leave it unchanged. +-- +-- @ +-- sendPatchSignals gen (patchSignals \"{\\\"count\\\": 42}\") +-- @ +-- +-- To set initial state without overwriting values the user may have already +-- changed (e.g. form inputs), use 'psOnlyIfMissing': +-- +-- @ +-- sendPatchSignals gen +-- (patchSignals \"{\\\"name\\\": \\\"default\\\"}\") +-- { psOnlyIfMissing = True } +-- @ +module Hypermedia.Datastar.PatchSignals where + +import Data.Text (Text) +import Data.Text qualified as T +import Hypermedia.Datastar.Types + +-- | Configuration for a @datastar-patch-signals@ SSE event. +-- +-- Construct values with 'patchSignals', then customise with record updates. +data PatchSignals = PatchSignals + { psSignals :: Text + -- ^ JSON object containing the signal values to patch. Uses JSON Merge + -- Patch semantics: set a key to update it, set to @null@ to remove it. + , psOnlyIfMissing :: Bool + -- ^ When 'True', signal values are only set if the key doesn't already + -- exist in the browser's store. Useful for setting initial state that + -- shouldn't overwrite user changes (e.g. form input defaults). + -- Default: 'False'. + , psEventId :: Maybe Text + -- ^ Optional SSE event ID for reconnection. See 'Hypermedia.Datastar.PatchElements.PatchElements' for details. + , psRetryDuration :: Int + -- ^ SSE retry interval in milliseconds. Default: @1000@. + } + deriving (Eq, Show) + +-- | Build a 'PatchSignals' event with sensible defaults. +-- +-- The argument is a JSON object (as 'Text') describing the signals to update. +-- +-- @ +-- patchSignals \"{\\\"count\\\": 42, \\\"label\\\": \\\"hello\\\"}\" +-- @ +patchSignals :: Text -> PatchSignals +patchSignals sigs = + PatchSignals + { psSignals = sigs + , psOnlyIfMissing = defaultOnlyIfMissing + , psEventId = Nothing + , psRetryDuration = defaultRetryDuration + } + +toDatastarEvent :: PatchSignals -> DatastarEvent +toDatastarEvent ps = + DatastarEvent + { eventType = EventPatchSignals + , eventId = psEventId ps + , retry = psRetryDuration ps + , dataLines = ifMissingLine ++ signalLines + } + where + ifMissingLine = ["onlyIfMissing true" | psOnlyIfMissing ps] + signalLines = map ("signals " <>) $ T.lines $ psSignals ps diff --git a/src/Hypermedia/Datastar/Types.hs b/src/Hypermedia/Datastar/Types.hs new file mode 100644 --- /dev/null +++ b/src/Hypermedia/Datastar/Types.hs @@ -0,0 +1,140 @@ +-- | +-- Module : Hypermedia.Datastar.Types +-- Description : Core types for the Datastar SSE protocol +-- +-- This module defines the types that model the Datastar server-sent events +-- protocol. Most users won't import this module directly — the types are +-- re-exported from "Hypermedia.Datastar". +-- +-- Default values for protocol fields ('defaultPatchMode', 'defaultRetryDuration', +-- etc.) follow the Datastar ADR specification at +-- . +module Hypermedia.Datastar.Types where + +import Data.Text (Text) + +-- | The two SSE event types defined by the Datastar protocol. +-- +-- Every event the server sends is one of these. 'EventPatchElements' covers +-- both DOM patching and script execution (the protocol encodes @executeScript@ +-- as a special case of element patching). 'EventPatchSignals' updates the +-- browser's reactive signal store. +data EventType + = -- | Sent as @datastar-patch-elements@ on the wire. Used by both + -- 'Hypermedia.Datastar.PatchElements.PatchElements' and + -- 'Hypermedia.Datastar.ExecuteScript.ExecuteScript'. + EventPatchElements + | -- | Sent as @datastar-patch-signals@ on the wire. Used by + -- 'Hypermedia.Datastar.PatchSignals.PatchSignals'. + EventPatchSignals + deriving (Eq, Show) + +eventTypeToText :: EventType -> Text +eventTypeToText EventPatchElements = "datastar-patch-elements" +eventTypeToText EventPatchSignals = "datastar-patch-signals" + +-- | How the patched HTML should be applied to the DOM. +-- +-- The default mode is 'Outer', which replaces the target element (matched by +-- its @id@ attribute) including the element itself. This works well with +-- Datastar's morphing algorithm, which preserves focus, scroll position, and +-- CSS transitions during the replacement. +data ElementPatchMode + = -- | Replace the target element and its contents (the default). + Outer + | -- | Replace only the target element's children, keeping the element itself. + Inner + | -- | Remove the target element from the DOM entirely. + Remove + | -- | Replace the target element without morphing (a hard swap). + Replace + | -- | Insert the new content as the first child of the target element. + Prepend + | -- | Insert the new content as the last child of the target element. + Append + | -- | Insert the new content immediately before the target element. + Before + | -- | Insert the new content immediately after the target element. + After + deriving (Eq, Show) + +patchModeToText :: ElementPatchMode -> Text +patchModeToText Outer = "outer" +patchModeToText Inner = "inner" +patchModeToText Remove = "remove" +patchModeToText Replace = "replace" +patchModeToText Prepend = "prepend" +patchModeToText Append = "append" +patchModeToText Before = "before" +patchModeToText After = "after" + +-- | The XML namespace for the patched elements. +-- +-- Almost all content uses 'HtmlNs' (the default). Use 'SvgNs' or 'MathmlNs' +-- when patching inline SVG or MathML elements so that Datastar creates them +-- in the correct namespace. +data ElementNamespace + = -- | Standard HTML namespace (the default). + HtmlNs + | -- | SVG namespace — use when patching @\@ content. + SvgNs + | -- | MathML namespace — use when patching @\@ content. + MathmlNs + deriving (Eq, Show) + +namespaceToText :: ElementNamespace -> Text +namespaceToText HtmlNs = "html" +namespaceToText SvgNs = "svg" +namespaceToText MathmlNs = "mathml" + +-- | Internal representation of a rendered SSE event. +-- +-- Users don't construct these directly. Instead, use 'Hypermedia.Datastar.PatchElements.patchElements', +-- 'Hypermedia.Datastar.PatchSignals.patchSignals', or 'Hypermedia.Datastar.ExecuteScript.executeScript' +-- to build events, and 'Hypermedia.Datastar.WAI.sendPatchElements' (etc.) to send them. +data DatastarEvent = DatastarEvent + { eventType :: EventType + , eventId :: Maybe Text + , retry :: Int + , dataLines :: [Text] + } + +-- | Default SSE retry duration in milliseconds. +-- +-- If the connection drops, the browser waits this long before reconnecting. +-- Per the Datastar ADR spec, the default is @1000@ ms. +defaultRetryDuration :: Int +defaultRetryDuration = 1000 + +-- | Default element patch mode: 'Outer'. +-- +-- Replaces the target element (matched by @id@) and its contents using +-- Datastar's morphing algorithm. +defaultPatchMode :: ElementPatchMode +defaultPatchMode = Outer + +-- | Default for the @useViewTransition@ flag: 'False'. +-- +-- When 'True', Datastar wraps the DOM update in a +-- , +-- enabling CSS-animated transitions between states. +defaultUseViewTransition :: Bool +defaultUseViewTransition = False + +-- | Default for the @onlyIfMissing@ flag: 'False'. +-- +-- When 'True', signal values are only set if they don't already exist in the +-- browser's store. See 'Hypermedia.Datastar.PatchSignals.psOnlyIfMissing'. +defaultOnlyIfMissing :: Bool +defaultOnlyIfMissing = False + +-- | Default for the @autoRemove@ flag: 'True'. +-- +-- When 'True', scripts executed via 'Hypermedia.Datastar.ExecuteScript.executeScript' +-- are automatically removed from the DOM after running. +defaultAutoRemove :: Bool +defaultAutoRemove = True + +-- | Default element namespace: 'HtmlNs'. +defaultNamespace :: ElementNamespace +defaultNamespace = HtmlNs diff --git a/src/Hypermedia/Datastar/WAI.hs b/src/Hypermedia/Datastar/WAI.hs new file mode 100644 --- /dev/null +++ b/src/Hypermedia/Datastar/WAI.hs @@ -0,0 +1,196 @@ +-- | +-- Module : Hypermedia.Datastar.WAI +-- Description : SSE streaming and request handling for WAI +-- +-- This module connects Datastar to WAI (Web Application Interface), Haskell's +-- standard HTTP server interface. It provides: +-- +-- * 'sseResponse' — create a streaming SSE response with a +-- 'ServerSentEventGenerator' callback +-- * 'sendPatchElements', 'sendPatchSignals', 'sendExecuteScript' — send +-- Datastar events through the open connection +-- * 'readSignals' — decode signals sent by the browser (from query params on +-- GET, or from the request body on POST) +-- * 'isDatastarRequest' — distinguish Datastar SSE requests from normal +-- page loads +-- +-- === Streaming architecture +-- +-- 'sseResponse' uses WAI's @responseStream@ to hold the HTTP connection open. +-- You receive a 'ServerSentEventGenerator' and call @send*@ functions as many +-- times as needed. The connection stays open until your callback returns (or +-- the client disconnects). +-- +-- === Thread safety +-- +-- The 'ServerSentEventGenerator' uses an internal 'Control.Concurrent.MVar.MVar' +-- lock, so it is safe to call @send*@ functions from multiple threads +-- concurrently. +-- +-- === How signals flow from browser to server +-- +-- When the browser makes a Datastar request, signals are sent as JSON: +-- +-- * __GET requests__: signals are URL-encoded in the @datastar@ query parameter +-- * __POST requests__: signals are in the request body as JSON +-- +-- Use 'readSignals' with any 'Data.Aeson.FromJSON' instance to decode them. +module Hypermedia.Datastar.WAI where + +import Control.Concurrent.MVar +import Control.Exception + +import Data.Text (Text) +import Data.Text.Encoding qualified as TE + +import Data.Aeson (FromJSON) +import Data.Aeson qualified as A + +import Data.ByteString.Builder qualified as BSB + +import Network.HTTP.Types qualified as WAI +import Network.Wai qualified as WAI + +import Hypermedia.Datastar.Types + +import Hypermedia.Datastar.ExecuteScript qualified as ES +import Hypermedia.Datastar.PatchElements qualified as PE +import Hypermedia.Datastar.PatchSignals qualified as PS + +-- | An opaque handle for sending SSE events to the browser. +-- +-- Obtain one from the callback passed to 'sseResponse'. The handle is +-- thread-safe — you can send events from multiple threads concurrently. +-- +-- You don't construct these directly; 'sseResponse' creates one for you. +data ServerSentEventGenerator = ServerSentEventGenerator + { sseWrite :: BSB.Builder -> IO () + , sseFlush :: IO () + , sseLock :: MVar () + -- , sseLogger :: DatastarLogger -- FIXME + } + +-- | Create a WAI 'WAI.Response' that streams SSE events. +-- +-- The callback receives a 'ServerSentEventGenerator' for sending events. +-- The SSE connection stays open until the callback returns. +-- +-- @ +-- app :: WAI.Request -> (WAI.Response -> IO b) -> IO b +-- app req respond = +-- respond $ sseResponse $ \\gen -> do +-- sendPatchElements gen (patchElements "\
Hello\<\/div\>") +-- @ +sseResponse :: (ServerSentEventGenerator -> IO ()) -> WAI.Response +sseResponse callback = + WAI.responseStream + WAI.status200 + headers + action + where + headers = + [ ("Cache-Control", "no-cache") + , ("Content-Type", "text/event-stream") + , ("Connection", "keep-alive") + ] + + action write flush = do + lock <- newMVar () + callback $ + ServerSentEventGenerator + { sseWrite = write + , sseFlush = flush + , sseLock = lock + } + +send :: ServerSentEventGenerator -> DatastarEvent -> IO () +send gen event = do + let rendered = renderEvent event + + bracket_ + (takeMVar $ sseLock gen) + (putMVar (sseLock gen) ()) + $ do + sseWrite gen rendered + sseFlush gen + +-- | Send a 'PE.PatchElements' event, morphing HTML into the browser's DOM. +sendPatchElements :: ServerSentEventGenerator -> PE.PatchElements -> IO () +sendPatchElements gen pe = send gen $ PE.toDatastarEvent pe + +-- | Send a 'PS.PatchSignals' event, updating the browser's reactive signal store. +sendPatchSignals :: ServerSentEventGenerator -> PS.PatchSignals -> IO () +sendPatchSignals gen ps = send gen $ PS.toDatastarEvent ps + +-- | Send an 'ES.ExecuteScript' event, running JavaScript in the browser. +sendExecuteScript :: ServerSentEventGenerator -> ES.ExecuteScript -> IO () +sendExecuteScript gen es = send gen $ ES.toDatastarEvent es + +-- | Decode signals sent by the browser in a Datastar request. +-- +-- For GET requests, signals are URL-encoded in the @datastar@ query parameter. +-- For POST requests (and other methods), signals are read from the request +-- body as JSON. +-- +-- Define a Haskell data type with a 'FromJSON' instance to decode into: +-- +-- @ +-- data MySignals = MySignals { count :: Int, label :: Text } +-- deriving (Generic) +-- deriving anyclass (FromJSON) +-- +-- handler :: WAI.Request -> IO () +-- handler req = do +-- Right signals <- readSignals req +-- putStrLn $ \"Count is: \" <> show (count signals) +-- @ +readSignals :: (FromJSON a) => WAI.Request -> IO (Either String a) +readSignals req + | WAI.requestMethod req == "GET" = + pure $ parseFromQuery req + | otherwise = + parseFromBody req + +parseFromQuery :: (FromJSON a) => WAI.Request -> Either String a +parseFromQuery req = + case lookup "datastar" (WAI.queryString req) of + (Just (Just val)) -> + A.eitherDecodeStrict $ WAI.urlDecode True val + _ -> Left "missing 'datastar' query parameter" + +parseFromBody :: (FromJSON a) => WAI.Request -> IO (Either String a) +parseFromBody req = A.eitherDecode <$> WAI.strictRequestBody req + +-- | Check whether a request was initiated by Datastar. +-- +-- Datastar adds a @datastar-request@ header to its SSE requests. Use this to +-- distinguish Datastar requests from normal page loads — for example, to +-- serve either an SSE stream or a full HTML page from the same route. +-- +-- @ +-- app req respond +-- | isDatastarRequest req = +-- respond $ sseResponse $ \\gen -> ... +-- | otherwise = +-- respond $ responseLBS status200 [] fullPageHtml +-- @ +isDatastarRequest :: WAI.Request -> Bool +isDatastarRequest req = any ((== "datastar-request") . fst) (WAI.requestHeaders req) + +renderEvent :: DatastarEvent -> BSB.Builder +renderEvent event = + mconcat + [ BSB.stringUtf8 "event: " <> text (eventTypeToText (eventType event)) <> newline + , maybe mempty (\eid -> BSB.stringUtf8 "id: " <> text eid <> newline) (eventId event) + , if retry event /= defaultRetryDuration + then BSB.stringUtf8 "retry: " <> BSB.intDec (retry event) <> newline + else mempty + , foldMap (\line -> BSB.stringUtf8 "data: " <> text line <> newline) (dataLines event) + , newline + ] + where + text :: Text -> BSB.Builder + text = TE.encodeUtf8Builder + + newline :: BSB.Builder + newline = BSB.charUtf8 '\n' diff --git a/test/Hypermedia/Datastar/PatchElementsSpec.hs b/test/Hypermedia/Datastar/PatchElementsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hypermedia/Datastar/PatchElementsSpec.hs @@ -0,0 +1,103 @@ +module Hypermedia.Datastar.PatchElementsSpec where + +import Data.Text qualified as T +import Test.Hspec + +import Hypermedia.Datastar +import Hypermedia.Datastar.PatchElements +import Hypermedia.Datastar.Types + +spec :: Spec +spec = describe "Hypermedia.Datastar.PatchElements.toDatastarEvent" $ do + it "minimal: single-line elements, all defaults" $ do + let event = + toDatastarEvent $ + patchElements "
1
" + + eventType event `shouldBe` EventPatchElements + eventId event `shouldBe` Nothing + retry event `shouldBe` defaultRetryDuration + dataLines event `shouldBe` ["elements
1
"] + + it "full: all options set" $ do + let event = + toDatastarEvent $ + (patchElements "
\n 1\n
") + { peSelector = Just "#feed" + , peMode = Inner + , peUseViewTransition = True + , peNamespace = HtmlNs + , peEventId = Just "123" + , peRetryDuration = 2000 + } + + eventType event `shouldBe` EventPatchElements + eventId event `shouldBe` Just "123" + retry event `shouldBe` 2000 + dataLines event + `shouldBe` [ "selector #feed" + , "mode inner" + , "useViewTransition true" + , "elements
" + , "elements 1" + , "elements
" + ] + + it "remove: mode remove with selector, no elements" $ do + let pe = removeElements "#feed, #otherid" + event = toDatastarEvent pe + dataLines event + `shouldBe` [ "selector #feed, #otherid" + , "mode remove" + ] + + it "append with selector" $ do + let pe = + (patchElements "
New content
") + { peSelector = Just "#mycontainer" + , peMode = Append + } + event = toDatastarEvent pe + dataLines event + `shouldBe` [ "selector #mycontainer" + , "mode append" + , "elements
New content
" + ] + + it "SVG namespace" $ do + let pe = + (patchElements "\n\n") + { peSelector = Just "#vis" + , peMode = Append + , peNamespace = SvgNs + } + event = toDatastarEvent pe + dataLines event + `shouldBe` [ "selector #vis" + , "mode append" + , "namespace svg" + , "elements " + , "elements " + , "elements " + ] + + it "omits namespace when html (default)" $ do + let lines = + dataLines $ + toDatastarEvent $ + patchElements "

hello

" + + any (T.isPrefixOf "namespace") lines `shouldBe` False + + it "omits mode when Outer (default)" $ do + let pe = patchElements "

hello

" + event = toDatastarEvent pe + lines = dataLines event + any (T.isPrefixOf "mode") lines `shouldBe` False + + it "politely ignores empty element strings" $ do + let lines = + dataLines $ + toDatastarEvent $ + patchElements "" + lines `shouldBe` [] diff --git a/test/Hypermedia/Datastar/SSESpec.hs b/test/Hypermedia/Datastar/SSESpec.hs new file mode 100644 --- /dev/null +++ b/test/Hypermedia/Datastar/SSESpec.hs @@ -0,0 +1,80 @@ +module Hypermedia.Datastar.SSESpec where + +import Data.Text qualified as T +import Test.Hspec + +import Data.ByteString.Builder qualified as BSB +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.IORef +import Data.List (isInfixOf) + +import Hypermedia.Datastar +import Hypermedia.Datastar.PatchElements +import Hypermedia.Datastar.PatchSignals +import Hypermedia.Datastar.Types +import Hypermedia.Datastar.WAI (renderEvent) +import Network.Wai.Internal (Response (..)) + +render :: DatastarEvent -> String +render = LBS.unpack . BSB.toLazyByteString . renderEvent + +-- | Consume a streaming WAI response and return the full body as a string. +consumeStreamingResponse :: Response -> IO String +consumeStreamingResponse (ResponseStream _status _headers body) = do + chunksRef <- newIORef [] + body + (\chunk -> modifyIORef' chunksRef (chunk :)) + (pure ()) + chunks <- readIORef chunksRef + pure $ LBS.unpack $ BSB.toLazyByteString $ mconcat $ reverse chunks +consumeStreamingResponse _ = error "Expected a streaming response" + +spec :: Spec +spec = do + describe "Hypermedia.Datastar.SSE.renderEvent" $ do + it "renders a simple event" $ do + let event = + DatastarEvent + { eventType = EventPatchElements + , eventId = Nothing + , retry = defaultRetryDuration + , dataLines = ["elements
1
"] + } + render event + `shouldBe` "event: datastar-patch-elements\n\ + \data: elements
1
\n\ + \\n" + + describe "SSE streaming" $ do + it "sends multiple events over a single SSE connection" $ do + let e0 = "
1
" + e1 = "
2
" + e2 = "{\"count\": 42}" + + resp = sseResponse $ \gen -> do + sendPatchElements gen (patchElements e0) + sendPatchElements gen (patchElements e1) + sendPatchSignals gen (patchSignals e2) + + body <- consumeStreamingResponse resp + + let s0 = "elements " ++ T.unpack e0 + s1 = "elements " ++ T.unpack e1 + s2 = "signals " ++ T.unpack e2 + + -- All three events are present in the single response body + length (filter ("event: datastar-patch-elements" `isInfixOf`) (lines body)) + `shouldBe` 2 + length (filter ("event: datastar-patch-signals" `isInfixOf`) (lines body)) + `shouldBe` 1 + + -- The actual data is there too + body `shouldSatisfy` isInfixOf s0 + body `shouldSatisfy` isInfixOf s1 + body `shouldSatisfy` isInfixOf s2 + + -- Events arrive in the order they were sent + let eventLines = filter (\l -> "event: " `isInfixOf` l || "data: " `isInfixOf` l) (lines body) + indexOf needle = length $ takeWhile (not . isInfixOf needle) eventLines + indexOf s0 `shouldSatisfy` (< indexOf s1) + indexOf s1 `shouldSatisfy` (< indexOf s2) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,11 @@ +module Main where + +import Test.Hspec + +import Hypermedia.Datastar.PatchElementsSpec qualified +import Hypermedia.Datastar.SSESpec qualified + +main :: IO () +main = hspec $ do + Hypermedia.Datastar.PatchElementsSpec.spec + Hypermedia.Datastar.SSESpec.spec