coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

host: typed relations — Phase 3, tags as posts

Browse Source 
A tag is just a post that is-a tag; tagging is a "tagged" edge to it. End to end:
mark a post a tag, tag posts with it, see a post's tags and a tag's members.

- helpers: host/blog-is-tag? (= is-a? slug "tag"), host/blog-tags (out tagged),
  host/blog-tagged-with (in tagged), host/blog-instances-of (a type's members,
  O(#subtypes) not O(#posts) — the efficient candidate source).
- picker generalised to be KIND-AWARE and MULTI-INSTANCE: relate-options takes
  &kind=, candidates come from the kind's registry :candidates (all/tags/types);
  /relate-picker.js wires every .relate-picker box by data-kind (a Related picker
  and a Tags picker now coexist on the edit page).
- render: post page gains a "Tags" block; a tag post additionally lists "Tagged
  with this" (its members). edit page: a Related editor + a Tags editor + an
  "is this post a tag" toggle (reuses /relate kind=is-a — no new route).
- GOTCHA (again): host/blog--relation-editor read host/blog-out INSIDE its
  quasiquote -> VmSuspended/500 under http-listen + durable edges; moved the read
  to a let before the quasiquote (conformance can't see it — in-memory store;
  the ephemeral Playwright run caught it).

6 conformance tests (is-tag?, instances-of, tag+tagged-with, tagged picker offers
only tags, related picker still all, is-a-tag toggle) -> 261/261. Playwright
multi-picker 4/4. Verified live: ocaml made a tag, welcome tagged ocaml, Tags
block + Tagged-with-this both render.

Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
This commit is contained in:
giles
2026-06-28 17:09:53 +00:00
parent cb2fc788d7
commit 62b7fc1ff0
3 changed files with 193 additions and 62 deletions
Download Patch File Download Diff File Expand all files Collapse all files

201
lib/host/blog.sx
View File

@@ -211,6 +211,24 @@
;; is this post (transitively) of the given type-slug?
(define host/blog-is-a? (fn (slug type) (contains? (host/blog-types-of slug) type)))
;; all posts that are (transitively) instances of `type`: instances of the type
;; itself plus instances of any of its subtypes. Computed in O(#subtypes) relation
;; queries, NOT one type-resolution per post — the efficient way to enumerate a
;; type's members (e.g. "all tags") for the picker.
(define host/blog-instances-of
(fn (type)
(let ((subtypes
(concat (list type)
(host/blog--edge-slugs
(relations/ancestors (host/blog--node type) (string->symbol "subtype-of"))))))
(host/blog--uniq
(reduce (fn (acc t) (concat acc (host/blog-in t "is-a"))) (list) subtypes)))))
;; ── tags (a tag is a post that is-a tag) ────────────────────────────
(define host/blog-is-tag? (fn (slug) (host/blog-is-a? slug "tag")))
(define host/blog-tags (fn (slug) (host/blog-out slug "tagged"))) ;; a post's tags
(define host/blog-tagged-with (fn (tag) (host/blog-in tag "tagged"))) ;; posts with a tag
;; ── gradual validation seam ─────────────────────────────────────────
;; A type-post optionally carries a schema: a predicate over content. The map is
;; empty for now — validation is gradual, types accrue schemas later — but the
@@ -245,57 +263,71 @@
;; 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)))))))
;; The candidate POOL for a kind comes from its registry :candidates: "all" posts,
;; or the members of a type ("tags" = instances of tag, "types" = instances of
;; type). Enumerating a type's members is O(#subtypes), not O(#posts).
(define host/blog--candidate-pool
(fn (candidates)
(cond
((= candidates "tags") (host/blog-instances-of "tag"))
((= candidates "types") (host/blog-instances-of "type"))
(else (host/blog-slugs)))))
;; One candidate row: a tiny form whose button adds the relation (POST /relate).
(define host/blog--relate-candidates
(fn (slug q kind)
(let ((spec (host/blog--kind-spec kind)))
(let ((pool (host/blog--candidate-pool (get spec :candidates)))
(already (host/blog-out slug kind))
(ql (lower (or q ""))))
;; pool is slugs; resolve titles, drop self + already-linked, filter by q
(let ((cands
(filter
(fn (p)
(or (= ql "")
(contains? (lower (get p :title)) ql)
(contains? (get p :slug) ql)))
(map (fn (s) {:slug s :title (get (host/blog-get s) :title)})
(filter (fn (s) (and (not (= s slug)) (not (contains? already s)))) pool)))))
;; 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 under `kind`.
(define host/blog--picker-item
(fn (slug p)
(fn (slug p kind)
(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)))
(input :type "hidden" :name "kind" :value (unquote kind))
(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.
;; GET /<slug>/relate-options?kind=&q=&offset= — one page of candidate rows for a
;; kind as an HTML fragment (the <li>s the picker script appends). Public read; the
;; relate action stays guarded.
(define host/blog-relate-options
(fn (req)
(let ((slug (dream-param req "slug"))
(kind (or (dream-query-param req "kind") "related"))
;; dream's query parser does not %-decode values (its form parser does),
;; so a filter like "Item 13" arrives as "Item%2013" — decode it with
;; dream's own dr/url-decode before matching.
;; so a filter like "Item 13" arrives as "Item%2013" — decode it.
(q (dr/url-decode (or (dream-query-param req "q") "")))
(offset (host/query-int req "offset" 0)))
(let ((page (take (drop (host/blog--relate-candidates slug q) offset)
(let ((page (take (drop (host/blog--relate-candidates slug q kind) offset)
host/blog--picker-limit)))
(dream-html
(join "" (map (fn (p) (render-page (host/blog--picker-item slug p))) page)))))))
(join "" (map (fn (p) (render-page (host/blog--picker-item slug p kind))) 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).
;; GET /relate-picker.js — progressive-enhancement glue. MULTI-INSTANCE: wires
;; every .relate-picker box on the page (a Related picker + a Tags picker can
;; coexist), reading data-slug + data-kind from each. Debounced live filter +
;; scroll-to-load-more against /<slug>/relate-options. The host serves static HTML
;; (no SX hydration), so the interactive layer is this small cached script.
(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,pending=false,t;function load(reset){if(busy){if(reset)pending=true;return;}if(!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;if(pending){pending=false;load(true);}}).catch(function(){busy=false;if(pending){pending=false;load(true);}});}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);})();")
"(function(){function wire(box){var f=box.querySelector('.rp-filter');if(!f)return;var r=box.querySelector('.rp-results');var slug=box.getAttribute('data-slug'),kind=box.getAttribute('data-kind')||'related',off=0,q='',busy=false,done=false,pending=false,t;function load(reset){if(busy){if(reset)pending=true;return;}if(!reset&&done)return;busy=true;if(reset){off=0;done=false;}fetch('/'+slug+'/relate-options?kind='+encodeURIComponent(kind)+'&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;if(pending){pending=false;load(true);}}).catch(function(){busy=false;if(pending){pending=false;load(true);}});}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);}var boxes=document.querySelectorAll('.relate-picker');for(var i=0;i<boxes.length;i++){wire(boxes[i]);}})();")
(define host/blog-picker-js
(fn (req)
(dream-response 200 {:content-type "application/javascript; charset=utf-8"}
@@ -343,16 +375,57 @@
(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).
(define host/blog--related-editor
;; 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 (host/blog-related 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
;; kind's registry :candidates ("all" / tags / types). One editor per kind.
(define host/blog--relation-editor
(fn (slug kind)
;; current edges read up front (a perform) — NOT inside the quasiquote, where
;; a perform would raise VmSuspended under http-listen.
(let ((spec (host/blog--kind-spec kind))
(current (host/blog-out slug kind)))
(quasiquote
(div :style "margin-top:2em;border-top:1px solid #ccc;padding-top:1em"
(h3 "Related posts")
(h3 (unquote (get spec :label)))
(unquote
(if (> (len rel) 0)
(if (> (len current) 0)
(list (quote ul)
(map (fn (s)
(quasiquote
@@ -360,20 +433,33 @@
(form :method "post" :style "display:inline"
:action (unquote (str "/" slug "/unrelate"))
(input :type "hidden" :name "other" :value (unquote s))
(input :type "hidden" :name "kind" :value (unquote kind))
(button :type "submit" "remove")))))
rel))
current))
(quote (p :style "opacity:0.7" "None yet."))))
;; 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>"))))))
(div :class "relate-picker" :data-slug (unquote slug) :data-kind (unquote kind)
(input :type "text" :class "rp-filter" :placeholder "filter…" :autocomplete "off"
:style "width:100%;padding:0.4em;box-sizing:border-box")
(ul :class "rp-results"
:style "list-style:none;padding:0;margin:0.5em 0;max-height:240px;overflow:auto;border:1px solid #ddd")))))))
;; "Is this post a tag?" toggle — marking a post a tag is just an is-a edge to the
;; "tag" type-post, so it reuses the relate/unrelate routes (no new endpoint).
(define host/blog--is-tag-toggle
(fn (slug)
(if (host/blog-is-tag? slug)
(quasiquote
(p (span "This post is a tag ✓ ")
(form :method "post" :style "display:inline"
:action (unquote (str "/" slug "/unrelate"))
(input :type "hidden" :name "other" :value "tag")
(input :type "hidden" :name "kind" :value "is-a")
(button :type "submit" "remove tag status"))))
(quasiquote
(form :method "post" :action (unquote (str "/" slug "/relate"))
(input :type "hidden" :name "other" :value "tag")
(input :type "hidden" :name "kind" :value "is-a")
(button :type "submit" "Make this a tag"))))))
;; ── read handlers ───────────────────────────────────────────────────
;; Post body is rendered per-block (a guarded HTML string) then injected raw.
@@ -389,12 +475,18 @@
(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) ""))
(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)
(p :style "margin-top:2em;font-size:0.9em;opacity:0.8"
(a :href (unquote (str "/" slug "/source")) "view source")
@@ -617,9 +709,11 @@
(host/blog--page "Not found"
(quasiquote (div (h1 "404") (p (unquote (str "No post: " slug)))))))
(let ((status (get r :status)))
;; 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))
;; 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"))
(tag-toggle (host/blog--is-tag-toggle slug))
(mk-opt
(fn (val label)
(if (= val status)
@@ -641,7 +735,12 @@
(unquote (mk-opt "published" "Published")))
" "
(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)
;; one shared picker script wires every .relate-picker box
(raw! "<script src=\"/relate-picker.js\"></script>")
(p :style "margin-top:1.5em"
(a :href (unquote (str "/" slug "/")) "view post")
" · "