diff --git a/lib/host/blog.sx b/lib/host/blog.sx index 5e497819..6a13a841 100644 --- a/lib/host/blog.sx +++ b/lib/host/blog.sx @@ -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 //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! "") (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) diff --git a/lib/host/tests/blog.sx b/lib/host/tests/blog.sx index dfb30c46..03463d7c 100644 --- a/lib/host/tests/blog.sx +++ b/lib/host/tests/blog.sx @@ -276,10 +276,11 @@ "application/javascript; charset=utf-8") (host-bl-test "relate-picker.js carries the fetch glue" (contains? (dream-resp-body (host-bl-app (host-bl-req "/relate-picker.js"))) "relate-options") true) -(host-bl-test "related block: hint when logged-in + no relations" - (contains? (str (host/blog--related-block "gamma-post" true)) "add some") true) -(host-bl-test "related block: empty when anonymous + no relations" - (= (host/blog--related-block "gamma-post" false) "") true) +(host/blog-put! "hint-post" "Hint Post" "(p \"h\")" "published") +(host-bl-test "relations section: hint when logged-in + no relations" + (contains? (str (host/blog--relations-or-hint "hint-post" true)) "add some") true) +(host-bl-test "relations section: empty when anonymous + no relations" + (= (host/blog--relations-or-hint "hint-post" false) "") true) ;; -- Phase 1: relations carry a kind -- (host-bl-test "symmetric kind (related) reads from both sides" @@ -395,6 +396,21 @@ (host/blog-is-tag? "pdoc")) true) +;; -- Phase 4: registry-driven render + /tags index -- +(host-bl-test "relation-blocks renders Related + Tags from the registry" + (begin + (host/blog-relate! "hint-post" "ppost" "related") + (host/blog-relate! "hint-post" "ocaml" "tagged") + (let ((body (str (host/blog--relation-blocks "hint-post")))) + (list (contains? body "Related posts") (contains? body "Tags")))) + (list true true)) +(host-bl-test "relation-blocks shows an inverse block (Tagged with this) for a tag" + (contains? (str (host/blog--relation-blocks "ocaml")) "Tagged with this") true) +(host-bl-test "/tags lists the tag posts" + (contains? (dream-resp-body (host-bl-app (host-bl-req "/tags"))) "OCaml") true) +(host-bl-test "/tags is 200 (not shadowed by /:slug)" + (dream-status (host-bl-app (host-bl-req "/tags"))) 200) + ;; -- 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))