From ccbee8c1beb16674125658300a1a78d1c043b3cb Mon Sep 17 00:00:00 2001 From: giles Date: Thu, 25 Jun 2026 22:57:03 +0000 Subject: [PATCH] =?UTF-8?q?host:=20relate=20posts=20=E2=80=94=20"related?= =?UTF-8?q?=20posts"=20on=20blog=20=C3=97=20relations=20(blog=2061/61,=202?= =?UTF-8?q?30)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Compose two already-migrated domains: a post is a relations-graph node "blog:", 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 --- lib/host/blog.sx | 152 ++++++++++++++++++++++++++++++++++++----- lib/host/tests/blog.sx | 38 +++++++++++ 2 files changed, 174 insertions(+), 16 deletions(-) diff --git a/lib/host/blog.sx b/lib/host/blog.sx index 8fbdd1af..7e87fa76 100644 --- a/lib/host/blog.sx +++ b/lib/host/blog.sx @@ -84,6 +84,37 @@ (join "" (map host/blog--render-node (rest tree)))) (else (host/blog--render-node tree)))) (str "

(empty post)

"))))) +;; ── related posts (blog × relations) ──────────────────────────────── +;; A "related" link between two posts is a SYMMETRIC pair of edges in the +;; relations graph (lib/relations): node = "blog:", 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 //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 //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 //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))))) diff --git a/lib/host/tests/blog.sx b/lib/host/tests/blog.sx index 68618b03..e98c9c1f 100644 --- a/lib/host/tests/blog.sx +++ b/lib/host/tests/blog.sx @@ -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))