host: logged-in "add related" hint + filterable infinite-scroll relate picker
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 /<slug>/relate-options?q=&offset= — SX endpoint returning one page of candidate rows (HTML <li> 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 <noreply@anthropic.com>
This commit is contained in:
116
lib/host/blog.sx
116
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 /<slug>/relate-options?q=&offset= — one page of candidate rows as an HTML
|
||||
;; fragment (the <li>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 /<slug>/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 /<slug>/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! "<script src=\"/relate-picker.js\"></script>"))))))
|
||||
|
||||
;; ── 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.
|
||||
|
||||
@@ -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))
|
||||
|
||||
Reference in New Issue
Block a user