From 04aa537c7b00ba328e2548c867bec32d62687ce0 Mon Sep 17 00:00:00 2001 From: giles Date: Fri, 26 Jun 2026 10:53:54 +0000 Subject: [PATCH] host: logged-in "add related" hint + filterable infinite-scroll relate picker MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Make relating discoverable and pleasant: a hint on posts with no relations, and a real candidate picker on the edit page. - post page: when a post has no relations AND the viewer is logged in, show a subtle "No related posts yet — add some" hint linking to the edit page; anonymous viewers still see nothing. - GET //relate-options?q=&offset= — SX endpoint returning one page of candidate rows (HTML
  • fragment): every post except itself and ones already related, narrowed by q (case-insensitive title/slug substring), title-sorted, paginated by host/blog--picker-limit. Public read; the relate POST stays guarded. - GET /relate-picker.js — small vanilla glue (debounced live filter + scroll-to-load-more) served from a route. The host serves static HTML (no SX island hydration), so the interactive layer is a cached script, not an island; data-slug on the input carries the post to it. - edit page: the plain "slug to relate" box becomes a filter input + scrollable results list (#relate-filter/#relate-results) populated by the script; each row is a one-click relate form. 8 tests: endpoint lists/excludes-self/filters-by-q/excludes-already-related, JS route content-type + glue, hint shown logged-in / hidden anonymous. 238/238. Verified live: hint (logged-in only), candidate rows, q=filter, JS route (node --check OK), edit picker UI with data-slug. Co-Authored-By: Claude Opus 4.8 --- lib/host/blog.sx | 116 ++++++++++++++++++++++++++++++++++------- lib/host/tests/blog.sx | 28 ++++++++++ 2 files changed, 124 insertions(+), 20 deletions(-) diff --git a/lib/host/blog.sx b/lib/host/blog.sx index 7e87fa76..384c174a 100644 --- a/lib/host/blog.sx +++ b/lib/host/blog.sx @@ -115,6 +115,64 @@ (map (fn (n) (substr (symbol->string n) 5)) (filter (fn (n) (starts-with? (symbol->string n) "blog:")) kids))))))) +;; ── relate picker (filterable, paginated candidate list) ──────────── +;; Candidates to relate `slug` to: every post except itself and ones already +;; related, narrowed by `q` (case-insensitive substring of title or slug), +;; title-sorted. One page is `host/blog--picker-limit` rows from `offset`. +(define host/blog--picker-limit 20) +(define host/blog--relate-candidates + (fn (slug q) + (let ((already (host/blog-related slug)) + (ql (lower (or q "")))) + (let ((cands + (filter + (fn (p) + (and (not (= (get p :slug) slug)) + (not (contains? already (get p :slug))) + (or (= ql "") + (contains? (lower (get p :title)) ql) + (contains? (get p :slug) ql)))) + (host/blog-list)))) + ;; title-sort via [title slug] pairs (sort compares the title first) + (map (fn (pair) {:slug (nth pair 1) :title (nth pair 0)}) + (sort (map (fn (p) (list (get p :title) (get p :slug))) cands))))))) + +;; One candidate row: a tiny form whose button adds the relation (POST /relate). +(define host/blog--picker-item + (fn (slug p) + (quasiquote + (li :style "border-bottom:1px solid #eee" + (form :method "post" :style "margin:0" + :action (unquote (str "/" slug "/relate")) + (input :type "hidden" :name "other" :value (unquote (get p :slug))) + (button :type "submit" + :style "width:100%;text-align:left;background:none;border:none;padding:0.5em;cursor:pointer" + (unquote (get p :title)))))))) + +;; GET //relate-options?q=&offset= — one page of candidate rows as an HTML +;; fragment (the
  • s the picker script appends). Public read (same data as +;; /posts); the relate action itself stays guarded. +(define host/blog-relate-options + (fn (req) + (let ((slug (dream-param req "slug")) + (q (or (dream-query-param req "q") "")) + (offset (host/query-int req "offset" 0))) + (let ((page (take (drop (host/blog--relate-candidates slug q) offset) + host/blog--picker-limit))) + (dream-html + (join "" (map (fn (p) (render-page (host/blog--picker-item slug p))) page))))))) + +;; GET /relate-picker.js — progressive-enhancement glue for the edit-page picker: +;; debounced live filter + scroll-to-load-more against //relate-options. The +;; host serves static HTML (no SX hydration), so the interactive layer is a small +;; vanilla script served from this route (read once, cached). +(define host/blog-picker-js-src + "(function(){var f=document.getElementById('relate-filter');if(!f)return;var r=document.getElementById('relate-results');var slug=f.getAttribute('data-slug'),off=0,q='',busy=false,done=false,t;function load(reset){if(busy||(!reset&&done))return;busy=true;if(reset){off=0;done=false;}fetch('/'+slug+'/relate-options?q='+encodeURIComponent(q)+'&offset='+off).then(function(x){return x.text();}).then(function(h){var d=document.createElement('div');d.innerHTML=h;var n=d.children.length;if(reset)r.innerHTML='';while(d.firstChild)r.appendChild(d.firstChild);off+=n;done=n<20;busy=false;}).catch(function(){busy=false;});}f.addEventListener('input',function(){clearTimeout(t);t=setTimeout(function(){q=f.value.trim();load(true);},200);});r.addEventListener('scroll',function(){if(r.scrollTop+r.clientHeight>=r.scrollHeight-40){load(false);}});load(true);})();") +(define host/blog-picker-js + (fn (req) + (dream-response 200 {:content-type "application/javascript; charset=utf-8"} + host/blog-picker-js-src))) + ;; ── 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 @@ -129,25 +187,33 @@ (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. +;; "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 - (fn (slug) + (fn (slug logged-in) (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))) + (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)))))) + (logged-in (quasiquote - (div :style "margin-top:2em" - (h3 "Related posts") - (unquote (list (quote ul) items))))) - "")))) + (p :style "margin-top:2em;font-size:0.9em;opacity:0.7" + "No related posts yet — " + (a :href (unquote (str "/" slug "/edit")) "add some") "."))) + (else ""))))) ;; 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). @@ -169,10 +235,17 @@ (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"))))))) + ;; add: a filterable, infinite-scrolling picker. The filter input + the + ;; results list are populated by /relate-picker.js (debounced filter, + ;; scroll-to-load) hitting //relate-options; each row's button + ;; POSTs /relate. data-slug carries the post to the script. + (h4 :style "margin-bottom:0.3em" "Add related") + (input :type "text" :id "relate-filter" :data-slug (unquote slug) + :placeholder "filter posts…" :autocomplete "off" + :style "width:100%;padding:0.4em;box-sizing:border-box") + (ul :id "relate-results" + :style "list-style:none;padding:0;margin:0.5em 0;max-height:240px;overflow:auto;border:1px solid #ddd") + (raw! "")))))) ;; ── read handlers ─────────────────────────────────────────────────── ;; Post body is rendered per-block (a guarded HTML string) then injected raw. @@ -185,7 +258,8 @@ ;; 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))) + (related-block (host/blog--related-block slug + (not (nil? (host/current-principal req)))))) (dream-html (host/blog--page (get r :title) (quasiquote @@ -455,7 +529,9 @@ (dream-get "/" host/blog-home) (dream-get "/posts" host/blog-index) (dream-get "/new" host/blog-new-form) + (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) (dream-get "/:slug" host/blog-post))) ;; Guarded writes: form ingest + JSON create/update/delete behind auth+ACL. diff --git a/lib/host/tests/blog.sx b/lib/host/tests/blog.sx index e98c9c1f..35965c3c 100644 --- a/lib/host/tests/blog.sx +++ b/lib/host/tests/blog.sx @@ -249,6 +249,34 @@ (contains? (host/blog-related "my-first-post") "another-one")) false) +;; -- relate picker (filterable candidate endpoint + glue + hint) -- +(host/blog-put! "alpha-post" "Alpha Post" "(p \"a\")" "published") +(host/blog-put! "beta-post" "Beta Post" "(p \"b\")" "published") +(host/blog-put! "gamma-post" "Gamma Post" "(p \"g\")" "published") +(host-bl-test "relate-options lists other posts" + (contains? (dream-resp-body (host-bl-app (host-bl-req "/alpha-post/relate-options"))) "Beta Post") true) +(host-bl-test "relate-options excludes the post itself" + (contains? (dream-resp-body (host-bl-app (host-bl-req "/alpha-post/relate-options"))) ">Alpha Post<") false) +(host-bl-test "relate-options filters by q (title substring)" + (let ((body (dream-resp-body (host-bl-app (host-bl-req "/alpha-post/relate-options?q=beta"))))) + (list (contains? body "Beta Post") (contains? body "Gamma Post"))) + (list true false)) +(host-bl-test "relate-options excludes already-related candidates" + (begin + (host/blog-relate! "alpha-post" "beta-post") + (contains? (dream-resp-body (host-bl-app (host-bl-req "/alpha-post/relate-options"))) "Beta Post")) + false) +(host/blog-unrelate! "alpha-post" "beta-post") +(host-bl-test "relate-picker.js served as javascript" + (dream-resp-header (host-bl-app (host-bl-req "/relate-picker.js")) "content-type") + "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) + ;; -- 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))