From 62b7fc1ff0a245cdac1b319053ca50da9dcc70f3 Mon Sep 17 00:00:00 2001 From: giles Date: Sun, 28 Jun 2026 17:09:53 +0000 Subject: [PATCH] =?UTF-8?q?host:=20typed=20relations=20=E2=80=94=20Phase?= =?UTF-8?q?=203,=20tags=20as=20posts?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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 --- lib/host/blog.sx | 201 ++++++++++++++++------ lib/host/playwright/relate-picker.spec.js | 28 +-- lib/host/tests/blog.sx | 26 +++ 3 files changed, 193 insertions(+), 62 deletions(-) diff --git a/lib/host/blog.sx b/lib/host/blog.sx index 55134566..5e497819 100644 --- a/lib/host/blog.sx +++ b/lib/host/blog.sx @@ -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 //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. +;; GET //relate-options?kind=&q=&offset= — one page of candidate rows for a +;; kind as an HTML fragment (the
  • 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 //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 //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 (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 //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! "")))))) + (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! "") (p :style "margin-top:1.5em" (a :href (unquote (str "/" slug "/")) "view post") " · " diff --git a/lib/host/playwright/relate-picker.spec.js b/lib/host/playwright/relate-picker.spec.js index 17f454a1..d1decede 100644 --- a/lib/host/playwright/relate-picker.spec.js +++ b/lib/host/playwright/relate-picker.spec.js @@ -9,6 +9,10 @@ const USER = process.env.SX_ADMIN_USER || 'admin'; const PASS = process.env.SX_ADMIN_PASSWORD || 'letmein'; const HOST = 'picker-host'; // the post whose edit page we drive const LIMIT = 20; // host/blog--picker-limit +// the Related picker box (the edit page now has one picker per kind) +const REL = '.relate-picker[data-kind="related"]'; +const RELF = `${REL} .rp-filter`; +const RELR = `${REL} .rp-results`; // Navigate to a guarded path; the host redirects to /login?next=…, so fill the // form and we should land back on the original path (exercises the auth flow). @@ -22,35 +26,37 @@ async function loginTo(page, path) { } test.describe('relate picker', () => { - test('login redirect returns to the edit page', async ({ page }) => { + test('edit page has Related + Tags pickers and an is-a-tag toggle', async ({ page }) => { await loginTo(page, `/${HOST}/edit`); await expect(page).toHaveURL(new RegExp(`/${HOST}/edit`)); - await expect(page.locator('#relate-filter')).toBeVisible(); + await expect(page.locator(RELF)).toBeVisible(); // Related picker + await expect(page.locator('.relate-picker[data-kind="tagged"] .rp-filter')).toBeVisible(); // Tags picker + await expect(page.getByRole('button', { name: 'Make this a tag' })).toBeVisible(); // toggle }); test('picker loads a page of candidates then loads more on scroll', async ({ page }) => { await loginTo(page, `/${HOST}/edit`); - const rows = page.locator('#relate-results li'); + const rows = page.locator(`${RELR} li`); // initial JS load fills exactly one page await expect.poll(() => rows.count(), { timeout: 8000 }).toBe(LIMIT); // scroll the results box to the bottom -> infinite scroll fetches the rest - await page.locator('#relate-results').evaluate((el) => el.scrollTo(0, el.scrollHeight)); + await page.locator(RELR).evaluate((el) => el.scrollTo(0, el.scrollHeight)); await expect.poll(() => rows.count(), { timeout: 8000 }).toBeGreaterThan(LIMIT); }); test('typing in the filter narrows the candidates', async ({ page }) => { await loginTo(page, `/${HOST}/edit`); - await expect.poll(() => page.locator('#relate-results li').count(), { timeout: 8000 }).toBeGreaterThan(0); - await page.fill('#relate-filter', 'Item 13'); - await expect.poll(() => page.locator('#relate-results li').count(), { timeout: 8000 }).toBe(1); - await expect(page.locator('#relate-results')).toContainText('Picker Item 13'); + await expect.poll(() => page.locator(`${RELR} li`).count(), { timeout: 8000 }).toBeGreaterThan(0); + await page.fill(RELF, 'Item 13'); + await expect.poll(() => page.locator(`${RELR} li`).count(), { timeout: 8000 }).toBe(1); + await expect(page.locator(RELR)).toContainText('Picker Item 13'); }); test('clicking a candidate relates it (and it shows on the post page)', async ({ page }) => { await loginTo(page, `/${HOST}/edit`); - await page.fill('#relate-filter', 'Item 07'); - await expect.poll(() => page.locator('#relate-results li').count(), { timeout: 8000 }).toBe(1); - await page.locator('#relate-results button').first().click(); + await page.fill(RELF, 'Item 07'); + await expect.poll(() => page.locator(`${RELR} li`).count(), { timeout: 8000 }).toBe(1); + await page.locator(`${RELR} button`).first().click(); // form POST -> 303 back to the edit page; the related list now links the slug await expect(page).toHaveURL(new RegExp(`/${HOST}/edit`)); await expect(page.locator('a[href="/picker-item-07/"]')).toHaveCount(1); diff --git a/lib/host/tests/blog.sx b/lib/host/tests/blog.sx index 6b8f0f16..dfb30c46 100644 --- a/lib/host/tests/blog.sx +++ b/lib/host/tests/blog.sx @@ -369,6 +369,32 @@ (host-bl-test "type-valid? is vacuously true with no schemas (gradual)" (host/blog-type-valid? "ppost" "(p \"anything\")") true) +;; -- Phase 3: tags as posts -- (ocaml is-a tag, from the seed-types test above) +(host-bl-test "is-tag?: a post that is-a tag is a tag; others are not" + (list (host/blog-is-tag? "ocaml") (host/blog-is-tag? "ppost")) + (list true false)) +(host-bl-test "instances-of tag includes the tag posts" + (contains? (host/blog-instances-of "tag") "ocaml") true) +(host-bl-test "tag a post: it appears in tags + tagged-with (inverse)" + (begin + (host/blog-relate! "ppost" "ocaml" "tagged") ;; ppost tagged ocaml + (list (contains? (host/blog-tags "ppost") "ocaml") + (contains? (host/blog-tagged-with "ocaml") "ppost"))) + (list true true)) +(host-bl-test "tagged picker offers only tags (kind=tagged)" + (let ((body (dream-resp-body (host-bl-app (host-bl-req "/particle/relate-options?kind=tagged"))))) + (list (contains? body ">OCaml<") (contains? body ">P Article<"))) + (list true false)) +(host-bl-test "related picker still offers all posts (kind defaults to related)" + (contains? (dream-resp-body (host-bl-app (host-bl-req "/particle/relate-options"))) ">P Doc<") + true) +(host-bl-test "is-a-tag toggle marks a post a tag via /relate kind=is-a" + (begin + (host-bl-wapp (host-bl-send "POST" "/pdoc/relate" "Bearer good" + "application/x-www-form-urlencoded" "other=tag&kind=is-a")) + (host/blog-is-tag? "pdoc")) + 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))