add todomvc example

.agents/skills/ihp-datastar.md

@@ -5,50 +5,59 @@ description: Gotchas and patterns for wiring datastar-haskell (SSE hypermedia) i
 
 # IHP + Datastar integration notes
 
-## Bootstrap
+## Setup
 
-Started from a bare `ihp-boilerplate` clone, not `ihp-new` — so it had no `Web/` until `make -s all; new-application Web` scaffolded it.
-
-## Datastar package sourcing
-
-`datastar-hs`/`datastar-hs-zlib` come from Hackage via `callHackageDirect` in `flake.nix` (plain `callHackage` can't find a hash — they postdate nixpkgs' cabal-hashes snapshot).
-
-`datastar-hs`'s `WAI.hs` needs `WAI.hAcceptEncoding` (http-types >=0.12.5); this project's pinned nixpkgs ships 0.12.4. Patched via `overrideCabal`/`postPatch`/`substituteInPlace --replace-fail` in `flake.nix` rather than bumping http-types project-wide (would rebuild `wai`/`warp`/IHP). Use `--replace-fail`, not `sed` — it fails loudly if the patched line ever moves.
+- Bootstrapped from bare `ihp-boilerplate` (no `Web/` until `make -s all; new-application Web`).
+- `datastar-hs`/`datastar-hs-zlib` via `callHackageDirect` in `flake.nix` (they postdate nixpkgs' cabal-hashes snapshot; plain `callHackage` fails).
+- `datastar-hs` needs http-types >=0.12.5 for `WAI.hAcceptEncoding`; pinned nixpkgs has 0.12.4. Patched with `substituteInPlace --replace-fail` in `flake.nix` (fails loudly if the line moves) instead of bumping http-types (would rebuild wai/warp/IHP).
 
 ## POST body: `readPostSignals`, never `readSignals`
 
-Datastar's `readSignals` reads via `strictRequestBody`, but IHP's middleware already drained that stream → empty-body 400. Fix, decode from IHP's cached copy:
+IHP's middleware drains the body stream, so Datastar's `readSignals` gets an empty body → 400. Decode IHP's cached copy instead, in **every** POST action:
 
 ```haskell
 readPostSignals :: (FromJSON a, ?request :: Request) => IO (Either String a)
 readPostSignals = eitherDecode <$> getRequestBody
 ```
 
-Apply to **every** POST action, not just the one in front of you — easy to fix one handler and miss a shared helper. `readSignals ?request` is only correct for GET (signals in query string).
+`readSignals ?request` is only correct for GET (query string).
 
 ## Patching elements
 
-- Whole-element replace (default): `patchElements html`.
-- Inner content only: `(patchElements html){peSelector = Just "#id", peMode = Inner}`.
-- Prepend to a list: `peMode = Prepend`, targeting a dedicated container (so it can be reset later).
-- **`patchElements ""` is a no-op**, not an empty patch (`peElements = Nothing` for blank input). To clear a container, `Outer`-replace it with an empty-but-present copy: `patchElements "<div id=\"x\"></div>"`.
+- Whole-element replace (default): `patchElements html`. Inner: `(patchElements html){peSelector = Just "#id", peMode = Inner}`. Prepend: `peMode = Prepend` on a dedicated container.
+- `patchElements ""` is a **no-op**, not an empty patch. To clear, `Outer`-replace with an empty-but-present copy: `patchElements "<div id=\"x\"></div>"`.
 
 ## HSX gotchas
 
-- `IHP.HSX.Markup.Html` ≠ `Text.Blaze.Html.Html` (this project uses the "direct" HSX backend). Render with `renderMarkupText`, not blaze's `renderHtml`. `Html` is a plain concrete type, no implicit params needed.
-- `patchElements`/`sendPatchElements` do **not** escape their `Text` argument (raw HTML client-side). Escape user input first: `renderMarkupText (escapeHtml someText)`.
-- `{}`-interpolation doesn't work inside `<script>`/`<style>` (parsed as raw text). Pass server values via an attribute instead: `<script data-dark={val}>`, read via `dataset.dark`.
-- Bare `data-*` attrs get auto-filled `="true"`. Datastar's `data-bind:<signal>`/`data-popover` etc. want no value — write `data-bind:delay=""` explicitly.
-- `tshow` (IHP prelude) = `Text.pack . show`; `show` itself already returns `Text` here, so `T.pack (show x)` is usually redundant.
-- Only known HTML attribute names (plus `data-`/`aria-`/`hx-`/`_`) pass HSX's parser — e.g. `autocorrect` isn't in the whitelist and fails to compile.
+- Direct HSX backend: render with `renderMarkupText`, not blaze's `renderHtml`.
+- View-prelude `Html` = `(?context :: Request, ?request :: Request) => Markup` (v1.6: `ControllerContext = Request`). Controller helpers rendering view functions need both in their signature.
+- Literal `{`/`}` inside a `{...}` splice break HSX's lexer. Use `data-class:name={expr}`, or braces only in quoted literal attr values (`data-signals="{...}"` is fine).
+- `patchElements`/`sendPatchElements` don't escape — `renderMarkupText (escapeHtml userText)` first.
+- `{}`-interpolation is dead inside `<script>`/`<style>`; pass values via attribute (`<script data-dark={val}>`).
+- Bare `data-*` attrs auto-fill `="true"` — write `data-bind:delay=""` explicitly.
+- `show` already returns `Text` here; `T.pack (show x)` is redundant (`tshow` for the general case).
+- Unknown attr names fail to compile (whitelist + `data-`/`aria-`/`hx-`/`_`), e.g. `autocorrect`.
+
+## Datastar attribute/expression gotchas
+
+- HTML lowercases attr names: `data-signals:editingId` creates signal `editingid`, not `$editingId`. Use object-form `data-signals="{editingId: ''}"` or kebab-case (`data-bind:edit-title` → `$editTitle`).
+- `;`-separated statements only work as a whole expression; inside a ternary/`&&` branch use the comma operator: `cond && (@patch(...), $x = '')`.
+- Elements with transient DOM state (open `<dialog>` etc.) must live outside SSE-patched sections — every patch incl. heartbeats resets them. Feed them per-item data via signals (`$deleteUrl` from server-rendered `pathTo`).
+- Focus-on-reveal: `data-effect="$editingId === 'id' && setTimeout(() => el.focus())"` — without the deferral the element may still be hidden and `focus()` silently no-ops.
+- Open multi-tab SSE streams with `@post`, not `@get`: Firefox serializes concurrent same-URL GETs — the second tab's request is held (never sent) behind the first never-ending stream. `Cache-Control: no-store` does NOT fix it; POST does.
 
 ## Theme (dark/light)
 
-Handled by `basecoat`'s own theme toggle (`window.basecoat.theme.toggle()`), storing in `localStorage`; a synchronous inline `<script>` in `<head>` sets `.dark` before first paint to avoid a flash. Re-derive from `Web/View/Layout.hs` if this breaks — the mechanism has changed shape more than once (TVar → cookie → basecoat/localStorage).
+basecoat's toggle (`window.basecoat.theme.toggle()`) + `localStorage`; a sync inline `<script>` in `<head>` sets `.dark` pre-paint. Re-derive from `Web/View/Layout.hs` if broken — the mechanism has changed shape repeatedly.
 
-Tailwind v4's `dark:` variant defaults to `prefers-color-scheme`, **not** the toggled `.dark` class — needs `@custom-variant dark (&:where(.dark, .dark *));` (a `<style type="text/tailwindcss">` block in `Layout.hs`) or `dark:` utilities silently only track OS preference.
+Tailwind v4 `dark:` tracks `prefers-color-scheme`, not the `.dark` class — needs `@custom-variant dark (&:where(.dark, .dark *));` in `Layout.hs` or `dark:` utilities silently follow OS only.
 
 ## Misc
 
-- No automated tests for the Datastar demo routes — verify manually in-browser; `nix flake check --impure` only covers the build.
-- `NOINLINE unsafePerformIO` top-level `IORef`/`TVar` is this project's pattern for ad hoc app-wide mutable state (IHP has no built-in slot for it outside session/cookies) — e.g. `Rocket.hs`'s generation counter for cancelling stale SSE runs.
+- No automated tests for demo routes — verify in-browser; `nix flake check --impure` covers the build only.
+- App-wide mutable state: `NOINLINE unsafePerformIO` top-level `IORef`/`TVar` (IHP has no other slot for it).
+- Schema parser rejects `TIMESTAMPTZ` — write `TIMESTAMP WITH TIME ZONE`.
+- `IHP.Prelude` re-exports only `throw, throwIO, catch` from `Control.Exception.Safe`; `bracket_` etc. need explicit import.
+- `respondAndExit :: ... -> IO a` (needs `?request`/`?respond`); helpers wrapping it must stay `IO a` to unify with `action`'s `IO ResponseReceived`.
+- AutoRoute verbs from constructor prefixes: `Create*`→POST, `Update*`→POST/PATCH (no PUT), `Delete*`→DELETE, other→GET/POST/HEAD. Match with `@post`/`@patch`/`@delete`.
+- Multi-tab broadcast pattern (version TVar + `registerDelay` heartbeat + `bracket_` client count): see `Web/Controller/Todo.hs`.

Application/Helper/View.hs

@@ -19,6 +19,16 @@ iconChevronDown = [hsx|
     <svg class="lucide lucide-chevron-right size-4 rotate-90" xmlns="http://www.w3.org/2000/svg" width="24" height="24" viewBox="0 0 24 24" fill="none" stroke="currentColor" stroke-width="2" stroke-linecap="round" stroke-linejoin="round"><path d="m9 18 6-6-6-6"/></svg>
     |]
 
+iconLoader :: Html
+iconLoader = [hsx|
+    <svg aria-label="Loading" role="status" class="animate-spin lucide lucide-loader-circle" xmlns="http://www.w3.org/2000/svg" width="24" height="24" viewBox="0 0 24 24" fill="none" stroke="currentColor" stroke-width="2" stroke-linecap="round" stroke-linejoin="round"><path d="M21 12a9 9 0 1 1-6.219-8.56" /></svg>
+    |]
+
+iconTrash :: Html
+iconTrash = [hsx|
+    <svg class="lucide lucide-trash-2" xmlns="http://www.w3.org/2000/svg" width="24" height="24" viewBox="0 0 24 24" fill="none" stroke="currentColor" stroke-width="2" stroke-linecap="round" stroke-linejoin="round"><path d="M10 11v6" /><path d="M14 11v6" /><path d="M19 6v14a2 2 0 0 1-2 2H7a2 2 0 0 1-2-2V6" /><path d="M3 6h18" /><path d="M8 6V4a2 2 0 0 1 2-2h4a2 2 0 0 1 2 2v2" /></svg>
+    |]
+
 iconSun :: Html
 iconSun = [hsx|
     <svg class="lucide lucide-sun" xmlns="http://www.w3.org/2000/svg" width="24" height="24" viewBox="0 0 24 24" fill="none" stroke="currentColor" stroke-width="2" stroke-linecap="round" stroke-linejoin="round"><circle cx="12" cy="12" r="4"/><path d="M12 2v2"/><path d="M12 20v2"/><path d="m4.93 4.93 1.41 1.41"/><path d="m17.66 17.66 1.41 1.41"/><path d="M2 12h2"/><path d="M20 12h2"/><path d="m6.34 17.66-1.41 1.41"/><path d="m19.07 4.93-1.41 1.41"/></svg>

Application/Migration/1787301022-create-todos.sql

@@ -0,0 +1,14 @@
+CREATE FUNCTION set_updated_at_to_now() RETURNS TRIGGER AS $$
+BEGIN
+    NEW.updated_at = NOW();
+    RETURN NEW;
+END;
+$$ language plpgsql;
+CREATE TABLE todos (
+    id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
+    title TEXT NOT NULL,
+    completed BOOLEAN DEFAULT false NOT NULL,
+    created_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL,
+    updated_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL
+);
+CREATE TRIGGER update_todos_updated_at BEFORE UPDATE ON todos FOR EACH ROW EXECUTE FUNCTION set_updated_at_to_now();

Application/Schema.sql

@@ -1 +1,15 @@
+CREATE FUNCTION set_updated_at_to_now() RETURNS TRIGGER AS $$
+BEGIN
+    NEW.updated_at = NOW();
+    RETURN NEW;
+END;
+$$ language plpgsql;
 -- Your database schema. Use the Schema Designer at http://localhost:8001/ to add some tables.
+CREATE TABLE todos (
+    id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
+    title TEXT NOT NULL,
+    completed BOOLEAN DEFAULT false NOT NULL,
+    created_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL,
+    updated_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL
+);
+CREATE TRIGGER update_todos_updated_at BEFORE UPDATE ON todos FOR EACH ROW EXECUTE FUNCTION set_updated_at_to_now();

README.md

@@ -6,11 +6,15 @@ PoC to discover [IHP](https://ihp.digitallyinduced.com/Guide/) and [Datastar](ht
 
 # Examples
 
-## Rocket
+## Todos (synced)
+
+![Todos example](./data/todomvc.gif)
+
+## Rocket (animated)
 
 ![Rocket example](./data/rocket.gif)
 
-## Typewriter
+## Typewriter (streamed)
 
 ![Typewriter example](./data/typewriter.gif)
 

Web/Controller/Todo.hs

@@ -0,0 +1,118 @@
+module Web.Controller.Todo where
+
+import Web.Controller.Prelude
+import Web.View.Todo.Index
+
+import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVar, readTVarIO, registerDelay, retry)
+import Control.Exception.Safe (bracket_)
+import Data.Aeson (eitherDecode, withObject, (.:))
+import Data.Functor (void)
+import Data.Text qualified as T
+import System.IO.Unsafe (unsafePerformIO)
+
+import Network.HTTP.Types (status204)
+import Network.Wai (responseLBS)
+
+import Hypermedia.Datastar
+import Hypermedia.Datastar.Compression.Zlib (deflate, gzip)
+
+import IHP.HSX.Markup (renderMarkupText)
+
+-- | STM wake signal: bumped by every mutation and connect/disconnect.
+{-# NOINLINE todosVersion #-}
+todosVersion :: TVar Int
+todosVersion = unsafePerformIO (newTVarIO 0)
+
+-- | Open /TodosUpdates connections.
+{-# NOINLINE connectedClients #-}
+connectedClients :: TVar Int
+connectedClients = unsafePerformIO (newTVarIO 0)
+
+compressors :: [Compressor]
+compressors = [gzip, deflate]
+
+heartbeatMicros :: Int
+heartbeatMicros = 15 * 1000 * 1000
+
+-- | Decode signals from IHP's cached body copy; readSignals would hit the
+-- already-drained stream (see .agents/skills/ihp-datastar.md).
+readPostSignals :: (FromJSON a, ?request :: Request) => IO (Either String a)
+readPostSignals = eitherDecode <$> getRequestBody
+
+newtype CreateSignals = CreateSignals { newTitle :: Text }
+instance FromJSON CreateSignals where
+    parseJSON = withObject "CreateSignals" \o -> CreateSignals <$> o .: "newTitle"
+
+newtype EditSignals = EditSignals { editTitle :: Text }
+instance FromJSON EditSignals where
+    parseJSON = withObject "EditSignals" \o -> EditSignals <$> o .: "editTitle"
+
+instance Controller TodoController where
+    action TodosAction = render IndexView
+
+    -- @post, not @get: Firefox serializes concurrent same-URL GETs (second
+    -- tab hangs behind the never-ending first stream); POSTs are never
+    -- coalesced. Cache-Control: no-store did NOT fix the GET variant.
+    action TodosUpdatesAction = respondAndExit $ sseResponseWith nullLogger compressors ?request \gen ->
+        bracket_ (trackClient 1) (trackClient (-1)) (broadcastLoop gen)
+
+    action CreateTodoAction = do
+        signals <- readPostSignals
+        case signals of
+            Right CreateSignals { newTitle }
+                | title <- T.strip newTitle
+                , not (T.null title) -> void $ newRecord @Todo |> set #title title |> createRecord
+            _ -> pure ()
+        bumpAndRespond204
+
+    -- fetchOneOrNothing + forM_ in the {todoId} actions: no-op instead of 500
+    -- when the row was already deleted elsewhere.
+    action ToggleTodoAction { todoId } = do
+        maybeTodo <- query @Todo |> filterWhere (#id, todoId) |> fetchOneOrNothing
+        forM_ maybeTodo \todo -> todo |> set #completed (not todo.completed) |> updateRecord
+        bumpAndRespond204
+
+    action UpdateTodoAction { todoId } = do
+        signals <- readPostSignals
+        maybeTodo <- query @Todo |> filterWhere (#id, todoId) |> fetchOneOrNothing
+        case (signals, maybeTodo) of
+            (Right EditSignals { editTitle }, Just todo)
+                | title <- T.strip editTitle
+                , not (T.null title) -> void $ todo |> set #title title |> updateRecord
+            _ -> pure ()
+        bumpAndRespond204
+
+    action DeleteTodoAction { todoId } = do
+        maybeTodo <- query @Todo |> filterWhere (#id, todoId) |> fetchOneOrNothing
+        forM_ maybeTodo deleteRecord
+        bumpAndRespond204
+
+-- | Connect/disconnect: adjust the client count and wake all loops.
+trackClient :: Int -> IO ()
+trackClient delta = atomically do
+    modifyTVar' connectedClients (+ delta)
+    modifyTVar' todosVersion (+1)
+
+-- | Version read BEFORE the query: a bump during fetch/send re-renders
+-- immediately instead of being lost. Heartbeat expiry re-sends the section;
+-- the write fails on a dead socket and bracket_ cleans up.
+broadcastLoop :: (?modelContext :: ModelContext, ?context :: ControllerContext, ?request :: Request) => ServerSentEventGenerator -> IO ()
+broadcastLoop gen = do
+    version <- readTVarIO todosVersion
+    todos <- query @Todo |> orderBy #createdAt |> fetch
+    connected <- readTVarIO connectedClients
+    sendPatchElements gen $ patchElements $ renderMarkupText $ todoSectionHtml todos connected
+    heartbeat <- registerDelay heartbeatMicros
+    atomically do
+        v <- readTVar todosVersion
+        expired <- readTVar heartbeat
+        when (v == version && not expired) retry
+    broadcastLoop gen
+
+-- | Unconditional bump even on no-op mutations: the only bridge from a
+-- mutation to the broadcasts, and it converges the actor's own tab to true
+-- state in the tightest race (e.g. toggling a row someone else deleted).
+bumpAndRespond204 :: (?request :: Request, ?respond :: Respond) => IO a
+bumpAndRespond204 = do
+    atomically $ modifyTVar' todosVersion (+1)
+    respondAndExit $ responseLBS status204 [] ""

Web/FrontController.hs

@@ -8,12 +8,14 @@ import Web.View.Layout (defaultLayout)
 import Web.Controller.Static
 import Web.Controller.Typewriter
 import Web.Controller.Rocket
+import Web.Controller.Todo
 
 instance FrontController WebApplication where
     controllers =
         [ startPage WelcomeAction
         , parseRoute @TypewriterController
         , parseRoute @RocketController
+        , parseRoute @TodoController
         -- Generator Marker
         ]
 

Web/Routes.hs

@@ -10,3 +10,4 @@ GET /    WelcomeAction
 
 instance AutoRoute TypewriterController
 instance AutoRoute RocketController
+instance AutoRoute TodoController

Web/Types.hs

@@ -18,3 +18,12 @@ data RocketController
     = RocketAction
     | RocketRunAction
     deriving (Eq, Show, Data)
+
+data TodoController
+    = TodosAction
+    | TodosUpdatesAction
+    | CreateTodoAction
+    | ToggleTodoAction { todoId :: !(Id Todo) }
+    | UpdateTodoAction { todoId :: !(Id Todo) }
+    | DeleteTodoAction { todoId :: !(Id Todo) }
+    deriving (Eq, Show, Data)

Web/View/Static/Welcome.hs

@@ -18,5 +18,11 @@ instance View WelcomeView where
                 </section>
                 <aside>{iconArrowRight}</aside>
             </a>
+            <a href={TodosAction} class="item">
+                <section>
+                <h3>Todos</h3>
+                </section>
+                <aside>{iconArrowRight}</aside>
+            </a>
         </div>
     |]