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

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>

lib/host/blog.sx

@@ -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
+          ;; Compute the rendered body + related block in let bindings BEFORE the
-            (host/blog--page (get r :title)
+          ;; quasiquote — host/blog--related-block does durable reads, and IO must
-              (quasiquote
+          ;; happen in the handler body, not while the page tree is being built.
-                (div
+          (let ((body-html (host/blog-render r))
-                  (article (raw! (unquote (host/blog-render r))))
+                (related-block (host/blog--related-block slug)))
-                  (p :style "margin-top:2em;font-size:0.9em;opacity:0.8"
+            (dream-html
-                    (a :href (unquote (str "/" slug "/source")) "view source")
+              (host/blog--page (get r :title)
-                    " · "
+                (quasiquote
-                    (a :href (unquote (str "/" slug "/edit")) "edit")
+                  (div
-                    " · "
+                    (article (raw! (unquote body-html)))
-                    (a :href "/" "all posts")
+                    (unquote related-block)
-                    " · "
+                    (p :style "margin-top:2em;font-size:0.9em;opacity:0.8"
-                    (unquote (host/auth-footer req)))))))
+                      (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)))))

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))