coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

host: typed relations — Phase 4 cleanup, registry-driven render + /tags
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 21s
Details

Browse Source 
Replace the hard-coded related/tagged blocks with iteration over the registry,
so adding a kind renders automatically — no handler edit.

- host/blog--relation-blocks: iterates host/blog-rel-kinds; each kind contributes
  its outgoing block (label) and, if it has an inverse, its incoming block
  (inverse-label, e.g. tagged -> "Tagged with this", is-a -> "Instances"). Empty
  blocks dropped; one kv-keys read up front, relation lookups in-memory.
  host/blog--relations-or-hint adds the logged-in "add some" hint when empty.
- host/blog--relation-editors: one editor per registry kind on the edit page
  (Related / Types / Subtype of / Tags), replacing the hard-coded two.
- GET /tags: index of every tag (a post that is-a tag), each linking its own page.
- dropped host/blog--related-block / --kind-block / --tagged-with-block (folded
  into host/blog--edges-block + the registry iteration).
- GOTCHA (4th time): host/blog-tags-index called host/blog-get INSIDE the item
  quasiquote -> VmSuspended/500 live (conformance in-memory store can't see it);
  pre-fetch records before the quasiquote.

5 tests (relations-section hint, registry render of Related+Tags, inverse block
for a tag, /tags lists + 200). 265/265; Playwright 4/4. Verified live: /tags,
post pages show registry blocks, tag page shows Types + Tagged-with-this, edit
page has a picker per kind.

Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
This commit is contained in:
giles
2026-06-28 17:29:58 +00:00
parent 62b7fc1ff0
commit 7e50d3d1bb
2 changed files with 116 additions and 72 deletions
Download Patch File Download Diff File Expand all files Collapse all files

164
lib/host/blog.sx
View File

@@ -347,70 +347,71 @@
(head (meta :charset "utf-8") (title (unquote title)))
(body (unquote body))))))))
;; "Related posts" block for the post page: a list of links when there are any;
;; a subtle "add some" hint when there are none AND the viewer is logged in (an
;; editor); nothing for an anonymous viewer. Records (slug+title) are fetched up
;; front so the SX tree is built from in-memory data — no durable read happens
;; while the page tree is rendered.
(define host/blog--related-block
;; ── registry-driven relation rendering (post page) ──────────────────
;; One labelled block of links from records ({:slug :title}), or "" when empty.
;; Records are pre-fetched, so the tree is built from in-memory data only.
(define host/blog--edges-block
(fn (records label)
(if (> (len records) 0)
(let ((items (map (fn (p)
(quasiquote
(li (a :href (unquote (str "/" (get p :slug) "/"))
(unquote (get p :title))))))
records)))
(quasiquote
(div :style "margin-top:2em"
(h3 (unquote label))
(unquote (list (quote ul) items)))))
"")))
;; nodes -> {:slug :title} records, existence-filtered against a shared key set.
(define host/blog--recs
(fn (existing nodes)
(map (fn (s) {:slug s :title (get (host/blog-get s) :title)})
(filter (fn (s) (contains? existing s))
(map (fn (n) (substr (symbol->string n) 5))
(filter (fn (n) (starts-with? (symbol->string n) "blog:")) nodes))))))
;; ALL of a post's relation blocks, generated by ITERATING the registry: each
;; kind contributes its outgoing block (label) and, if it has an inverse, its
;; incoming block (inverse-label). Empty blocks are dropped. So adding a kind to
;; the registry makes it render automatically — no handler edit. One kv-keys read
;; up front; the relation lookups are in-memory. Returns a wrapper div, or "".
(define host/blog--relation-blocks
(fn (slug)
(let ((existing (host/blog-slugs))
(node (host/blog--node slug)))
(let ((blocks
(reduce
(fn (acc spec)
(let ((k (string->symbol (get spec :kind))))
(let ((out-b (host/blog--edges-block
(host/blog--recs existing (relations/children node k))
(get spec :label)))
(in-b (if (get spec :inverse-label)
(host/blog--edges-block
(host/blog--recs existing (relations/parents node k))
(get spec :inverse-label))
"")))
(concat acc (filter (fn (b) (not (= b ""))) (list out-b in-b))))))
(list)
host/blog-rel-kinds)))
(if (> (len blocks) 0) (cons (quote div) blocks) "")))))
;; the relation section for the post page: the blocks, or — when empty and the
;; viewer is logged in — a subtle "add some" hint; nothing for anonymous viewers.
(define host/blog--relations-or-hint
(fn (slug logged-in)
(let ((rel (map (fn (s) {:slug s :title (get (host/blog-get s) :title)})
(host/blog-related slug))))
(let ((blocks (host/blog--relation-blocks slug)))
(cond
((> (len rel) 0)
(let ((items
(map (fn (p)
(quasiquote
(li (a :href (unquote (str "/" (get p :slug) "/"))
(unquote (get p :title))))))
rel)))
(quasiquote
(div :style "margin-top:2em"
(h3 "Related posts")
(unquote (list (quote ul) items))))))
((not (= blocks "")) blocks)
(logged-in
(quasiquote
(p :style "margin-top:2em;font-size:0.9em;opacity:0.7"
"No related posts yet — "
"No relations yet — "
(a :href (unquote (str "/" slug "/edit")) "add some") ".")))
(else "")))))
;; Generic "outgoing edges of a kind" block for the post page (e.g. "Tags"): a
;; labelled list of links, or "" when empty. Records fetched up front (no durable
;; read while the page tree is built).
(define host/blog--kind-block
(fn (slug kind)
(let ((rel (map (fn (s) {:slug s :title (get (host/blog-get s) :title)})
(host/blog-out slug kind))))
(if (> (len rel) 0)
(let ((items (map (fn (p)
(quasiquote
(li (a :href (unquote (str "/" (get p :slug) "/"))
(unquote (get p :title))))))
rel)))
(quasiquote
(div :style "margin-top:2em"
(h3 (unquote (get (host/blog--kind-spec kind) :label)))
(unquote (list (quote ul) items)))))
""))))
;; "Tagged with this" — the posts tagged with this (tag) post, for a tag's page.
(define host/blog--tagged-with-block
(fn (slug)
(let ((rel (map (fn (s) {:slug s :title (get (host/blog-get s) :title)})
(host/blog-tagged-with slug))))
(if (> (len rel) 0)
(let ((items (map (fn (p)
(quasiquote
(li (a :href (unquote (str "/" (get p :slug) "/"))
(unquote (get p :title))))))
rel)))
(quasiquote
(div :style "margin-top:2em"
(h3 "Tagged with this")
(unquote (list (quote ul) items)))))
""))))
;; Kind-aware relation editor for the edit page: current links (each with a
;; kind-scoped remove), plus a filterable picker (a .relate-picker box the shared
;; /relate-picker.js wires by data-kind). The picker's candidates come from the
@@ -461,6 +462,14 @@
(input :type "hidden" :name "kind" :value "is-a")
(button :type "submit" "Make this a tag"))))))
;; One editor per registry kind, wrapped in a div — the edit page's relation
;; section, generated by ITERATING the registry (add a kind -> it gets an editor).
(define host/blog--relation-editors
(fn (slug)
(cons (quote div)
(map (fn (spec) (host/blog--relation-editor slug (get spec :kind)))
host/blog-rel-kinds))))
;; ── read handlers ───────────────────────────────────────────────────
;; Post body is rendered per-block (a guarded HTML string) then injected raw.
(define host/blog-post
@@ -474,20 +483,16 @@
;; tree is built (a perform there raises VmSuspended under http-listen).
(let ((principal (host/current-principal req)))
(let ((body-html (host/blog-render r))
(related-block (host/blog--related-block slug (not (nil? principal))))
(tags-block (host/blog--kind-block slug "tagged"))
;; a tag post lists what's tagged with it (its members)
(members-block (if (host/blog-is-tag? slug)
(host/blog--tagged-with-block slug) ""))
;; all relation blocks (Related, Tags, Types, Tagged-with-this …)
;; come from iterating the registry — one section, registry-driven.
(relations (host/blog--relations-or-hint slug (not (nil? principal))))
(auth-foot (host/auth-footer req)))
(dream-html
(host/blog--page (get r :title)
(quasiquote
(div
(article (raw! (unquote body-html)))
(unquote tags-block)
(unquote members-block)
(unquote related-block)
(unquote relations)
(p :style "margin-top:2em;font-size:0.9em;opacity:0.8"
(a :href (unquote (str "/" slug "/source")) "view source")
" · "
@@ -529,6 +534,30 @@
(define host/blog-index (fn (req) (host/ok (host/blog-list))))
;; GET /tags — index of every tag (a post that is-a tag). Tags are posts, so each
;; links to its own page (which documents the tag + lists what's tagged with it).
(define host/blog-tags-index
(fn (req)
;; pre-fetch records (slug+title) BEFORE the quasiquote — host/blog-get is a
;; durable read; a perform during tree-build raises VmSuspended.
(let ((recs (map (fn (s) {:slug s :title (get (host/blog-get s) :title)})
(sort (host/blog-instances-of "tag"))))
(auth-foot (host/auth-footer req)))
(let ((items (map (fn (p)
(quasiquote
(li (a :href (unquote (str "/" (get p :slug) "/"))
(unquote (get p :title))))))
recs)))
(dream-html
(host/blog--page "Tags"
(quasiquote
(div (h1 "Tags")
(unquote (if (> (len recs) 0)
(list (quote ul) items)
(quote (p "No tags yet."))))
(p :style "margin-top:2em;font-size:0.9em;opacity:0.8"
(a :href "/" "all posts") " · " (unquote auth-foot))))))))))
;; GET /<slug>/source — the raw sx_content as text/plain. Posts ARE SX source, so
;; this just hands back the stored markup (public; a published post's source is
;; not secret). 404 if the post is absent.
@@ -711,8 +740,7 @@
(let ((status (get r :status)))
;; the relation editors + tag toggle do durable reads — compute them
;; here, not in the quasiquote, so IO stays in the handler body.
(let ((related-editor (host/blog--relation-editor slug "related"))
(tags-editor (host/blog--relation-editor slug "tagged"))
(let ((relation-editors (host/blog--relation-editors slug))
(tag-toggle (host/blog--is-tag-toggle slug))
(mk-opt
(fn (val label)
@@ -737,8 +765,7 @@
(button :type "submit" "Save")))
(div :style "margin-top:2em;border-top:1px solid #ccc;padding-top:1em"
(unquote tag-toggle))
(unquote related-editor)
(unquote tags-editor)
(unquote relation-editors)
;; one shared picker script wires every .relate-picker box
(raw! "<script src=\"/relate-picker.js\"></script>")
(p :style "margin-top:1.5em"
@@ -779,6 +806,7 @@
(dream-get "/" host/blog-home)
(dream-get "/posts" host/blog-index)
(dream-get "/new" host/blog-new-form)
(dream-get "/tags" host/blog-tags-index)
(dream-get "/relate-picker.js" host/blog-picker-js)
(dream-get "/:slug/source" host/blog-source)
(dream-get "/:slug/relate-options" host/blog-relate-options)