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

host: relate posts — "related posts" on blog × relations (blog 61/61, 230)

Browse Source 
Compose two already-migrated domains: a post is a relations-graph node
"blog:<slug>", and a "related" link is a symmetric pair of edges
(lib/relations). The post page shows a "Related posts" block; the edit page
gets an editor to add (by slug) and remove relations.

- host/blog-relate!/unrelate!/related: symmetric edges under kind "related";
  related slugs = blog children, existence-filtered against ONE kv-keys read.
- post page: "Related posts" links block; edit page: related editor (remove
  buttons + add-by-slug box).
- POST /:slug/relate, /:slug/unrelate — guarded browser routes (redirect to
  login like the other write routes); relate validates the other post exists.
- delete cleans up a post's related edges (no dangling links).

IO ORDERING (the live 500 that conformance missed): host/blog--related-block/
-editor do durable reads (perform). Performing inside the quasiquote, via
unquote, while the page tree renders raised Sx_vm.VmSuspended under http-listen;
the in-memory conformance store never performs, so it passed. Fix mirrors
host/blog-home: do the reads in the handler's let bindings BEFORE the
quasiquote, and check related-existence against a single host/blog-slugs read
rather than a perform per candidate inside filter.

9 relate tests (guard, symmetry, render, no-op on missing, unrelate both ways,
delete cleanup). Verified live: relate -> Related block both ways; unrelate
clears it; posts without relations and the whole site stay 200.

Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
This commit is contained in:
giles
2026-06-25 22:57:03 +00:00
parent 6419aa38c5
commit ccbee8c1be
2 changed files with 174 additions and 16 deletions
Download Patch File Download Diff File Expand all files Collapse all files

152
lib/host/blog.sx
View File

@@ -84,6 +84,37 @@
(join "" (map host/blog--render-node (rest tree))))
(else (host/blog--render-node tree))))
(str "<p>(empty post)</p>")))))
;; ── related posts (blog × relations) ────────────────────────────────
;; A "related" link between two posts is a SYMMETRIC pair of edges in the
;; relations graph (lib/relations): node = "blog:<slug>", kind = related. Edges go
;; both ways so "related posts" reads the same from either side via children alone
;; — composing two already-migrated domains (blog + relations) on the host.
(define host/blog--rel-kind (string->symbol "related"))
(define host/blog--node (fn (slug) (string->symbol (str "blog:" slug))))
(define host/blog-relate!
(fn (a b)
(begin
(relations/relate (host/blog--node a) (host/blog--node b) host/blog--rel-kind)
(relations/relate (host/blog--node b) (host/blog--node a) host/blog--rel-kind))))
(define host/blog-unrelate!
(fn (a b)
(begin
(relations/unrelate (host/blog--node a) (host/blog--node b) host/blog--rel-kind)
(relations/unrelate (host/blog--node b) (host/blog--node a) host/blog--rel-kind))))
;; related slugs for a post: blog children under "related", stripped to slug, and
;; limited to posts that still exist (a deleted post can leave a dangling edge).
;; Existence is checked against ONE kv-keys read (host/blog-slugs), not a perform
;; per candidate — keeping IO out of the inner filter.
(define host/blog-related
(fn (slug)
(let ((existing (host/blog-slugs)))
(let ((kids (relations/children (host/blog--node slug) host/blog--rel-kind)))
(filter (fn (s) (contains? existing s))
(map (fn (n) (substr (symbol->string n) 5))
(filter (fn (n) (starts-with? (symbol->string n) "blog:")) kids)))))))
;; ── page shell ──────────────────────────────────────────────────────
;; A page is an SX element tree, rendered via render-page (5.1). The handler
;; builds the tree (running any dynamic logic in the full evaluator, e.g. a posts
@@ -98,6 +129,51 @@
(head (meta :charset "utf-8") (title (unquote title)))
(body (unquote body))))))))
;; "Related posts" block for the post page: a list of links, or "" when none.
;; 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
(fn (slug)
(let ((rel (map (fn (s) {:slug s :title (get (host/blog-get s) :title)})
(host/blog-related 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 "Related posts")
(unquote (list (quote ul) items)))))
""))))
;; Related-posts editor for the edit page: current links each with a remove
;; button, plus an "add related" box (relate by slug; the submit validates it).
(define host/blog--related-editor
(fn (slug)
(let ((rel (host/blog-related slug)))
(quasiquote
(div :style "margin-top:2em;border-top:1px solid #ccc;padding-top:1em"
(h3 "Related posts")
(unquote
(if (> (len rel) 0)
(list (quote ul)
(map (fn (s)
(quasiquote
(li (a :href (unquote (str "/" s "/")) (unquote s)) " "
(form :method "post" :style "display:inline"
:action (unquote (str "/" slug "/unrelate"))
(input :type "hidden" :name "other" :value (unquote s))
(button :type "submit" "remove")))))
rel))
(quote (p :style "opacity:0.7" "None yet."))))
(form :method "post" :action (unquote (str "/" slug "/relate"))
(input :name "other" :placeholder "slug to relate")
" "
(button :type "submit" "Add related")))))))
;; ── read handlers ───────────────────────────────────────────────────
;; Post body is rendered per-block (a guarded HTML string) then injected raw.
(define host/blog-post
@@ -105,19 +181,25 @@
(let ((slug (dream-param req "slug")))
(let ((r (host/blog-get slug)))
(if r
(dream-html
(host/blog--page (get r :title)
(quasiquote
(div
(article (raw! (unquote (host/blog-render r))))
(p :style "margin-top:2em;font-size:0.9em;opacity:0.8"
(a :href (unquote (str "/" slug "/source")) "view source")
" · "
(a :href (unquote (str "/" slug "/edit")) "edit")
" · "
(a :href "/" "all posts")
" · "
(unquote (host/auth-footer req)))))))
;; Compute the rendered body + related block in let bindings BEFORE the
;; quasiquote — host/blog--related-block does durable reads, and IO must
;; happen in the handler body, not while the page tree is being built.
(let ((body-html (host/blog-render r))
(related-block (host/blog--related-block slug)))
(dream-html
(host/blog--page (get r :title)
(quasiquote
(div
(article (raw! (unquote body-html)))
(unquote related-block)
(p :style "margin-top:2em;font-size:0.9em;opacity:0.8"
(a :href (unquote (str "/" slug "/source")) "view source")
" · "
(a :href (unquote (str "/" slug "/edit")) "edit")
" · "
(a :href "/" "all posts")
" · "
(unquote (host/auth-footer req))))))))
(dream-html-status 404
(host/blog--page "Not found"
(quasiquote
@@ -266,9 +348,40 @@
(fn (req)
(let ((slug (dream-param req "slug")))
(if (host/blog-exists? slug)
(begin (host/blog-delete! slug) (host/ok {:slug slug :deleted true}))
(begin
;; drop the post's related edges so no dangling links survive it
(for-each (fn (o) (host/blog-unrelate! slug o)) (host/blog-related slug))
(host/blog-delete! slug)
(host/ok {:slug slug :deleted true}))
(host/error 404 "no such post")))))
;; POST /<slug>/relate — relate this post to another (form field `other` = slug).
;; Validated: the other post must exist and differ; otherwise it's a no-op. Always
;; redirects back to the edit page. Guarded like the other browser write routes.
(define host/blog-relate-submit
(fn (req)
(let ((slug (dream-param req "slug"))
(other (dream-form-field req "other")))
(if (nil? (host/blog-get slug))
(dream-html-status 404
(host/blog--page "Not found"
(quasiquote (div (h1 "404") (p (unquote (str "No post: " slug)))))))
(begin
(when (and other (not (= other "")) (not (= other slug)) (host/blog-exists? other))
(host/blog-relate! slug other))
(dream-redirect (str "/" slug "/edit")))))))
;; POST /<slug>/unrelate — remove the relation to `other`. Idempotent; redirects
;; back to the edit page.
(define host/blog-unrelate-submit
(fn (req)
(let ((slug (dream-param req "slug"))
(other (dream-form-field req "other")))
(begin
(when (and other (not (= other "")))
(host/blog-unrelate! slug other))
(dream-redirect (str "/" slug "/edit"))))))
;; GET /<slug>/edit — edit form pre-filled with the post's current title, raw
;; sx_content (in a textarea — render-to-html escapes the text child, so the
;; browser shows the source verbatim), and status (current value pre-selected).
@@ -282,7 +395,10 @@
(host/blog--page "Not found"
(quasiquote (div (h1 "404") (p (unquote (str "No post: " slug)))))))
(let ((status (get r :status)))
(let ((mk-opt
;; related-editor does durable reads — compute it here, not in the
;; quasiquote, so IO stays in the handler body.
(let ((related-editor (host/blog--related-editor slug))
(mk-opt
(fn (val label)
(if (= val status)
(quasiquote (option :value (unquote val) :selected "selected" (unquote label)))
@@ -303,7 +419,9 @@
(unquote (mk-opt "published" "Published")))
" "
(button :type "submit" "Save")))
(p (a :href (unquote (str "/" slug "/")) "view post")
(unquote related-editor)
(p :style "margin-top:1.5em"
(a :href (unquote (str "/" slug "/")) "view post")
" · "
(a :href (unquote (str "/" slug "/source")) "view source")))))))))))))
@@ -368,6 +486,8 @@
(dream-post "/new" (host/blog--protect-html resolve host/blog-form-submit))
(dream-get "/:slug/edit" (host/blog--protect-html resolve host/blog-edit-form))
(dream-post "/:slug/edit" (host/blog--protect-html resolve host/blog-edit-submit))
(dream-post "/:slug/relate" (host/blog--protect-html resolve host/blog-relate-submit))
(dream-post "/:slug/unrelate" (host/blog--protect-html resolve host/blog-unrelate-submit))
(dream-post "/posts" (host/blog--protect resolve host/blog-create))
(dream-put "/posts/:slug" (host/blog--protect resolve host/blog-update-handler))
(dream-delete "/posts/:slug" (host/blog--protect resolve host/blog-delete-handler)))))

38
lib/host/tests/blog.sx
View File

@@ -211,6 +211,44 @@
(host-bl-test "GET /logout -> 303"
(dream-status (host-bl-app (host-bl-req "/logout"))) 303)
;; -- relate posts (blog × relations) --
;; my-first-post and another-one both exist in the write-test store at this point.
(host-bl-test "relate no auth -> redirect to login"
(dream-status (host-bl-wapp (host-bl-send "POST" "/my-first-post/relate" nil
"application/x-www-form-urlencoded" "other=another-one"))) 303)
(host-bl-test "relate authed -> 303 back to edit"
(dream-resp-header (host-bl-wapp (host-bl-send "POST" "/my-first-post/relate" "Bearer good"
"application/x-www-form-urlencoded" "other=another-one")) "location")
"/my-first-post/edit")
(host-bl-test "related is symmetric (a -> b)"
(contains? (host/blog-related "my-first-post") "another-one") true)
(host-bl-test "related is symmetric (b -> a)"
(contains? (host/blog-related "another-one") "my-first-post") true)
(host-bl-test "post page shows a Related posts block"
(contains? (dream-resp-body (host-bl-wapp (host-bl-req "/my-first-post/"))) "Related posts") true)
(host-bl-test "post page links the related post"
(contains? (dream-resp-body (host-bl-wapp (host-bl-req "/my-first-post/"))) "/another-one/") true)
(host-bl-test "relate nonexistent other -> no-op"
(begin
(host-bl-wapp (host-bl-send "POST" "/my-first-post/relate" "Bearer good"
"application/x-www-form-urlencoded" "other=ghost-post"))
(contains? (host/blog-related "my-first-post") "ghost-post"))
false)
(host-bl-test "unrelate -> removes the link both ways"
(begin
(host-bl-wapp (host-bl-send "POST" "/my-first-post/unrelate" "Bearer good"
"application/x-www-form-urlencoded" "other=another-one"))
(list (contains? (host/blog-related "my-first-post") "another-one")
(contains? (host/blog-related "another-one") "my-first-post")))
(list false false))
(host-bl-test "delete cleans up related edges"
(begin
(host-bl-wapp (host-bl-send "POST" "/my-first-post/relate" "Bearer good"
"application/x-www-form-urlencoded" "other=another-one"))
(host-bl-wapp (host-bl-send "DELETE" "/posts/another-one" "Bearer good" "" ""))
(contains? (host/blog-related "my-first-post") "another-one"))
false)
;; -- experimental unguarded create-only route (POST /new, no auth) --
(define host-bl-oapp (host/make-app (list host/blog-open-create-routes host/blog-routes)))
(host/blog-use-store! (persist/open))