packages feed

datastar-hs (empty) → 0.1.0.0

raw patch · 13 files changed

+1052/−0 lines, 13 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, datastar-hs, hspec, http-types, text, wai

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Changelog++## 0.1.0.0++* Initial release.
+ LICENSE view
@@ -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.
+ datastar-hs.cabal view
@@ -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+  <https://data-star.dev/ Datastar>. 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
+ src/Hypermedia/Datastar.hs view
@@ -0,0 +1,92 @@+-- |+-- Module      : Hypermedia.Datastar+-- Description : Haskell SDK for building real-time hypermedia apps with Datastar+--+-- <https://data-star.dev/ 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+-- <https://hackage.haskell.org/package/wai WAI> 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 \"\<div id=\\\"msg\\\"\>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+--+-- * <https://data-star.dev/ Datastar homepage> — guides, reference, and examples+-- * <https://github.com/carlohamalainen/datastar-hs-examples Examples repository> — full working Haskell examples+-- * <https://cljdoc.org/d/dev.data-star.clojure/http-kit/1.0.0-RC7/doc/sdk-docs/using-datastar Clojure SDK docs> — 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+  )
+ src/Hypermedia/Datastar/ExecuteScript.hs view
@@ -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 @\<script\>@ tag to @\<body\>@. 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 @\<script\>@ 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 @\<script\>@ 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 @\<script\>@ 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 =+    "<script"+      <> (if esAutoRemove es then " data-effect=\"el.remove()\"" else "")+      <> foldMap (" " <>) (esAttributes es)+      <> ">"++  closeTag :: Text+  closeTag = "</script>"
+ src/Hypermedia/Datastar/Logger.hs view
@@ -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)
+ src/Hypermedia/Datastar/PatchElements.hs view
@@ -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 "\<div id=\\\"count\\\"\>42\<\/div\>")+-- @+--+-- To customise the patching behaviour, use record update syntax on the result+-- of 'patchElements':+--+-- @+-- sendPatchElements gen+--   (patchElements "\<li\>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+  -- <https://developer.mozilla.org/en-US/docs/Web/API/View_Transition_API View Transition>.+  -- 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 "\<div id=\\\"greeting\\\"\>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)+          ]+    }
+ src/Hypermedia/Datastar/PatchSignals.hs view
@@ -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
+ src/Hypermedia/Datastar/Types.hs view
@@ -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+-- <https://data-star.dev/reference/action_plugins>.+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 @\<svg\>@ content.+    SvgNs+  | -- | MathML namespace — use when patching @\<math\>@ 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+-- <https://developer.mozilla.org/en-US/docs/Web/API/View_Transition_API View Transition>,+-- 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
+ src/Hypermedia/Datastar/WAI.hs view
@@ -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 "\<div id=\\\"msg\\\"\>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'
+ test/Hypermedia/Datastar/PatchElementsSpec.hs view
@@ -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 "<div id=\"feed\"><span>1</span></div>"++    eventType event `shouldBe` EventPatchElements+    eventId event `shouldBe` Nothing+    retry event `shouldBe` defaultRetryDuration+    dataLines event `shouldBe` ["elements <div id=\"feed\"><span>1</span></div>"]++  it "full: all options set" $ do+    let event =+          toDatastarEvent $+            (patchElements "<div id=\"feed\">\n    <span>1</span>\n</div>")+              { 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 <div id=\"feed\">"+                 , "elements     <span>1</span>"+                 , "elements </div>"+                 ]++  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 "<div>New content</div>")+            { peSelector = Just "#mycontainer"+            , peMode = Append+            }+        event = toDatastarEvent pe+    dataLines event+      `shouldBe` [ "selector #mycontainer"+                 , "mode append"+                 , "elements <div>New content</div>"+                 ]++  it "SVG namespace" $ do+    let pe =+          (patchElements "<circle id=\"c1\" cx=\"10\" r=\"5\" fill=\"red\"/>\n<circle id=\"c2\" cx=\"20\" r=\"5\" fill=\"green\"/>\n<circle id=\"c3\" cx=\"30\" r=\"5\" fill=\"blue\"/>")+            { peSelector = Just "#vis"+            , peMode = Append+            , peNamespace = SvgNs+            }+        event = toDatastarEvent pe+    dataLines event+      `shouldBe` [ "selector #vis"+                 , "mode append"+                 , "namespace svg"+                 , "elements <circle id=\"c1\" cx=\"10\" r=\"5\" fill=\"red\"/>"+                 , "elements <circle id=\"c2\" cx=\"20\" r=\"5\" fill=\"green\"/>"+                 , "elements <circle id=\"c3\" cx=\"30\" r=\"5\" fill=\"blue\"/>"+                 ]++  it "omits namespace when html (default)" $ do+    let lines =+          dataLines $+            toDatastarEvent $+              patchElements "<p>hello</p>"++    any (T.isPrefixOf "namespace") lines `shouldBe` False++  it "omits mode when Outer (default)" $ do+    let pe = patchElements "<p>hello</p>"+        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` []
+ test/Hypermedia/Datastar/SSESpec.hs view
@@ -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 <div id=\"feed\"><span>1</span></div>"]+              }+      render event+        `shouldBe` "event: datastar-patch-elements\n\+                   \data: elements <div id=\"feed\"><span>1</span></div>\n\+                   \\n"++  describe "SSE streaming" $ do+    it "sends multiple events over a single SSE connection" $ do+      let e0 = "<div id=\"a\">1</div>"+          e1 = "<div id=\"b\">2</div>"+          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)
+ test/Main.hs view
@@ -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