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