giles
09465f4483
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 34s
Bug: the edit page's remove button (on a current relation) was a plain boosted
form — POST /unrelate -> 303 redirect -> the engine re-rendered #content, and the
freshly-swapped relate picker came back EMPTY ("the list of posts to relate" was
cleared).
Fix: make the remove button an AJAX in-place delete, exactly like the relate
candidate rows — each current-relation <li> gets an id and its form carries
sx-post + sx-target=#cur-<kind>-<other> + sx-swap=delete. unrelate-submit returns
an empty 200 for that request so the engine deletes just that one row; #content is
never re-rendered, so the picker is untouched. method+action stay for no-JS.
The empty-200 is gated on the SX-Target header (sent only by the sx-post form), so
a plain boosted form / no-JS POST still redirects + re-renders — the is-a-tag
toggle and graceful degradation are unaffected.
Tests (all red before the fix):
- lib/host/playwright/relate-picker.spec.js: the remove-button test now asserts
the picker still has candidates after a removal (the reproduction).
- web/tests/test-relate-picker.sx: an SX engine test — removing a current relation
deletes just that row and leaves the sibling picker's list intact.
- lib/host/tests/blog.sx: the relation-editor renders the AJAX delete attrs;
unrelate returns empty-200 with SX-Target and 303 without.
Verified: host conformance 275/275, web engine suite 8/8, run-picker-check 2/2.
Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
385 lines
18 KiB
Plaintext
385 lines
18 KiB
Plaintext
;; SX-native engine tests for the host's relate picker (lib/host/blog.sx).
|
|
;;
|
|
;; These drive the REAL hypermedia engine (web/engine.sx + web/orchestration.sx)
|
|
;; against the OCaml test harness's in-memory mock DOM — NO browser. They are the
|
|
;; SX-native replacement for lib/host/playwright/relate-picker.spec.js: the same
|
|
;; populate / filter / paging / relate-delete / error-retry behaviours, asserted
|
|
;; with zero Chromium. The engine only ever talks to a *platform* (fetch, DOM ops,
|
|
;; timers) that is injected; the harness supplies a mock platform, so the engine's
|
|
;; fetch -> swap -> DOM-mutation loop is exercised end to end in pure SX.
|
|
;;
|
|
;; Pattern (mirrors test-swap-integration.sx's mock-response approach):
|
|
;; 1. build a mock DOM by setting innerHTML on a container attached to the body
|
|
;; 2. (process-elements root) binds the engine's triggers (load / input / submit)
|
|
;; 3. override `fetch-request` to invoke the success/error callback with a
|
|
;; mocked response (status, content-type, body) — relate-options returns
|
|
;; HTML rows, so the body is HTML and the engine swaps via DOMParser
|
|
;; 4. fire the trigger (dispatch a DOM event) and assert the resulting DOM
|
|
|
|
;; ── mock fetch ──────────────────────────────────────────────────────
|
|
;; The engine's do-fetch calls (fetch-request config success-fn error-fn) with
|
|
;; success-fn signature (resp-ok status get-header text). We override it to feed a
|
|
;; canned response synchronously — the swap path then runs exactly as in a browser.
|
|
(define _mock-fetch-calls 0)
|
|
(define _mock-fetch-ok true)
|
|
(define _mock-fetch-status 200)
|
|
(define _mock-fetch-ct "text/html; charset=utf-8")
|
|
(define _mock-fetch-body "")
|
|
(define _mock-fetch-fail false)
|
|
|
|
(define reset-fetch-mock!
|
|
(fn ()
|
|
(set! _mock-fetch-calls 0)
|
|
(set! _mock-fetch-ok true)
|
|
(set! _mock-fetch-status 200)
|
|
(set! _mock-fetch-ct "text/html; charset=utf-8")
|
|
(set! _mock-fetch-body "")
|
|
(set! _mock-fetch-fail false)))
|
|
|
|
(define fetch-request
|
|
(fn (config success-fn error-fn)
|
|
(set! _mock-fetch-calls (+ _mock-fetch-calls 1))
|
|
(if _mock-fetch-fail
|
|
(error-fn "network error")
|
|
(success-fn _mock-fetch-ok _mock-fetch-status
|
|
(fn (name) (if (= name "content-type") _mock-fetch-ct nil))
|
|
_mock-fetch-body))))
|
|
|
|
;; ── harness platform shims ──────────────────────────────────────────
|
|
;; Reactive hydration + island disposal live in web/boot.sx (the browser boot
|
|
;; module, not loaded by the test runner — it pulls the signals/adapter-dom boot
|
|
;; chain). The picker is plain SX-htmx with no islands or reactive attrs, so each
|
|
;; of these is a no-op here. Defined at top level so orchestration's swap path
|
|
;; (post-swap -> sx-hydrate -> sx-hydrate-elements, dispose-islands-in) resolves
|
|
;; them by late binding through the global env — the same mechanism that lets the
|
|
;; fetch-request override above take effect. With these in place post-swap runs to
|
|
;; completion, including its final (process-elements root) that re-binds triggers
|
|
;; on swapped-in content — which the paging test below depends on.
|
|
(define dispose-islands-in (fn (root) nil))
|
|
(define sx-hydrate-elements (fn (root) nil))
|
|
(define sx-hydrate-islands (fn (root) nil))
|
|
(define run-post-render-hooks (fn () nil))
|
|
|
|
;; observe-intersection is a platform NATIVE (registered by the browser's
|
|
;; sx-platform.js, absent in the OCaml test runner). The picker's "load more"
|
|
;; sentinel binds its `revealed` trigger through it. Model it as a recording stub:
|
|
;; binding the sentinel registers its reveal callback; the test fires it explicitly
|
|
;; to simulate the sentinel scrolling into view. Without this, process-elements
|
|
;; would throw on the sentinel's trigger and the paged-in content would never bind.
|
|
(define _last-reveal nil)
|
|
(define observe-intersection
|
|
(fn (el callback once delay) (set! _last-reveal callback)))
|
|
(define reset-reveal! (fn () (set! _last-reveal nil)))
|
|
(define fire-reveal! (fn () (when _last-reveal (_last-reveal))))
|
|
|
|
;; ── mock DOM helpers ────────────────────────────────────────────────
|
|
;; Build a detached-then-attached subtree from an HTML string and return the
|
|
;; container. Attaching to (dom-body) is required because resolve-target uses
|
|
;; (dom-query "#id") which queries the document.
|
|
(define mk-root
|
|
(fn (html)
|
|
(let ((container (dom-create-element "div" nil)))
|
|
(dom-set-attr container "id" "test-root")
|
|
(dom-append (dom-body) container)
|
|
(dom-set-inner-html container html)
|
|
container)))
|
|
|
|
;; Remove the test root from the body so tests don't leak DOM into each other.
|
|
(define clear-root!
|
|
(fn (container)
|
|
(when container (dom-remove-child (dom-body) container))))
|
|
|
|
;; Fire a (non-bubbling) DOM event of `type` on `el`, as the browser would. The
|
|
;; engine's triggers listen directly on the element carrying the verb (the form),
|
|
;; so the event need not bubble.
|
|
(define fire-event!
|
|
(fn (el type)
|
|
(host-call el "dispatchEvent" (host-new "Event" type))))
|
|
|
|
;; Candidate-row / sentinel counts via the engine's own dom-query-all — asserts
|
|
;; through the platform DOM API, not a private shape. Sentinel rows carry .rp-more;
|
|
;; candidate rows are the rest (mirrors the spec's `li:not(.rp-more)`).
|
|
(define count-li (fn (c) (len (dom-query-all c "li"))))
|
|
(define count-more (fn (c) (len (dom-query-all c "li.rp-more"))))
|
|
(define count-candidates (fn (c) (- (count-li c) (count-more c))))
|
|
|
|
;; ── markup builders (the expanded ~relate-picker, server-rendered) ──
|
|
;; The picker form, exactly as ~relate-picker (lib/host/sx/relate-picker.sx)
|
|
;; expands: sx-get the candidate list, innerHTML-swap into its results <ul> on
|
|
;; "load" and on a debounced "input".
|
|
(define picker-form-html
|
|
(fn (slug kind)
|
|
(str
|
|
"<form class=\"relate-picker\" data-slug=\"" slug "\" data-kind=\"" kind "\""
|
|
" sx-get=\"/" slug "/relate-options\""
|
|
" sx-trigger=\"input delay:200ms, load\""
|
|
" sx-target=\"#rp-" kind "-results\""
|
|
" sx-swap=\"innerHTML\""
|
|
" sx-retry=\"exponential:1000:30000\">"
|
|
"<input type=\"hidden\" name=\"kind\" value=\"" kind "\">"
|
|
"<input type=\"text\" name=\"q\" class=\"rp-filter\" placeholder=\"filter…\">"
|
|
"<ul id=\"rp-" kind "-results\" class=\"rp-results\"></ul>"
|
|
"</form>")))
|
|
|
|
;; One candidate row, as host/blog--picker-item renders it.
|
|
(define row-html
|
|
(fn (slug kind cand title)
|
|
(str
|
|
"<li id=\"cand-" kind "-" cand "\">"
|
|
"<form method=\"post\" action=\"/" slug "/relate\""
|
|
" sx-post=\"/" slug "/relate\""
|
|
" sx-target=\"#cand-" kind "-" cand "\""
|
|
" sx-swap=\"delete\">"
|
|
"<input type=\"hidden\" name=\"other\" value=\"" cand "\">"
|
|
"<input type=\"hidden\" name=\"kind\" value=\"" kind "\">"
|
|
"<button type=\"submit\">" title "</button>"
|
|
"</form>"
|
|
"</li>")))
|
|
|
|
;; One CURRENT-relation row, as host/blog--relation-editor renders it: an AJAX
|
|
;; in-place remove (sx-post + sx-target=#cur-… + sx-swap=delete).
|
|
(define cur-row-html
|
|
(fn (slug kind other label)
|
|
(str
|
|
"<li id=\"cur-" kind "-" other "\">"
|
|
"<a href=\"/" other "/\">" label "</a> "
|
|
"<form method=\"post\" action=\"/" slug "/unrelate\""
|
|
" sx-post=\"/" slug "/unrelate\""
|
|
" sx-target=\"#cur-" kind "-" other "\""
|
|
" sx-swap=\"delete\">"
|
|
"<input type=\"hidden\" name=\"other\" value=\"" other "\">"
|
|
"<input type=\"hidden\" name=\"kind\" value=\"" kind "\">"
|
|
"<button type=\"submit\">remove</button>"
|
|
"</form>"
|
|
"</li>")))
|
|
|
|
;; The "load more" sentinel, as host/blog--picker-more renders it.
|
|
(define sentinel-html
|
|
(fn (slug kind offset)
|
|
(str
|
|
"<li class=\"rp-more\""
|
|
" sx-get=\"/" slug "/relate-options?kind=" kind "&q=&offset=" offset "\""
|
|
" sx-trigger=\"revealed\""
|
|
" sx-swap=\"outerHTML\""
|
|
" sx-retry=\"exponential:1000:30000\">Loading more…</li>")))
|
|
|
|
;; A page of N candidate rows "cand-i" / "Item i" for i in [lo, hi).
|
|
(define rows-html
|
|
(fn (slug kind lo hi)
|
|
(let ((acc ""))
|
|
(let loop ((i lo))
|
|
(if (< i hi)
|
|
(do
|
|
(set! acc (str acc (row-html slug kind (str "item-" i) (str "Picker Item " i))))
|
|
(loop (+ i 1)))
|
|
acc)))))
|
|
|
|
;; ── Phase 0: relate -> delete row ───────────────────────────────────
|
|
(defsuite
|
|
"relate-picker:relate-delete"
|
|
(deftest
|
|
"submitting a candidate's relate form deletes just that row"
|
|
(reset-fetch-mock!)
|
|
;; the AJAX relate returns an empty 200 (text/html); sx-swap=delete then
|
|
;; removes the candidate's own <li> — this is the host's real response.
|
|
(let
|
|
((root (mk-root (str "<ul class=\"rp-results\">"
|
|
(row-html "host" "related" "item-07" "Picker Item 07")
|
|
"</ul>")))
|
|
(results (dom-query ".rp-results"))
|
|
(form (dom-query "form")))
|
|
(process-elements root)
|
|
;; one candidate row before
|
|
(assert-equal 1 (count-candidates results))
|
|
;; submit the relate form -> execute-request -> mock fetch -> delete swap
|
|
(fire-event! form "submit")
|
|
;; the fetch actually ran, and the row is gone
|
|
(assert-true (> _mock-fetch-calls 0))
|
|
(assert-equal 0 (count-candidates results))
|
|
(clear-root! root))))
|
|
|
|
;; ── Phase 1: load / filter / paging / error-retry ───────────────────
|
|
(defsuite
|
|
"relate-picker:load"
|
|
(deftest
|
|
"the load trigger populates the results on first render"
|
|
(reset-fetch-mock!)
|
|
(reset-reveal!)
|
|
;; one full page of candidates (no sentinel) returned for the load fetch
|
|
(set! _mock-fetch-body (rows-html "host" "related" 0 5))
|
|
(let
|
|
((root (mk-root (picker-form-html "host" "related")))
|
|
(results (dom-query "#rp-related-results")))
|
|
;; results empty before binding
|
|
(assert-equal 0 (count-candidates results))
|
|
;; process-elements binds the "load" trigger; the harness fires its
|
|
;; set-timeout synchronously, so the populate fetch runs here
|
|
(process-elements root)
|
|
(assert-true (> _mock-fetch-calls 0))
|
|
(assert-equal 5 (count-candidates results))
|
|
;; Phase 3: the SAME populated tree renders to the console — the results
|
|
;; <ul> becomes a bulleted list of candidate titles. (Console renderer driven
|
|
;; for free by the engine tree; web/console-render.sx.)
|
|
(let ((txt (render-to-console results)))
|
|
(assert-true (contains? txt "• Picker Item 0"))
|
|
(assert-true (contains? txt "• Picker Item 4")))
|
|
(clear-root! root))))
|
|
|
|
(defsuite
|
|
"relate-picker:filter"
|
|
(deftest
|
|
"typing in the filter re-fetches and narrows the candidates"
|
|
(reset-fetch-mock!)
|
|
(reset-reveal!)
|
|
;; load shows 5 candidates...
|
|
(set! _mock-fetch-body (rows-html "host" "related" 0 5))
|
|
(let
|
|
((root (mk-root (picker-form-html "host" "related")))
|
|
(results (dom-query "#rp-related-results"))
|
|
(form (dom-query ".relate-picker"))
|
|
(filter (dom-query ".rp-filter")))
|
|
(process-elements root)
|
|
(assert-equal 5 (count-candidates results))
|
|
;; ...the filter narrows to a single match
|
|
(set! _mock-fetch-body (row-html "host" "related" "item-13" "Picker Item 13"))
|
|
(dom-set-attr filter "value" "Item 13")
|
|
;; debounced "input" trigger (delay fires synchronously in the harness)
|
|
(fire-event! form "input")
|
|
(assert-equal 1 (count-candidates results))
|
|
(clear-root! root))))
|
|
|
|
(defsuite
|
|
"relate-picker:paging"
|
|
(deftest
|
|
"revealing the load-more sentinel pages in the next page and replaces it"
|
|
(reset-fetch-mock!)
|
|
(reset-reveal!)
|
|
;; page 1: a full page of rows FOLLOWED BY the load-more sentinel
|
|
(set! _mock-fetch-body (str (rows-html "host" "related" 0 20)
|
|
(sentinel-html "host" "related" 20)))
|
|
(let
|
|
((root (mk-root (picker-form-html "host" "related")))
|
|
(results (dom-query "#rp-related-results")))
|
|
(process-elements root)
|
|
;; first page populated, sentinel present
|
|
(assert-equal 20 (count-candidates results))
|
|
(assert-equal 1 (count-more results))
|
|
;; page 2: the last page — more rows, NO sentinel
|
|
(set! _mock-fetch-body (rows-html "host" "related" 20 25))
|
|
;; the sentinel scrolling into view fires its `revealed` trigger
|
|
(fire-reveal!)
|
|
;; the new rows are appended and the sentinel (swapped outerHTML) is gone
|
|
(assert-equal 25 (count-candidates results))
|
|
(assert-equal 0 (count-more results))
|
|
(clear-root! root))))
|
|
|
|
(defsuite
|
|
"relate-picker:error-retry"
|
|
(deftest
|
|
"a dropped fetch shows .sx-error, and the next success clears it"
|
|
(reset-fetch-mock!)
|
|
(reset-reveal!)
|
|
;; the candidate fetch drops on load
|
|
(set! _mock-fetch-fail true)
|
|
(let
|
|
((root (mk-root (picker-form-html "host" "related")))
|
|
(results (dom-query "#rp-related-results"))
|
|
(form (dom-query ".relate-picker")))
|
|
;; sx-retry self-heals via exponential backoff on set-timeout — which fires
|
|
;; SYNCHRONOUSLY in the harness, so a retry against a still-failing mock would
|
|
;; recurse forever. Strip it: we assert the VISIBLE error state and that the
|
|
;; next *request* (the user retyping) clears it. The backoff math itself is
|
|
;; covered by test-engine.sx (parse-retry-spec / next-retry-ms).
|
|
(dom-remove-attr form "sx-retry")
|
|
(process-elements root)
|
|
;; visible failure state: .sx-error lands on the picker form
|
|
(assert-true (dom-has-class? form "sx-error"))
|
|
(assert-equal 0 (count-candidates results))
|
|
;; Phase 3: the console rendering of the errored picker shows the failure as
|
|
;; a flagged line (the terminal's "red line") — same tree, different binding.
|
|
(assert-true (contains? (render-to-console form) "✖"))
|
|
;; recovery: the endpoint works again, the next input retries and the error
|
|
;; clears as the results populate
|
|
(set! _mock-fetch-fail false)
|
|
(set! _mock-fetch-body (rows-html "host" "related" 0 3))
|
|
(fire-event! form "input")
|
|
(assert-false (dom-has-class? form "sx-error"))
|
|
(assert-equal 3 (count-candidates results))
|
|
(clear-root! root))))
|
|
|
|
;; ── regression: removing a relation must not clear the relate picker ─
|
|
;; The remove button is an AJAX in-place delete (sx-post + sx-swap=delete on its own
|
|
;; current-relation row). Submitting it deletes ONLY that row — the sibling picker's
|
|
;; candidate list is left intact, because #content is never re-rendered. (Bug: the
|
|
;; old plain-boosted remove redirected and the re-rendered picker came back empty.)
|
|
(defsuite
|
|
"relate-picker:unrelate-keeps-picker"
|
|
(deftest
|
|
"removing a current relation deletes just that row, leaving the picker intact"
|
|
(reset-fetch-mock!)
|
|
;; the AJAX unrelate returns an empty 200 (like the host); sx-swap=delete then
|
|
;; removes the current-relation row in place.
|
|
(let
|
|
((root (mk-root (str
|
|
"<div id=\"cur-box\"><ul>"
|
|
(cur-row-html "host" "related" "beta" "Beta")
|
|
(cur-row-html "host" "related" "gamma" "Gamma")
|
|
"</ul></div>"
|
|
"<div id=\"res-box\"><ul class=\"rp-results\">"
|
|
(row-html "host" "related" "delta" "Picker Delta")
|
|
(row-html "host" "related" "epsilon" "Picker Epsilon")
|
|
"</ul></div>")))
|
|
(cur-box (dom-query "#cur-box"))
|
|
(res-box (dom-query "#res-box")))
|
|
(process-elements root)
|
|
;; two current relations, two picker candidates to start
|
|
(assert-equal 2 (len (dom-query-all cur-box "li")))
|
|
(assert-equal 2 (len (dom-query-all res-box "li")))
|
|
;; remove Beta — submit its in-place remove form
|
|
(fire-event! (dom-query (dom-query "#cur-related-beta") "form") "submit")
|
|
;; just Beta's row is gone; Gamma remains
|
|
(assert-nil (dom-query "#cur-related-beta"))
|
|
(assert-true (not (nil? (dom-query "#cur-related-gamma"))))
|
|
(assert-equal 1 (len (dom-query-all cur-box "li")))
|
|
;; and the picker's candidate list is UNTOUCHED — the bug was it cleared to 0
|
|
(assert-equal 2 (len (dom-query-all res-box "li")))
|
|
(clear-root! root))))
|
|
|
|
;; ── Phase 3: the engine drives a non-browser target (the console) ───
|
|
;; render-to-console (web/console-render.sx) prints the live engine tree as text.
|
|
;; These assert the picker's terminal rendering directly on a built tree — the
|
|
;; console platform's draw step, proven without a terminal.
|
|
(defsuite
|
|
"relate-picker:console"
|
|
(deftest
|
|
"the picker form renders as a filter field over a bulleted candidate list"
|
|
(let
|
|
((root (mk-root (str
|
|
"<form class=\"relate-picker\">"
|
|
"<input type=\"hidden\" name=\"kind\" value=\"related\">"
|
|
"<input type=\"text\" name=\"q\" class=\"rp-filter\" placeholder=\"filter…\">"
|
|
"<ul class=\"rp-results\">"
|
|
(row-html "host" "related" "item-0" "Picker Item 0")
|
|
(row-html "host" "related" "item-1" "Picker Item 1")
|
|
(sentinel-html "host" "related" 20)
|
|
"</ul>"
|
|
"</form>")))
|
|
(form (dom-query ".relate-picker")))
|
|
(let ((txt (render-to-console form)))
|
|
;; the text input becomes a labelled field (placeholder as the label)...
|
|
(assert-true (contains? txt "filter…: ["))
|
|
;; ...the hidden kind input is not drawn...
|
|
(assert-false (contains? txt "related: ["))
|
|
;; ...each candidate is a bullet, the sentinel an ellipsis line
|
|
(assert-true (contains? txt "• Picker Item 0"))
|
|
(assert-true (contains? txt "• Picker Item 1"))
|
|
(assert-true (contains? txt "… Loading more…")))
|
|
(clear-root! root)))
|
|
(deftest
|
|
"an empty results list renders no bullets"
|
|
(let
|
|
((root (mk-root "<ul class=\"rp-results\"></ul>"))
|
|
(results (dom-query root ".rp-results"))) ;; scope to this root
|
|
(assert-equal "" (render-to-console results))
|
|
(clear-root! root))))
|