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? ;; is this post (transitively) of the given type-slug?
(define host/blog-is-a? (fn (slug type) (contains? (host/blog-types-of slug) type))) (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 ───────────────────────────────────────── ;; ── gradual validation seam ─────────────────────────────────────────
;; A type-post optionally carries a schema: a predicate over content. The map is ;; 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 ;; 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), ;; related, narrowed by `q` (case-insensitive substring of title or slug),
;; title-sorted. One page is `host/blog--picker-limit` rows from `offset`. ;; title-sorted. One page is `host/blog--picker-limit` rows from `offset`.
(define host/blog--picker-limit 20) (define host/blog--picker-limit 20)
(define host/blog--relate-candidates ;; The candidate POOL for a kind comes from its registry :candidates: "all" posts,
(fn (slug q) ;; or the members of a type ("tags" = instances of tag, "types" = instances of
(let ((already (host/blog-related slug)) ;; type). Enumerating a type's members is O(#subtypes), not O(#posts).
(ql (lower (or q "")))) (define host/blog--candidate-pool
(let ((cands (fn (candidates)
(filter (cond
(fn (p) ((= candidates "tags") (host/blog-instances-of "tag"))
(and (not (= (get p :slug) slug)) ((= candidates "types") (host/blog-instances-of "type"))
(not (contains? already (get p :slug))) (else (host/blog-slugs)))))
(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--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 (define host/blog--picker-item
(fn (slug p) (fn (slug p kind)
(quasiquote (quasiquote
(li :style "border-bottom:1px solid #eee" (li :style "border-bottom:1px solid #eee"
(form :method "post" :style "margin:0" (form :method "post" :style "margin:0"
:action (unquote (str "/" slug "/relate")) :action (unquote (str "/" slug "/relate"))
(input :type "hidden" :name "other" :value (unquote (get p :slug))) (input :type "hidden" :name "other" :value (unquote (get p :slug)))
(input :type "hidden" :name "kind" :value (unquote kind))
(button :type "submit" (button :type "submit"
:style "width:100%;text-align:left;background:none;border:none;padding:0.5em;cursor:pointer" :style "width:100%;text-align:left;background:none;border:none;padding:0.5em;cursor:pointer"
(unquote (get p :title)))))))) (unquote (get p :title))))))))
;; GET /<slug>/relate-options?q=&offset= — one page of candidate rows as an HTML ;; GET /<slug>/relate-options?kind=&q=&offset= — one page of candidate rows for a
;; fragment (the <li>s the picker script appends). Public read (same data as ;; kind as an HTML fragment (the <li>s the picker script appends). Public read; the
;; /posts); the relate action itself stays guarded. ;; relate action stays guarded.
(define host/blog-relate-options (define host/blog-relate-options
(fn (req) (fn (req)
(let ((slug (dream-param req "slug")) (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), ;; 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 ;; so a filter like "Item 13" arrives as "Item%2013" — decode it.
;; dream's own dr/url-decode before matching.
(q (dr/url-decode (or (dream-query-param req "q") ""))) (q (dr/url-decode (or (dream-query-param req "q") "")))
(offset (host/query-int req "offset" 0))) (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))) host/blog--picker-limit)))
(dream-html (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: ;; GET /relate-picker.js — progressive-enhancement glue. MULTI-INSTANCE: wires
;; debounced live filter + scroll-to-load-more against /<slug>/relate-options. The ;; every .relate-picker box on the page (a Related picker + a Tags picker can
;; host serves static HTML (no SX hydration), so the interactive layer is a small ;; coexist), reading data-slug + data-kind from each. Debounced live filter +
;; vanilla script served from this route (read once, cached). ;; 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 (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 (define host/blog-picker-js
(fn (req) (fn (req)
(dream-response 200 {:content-type "application/javascript; charset=utf-8"} (dream-response 200 {:content-type "application/javascript; charset=utf-8"}
@@ -343,16 +375,57 @@
(a :href (unquote (str "/" slug "/edit")) "add some") "."))) (a :href (unquote (str "/" slug "/edit")) "add some") ".")))
(else ""))))) (else "")))))
;; Related-posts editor for the edit page: current links each with a remove ;; Generic "outgoing edges of a kind" block for the post page (e.g. "Tags"): a
;; button, plus an "add related" box (relate by slug; the submit validates it). ;; labelled list of links, or "" when empty. Records fetched up front (no durable
(define host/blog--related-editor ;; 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) (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 (quasiquote
(div :style "margin-top:2em;border-top:1px solid #ccc;padding-top:1em" (div :style "margin-top:2em;border-top:1px solid #ccc;padding-top:1em"
(h3 "Related posts") (h3 (unquote (get spec :label)))
(unquote (unquote
(if (> (len rel) 0) (if (> (len current) 0)
(list (quote ul) (list (quote ul)
(map (fn (s) (map (fn (s)
(quasiquote (quasiquote
@@ -360,20 +433,33 @@
(form :method "post" :style "display:inline" (form :method "post" :style "display:inline"
:action (unquote (str "/" slug "/unrelate")) :action (unquote (str "/" slug "/unrelate"))
(input :type "hidden" :name "other" :value (unquote s)) (input :type "hidden" :name "other" :value (unquote s))
(input :type "hidden" :name "kind" :value (unquote kind))
(button :type "submit" "remove"))))) (button :type "submit" "remove")))))
rel)) current))
(quote (p :style "opacity:0.7" "None yet.")))) (quote (p :style "opacity:0.7" "None yet."))))
;; add: a filterable, infinite-scrolling picker. The filter input + the (div :class "relate-picker" :data-slug (unquote slug) :data-kind (unquote kind)
;; results list are populated by /relate-picker.js (debounced filter, (input :type "text" :class "rp-filter" :placeholder "filter…" :autocomplete "off"
;; scroll-to-load) hitting /<slug>/relate-options; each row's button :style "width:100%;padding:0.4em;box-sizing:border-box")
;; POSTs /relate. data-slug carries the post to the script. (ul :class "rp-results"
(h4 :style "margin-bottom:0.3em" "Add related") :style "list-style:none;padding:0;margin:0.5em 0;max-height:240px;overflow:auto;border:1px solid #ddd")))))))
(input :type "text" :id "relate-filter" :data-slug (unquote slug)
:placeholder "filter posts…" :autocomplete "off" ;; "Is this post a tag?" toggle — marking a post a tag is just an is-a edge to the
:style "width:100%;padding:0.4em;box-sizing:border-box") ;; "tag" type-post, so it reuses the relate/unrelate routes (no new endpoint).
(ul :id "relate-results" (define host/blog--is-tag-toggle
:style "list-style:none;padding:0;margin:0.5em 0;max-height:240px;overflow:auto;border:1px solid #ddd") (fn (slug)
(raw! "<script src=\"/relate-picker.js\"></script>")))))) (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 ─────────────────────────────────────────────────── ;; ── read handlers ───────────────────────────────────────────────────
;; Post body is rendered per-block (a guarded HTML string) then injected raw. ;; Post body is rendered per-block (a guarded HTML string) then injected raw.
@@ -389,12 +475,18 @@
(let ((principal (host/current-principal req))) (let ((principal (host/current-principal req)))
(let ((body-html (host/blog-render r)) (let ((body-html (host/blog-render r))
(related-block (host/blog--related-block slug (not (nil? principal)))) (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))) (auth-foot (host/auth-footer req)))
(dream-html (dream-html
(host/blog--page (get r :title) (host/blog--page (get r :title)
(quasiquote (quasiquote
(div (div
(article (raw! (unquote body-html))) (article (raw! (unquote body-html)))
(unquote tags-block)
(unquote members-block)
(unquote related-block) (unquote related-block)
(p :style "margin-top:2em;font-size:0.9em;opacity:0.8" (p :style "margin-top:2em;font-size:0.9em;opacity:0.8"
(a :href (unquote (str "/" slug "/source")) "view source") (a :href (unquote (str "/" slug "/source")) "view source")
@@ -617,9 +709,11 @@
(host/blog--page "Not found" (host/blog--page "Not found"
(quasiquote (div (h1 "404") (p (unquote (str "No post: " slug))))))) (quasiquote (div (h1 "404") (p (unquote (str "No post: " slug)))))))
(let ((status (get r :status))) (let ((status (get r :status)))
;; related-editor does durable reads — compute it here, not in the ;; the relation editors + tag toggle do durable reads — compute them
;; quasiquote, so IO stays in the handler body. ;; here, not in the quasiquote, so IO stays in the handler body.
(let ((related-editor (host/blog--related-editor slug)) (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 (mk-opt
(fn (val label) (fn (val label)
(if (= val status) (if (= val status)
@@ -641,7 +735,12 @@
(unquote (mk-opt "published" "Published"))) (unquote (mk-opt "published" "Published")))
" " " "
(button :type "submit" "Save"))) (button :type "submit" "Save")))
(div :style "margin-top:2em;border-top:1px solid #ccc;padding-top:1em"
(unquote tag-toggle))
(unquote related-editor) (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" (p :style "margin-top:1.5em"
(a :href (unquote (str "/" slug "/")) "view post") (a :href (unquote (str "/" slug "/")) "view post")
" · " " · "

28
lib/host/playwright/relate-picker.spec.js
View File

@@ -9,6 +9,10 @@ const USER = process.env.SX_ADMIN_USER || 'admin';
const PASS = process.env.SX_ADMIN_PASSWORD || 'letmein'; const PASS = process.env.SX_ADMIN_PASSWORD || 'letmein';
const HOST = 'picker-host'; // the post whose edit page we drive const HOST = 'picker-host'; // the post whose edit page we drive
const LIMIT = 20; // host/blog--picker-limit 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 // 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). // 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.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 loginTo(page, `/${HOST}/edit`);
await expect(page).toHaveURL(new RegExp(`/${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 }) => { test('picker loads a page of candidates then loads more on scroll', async ({ page }) => {
await loginTo(page, `/${HOST}/edit`); 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 // initial JS load fills exactly one page
await expect.poll(() => rows.count(), { timeout: 8000 }).toBe(LIMIT); await expect.poll(() => rows.count(), { timeout: 8000 }).toBe(LIMIT);
// scroll the results box to the bottom -> infinite scroll fetches the rest // 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); await expect.poll(() => rows.count(), { timeout: 8000 }).toBeGreaterThan(LIMIT);
}); });
test('typing in the filter narrows the candidates', async ({ page }) => { test('typing in the filter narrows the candidates', async ({ page }) => {
await loginTo(page, `/${HOST}/edit`); await loginTo(page, `/${HOST}/edit`);
await expect.poll(() => page.locator('#relate-results li').count(), { timeout: 8000 }).toBeGreaterThan(0); await expect.poll(() => page.locator(`${RELR} li`).count(), { timeout: 8000 }).toBeGreaterThan(0);
await page.fill('#relate-filter', 'Item 13'); await page.fill(RELF, 'Item 13');
await expect.poll(() => page.locator('#relate-results li').count(), { timeout: 8000 }).toBe(1); await expect.poll(() => page.locator(`${RELR} li`).count(), { timeout: 8000 }).toBe(1);
await expect(page.locator('#relate-results')).toContainText('Picker Item 13'); await expect(page.locator(RELR)).toContainText('Picker Item 13');
}); });
test('clicking a candidate relates it (and it shows on the post page)', async ({ page }) => { test('clicking a candidate relates it (and it shows on the post page)', async ({ page }) => {
await loginTo(page, `/${HOST}/edit`); await loginTo(page, `/${HOST}/edit`);
await page.fill('#relate-filter', 'Item 07'); await page.fill(RELF, 'Item 07');
await expect.poll(() => page.locator('#relate-results li').count(), { timeout: 8000 }).toBe(1); await expect.poll(() => page.locator(`${RELR} li`).count(), { timeout: 8000 }).toBe(1);
await page.locator('#relate-results button').first().click(); await page.locator(`${RELR} button`).first().click();
// form POST -> 303 back to the edit page; the related list now links the slug // 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).toHaveURL(new RegExp(`/${HOST}/edit`));
await expect(page.locator('a[href="/picker-item-07/"]')).toHaveCount(1); await expect(page.locator('a[href="/picker-item-07/"]')).toHaveCount(1);

26
lib/host/tests/blog.sx
View File

@@ -369,6 +369,32 @@
(host-bl-test "type-valid? is vacuously true with no schemas (gradual)" (host-bl-test "type-valid? is vacuously true with no schemas (gradual)"
(host/blog-type-valid? "ppost" "(p \"anything\")") true) (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) -- ;; -- 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))) (define host-bl-oapp (host/make-app (list host/blog-open-create-routes host/blog-routes)))
(host/blog-use-store! (persist/open)) (host/blog-use-store! (persist/open))