giles
a5d43246e0
REVIEW at the P0-complete milestone found one live bug and several forward prerequisites. FIX (was live): edit-submit ran maybe-publish! BEFORE set-field-values!, so an edit that set a category and published in one submit fired the publish activity on the STALE category (wrong branch). Reordered — fields land before the transition fires. Regression test added (fields-first → newsletter→digest, not stale→notify). blog 210/210. Recorded carried-forward debt in the plan: activity identity (DEBT #1, blocks P2 — :id=CID false- dedups relation events), capability bind not wired into the live engine (DEBT #2, P1), synchronous- in-request dispatch (DEBT #3, RA needs the async boundary + background pump), the 'urgent' default smell (DEBT #4). Sequencing note: P1's runner-derivation is vacuous until RA adds a 2nd runner, and RA is the load-bearing risk — recommend a narrow RA spike next to de-risk the durable/federated half. Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
1268 lines
74 KiB
Plaintext
1268 lines
74 KiB
Plaintext
;; lib/host/tests/blog.sx — blog on the editor's content model. Posts are
|
||
;; {slug,title,sx_content,status} records in the durable KV; a post page is
|
||
;; render-to-html(parse sx_content). Covers read/render, home index, JSON list,
|
||
;; slugify, the form-urlencoded editor ingest, and JSON CRUD (auth+ACL guarded).
|
||
|
||
(define host-bl-pass 0)
|
||
(define host-bl-fail 0)
|
||
(define host-bl-fails (list))
|
||
(define
|
||
host-bl-test
|
||
(fn (name actual expected)
|
||
(if (= actual expected)
|
||
(set! host-bl-pass (+ host-bl-pass 1))
|
||
(begin
|
||
(set! host-bl-fail (+ host-bl-fail 1))
|
||
(append! host-bl-fails {:name name :actual actual :expected expected})))))
|
||
|
||
(define host-bl-req (fn (target) (dream-request "GET" target {} "")))
|
||
(define host-bl-app (host/make-app (list host/feed-routes host/blog-routes)))
|
||
|
||
;; ── slugify ─────────────────────────────────────────────────────────
|
||
(host-bl-test "slugify" (host/blog-slugify "Hello World") "hello-world")
|
||
(host-bl-test "slugify trims spaces" (host/blog-slugify " A B ") "a-b")
|
||
|
||
;; ── render a stored post ────────────────────────────────────────────
|
||
(host/blog-use-store! (persist/open))
|
||
(host/blog-put! "hello" "Hello World"
|
||
"(article (h1 \"Hello World\") (p \"A \" (strong \"bold\") \" word.\"))" "published")
|
||
|
||
(host-bl-test "post 200" (dream-status (host-bl-app (host-bl-req "/hello/"))) 200)
|
||
(host-bl-test "post content-type html"
|
||
(contains? (dream-resp-header (host-bl-app (host-bl-req "/hello/")) "content-type") "text/html")
|
||
true)
|
||
(host-bl-test "post renders sx_content markup"
|
||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/hello/"))) "<strong>bold</strong>")
|
||
true)
|
||
(host-bl-test "post title in page"
|
||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/hello/"))) "<title>Hello World</title>")
|
||
true)
|
||
|
||
;; ── home + list ─────────────────────────────────────────────────────
|
||
(host-bl-test "home lists post"
|
||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/"))) "href=\"/hello/\"")
|
||
true)
|
||
(host-bl-test "sx list shows post"
|
||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/posts"))) ":slug \"hello\"")
|
||
true)
|
||
(host-bl-test "GET /new shows form"
|
||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/new"))) "<form")
|
||
true)
|
||
|
||
;; ── unknown + precedence ────────────────────────────────────────────
|
||
(host-bl-test "unknown slug 404" (dream-status (host-bl-app (host-bl-req "/nope/"))) 404)
|
||
(feed/reset!)
|
||
(host-bl-test "/feed not captured by :slug"
|
||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/feed"))) ":ok true")
|
||
true)
|
||
|
||
;; ── writes: editor form ingest + JSON CRUD (auth+ACL) ───────────────
|
||
(acl/load! (list (acl-grant "editor" "edit" "blog")))
|
||
(define host-bl-resolve
|
||
(fn (tok) (cond ((= tok "good") "editor") ((= tok "weak") "reader") (true nil))))
|
||
(define host-bl-wapp
|
||
(host/make-app (list (host/blog-write-routes host-bl-resolve) host/blog-routes)))
|
||
(define host-bl-send
|
||
(fn (method target auth ctype body)
|
||
(dream-request method target
|
||
(merge (if auth {:authorization auth} {}) (if ctype {:content-type ctype} {})) body)))
|
||
|
||
(host/blog-use-store! (persist/open))
|
||
|
||
;; -- editor form ingest (form-urlencoded, the editor's submit shape) --
|
||
(host-bl-test "form ingest no auth -> redirect to login"
|
||
(dream-status (host-bl-wapp (host-bl-send "POST" "/new" nil
|
||
"application/x-www-form-urlencoded" "title=X")))
|
||
303)
|
||
(host-bl-test "form ingest no auth Location is /login"
|
||
(contains? (dream-resp-header (host-bl-wapp (host-bl-send "POST" "/new" nil
|
||
"application/x-www-form-urlencoded" "title=X")) "location") "/login")
|
||
true)
|
||
(host-bl-test "form ingest authed -> 303 redirect"
|
||
(dream-status (host-bl-wapp (host-bl-send "POST" "/new" "Bearer good"
|
||
"application/x-www-form-urlencoded"
|
||
"title=My+First+Post&sx_content=(article+(h1+%22My+First+Post%22)+(p+%22Hi%22))&status=published")))
|
||
303)
|
||
(host-bl-test "form ingest set Location to the new slug"
|
||
(dream-resp-header
|
||
(host-bl-wapp (host-bl-send "POST" "/new" "Bearer good"
|
||
"application/x-www-form-urlencoded"
|
||
"title=Another+One&sx_content=(p+%22x%22)&status=published"))
|
||
"location")
|
||
"/another-one/")
|
||
(host-bl-test "ingested post renders"
|
||
(contains? (dream-resp-body (host-bl-wapp (host-bl-req "/my-first-post/"))) "<h1>My First Post</h1>")
|
||
true)
|
||
|
||
;; (JSON CRUD tests removed — the /posts JSON create/update/delete endpoints were
|
||
;; deleted in the SX-native pivot; create + edit go through the form ingest above.)
|
||
|
||
;; -- write-time validation: malformed sx_content rejected, never stored --
|
||
;; "%3Ch1+broken%29" decodes to "<h1 broken)" — a typo'd paren the parser rejects.
|
||
(host-bl-test "form ingest malformed sx_content -> 400"
|
||
(dream-status (host-bl-wapp (host-bl-send "POST" "/new" "Bearer good"
|
||
"application/x-www-form-urlencoded"
|
||
"title=Bad+Form&sx_content=%3Ch1+broken%29&status=published")))
|
||
400)
|
||
(host-bl-test "rejected form post was not stored"
|
||
(dream-status (host-bl-wapp (host-bl-req "/bad-form/")))
|
||
404)
|
||
;; (JSON malformed-content tests removed with the JSON CRUD endpoints; the form
|
||
;; ingest malformed-content checks above still cover write-time validation.)
|
||
|
||
;; -- view source (public) --
|
||
(host-bl-test "view source -> 200"
|
||
(dream-status (host-bl-wapp (host-bl-req "/my-first-post/source"))) 200)
|
||
(host-bl-test "view source is text/plain"
|
||
(dream-resp-header (host-bl-wapp (host-bl-req "/my-first-post/source")) "content-type")
|
||
"text/plain; charset=utf-8")
|
||
(host-bl-test "view source returns raw sx_content"
|
||
(contains? (dream-resp-body (host-bl-wapp (host-bl-req "/my-first-post/source"))) "(article")
|
||
true)
|
||
(host-bl-test "view source missing -> 404"
|
||
(dream-status (host-bl-wapp (host-bl-req "/ghost/source"))) 404)
|
||
(host-bl-test "/:slug not shadowed by /:slug/source"
|
||
(dream-status (host-bl-wapp (host-bl-req "/my-first-post/"))) 200)
|
||
|
||
;; -- edit source (guarded GET form + guarded POST save) --
|
||
(host-bl-test "edit form no auth -> redirect to login"
|
||
(dream-status (host-bl-wapp (host-bl-send "GET" "/my-first-post/edit" nil "" ""))) 303)
|
||
(host-bl-test "edit form no auth Location carries next=/…/edit"
|
||
(contains?
|
||
(dream-resp-header (host-bl-wapp (host-bl-send "GET" "/my-first-post/edit" nil "" "")) "location")
|
||
"/login?next=/my-first-post/edit")
|
||
true)
|
||
(host-bl-test "edit form authed -> 200"
|
||
(dream-status (host-bl-wapp (host-bl-send "GET" "/my-first-post/edit" "Bearer good" "" ""))) 200)
|
||
(host-bl-test "edit form shows current source"
|
||
(contains? (dream-resp-body (host-bl-wapp (host-bl-send "GET" "/my-first-post/edit" "Bearer good" "" "")))
|
||
"(article")
|
||
true)
|
||
(host-bl-test "edit submit no auth -> redirect to login"
|
||
(dream-status (host-bl-wapp (host-bl-send "POST" "/my-first-post/edit" nil
|
||
"application/x-www-form-urlencoded" "sx_content=(p+%22x%22)"))) 303)
|
||
(host-bl-test "edit submit authed -> 303"
|
||
(dream-status (host-bl-wapp (host-bl-send "POST" "/my-first-post/edit" "Bearer good"
|
||
"application/x-www-form-urlencoded"
|
||
"title=My+First+Post&sx_content=(p+%22edited+via+editor%22)&status=published"))) 303)
|
||
(host-bl-test "edit persisted the new content"
|
||
(contains? (dream-resp-body (host-bl-wapp (host-bl-req "/my-first-post/"))) "edited via editor")
|
||
true)
|
||
(host-bl-test "edit preserves the slug"
|
||
(dream-resp-header
|
||
(host-bl-wapp (host-bl-send "POST" "/my-first-post/edit" "Bearer good"
|
||
"application/x-www-form-urlencoded" "title=Renamed&sx_content=(p+%22y%22)&status=draft"))
|
||
"location")
|
||
"/my-first-post/")
|
||
(host-bl-test "edit malformed body -> 400"
|
||
(dream-status (host-bl-wapp (host-bl-send "POST" "/my-first-post/edit" "Bearer good"
|
||
"application/x-www-form-urlencoded" "sx_content=%3Ch1+broken%29"))) 400)
|
||
(host-bl-test "edit missing post -> 404"
|
||
(dream-status (host-bl-wapp (host-bl-send "GET" "/ghost/edit" "Bearer good" "" ""))) 404)
|
||
|
||
;; -- auth footer (discoverable login/logout) --
|
||
(host-bl-test "home footer shows a log in link when anonymous"
|
||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/"))) ">log in</a>") true)
|
||
(host-bl-test "post footer shows a log in link when anonymous"
|
||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/my-first-post/"))) ">log in</a>") true)
|
||
(host-bl-test "GET /logout -> 303"
|
||
(dream-status (host-bl-app (host-bl-req "/logout"))) 303)
|
||
|
||
;; -- relate posts (blog × relations) --
|
||
;; my-first-post and another-one both exist in the write-test store at this point.
|
||
;; Relations are posts now (their symmetry/labels live on relation-posts), so seed
|
||
;; them up front exactly as boot does (serve.sh) before exercising relate, and load
|
||
;; the relation metadata into the in-memory cache the same way.
|
||
(host/blog-seed-types!)
|
||
(host/blog-load-rel-kinds!)
|
||
(host-bl-test "relate no auth -> redirect to login"
|
||
(dream-status (host-bl-wapp (host-bl-send "POST" "/my-first-post/relate" nil
|
||
"application/x-www-form-urlencoded" "other=another-one"))) 303)
|
||
(host-bl-test "relate authed -> 303 back to edit"
|
||
(dream-resp-header (host-bl-wapp (host-bl-send "POST" "/my-first-post/relate" "Bearer good"
|
||
"application/x-www-form-urlencoded" "other=another-one")) "location")
|
||
"/my-first-post/edit")
|
||
(host-bl-test "related is symmetric (a -> b)"
|
||
(contains? (host/blog-related "my-first-post") "another-one") true)
|
||
(host-bl-test "related is symmetric (b -> a)"
|
||
(contains? (host/blog-related "another-one") "my-first-post") true)
|
||
(host-bl-test "post page shows a Related posts block"
|
||
(contains? (dream-resp-body (host-bl-wapp (host-bl-req "/my-first-post/"))) "Related posts") true)
|
||
(host-bl-test "post page links the related post"
|
||
(contains? (dream-resp-body (host-bl-wapp (host-bl-req "/my-first-post/"))) "/another-one/") true)
|
||
(host-bl-test "relate nonexistent other -> no-op"
|
||
(begin
|
||
(host-bl-wapp (host-bl-send "POST" "/my-first-post/relate" "Bearer good"
|
||
"application/x-www-form-urlencoded" "other=ghost-post"))
|
||
(contains? (host/blog-related "my-first-post") "ghost-post"))
|
||
false)
|
||
(host-bl-test "unrelate -> removes the link both ways"
|
||
(begin
|
||
(host-bl-wapp (host-bl-send "POST" "/my-first-post/unrelate" "Bearer good"
|
||
"application/x-www-form-urlencoded" "other=another-one"))
|
||
(list (contains? (host/blog-related "my-first-post") "another-one")
|
||
(contains? (host/blog-related "another-one") "my-first-post")))
|
||
(list false false))
|
||
;; (The "delete cleans up related edges" test was removed with the JSON DELETE
|
||
;; /posts endpoint; cascade edge cleanup returns when a browser delete route is
|
||
;; added — see the FOLLOW-UP note in lib/host/blog.sx.)
|
||
|
||
;; -- 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 filter url-decodes q (spaces)"
|
||
(let ((body (dream-resp-body (host-bl-app (host-bl-req "/alpha-post/relate-options?q=Beta%20Post")))))
|
||
(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" "related")
|
||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/alpha-post/relate-options"))) "Beta Post"))
|
||
false)
|
||
(host/blog-unrelate! "alpha-post" "beta-post" "related")
|
||
;; The picker is a declarative SX-htmx form (no client JS): the form GETs
|
||
;; relate-options serialising kind + the filter q, swapping the results ul on
|
||
;; "load" and on debounced "input". The SX engine re-binds these triggers on
|
||
;; swapped content, so it works on a full load AND a boosted SPA nav.
|
||
(host-bl-test "picker form is declaratively wired to relate-options (load + debounced input)"
|
||
(let ((html (render-page (host/blog--relation-editor "alpha-post" "related" true))))
|
||
(list (contains? html "/alpha-post/relate-options")
|
||
(contains? html "input delay:200ms, load")
|
||
(contains? html "rp-related-results")))
|
||
(list true true true))
|
||
;; the editor server-renders the first page of candidates INTO the picker's results
|
||
;; <ul>, so a re-rendered editor is never briefly empty (no flash). The candidate row
|
||
;; for an existing post appears inside the results ul.
|
||
(host-bl-test "editor server-renders the first page of candidates into the picker"
|
||
(let ((html (render-page (host/blog--relation-editor "alpha-post" "related" true))))
|
||
(list (contains? html "id=\"cand-related-") ;; a candidate row is present
|
||
(contains? html "Beta Post"))) ;; an unrelated post is offered
|
||
(list true true))
|
||
;; Paging is server-driven: a full page carries a "load more" sentinel that, when
|
||
;; revealed, GETs the next page and replaces itself (outerHTML), preserving q.
|
||
(host-bl-test "load-more sentinel: revealed, outerHTML-swap, next offset, preserved q"
|
||
(let ((html (render-page (host/blog--picker-more "alpha-post" "related" "my q" 20))))
|
||
(list (contains? html "rp-more")
|
||
(contains? html "revealed")
|
||
(contains? html "outerHTML")
|
||
(contains? html "offset=20")
|
||
(contains? html "q=my%20q")
|
||
(contains? html "exponential:1000:30000"))) ;; retries a dropped fetch
|
||
(list true true true true true true))
|
||
;; a page that isn't full carries NO load-more sentinel. Past the end of the pool the last
|
||
;; page is empty (0 rows < limit) — deterministic regardless of how many posts the metamodel
|
||
;; has seeded (the `related` pool is every post, which grows as types/cards are added).
|
||
(host-bl-test "relate-options omits the load-more sentinel when the page isn't full"
|
||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/alpha-post/relate-options?offset=100000"))) "rp-more")
|
||
false)
|
||
|
||
;; -- relate / unrelate keep BOTH lists in sync by re-rendering the kind's editor.
|
||
;; Regressions: (1) relating a candidate must ADD it to the current-relations
|
||
;; list (not just delete the candidate row); (2) removing must NOT clear the
|
||
;; relate picker. Both the candidate's relate form and the remove form target
|
||
;; #rel-editor-KIND with sx-swap=outerHTML; the handler returns the re-rendered
|
||
;; editor, so the current list updates and the fresh picker re-loads. --
|
||
(host/blog-relate! "alpha-post" "beta-post" "related")
|
||
;; the editor wraps current list + picker in #rel-editor-KIND; remove re-renders it
|
||
(host-bl-test "relation-editor wires remove to re-render the kind's editor"
|
||
(let ((html (render-page (host/blog--relation-editor "alpha-post" "related" true))))
|
||
(list (contains? html "id=\"rel-editor-related\"") ;; the swap target
|
||
(contains? html "sx-post=\"/alpha-post/unrelate\"") ;; AJAX, not plain post
|
||
(contains? html "sx-target=\"#rel-editor-related\"")
|
||
(contains? html "sx-swap=\"outerHTML\"")))
|
||
(list true true true true))
|
||
;; the candidate's relate form targets the SAME editor (so relating re-renders it)
|
||
(host-bl-test "picker candidate relate form re-renders the kind's editor"
|
||
(let ((html (render-page (host/blog--picker-item "alpha-post" {:slug "gamma-post" :title "Gamma"} "related"))))
|
||
(list (contains? html "sx-post=\"/alpha-post/relate\"")
|
||
(contains? html "sx-target=\"#rel-editor-related\"")
|
||
(contains? html "sx-swap=\"outerHTML\"")))
|
||
(list true true true))
|
||
;; a POST request to a /:slug/… route, with the :slug route param populated (which
|
||
;; the route matcher would set) plus headers + a form body.
|
||
(define host-bl-relreq
|
||
(fn (slug action headers other kind)
|
||
(merge (dream-request "POST" (str "/" slug "/" action) headers
|
||
(str "other=" other "&kind=" kind))
|
||
{:params {:slug slug}})))
|
||
;; the AJAX remove (carries SX-Target) returns the re-rendered editor fragment (200,
|
||
;; with the #rel-editor wrapper + the picker) — not an empty body or a redirect.
|
||
(host-bl-test "unrelate (AJAX, SX-Target) returns the re-rendered editor fragment"
|
||
(let ((resp (host/blog-unrelate-submit
|
||
(host-bl-relreq "alpha-post" "unrelate"
|
||
{:sx-request "true" :sx-target "#rel-editor-related"}
|
||
"beta-post" "related"))))
|
||
(list (dream-status resp)
|
||
(contains? (dream-resp-body resp) "rel-editor-related")
|
||
(contains? (dream-resp-body resp) "relate-picker")))
|
||
(list 200 true true))
|
||
;; relate (AJAX, SX-Target) likewise returns the editor with the new relation listed
|
||
(host/blog-unrelate! "alpha-post" "gamma-post" "related") ;; clean state
|
||
(host-bl-test "relate (AJAX, SX-Target) returns the editor showing the new relation"
|
||
(let ((resp (host/blog-relate-submit
|
||
(host-bl-relreq "alpha-post" "relate"
|
||
{:sx-request "true" :sx-target "#rel-editor-related"}
|
||
"gamma-post" "related"))))
|
||
(list (dream-status resp)
|
||
(contains? (dream-resp-body resp) "/gamma-post/"))) ;; now in the current list
|
||
(list 200 true))
|
||
(host/blog-unrelate! "alpha-post" "gamma-post" "related")
|
||
;; a plain boosted form / no-JS POST (no SX-Target) still redirects + re-renders,
|
||
;; so the is-a-tag toggle and graceful degradation are unaffected.
|
||
(host-bl-test "unrelate (plain boosted / no-JS, no SX-Target) still redirects"
|
||
(dream-status (host/blog-unrelate-submit
|
||
(host-bl-relreq "alpha-post" "unrelate"
|
||
{:sx-request "true"} "beta-post" "related")))
|
||
303)
|
||
(host/blog-unrelate! "alpha-post" "beta-post" "related")
|
||
(host/blog-put! "hint-post" "Hint Post" "(p \"h\")" "published")
|
||
(host-bl-test "relations section: hint when logged-in + no relations"
|
||
(contains? (str (host/blog--relations-or-hint "hint-post" true)) "add some") true)
|
||
(host-bl-test "relations section: empty when anonymous + no relations"
|
||
(= (host/blog--relations-or-hint "hint-post" false) "") true)
|
||
|
||
;; -- Phase 1: relations carry a kind --
|
||
(host-bl-test "symmetric kind (related) reads from both sides"
|
||
(begin
|
||
(host/blog-relate! "alpha-post" "gamma-post" "related")
|
||
(list (contains? (host/blog-out "alpha-post" "related") "gamma-post")
|
||
(contains? (host/blog-out "gamma-post" "related") "alpha-post")))
|
||
(list true true))
|
||
(host-bl-test "directed kind (tagged) writes one direction; inverse via host/blog-in"
|
||
(begin
|
||
(host/blog-relate! "alpha-post" "beta-post" "tagged")
|
||
(list (contains? (host/blog-out "alpha-post" "tagged") "beta-post")
|
||
(contains? (host/blog-out "beta-post" "tagged") "alpha-post")
|
||
(contains? (host/blog-in "beta-post" "tagged") "alpha-post")))
|
||
(list true false true))
|
||
(host-bl-test "unrelate is kind-scoped (related edge survives a tagged unrelate)"
|
||
(begin
|
||
(host/blog-unrelate! "alpha-post" "beta-post" "tagged")
|
||
(list (contains? (host/blog-out "alpha-post" "tagged") "beta-post")
|
||
(contains? (host/blog-out "alpha-post" "related") "gamma-post")))
|
||
(list false true))
|
||
(host/blog-unrelate! "alpha-post" "gamma-post" "related")
|
||
(host-bl-test "relate-submit rejects an unknown kind (no-op)"
|
||
(begin
|
||
(host-bl-wapp (host-bl-send "POST" "/alpha-post/relate" "Bearer good"
|
||
"application/x-www-form-urlencoded" "other=beta-post&kind=bogus"))
|
||
(contains? (host/blog-out "alpha-post" "bogus") "beta-post"))
|
||
false)
|
||
(host-bl-test "default kind is related (no kind field)"
|
||
(begin
|
||
(host-bl-wapp (host-bl-send "POST" "/alpha-post/relate" "Bearer good"
|
||
"application/x-www-form-urlencoded" "other=beta-post"))
|
||
(contains? (host/blog-out "alpha-post" "related") "beta-post"))
|
||
true)
|
||
(host-bl-test "edges are durable: KV row written on relate"
|
||
(begin
|
||
(host/blog-relate! "alpha-post" "gamma-post" "tagged")
|
||
(persist/backend-kv-has? host/blog-store (host/blog--edge-key "alpha-post" "tagged" "gamma-post")))
|
||
true)
|
||
(host-bl-test "replay rebuilds the graph after an in-memory wipe (restart sim)"
|
||
(begin
|
||
(relations/load! (list)) ;; simulate a fresh process
|
||
(host/blog-load-edges!) ;; replay from the durable store
|
||
(list (contains? (host/blog-out "alpha-post" "tagged") "gamma-post")
|
||
(contains? (host/blog-out "alpha-post" "related") "beta-post")
|
||
(contains? (host/blog-out "beta-post" "related") "alpha-post")))
|
||
(list true true true))
|
||
(host-bl-test "unrelate deletes the durable KV row"
|
||
(begin
|
||
(host/blog-unrelate! "alpha-post" "gamma-post" "tagged")
|
||
(persist/backend-kv-has? host/blog-store (host/blog--edge-key "alpha-post" "tagged" "gamma-post")))
|
||
false)
|
||
|
||
;; -- Phase 2: typing with subsumption (is-a + subtype-of) --
|
||
;; ppost --is-a--> ptutorial ; ptutorial --subtype-of--> particle --subtype-of--> pdoc
|
||
(host/blog-put! "ptutorial" "P Tutorial" "(p \"t\")" "published")
|
||
(host/blog-put! "particle" "P Article" "(p \"a\")" "published")
|
||
(host/blog-put! "pdoc" "P Doc" "(p \"d\")" "published")
|
||
(host/blog-put! "ppost" "P Post" "(p \"p\")" "published")
|
||
(host/blog-relate! "ptutorial" "particle" "subtype-of")
|
||
(host/blog-relate! "particle" "pdoc" "subtype-of")
|
||
(host/blog-relate! "ppost" "ptutorial" "is-a")
|
||
(host-bl-test "types-of = declared type + ALL its subtype-of supertypes"
|
||
(list (contains? (host/blog-types-of "ppost") "ptutorial")
|
||
(contains? (host/blog-types-of "ppost") "particle")
|
||
(contains? (host/blog-types-of "ppost") "pdoc"))
|
||
(list true true true))
|
||
(host-bl-test "is-a? is transitive THROUGH subtype-of (subsumption)"
|
||
(list (host/blog-is-a? "ppost" "ptutorial")
|
||
(host/blog-is-a? "ppost" "pdoc"))
|
||
(list true true))
|
||
(host-bl-test "is-a? alone does NOT chain (instance-of is not transitive)"
|
||
(begin
|
||
(host/blog-put! "pmeta" "P Meta" "(p \"m\")" "published")
|
||
(host/blog-relate! "pmeta" "ppost" "is-a") ;; pmeta is-a ppost is-a ptutorial
|
||
(host/blog-is-a? "pmeta" "ptutorial")) ;; ... does NOT make pmeta is-a ptutorial
|
||
false)
|
||
(host-bl-test "is-a? false for an unrelated type"
|
||
(host/blog-is-a? "ppost" "particle") true) ;; sanity: this one IS reachable
|
||
(host-bl-test "seed-types: an instance of tag is, transitively, a type"
|
||
(begin
|
||
(host/blog-seed-types!) ;; type, tag, tag subtype-of type
|
||
(host/blog-put! "ocaml" "OCaml" "(p \"lang\")" "published")
|
||
(host/blog-relate! "ocaml" "tag" "is-a") ;; ocaml is-a tag
|
||
(list (host/blog-is-a? "ocaml" "tag") (host/blog-is-a? "ocaml" "type")))
|
||
(list true true))
|
||
(host-bl-test "type-valid? is vacuously true with no schemas (gradual)"
|
||
(host/blog-type-valid? "ppost" "(p \"anything\")") true)
|
||
|
||
;; -- relations-as-posts: declaration-driven candidate pools (plans/relations-as-posts.md) --
|
||
;; The picker's candidate set is the down-closure of a relation's anchors. is-a/subtype-of
|
||
;; are anchored by `type`, so they offer the WHOLE type closure — the roots (type/tag/
|
||
;; article) AND the instances — fixing the wrinkle where only instances showed.
|
||
(host-bl-test "is-a candidates = the type closure: roots (type/tag/article) AND instances"
|
||
(let ((pool (host/blog--candidate-pool "is-a")))
|
||
(list (contains? pool "type") (contains? pool "tag")
|
||
(contains? pool "article") (contains? pool "ocaml"))) ;; ocaml is-a tag
|
||
(list true true true true))
|
||
(host-bl-test "is-a candidates exclude a plain content post (not is-a/subtype-reachable to Type)"
|
||
(contains? (host/blog--candidate-pool "is-a") "ppost") false)
|
||
(host-bl-test "tagged candidates are anchored by tag (tag + its instances)"
|
||
(let ((pool (host/blog--candidate-pool "tagged")))
|
||
(list (contains? pool "tag") (contains? pool "ocaml")))
|
||
(list true true))
|
||
(host-bl-test "related candidates = every post (no declaration anchors it)"
|
||
(let ((pool (host/blog--candidate-pool "related")))
|
||
(list (contains? pool "type") (contains? pool "ppost")))
|
||
(list true true))
|
||
;; and it flows through to the live picker endpoint: the is-a picker now offers a type root
|
||
(host-bl-test "is-a relate-options offers the type roots (Article)"
|
||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/ppost/relate-options?kind=is-a"))) "Article")
|
||
true)
|
||
|
||
;; -- relations are posts: symmetry + labels read off the relation-posts (slice 2) --
|
||
(host-bl-test "kind-spec reads :rel metadata off the relation-post"
|
||
(let ((s (host/blog--kind-spec "is-a")))
|
||
(list (get s :kind) (get s :label) (get s :symmetric) (get s :inverse-label)))
|
||
(list "is-a" "Types" false "Instances"))
|
||
(host-bl-test "kind-symmetric? reads symmetry off the post (related yes, is-a no)"
|
||
(list (host/blog--kind-symmetric? "related") (host/blog--kind-symmetric? "is-a"))
|
||
(list true false))
|
||
(host-bl-test "an unknown kind has no spec, so relate still validates it away"
|
||
(host/blog--kind-spec "bogus-kind") nil)
|
||
(host-bl-test "rel-kinds is DERIVED from the graph (every post that is-a relation)"
|
||
(let ((kinds (map (fn (s) (get s :kind)) host/blog-rel-kinds)))
|
||
(list (contains? kinds "related") (contains? kinds "is-a")
|
||
(contains? kinds "subtype-of") (contains? kinds "tagged")))
|
||
(list true true true true))
|
||
|
||
;; -- relations are TYPED: the target-type constraint is enforced (slice 3) --
|
||
;; A valid object of a relation is one in its declared candidate set (the picker's
|
||
;; pool). So is-a's object must be a type, tagged's must be a tag, related's any post.
|
||
(host-bl-test "valid-object?: is-a accepts a type (article), rejects a plain post (ppost)"
|
||
(list (host/blog--valid-object? "is-a" "article") (host/blog--valid-object? "is-a" "ppost"))
|
||
(list true false))
|
||
(host-bl-test "valid-object?: tagged accepts a tag (ocaml); related accepts any post"
|
||
(list (host/blog--valid-object? "tagged" "ocaml") (host/blog--valid-object? "related" "ppost"))
|
||
(list true true))
|
||
;; the relate ENDPOINT enforces it: is-a to a type relates; is-a to a non-type no-ops.
|
||
(host/blog-unrelate! "alpha-post" "article" "is-a")
|
||
(host-bl-test "relate-submit: is-a to a type (article) creates the edge"
|
||
(begin
|
||
(host/blog-relate-submit (host-bl-relreq "alpha-post" "relate"
|
||
{:sx-request "true" :sx-target "#rel-editor-is-a"} "article" "is-a"))
|
||
(contains? (host/blog-out "alpha-post" "is-a") "article"))
|
||
true)
|
||
(host/blog-unrelate! "alpha-post" "article" "is-a")
|
||
(host-bl-test "relate-submit: is-a to a NON-type (beta-post) is rejected (no edge)"
|
||
(begin
|
||
(host/blog-relate-submit (host-bl-relreq "alpha-post" "relate"
|
||
{:sx-request "true" :sx-target "#rel-editor-is-a"} "beta-post" "is-a"))
|
||
(contains? (host/blog-out "alpha-post" "is-a") "beta-post"))
|
||
false)
|
||
|
||
;; -- Slice 4: type ALGEBRA — intersection (∧) and union (∨) types --
|
||
;; ocaml is-a tag (seeded above); make it is-a article too, so it's in BOTH extents.
|
||
(host/blog-relate! "ocaml" "article" "is-a")
|
||
(host/blog-make-and! "taggy-article" "tag" "article") ;; tag ∧ article
|
||
(host/blog-make-or! "tag-or-article" "tag" "article") ;; tag ∨ article
|
||
(host-bl-test "intersection (∧): a member iff it's an instance of BOTH operands"
|
||
(list (host/blog-is-a-expr? "ocaml" "taggy-article") ;; is-a tag AND is-a article
|
||
(host/blog-is-a-expr? "ppost" "taggy-article")) ;; neither
|
||
(list true false))
|
||
(host-bl-test "union (∨): a member iff it's an instance of EITHER operand"
|
||
(list (host/blog-is-a-expr? "ocaml" "tag-or-article") ;; is-a tag (and article)
|
||
(host/blog-is-a-expr? "ppost" "tag-or-article")) ;; neither tag nor article
|
||
(list true false))
|
||
(host-bl-test "the extent is the set intersection of the operands' extents"
|
||
(let ((ext (host/blog-instances-of-expr "taggy-article")))
|
||
(list (contains? ext "ocaml") ;; in tag ∩ article
|
||
(contains? ext "ppost"))) ;; in neither
|
||
(list true false))
|
||
;; algebra is META-CIRCULAR: an operand can itself be an algebraic type.
|
||
(host/blog-make-and! "nested-and" "taggy-article" "tag") ;; (tag ∧ article) ∧ tag
|
||
(host-bl-test "nested type expression: (tag ∧ article) ∧ tag still admits ocaml"
|
||
(host/blog-is-a-expr? "ocaml" "nested-and") true)
|
||
|
||
;; -- Slice 5: refinement types — schemas live ON the type-post --
|
||
;; article's schema (now on the article post) is still enforced for its instances.
|
||
(host/blog-put! "art-test" "Art Test" "(p \"x\")" "published")
|
||
(host/blog-relate! "art-test" "article" "is-a")
|
||
(host-bl-test "article (refinement type, schema on the post) requires an h1"
|
||
(list (host/blog-type-valid? "art-test" "(p \"no heading\")") ;; missing h1
|
||
(host/blog-type-valid? "art-test" "(article (h1 \"H\") (p \"x\"))")) ;; has h1
|
||
(list false true))
|
||
;; a NEW refinement type is pure data: give a type-post a :schema and its instances
|
||
;; are validated against it — no code, no hardcoded table.
|
||
(host/blog-seed! "guide" "Guide" "(article (h1 \"Guide\") (p \"A guide.\"))" "published")
|
||
(host/blog-relate! "guide" "type" "subtype-of")
|
||
(host/blog--set-schema! "guide" (list {:block "pre" :msg "a guide needs a code block (pre)"}))
|
||
(host/blog-put! "g1" "G1" "(p \"x\")" "published")
|
||
(host/blog-relate! "g1" "guide" "is-a")
|
||
(host-bl-test "a NEW refinement type validates its instances against its :schema"
|
||
(list (host/blog-type-valid? "g1" "(p \"no code\")") ;; missing pre
|
||
(host/blog-type-valid? "g1" "(article (pre \"x\") (p \"y\"))")) ;; has pre
|
||
(list false true))
|
||
(host-bl-test "the schema is read off the type-post (data, not a hardcoded table)"
|
||
(contains? (str (host/blog-schema-of "guide")) "code block") true)
|
||
;; editing a refinement type preserves its :schema (put! merges over the record).
|
||
(host/blog-put! "guide" "Guide v2" "(article (h1 \"Guide\") (p \"edited\"))" "published")
|
||
(host-bl-test "editing a type-post preserves its :schema (and metadata survives edits)"
|
||
(contains? (str (host/blog-schema-of "guide")) "code block") 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))
|
||
;; `related` (no declaration) is UNRESTRICTED — it offers every post, including type-defs
|
||
;; like pdoc ("P Doc"), unlike `tagged` which offers only tags. Found via a filter so the
|
||
;; assertion is robust to pagination (the pool is >1 page once the metamodel is seeded).
|
||
(host-bl-test "related picker offers any post, incl a type-def (kind defaults to related)"
|
||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/particle/relate-options?q=doc"))) ">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)
|
||
|
||
;; -- Phase 4: registry-driven render + /tags index --
|
||
(host-bl-test "relation-blocks renders Related + Tags from the registry"
|
||
(begin
|
||
(host/blog-relate! "hint-post" "ppost" "related")
|
||
(host/blog-relate! "hint-post" "ocaml" "tagged")
|
||
(let ((body (str (host/blog--relation-blocks "hint-post"))))
|
||
(list (contains? body "Related posts") (contains? body "Tags"))))
|
||
(list true true))
|
||
(host-bl-test "relation-blocks shows an inverse block (Tagged with this) for a tag"
|
||
(contains? (str (host/blog--relation-blocks "ocaml")) "Tagged with this") true)
|
||
(host-bl-test "/tags lists the tag posts"
|
||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/tags"))) "OCaml") true)
|
||
(host-bl-test "/tags is 200 (not shadowed by /:slug)"
|
||
(dream-status (host-bl-app (host-bl-req "/tags"))) 200)
|
||
|
||
;; -- Phase 6: gradual schema validation --
|
||
(host/blog-seed-types!) ;; ensures the "article" type + its schema (requires h1)
|
||
(host-bl-test "all-tags finds nested element tags"
|
||
(let ((tags (host/blog--all-tags (parse-safe "(article (h1 \"T\") (p \"x\"))"))))
|
||
(list (contains? tags "h1") (contains? tags "p") (contains? tags "section")))
|
||
(list true true false))
|
||
(host-bl-test "schema-issues: missing required block -> 1 issue; present -> 0"
|
||
(let ((sch (host/blog-schema-of "article")))
|
||
(list (len (host/blog--schema-issues sch "(p \"no heading\")"))
|
||
(len (host/blog--schema-issues sch "(article (h1 \"yes\"))"))))
|
||
(list 1 0))
|
||
(host-bl-test "type-valid? enforces an is-a article's schema"
|
||
(begin
|
||
(host/blog-put! "art1" "Art 1" "(p \"x\")" "published")
|
||
(host/blog-relate! "art1" "article" "is-a")
|
||
(list (host/blog-type-valid? "art1" "(p \"no heading\")")
|
||
(host/blog-type-valid? "art1" "(article (h1 \"H\") (p \"x\"))")))
|
||
(list false true))
|
||
|
||
;; -- metamodel overview (GET /meta) --
|
||
(host-bl-test "type-defs = the subtype hierarchy (type defs), not is-a instances"
|
||
(let ((defs (host/blog-type-defs)))
|
||
(list (contains? defs "type") (contains? defs "article") (contains? defs "art1")))
|
||
(list true true false))
|
||
(host-bl-test "/meta is 200 (not shadowed by /:slug)"
|
||
(dream-status (host-bl-app (host-bl-req "/meta"))) 200)
|
||
(host-bl-test "/meta lists type definitions + relations + the article's required block"
|
||
(let ((body (dream-resp-body (host-bl-app (host-bl-req "/meta")))))
|
||
(list (contains? body "Metamodel") (contains? body "Article")
|
||
(contains? body "h1") (contains? body "related")
|
||
(contains? body "symmetric")))
|
||
(list true true true true true))
|
||
|
||
;; -- Slice 8: typed scalar fields on a type --
|
||
(host-bl-test "fields-of reads a type's declared fields (seeded on article)"
|
||
(map (fn (f) (get f :name)) (host/blog-fields-of "article"))
|
||
(list "subtitle" "hero" "body"))
|
||
(host-bl-test "widget-for: explicit > value-type default > text fallback"
|
||
(list (host/blog--widget-for {:name "a" :type "URL"})
|
||
(host/blog--widget-for {:name "b" :type "Text"})
|
||
(host/blog--widget-for {:name "c" :type "Nonsense"})
|
||
(host/blog--widget-for {:name "d" :type "String" :widget "custom"}))
|
||
(list "url" "textarea" "text" "custom"))
|
||
(host-bl-test "set-fields! is idempotent + preserves the rest of the record"
|
||
(begin
|
||
(host/blog--set-fields! "article"
|
||
(list {:name "subtitle" :type "String"} {:name "hero" :type "URL"} {:name "body" :type "Composition"}))
|
||
(list (get (host/blog-get "article") :title) (len (host/blog-fields-of "article"))))
|
||
(list "Article" 3))
|
||
(host-bl-test "a type with no declared fields -> empty list"
|
||
(host/blog-fields-of "tag") (list))
|
||
(host-bl-test "/meta shows the article's typed fields"
|
||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/meta"))) "subtitle:String") true)
|
||
|
||
;; -- Slice 8b: field values + the generic, type-driven edit form --
|
||
(host-bl-test "fields-for-post = union of the post's (transitive) types' fields"
|
||
(begin
|
||
(host/blog-put! "fpost" "F Post" "(article (h1 \"F\"))" "published")
|
||
(host/blog-relate! "fpost" "article" "is-a")
|
||
(map (fn (f) (get f :name)) (host/blog--fields-for-post "fpost")))
|
||
(list "subtitle" "hero" "body"))
|
||
(host-bl-test "a post of no typed type has no fields"
|
||
(host/blog--fields-for-post "hello") (list))
|
||
(host-bl-test "set/get field-values round-trips on an instance"
|
||
(begin
|
||
(host/blog--set-field-values! "fpost" {"subtitle" "A subtitle" "hero" "http://x/y.png"})
|
||
(list (get (host/blog-field-values-of "fpost") "subtitle")
|
||
(get (host/blog-field-values-of "fpost") "hero")))
|
||
(list "A subtitle" "http://x/y.png"))
|
||
(host-bl-test "edit form renders one input per field for a typed post"
|
||
(let ((body (dream-resp-body (host-bl-wapp (host-bl-send "GET" "/fpost/edit" "Bearer good" nil "")))))
|
||
(list (contains? body "field-subtitle") (contains? body "field-hero") (contains? body "Fields")))
|
||
(list true true true))
|
||
(host-bl-test "edit-submit stores the typed field values from the form"
|
||
(begin
|
||
(host-bl-wapp (host-bl-send "POST" "/fpost/edit" "Bearer good"
|
||
"application/x-www-form-urlencoded"
|
||
"sx_content=(article+(h1+%22F%22))&field-subtitle=Saved+Sub&field-hero=http%3A%2F%2Fz%2Fq.png"))
|
||
(list (get (host/blog-field-values-of "fpost") "subtitle")
|
||
(get (host/blog-field-values-of "fpost") "hero")))
|
||
(list "Saved Sub" "http://z/q.png"))
|
||
|
||
;; -- Slice 8c: render template per type (fields drive the page too) --
|
||
(host-bl-test "instantiate resolves (field name), replacing the placeholder"
|
||
(list (contains? (str (host/blog--instantiate (parse-safe "(p (field \"subtitle\"))") {"subtitle" "Hi"})) "Hi")
|
||
(contains? (str (host/blog--instantiate (parse-safe "(p (field \"x\"))") {})) "field"))
|
||
(list true false))
|
||
(host-bl-test "template-of reads the article's seeded render template"
|
||
(contains? (host/blog-template-of "article") "field") true)
|
||
(host-bl-test "typed-block renders a typed post's field values"
|
||
(begin
|
||
(host/blog--set-field-values! "fpost" {"subtitle" "My Standfirst" "hero" ""})
|
||
(contains? (str (host/blog--typed-block "fpost")) "My Standfirst"))
|
||
true)
|
||
(host-bl-test "typed-block is empty for an untyped post"
|
||
(host/blog--typed-block "hello") "")
|
||
(host-bl-test "post page renders the typed template standfirst"
|
||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/fpost/"))) "My Standfirst") true)
|
||
|
||
;; -- metamodel editor: define a type through the UI (POST /meta/new-type) --
|
||
(host-bl-test "/meta has the create-type form"
|
||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/meta"))) "/meta/new-type") true)
|
||
(host-bl-test "POST /meta/new-type creates a type (subtype-of type) in type-defs"
|
||
(begin
|
||
(host-bl-wapp (host-bl-send "POST" "/meta/new-type" "Bearer good"
|
||
"application/x-www-form-urlencoded" "title=Recipe"))
|
||
(list (host/blog-exists? "recipe") (contains? (host/blog-type-defs) "recipe")))
|
||
(list true true))
|
||
(host-bl-test "create-type requires auth (unauthed -> not created)"
|
||
(begin
|
||
(host-bl-wapp (host-bl-send "POST" "/meta/new-type" nil
|
||
"application/x-www-form-urlencoded" "title=Sneaky Type"))
|
||
(host/blog-exists? "sneaky-type"))
|
||
false)
|
||
|
||
;; -- metamodel editor: define a relation through the UI (POST /meta/new-relation) --
|
||
(host-bl-test "/meta has the create-relation form"
|
||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/meta"))) "/meta/new-relation") true)
|
||
(host-bl-test "POST /meta/new-relation creates + registers a relation (session-scoped)"
|
||
(begin
|
||
(host-bl-wapp (host-bl-send "POST" "/meta/new-relation" "Bearer good"
|
||
"application/x-www-form-urlencoded" "title=Blocks&label=Blocks&symmetric=on"))
|
||
(list (host/blog-exists? "blocks")
|
||
(host/blog-is-a? "blocks" "relation")
|
||
(not (nil? (host/blog--kind-spec "blocks")))
|
||
(host/blog--kind-symmetric? "blocks")))
|
||
(list true true true true))
|
||
(host-bl-test "create-relation requires auth (unauthed -> not created)"
|
||
(begin
|
||
(host-bl-wapp (host-bl-send "POST" "/meta/new-relation" nil
|
||
"application/x-www-form-urlencoded" "title=Sneaky Rel"))
|
||
(host/blog-exists? "sneaky-rel"))
|
||
false)
|
||
|
||
;; -- cards-as-types: the blog content block vocabulary --
|
||
(host-bl-test "card-types are seeded as subtypes of card (in type-defs)"
|
||
(let ((defs (host/blog-type-defs)))
|
||
(list (contains? defs "card") (contains? defs "card-image") (contains? defs "card-heading")))
|
||
(list true true true))
|
||
(host-bl-test "a card-type carries its fields"
|
||
(map (fn (f) (get f :name)) (host/blog-fields-of "card-image"))
|
||
(list "src" "alt" "caption"))
|
||
(host-bl-test "/meta lists the card vocabulary with fields"
|
||
(let ((body (dream-resp-body (host-bl-app (host-bl-req "/meta")))))
|
||
(list (contains? body ">Image</a>") (contains? body "src:URL, alt:String")))
|
||
(list true true))
|
||
|
||
;; -- typed Ghost import (the radar genesis-import seam) --
|
||
(host-bl-test "import-post! lands a Ghost post as a typed Article + fields + tags"
|
||
(begin
|
||
(host/blog-import-post! {"slug" "g1" "title" "G1" "sx_content" "(article (h1 \"G1\"))"
|
||
"status" "published" "custom_excerpt" "A standfirst"
|
||
"feature_image" "http://i/h.jpg" "tags" (list "News")})
|
||
(list (host/blog-is-a? "g1" "article")
|
||
(get (host/blog-field-values-of "g1") "subtitle")
|
||
(get (host/blog-field-values-of "g1") "hero")
|
||
(contains? (host/blog-out "g1" "tagged") "news")))
|
||
(list true "A standfirst" "http://i/h.jpg" true))
|
||
(host-bl-test "POST /import (text/sx list of Ghost dicts) lands typed posts"
|
||
(begin
|
||
(host-bl-wapp (host-bl-send "POST" "/import" "Bearer good" "text/sx"
|
||
"({:slug \"g2\" :title \"G2\" :sx_content \"(p \\\"b\\\")\" :status \"published\" :custom_excerpt \"S2\"})"))
|
||
(list (host/blog-is-a? "g2" "article") (get (host/blog-field-values-of "g2") "subtitle")))
|
||
(list true "S2"))
|
||
(host-bl-test "POST /import rejects a non-list body -> 400"
|
||
(dream-status (host-bl-wapp (host-bl-send "POST" "/import" "Bearer good" "text/sx" "{:x 1}")))
|
||
400)
|
||
|
||
;; -- composition objects: a record with :body renders via the render-fold --
|
||
(host-bl-test "a record's :body renders via the fold, different per context"
|
||
(begin
|
||
(host/blog-put! "cdoc" "C" "(p \"fallback\")" "published")
|
||
(host/blog--set-body! "cdoc"
|
||
(quote (seq (alt (when (has "auth") (text "MEMBER")) (else (text "ANON")))
|
||
(each (items {:name "X"} {:name "Y"}) (field :name)))))
|
||
(list (host/comp-render (host/blog-body-of "cdoc") {})
|
||
(host/comp-render (host/blog-body-of "cdoc") {"auth" "y"})))
|
||
(list "ANON<span>X</span><span>Y</span>" "MEMBER<span>X</span><span>Y</span>"))
|
||
(host-bl-test "post page renders :body (composition) over sx_content"
|
||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/cdoc/"))) "ANON") true)
|
||
;; -- the each source can be a GRAPH QUERY: the list isn't baked into the body, it's
|
||
;; whatever is-a the type right now (data-driven). The resolver (host/blog--comp-query)
|
||
;; is injected into the render context by host/blog--comp-ctx. --
|
||
(host-bl-test "each(query is-a TYPE) iterates real graph instances"
|
||
(begin
|
||
(host/blog-seed! "qtype" "QType" "(p \"t\")" "published")
|
||
(host/blog-relate! "qtype" "type" "subtype-of")
|
||
(host/blog-seed! "qi-1" "Item One" "(p \"1\")" "published")
|
||
(host/blog-seed! "qi-2" "Item Two" "(p \"2\")" "published")
|
||
(host/blog-relate! "qi-1" "qtype" "is-a")
|
||
(host/blog-relate! "qi-2" "qtype" "is-a")
|
||
(let ((out (host/comp-render
|
||
(quote (each (query is-a qtype)
|
||
(seq (text "<a href=\"/") (val :slug) (text "\">") (field :title) (text "</a>"))))
|
||
(host/blog--comp-ctx nil nil nil))))
|
||
;; field wraps in <span> (display); val is raw (for the href attribute).
|
||
(list (contains? out "Item One") (contains? out "Item Two")
|
||
(contains? out "/qi-1") (contains? out "<span>Item One</span>"))))
|
||
(list true true true true))
|
||
;; a query with no matching instances renders empty (not an error) — robustness.
|
||
(host-bl-test "each(query is-a TYPE) with no instances renders empty"
|
||
(host/comp-render
|
||
(quote (each (query is-a no-such-type) (field :title)))
|
||
(host/blog--comp-ctx nil nil nil))
|
||
"")
|
||
;; -- live context: the SAME object renders a responsive variant per request (device from
|
||
;; the User-Agent, locale from Accept-Language) — context is the execution environment. --
|
||
(host-bl-test "comp-ctx reads device + locale from the request headers"
|
||
(let ((mob (host/blog--comp-ctx nil (dream-request "GET" "/x" {"user-agent" "X iPhone Y" "accept-language" "fr-FR,fr"} "") nil))
|
||
(desk (host/blog--comp-ctx nil (dream-request "GET" "/x" {"user-agent" "Mozilla Linux" "accept-language" "en-US"} "") nil)))
|
||
(list (get mob "device") (get mob "locale") (get desk "device") (get desk "locale")))
|
||
(list "mobile" "fr" "desktop" "en"))
|
||
(host-bl-test "one object renders a device-specific variant via (alt (when (eq device …)))"
|
||
(let ((body (quote (alt (when (eq "device" "mobile") (text "M")) (else (text "D")))))
|
||
(mob (dream-request "GET" "/x" {"user-agent" "iPhone"} ""))
|
||
(desk (dream-request "GET" "/x" {"user-agent" "Linux"} "")))
|
||
(list (host/comp-render body (host/blog--comp-ctx nil mob nil))
|
||
(host/comp-render body (host/blog--comp-ctx nil desk nil))))
|
||
(list "M" "D"))
|
||
;; -- cards-as-objects: the importer decomposes content into card OBJECTS + a contains body
|
||
;; (not one opaque sx_content string). Each top-level block becomes a stored card object
|
||
;; (is-a a card-type + field-values), linked by ordered `contains` edges; the post :body is
|
||
;; (seq (ref c0) (ref c1) …) and the render-fold transcludes each card via its type template. --
|
||
(host-bl-test "import decomposes the body into typed card objects + a contains body"
|
||
(begin
|
||
(host/blog-import-post! {"slug" "imp-x" "title" "Imp X"
|
||
"sx_content" "(article (h1 \"Heading One\") (p \"Para text.\") (img :src \"p.jpg\" :alt \"alt\"))"
|
||
"status" "published"})
|
||
(list (len (host/blog-out "imp-x" "contains"))
|
||
(host/blog-is-a? "imp-x__body__b0" "card-heading")
|
||
(host/blog-is-a? "imp-x__body__b1" "card-text")
|
||
(host/blog-is-a? "imp-x__body__b2" "card-image")
|
||
(get (host/blog-field-values-of "imp-x__body__b0") "text")
|
||
(get (host/blog-field-values-of "imp-x__body__b2") "src")))
|
||
(list 3 true true true "Heading One" "p.jpg"))
|
||
(host-bl-test "a decomposed post :body is a (seq (ref …) …) composition"
|
||
(let ((body (host/blog-body-of "imp-x")))
|
||
(list (str (first body)) (len (rest body)) (str (first (first (rest body))))))
|
||
(list "seq" 3 "ref"))
|
||
;; the card objects are status "block" — stored but NOT listed as top-level posts.
|
||
(host-bl-test "decomposed card objects do not appear on the published home index"
|
||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/"))) "imp-x__body__b0") false)
|
||
;; the post page renders the cards by TRANSCLUSION (ref -> card-type template).
|
||
(host-bl-test "decomposed post page renders the transcluded cards"
|
||
(let ((html (dream-resp-body (host-bl-app (host-bl-req "/imp-x/")))))
|
||
(list (contains? html "Heading One") (contains? html "Para text.") (contains? html "p.jpg")))
|
||
(list true true true))
|
||
;; real-post block kinds: a <figure> -> card-image WITH its figcaption; an <iframe> ->
|
||
;; card-embed with its src as the url. (The nt-live-encore import shape.)
|
||
(host-bl-test "decompose maps figure->card-image (with caption) and iframe->card-embed"
|
||
(begin
|
||
(host/blog-import-post! {"slug" "imp-fig" "title" "Fig" "status" "published"
|
||
"sx_content" "(article (figure (img :src \"p.jpg\" :alt \"a\") (figcaption \"the cap\")) (iframe :src \"https://youtube.com/embed/xyz\"))"})
|
||
(list (host/blog-is-a? "imp-fig__body__b0" "card-image")
|
||
(get (host/blog-field-values-of "imp-fig__body__b0") "caption")
|
||
(get (host/blog-field-values-of "imp-fig__body__b0") "src")
|
||
(host/blog-is-a? "imp-fig__body__b1" "card-embed")
|
||
(get (host/blog-field-values-of "imp-fig__body__b1") "url")))
|
||
(list true "the cap" "p.jpg" true "https://youtube.com/embed/xyz"))
|
||
;; import accepts RAW HTML (converted by the pure-SX host/html->sx) — the first-class path,
|
||
;; replacing the one-off external converter used for the nt-live-encore import.
|
||
(host-bl-test "import-post! accepts raw \"html\" (html->sx) and decomposes it into typed cards"
|
||
(begin
|
||
(host/blog-import-post! {"slug" "html-imp" "title" "HI" "status" "published"
|
||
"html" "<h2>Hi</h2><p>Some <strong>bold</strong> text.</p><img src=\"p.jpg\" alt=\"a\">"})
|
||
(list (host/blog-is-a? "html-imp__body__b0" "card-heading")
|
||
(host/blog-is-a? "html-imp__body__b1" "card-text")
|
||
(get (host/blog-field-values-of "html-imp__body__b1") "text")
|
||
(host/blog-is-a? "html-imp__body__b2" "card-image")))
|
||
(list true true "Some bold text." true))
|
||
;; -- block editor: structural edits to the post :body composition (step 6). --
|
||
(host-bl-test "block-add! creates a card object + contains edge + appends a ref to the body"
|
||
(begin
|
||
(host/blog-put! "bdoc" "BDoc" "(article)" "published")
|
||
(host/blog--set-body! "bdoc" (quote (seq)))
|
||
(let ((c0 (host/blog-block-add! "bdoc" "body" "card-text" {"text" "first"}))
|
||
(c1 (host/blog-block-add! "bdoc" "body" "card-heading" {"level" "2" "text" "a head"})))
|
||
(list (host/blog-body-refs "bdoc")
|
||
(host/blog-is-a? c0 "card-text")
|
||
(contains? (host/blog-out "bdoc" "contains") c1))))
|
||
(list (list "body__b0" "body__b1") true true))
|
||
(host-bl-test "block-move-idx! reorders the body by index (no-op at the ends)"
|
||
(begin
|
||
(host/blog-block-move-idx! "bdoc" "body" 1 "up") ;; node 1 before node 0
|
||
(let ((after-up (host/blog-body-refs "bdoc")))
|
||
(host/blog-block-move-idx! "bdoc" "body" 0 "up") ;; index 0 up -> no-op
|
||
(list after-up (host/blog-body-refs "bdoc"))))
|
||
(list (list "body__b1" "body__b0") (list "body__b1" "body__b0")))
|
||
(host-bl-test "block-remove-idx! drops the node + its contained card's contains edge"
|
||
(begin
|
||
(host/blog-block-remove-idx! "bdoc" "body" 0) ;; node 0 is now body__b1
|
||
(list (host/blog-body-refs "bdoc") (contains? (host/blog-out "bdoc" "contains") "bdoc__body__b1")))
|
||
(list (list "body__b0") false))
|
||
(host-bl-test "the edit page shows the block editor (#block-editor + an add-block form)"
|
||
(let ((html (dream-resp-body (host-bl-wapp (host-bl-send "GET" "/bdoc/edit" "Bearer good" "" "")))))
|
||
(list (contains? html "block-editor") (contains? html "+ card")))
|
||
(list true true))
|
||
(host-bl-test "POST /bdoc/blocks/add (auth) adds a block -> body grows"
|
||
(begin
|
||
(host-bl-wapp (host-bl-send "POST" "/bdoc/blocks/add" "Bearer good"
|
||
"application/x-www-form-urlencoded" "ctype=card-text&text=added+block"))
|
||
(len (host/blog-body-refs "bdoc")))
|
||
2)
|
||
;; -- and/or/each authoring: card (and) / conditional (or) / repeater (each) blocks over the
|
||
;; type-defined :body composition. Refs are field-relative; contains edges track the cards. --
|
||
(host-bl-test "block-add-cond! appends an (alt (when …) (else …)) with then/else cards"
|
||
(begin
|
||
(host/blog-put! "cdoc2" "C2" "(article)" "published")
|
||
(host/blog--set-body! "cdoc2" (quote (seq)))
|
||
(host/blog-block-add-cond! "cdoc2" "body" "device:mobile")
|
||
(let ((n (host/blog--nth (host/blog-body-nodes "cdoc2") 0)))
|
||
(list (host/blog--node-kind n)
|
||
(host/blog--pred->ckey (host/blog--node-pred n))
|
||
(len (host/blog-out "cdoc2" "contains"))))) ;; two cards contained
|
||
(list "cond" "device:mobile" 2))
|
||
(host-bl-test "block-set-cond! changes the condition (branches kept)"
|
||
(begin
|
||
(host/blog-block-set-cond! "cdoc2" "body" 0 "locale:fr")
|
||
(let ((n (host/blog--nth (host/blog-body-nodes "cdoc2") 0)))
|
||
(list (host/blog--pred->ckey (host/blog--node-pred n)) (host/blog--node-kind n))))
|
||
(list "locale:fr" "cond"))
|
||
(host-bl-test "block-add-each! appends an (each (query is-a TYPE) (ref …)) repeater"
|
||
(begin
|
||
(host/blog-block-add-each! "cdoc2" "body" "compose-item")
|
||
(let ((n (host/blog--nth (host/blog-body-nodes "cdoc2") 1)))
|
||
(list (host/blog--node-kind n) (host/blog--node-each-type n))))
|
||
(list "each" "compose-item"))
|
||
;; the WHOLE point: a conditional block renders its chosen branch per the live context, via
|
||
;; the SAME render-fold. (End-to-end: alt+when over "device", cards resolved by relative ref.)
|
||
(host-bl-test "a conditional block renders the branch chosen by context"
|
||
(begin
|
||
(host/blog-put! "cdoc3" "C3" "(article)" "published")
|
||
(host/blog--set-body! "cdoc3" (quote (seq)))
|
||
(host/blog-block-add-cond! "cdoc3" "body" "auth")
|
||
(let ((body (host/blog-body-of "cdoc3")))
|
||
(list (contains? (host/comp-render body (host/blog--comp-ctx "u" nil "cdoc3")) "shown when the condition holds")
|
||
(contains? (host/comp-render body (host/blog--comp-ctx nil nil "cdoc3")) "shown otherwise"))))
|
||
(list true true))
|
||
;; the editor offers all three block kinds.
|
||
(host-bl-test "the block editor offers card + conditional + repeater add forms"
|
||
(let ((html (render-page (host/blog--block-editor "cdoc2" "body"))))
|
||
(list (contains? html "+ card") (contains? html "+ conditional")
|
||
(contains? html "+ repeater") (contains? html "for each")))
|
||
(list true true true true))
|
||
;; -- LAYER 2: a TYPE declares which fields are compositions; the editor renders one block
|
||
;; editor per field, each an independent composition (its own cards, field-qualified slugs). --
|
||
(host-bl-test "a type declaring TWO composition fields yields two independent block editors"
|
||
(begin
|
||
(host/blog-seed! "landing-type" "Landing" "(p)" "published")
|
||
(host/blog-relate! "landing-type" "type" "subtype-of")
|
||
(host/blog--set-fields! "landing-type"
|
||
(list {:name "body" :type "Composition"} {:name "aside" :type "Composition"}))
|
||
(host/blog-put! "land1" "L1" "(article)" "published")
|
||
(host/blog-relate! "land1" "landing-type" "is-a")
|
||
(let ((cf (host/blog--composition-fields "land1"))
|
||
(html (render-page (host/blog--block-editors "land1"))))
|
||
(list cf (contains? html "id=\"comp-body\"") (contains? html "id=\"comp-aside\"")
|
||
(contains? html ":aside (composition)"))))
|
||
(list (list "body" "aside") true true true))
|
||
(host-bl-test "block-add! writes to the NAMED field; fields are independent (slug carries it)"
|
||
(begin
|
||
(host/blog-block-add! "land1" "aside" "card-text" {"text" "sidebar"})
|
||
(host/blog-block-add! "land1" "body" "card-text" {"text" "main"})
|
||
(list (len (host/blog--comp-nodes "land1" "aside")) (len (host/blog--comp-nodes "land1" "body"))
|
||
(host/blog-is-a? "land1__aside__b0" "card-text") (host/blog-is-a? "land1__body__b0" "card-text")))
|
||
(list 1 1 true true))
|
||
(host-bl-test "composition-fields defaults to [body] when the type declares none"
|
||
(begin (host/blog-put! "plain1" "P" "(p)" "published") (host/blog--composition-fields "plain1"))
|
||
(list "body"))
|
||
;; -- LAYER 2b: type-block GRAMMAR — a Composition field declares which block kinds it PERMITS.
|
||
;; The type governs the composition: editor palette + add + validation all read the grammar. --
|
||
(host-bl-test "allowed-blocks + allows-control? read the field's grammar (:blocks / :allow)"
|
||
(begin
|
||
(host/blog-seed! "grmtype" "G" "(p)" "published")
|
||
(host/blog-relate! "grmtype" "type" "subtype-of")
|
||
(host/blog--set-fields! "grmtype"
|
||
(list {:name "body" :type "Composition" :blocks (list "card-text" "card-heading") :allow (list "cond")}))
|
||
(host/blog-put! "grm1" "G1" "(article)" "published")
|
||
(host/blog-relate! "grm1" "grmtype" "is-a")
|
||
(list (host/blog--allowed-blocks "grm1" "body")
|
||
(host/blog--block-allowed? "grm1" "body" "card-text") (host/blog--block-allowed? "grm1" "body" "card-image")
|
||
(host/blog--allows-control? "grm1" "body" "cond") (host/blog--allows-control? "grm1" "body" "each")))
|
||
(list (list "card-text" "card-heading") true false true false))
|
||
;; the editor PALETTE is the grammar — only the allowed card types + permitted control blocks.
|
||
(host-bl-test "the block editor palette shows only the grammar's card kinds + allowed controls"
|
||
(let ((html (render-page (host/blog--block-editor "grm1" "body"))))
|
||
(list (contains? html "value=\"card-text\"") (contains? html "value=\"card-heading\"")
|
||
(contains? html "value=\"card-image\"") (contains? html "+ conditional") (contains? html "+ repeater")))
|
||
(list true true false true false))
|
||
;; the add handler REJECTS a card kind outside the grammar (the type governs writes).
|
||
(host-bl-test "block-add-submit rejects a card kind the grammar forbids"
|
||
(begin
|
||
(host/blog--set-body! "grm1" (quote (seq)))
|
||
(host-bl-wapp (host-bl-send "POST" "/grm1/blocks/add" "Bearer good"
|
||
"application/x-www-form-urlencoded" "field=body&ctype=card-image&text=x"))
|
||
(list (len (host/blog--comp-nodes "grm1" "body")) ;; image rejected -> 0
|
||
(begin (host-bl-wapp (host-bl-send "POST" "/grm1/blocks/add" "Bearer good"
|
||
"application/x-www-form-urlencoded" "field=body&ctype=card-text&text=ok"))
|
||
(len (host/blog--comp-nodes "grm1" "body"))))) ;; text allowed -> 1
|
||
(list 0 1))
|
||
;; validation flags a composition holding a block the grammar forbids (import/save gate).
|
||
(host-bl-test "comp-violations flags a card kind outside the field's grammar"
|
||
(begin
|
||
(host/blog-block-add! "grm1" "body" "card-image" {"src" "x.jpg"}) ;; model add bypasses the handler guard
|
||
(> (len (host/blog--comp-violations "grm1" "body")) 0))
|
||
true)
|
||
;; -- Part C: the TYPE DEFINITION is itself displayed + edited (as composition) on the type's
|
||
;; own edit page. is-type? gates it; the grammar checklist edits what instances may contain. --
|
||
(host-bl-test "is-type? recognises type posts (article, card-image) but not a plain instance"
|
||
(begin
|
||
(host/blog-put! "plainpost" "PP" "(p \"x\")" "published")
|
||
(list (host/blog--is-type? "article") (host/blog--is-type? "card-image") (host/blog--is-type? "plainpost")))
|
||
(list true true false))
|
||
(host-bl-test "set-field-grammar! updates a Composition field's :blocks + :allow"
|
||
(begin
|
||
(host/blog-seed! "dt" "DT" "(p)" "published") (host/blog-relate! "dt" "type" "subtype-of")
|
||
(host/blog--set-fields! "dt" (list {:name "body" :type "Composition"}))
|
||
(host/blog--set-field-grammar! "dt" "body" (list "card-text") (list "each"))
|
||
(let ((f (host/blog--own-field "dt" "body")))
|
||
(list (get f :blocks) (get f :allow))))
|
||
(list (list "card-text") (list "each")))
|
||
(host-bl-test "the type-def editor renders a grammar checklist for a Composition field"
|
||
(let ((html (render-page (host/blog--type-def-editor "article"))))
|
||
(list (contains? html "Type definition") (contains? html "may contain")
|
||
(contains? html "blk-card-image") (contains? html "allow-cond")))
|
||
(list true true true true))
|
||
(host-bl-test "POST /<type>/grammar sets the grammar from the checklist"
|
||
(begin
|
||
(host/blog-seed! "dt2" "DT2" "(p)" "published") (host/blog-relate! "dt2" "type" "subtype-of")
|
||
(host/blog--set-fields! "dt2" (list {:name "body" :type "Composition"}))
|
||
(host-bl-wapp (host-bl-send "POST" "/dt2/grammar" "Bearer good"
|
||
"application/x-www-form-urlencoded" "field=body&blk-card-text=on&blk-card-heading=on&allow-cond=on"))
|
||
(let ((f (host/blog--own-field "dt2" "body")))
|
||
(list (contains? (get f :blocks) "card-text") (contains? (get f :blocks) "card-heading")
|
||
(contains? (get f :blocks) "card-image") (get f :allow))))
|
||
(list true true false (list "cond")))
|
||
;; a type's edit page SHOWS the type-def editor; an instance's does not.
|
||
(host-bl-test "the type-def editor appears on a type's edit page, not an instance's"
|
||
(list (contains? (dream-resp-body (host-bl-wapp (host-bl-send "GET" "/article/edit" "Bearer good" "" ""))) "Type definition")
|
||
(contains? (dream-resp-body (host-bl-wapp (host-bl-send "GET" "/my-first-post/edit" "Bearer good" "" ""))) "Type definition"))
|
||
(list true false))
|
||
;; -- Part B: RELATIONS are type-governed composition — the type declares which relation kinds
|
||
;; its instances may use; the editors + relate handler honour it; editable on the type page. --
|
||
(host-bl-test "allowed-relations reads the type's :type-relations (article excludes subtype-of)"
|
||
(begin
|
||
(host/blog-put! "artinst" "AI" "(article (h1 \"x\"))" "published")
|
||
(host/blog-relate! "artinst" "article" "is-a")
|
||
(let ((allowed (host/blog--allowed-relations "artinst")))
|
||
(list (contains? allowed "related") (contains? allowed "is-a") (contains? allowed "tagged")
|
||
(contains? allowed "subtype-of"))))
|
||
(list true true true false))
|
||
(host-bl-test "the relation editors show only the type's permitted kinds"
|
||
(let ((html (render-page (host/blog--relation-editors "artinst"))))
|
||
(list (contains? html "rel-editor-related") (contains? html "rel-editor-tagged")
|
||
(contains? html "rel-editor-subtype-of")))
|
||
(list true true false))
|
||
(host-bl-test "relate-submit rejects a relation kind the type forbids"
|
||
(begin
|
||
(host/blog-seed! "sometype" "ST" "(p)" "published") (host/blog-relate! "sometype" "type" "subtype-of")
|
||
(host-bl-wapp (host-bl-send "POST" "/artinst/relate" "Bearer good"
|
||
"application/x-www-form-urlencoded" "kind=subtype-of&other=sometype"))
|
||
(contains? (host/blog-out "artinst" "subtype-of") "sometype"))
|
||
false)
|
||
(host-bl-test "the type-def editor includes the relation checklist"
|
||
(let ((html (render-page (host/blog--type-def-editor "article"))))
|
||
(list (contains? html "may be linked by") (contains? html "rel-related") (contains? html "rel-tagged")))
|
||
(list true true true))
|
||
(host-bl-test "POST /<type>/relations sets the allowed relations from the checklist"
|
||
(begin
|
||
(host/blog-seed! "rtype" "RT" "(p)" "published") (host/blog-relate! "rtype" "type" "subtype-of")
|
||
(host-bl-wapp (host-bl-send "POST" "/rtype/relations" "Bearer good"
|
||
"application/x-www-form-urlencoded" "rel-related=on&rel-tagged=on"))
|
||
(let ((r (host/blog--type-relations "rtype")))
|
||
(list (contains? r "related") (contains? r "tagged") (contains? r "is-a"))))
|
||
(list true true false))
|
||
;; the type definition is READABLE on a type's PUBLIC page (read-only view of the same data).
|
||
(host-bl-test "the public type-def view shows fields, block grammar, and allowed relations"
|
||
(let ((html (render-page (host/blog--type-def-view "article"))))
|
||
(list (contains? html "Type definition") (contains? html "subtitle")
|
||
(contains? html "may contain") (contains? html "Instances may be linked by")))
|
||
(list true true true true))
|
||
(host-bl-test "GET /article/ (public) shows the type definition; an instance's page does not"
|
||
(list (contains? (dream-resp-body (host-bl-app (host-bl-req "/article/"))) "Type definition")
|
||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/my-first-post/"))) "Type definition"))
|
||
(list true false))
|
||
;; a type's page shows its POPULATION too — instances (is-a) + subtypes (schema + extension).
|
||
(host-bl-test "the type-population section lists a type's instances + count"
|
||
(begin
|
||
(host/blog-put! "pop-inst" "PopInst" "(article (h1 \"x\"))" "published")
|
||
(host/blog-relate! "pop-inst" "article" "is-a")
|
||
(let ((html (render-page (host/blog--type-population "article"))))
|
||
(list (contains? html "Population") (contains? html "pop-inst") (contains? html "instance"))))
|
||
(list true true true))
|
||
(host-bl-test "a parent type's population lists its subtypes"
|
||
(contains? (render-page (host/blog--type-population "card")) "Subtypes") true)
|
||
(host-bl-test "GET /article/ shows the Population section"
|
||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/article/"))) "Population") true)
|
||
;; the Landing demo: a type with TWO composition fields, an instance populated in both,
|
||
;; idempotent (re-seeding doesn't duplicate). Renders both fields; the aside forbids controls.
|
||
(host-bl-test "the landing demo seeds a 2-field type + instance (idempotent)"
|
||
(begin
|
||
(host/blog-seed-landing-demo!) (host/blog-seed-landing-demo!) ;; twice -> must not duplicate
|
||
(list (host/blog--composition-fields "landing-demo")
|
||
(len (host/blog--comp-nodes "landing-demo" "body"))
|
||
(len (host/blog--comp-nodes "landing-demo" "aside"))
|
||
(host/blog--allows-control? "landing-demo" "aside" "cond")))
|
||
(list (list "body" "aside") 2 2 false))
|
||
(host-bl-test "GET /landing-demo/ renders BOTH composition fields"
|
||
(let ((html (dream-resp-body (host-bl-app (host-bl-req "/landing-demo/")))))
|
||
(list (contains? html "Welcome to the Landing Demo") (contains? html "ASIDE composition")))
|
||
(list true true))
|
||
;; the editor renders a HAND-AUTHORED composition (text/row/alt-with-text) WITHOUT falling
|
||
;; through to "(unknown block)" — every node kind gets a labelled row (the compose-demo case).
|
||
(host-bl-test "the block editor renders text/layout/inline-alt nodes (no unknown block)"
|
||
(begin
|
||
(host/blog-put! "mixdoc" "Mix" "(article)" "published")
|
||
(host/blog--set-body! "mixdoc"
|
||
(quote (seq
|
||
(text "<p>intro</p>")
|
||
(alt (when (has "auth") (text "member")) (else (text "guest")))
|
||
(row (text "A") (text "B"))
|
||
(each (query is-a compose-item) (seq (text "x"))))))
|
||
(let ((html (render-page (host/blog--block-editor "mixdoc" "body"))))
|
||
(list (contains? html "unknown block")
|
||
(contains? html "text") (contains? html "layout") (contains? html "for each"))))
|
||
(list false true true true))
|
||
;; -- /workflow-demo: ONE composition object run through the EXECUTE-fold (step 7 live). The
|
||
;; same :body structure the render-fold renders, folded to an effect log (status=ready ->
|
||
;; validate, publish, notify each — not hold). --
|
||
(host-bl-test "GET /workflow-demo runs the composition through the execute-fold"
|
||
(begin
|
||
(host/blog-seed-workflow-demo!)
|
||
(let ((html (dream-resp-body (host-bl-app (host-bl-req "/workflow-demo")))))
|
||
(list (contains? html "validate") (contains? html "publish")
|
||
(contains? html "notify") (contains? html "hold"))))
|
||
(list true true true false))
|
||
(host-bl-test "a post with no schema'd type is vacuously valid"
|
||
(host/blog-type-valid? "ppost" "(p \"anything\")") true)
|
||
(host-bl-test "edit-submit rejects content violating the type schema (not saved)"
|
||
(begin
|
||
(host-bl-wapp (host-bl-send "POST" "/art1/edit" "Bearer good"
|
||
"application/x-www-form-urlencoded" "sx_content=(p+%22still+no+heading%22)"))
|
||
(contains? (dream-resp-body (host-bl-wapp (host-bl-req "/art1/"))) "still no heading"))
|
||
false)
|
||
(host-bl-test "edit-submit accepts content satisfying the schema -> 303"
|
||
(dream-status (host-bl-wapp (host-bl-send "POST" "/art1/edit" "Bearer good"
|
||
"application/x-www-form-urlencoded" "sx_content=(article+(h1+%22Heading%22)+(p+%22body%22))")))
|
||
303)
|
||
|
||
;; -- 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))
|
||
(host-bl-test "open create no auth -> 303"
|
||
(dream-status (host-bl-oapp (host-bl-send "POST" "/new" nil
|
||
"application/x-www-form-urlencoded" "title=Open+Post&sx_content=(p+%22o%22)&status=published")))
|
||
303)
|
||
(host-bl-test "open-created post renders"
|
||
(contains? (dream-resp-body (host-bl-oapp (host-bl-req "/open-post/"))) "<p>o</p>")
|
||
true)
|
||
|
||
;; ── content-addressing: every object carries a stable CID ───────────
|
||
;; A CID is the hash of the canonical (key-sorted) content; the slug (a name) and
|
||
;; any prior :cid are excluded. Same content -> same CID, across slugs and processes.
|
||
(host/blog-use-store! (persist/open))
|
||
(host/blog-put! "cid-a" "Same Body" "(p \"same\")" "published")
|
||
(host/blog-put! "cid-b" "Same Body" "(p \"same\")" "published")
|
||
(host-bl-test "put! stamps a non-nil CID"
|
||
(and (not (nil? (host/blog-cid "cid-a"))) (> (len (host/blog-cid "cid-a")) 1)) true)
|
||
(host-bl-test "content-addressed: identical content -> identical CID (slug excluded)"
|
||
(= (host/blog-cid "cid-a") (host/blog-cid "cid-b")) true)
|
||
(host-bl-test "CID changes when content changes"
|
||
(let ((before (host/blog-cid "cid-a")))
|
||
(host/blog-put! "cid-a" "Same Body" "(p \"different now\")" "published")
|
||
(not (= before (host/blog-cid "cid-a"))))
|
||
true)
|
||
(host-bl-test "canon excludes :slug and :cid"
|
||
(= (host/blog--canon {:slug "x" :cid "old" :title "T"})
|
||
(host/blog--canon {:title "T"}))
|
||
true)
|
||
(host-bl-test "by-cid reverse lookup finds a slug with that CID"
|
||
(not (nil? (host/blog-by-cid (host/blog-cid "cid-b")))) true)
|
||
(host-bl-test "by-cid of an unknown CID is nil"
|
||
(host/blog-by-cid "znope-nope") nil)
|
||
|
||
;; ── P0.1: business-logic fed-flows — the publish-activity contract ──
|
||
;; a published post is described as a fed-sx create activity that next/'s trigger machinery
|
||
;; consumes; category (drives the flow branch) comes from a field-value, else a tag, else urgent.
|
||
(host-bl-test "P0.4: publish-activity is the CANONICAL seam shape (:verb :object=cid :object-type :slug :category :id)"
|
||
(begin
|
||
(host/blog-put! "pub1" "Pub One" "(article (h1 \"P\"))" "published")
|
||
(host/blog--set-field-values! "pub1" {"category" "newsletter"})
|
||
(let ((a (host/blog--publish-activity "pub1")))
|
||
(list (get a :verb) (get a :object-type) (get a :category) (get a :slug)
|
||
(= (get a :object) (get a :id)) (not (nil? (get a :id))))))
|
||
(list "create" "article" "newsletter" "pub1" true true))
|
||
(host-bl-test "publish-activity category falls back to a tag, else urgent"
|
||
(begin
|
||
(host/blog-put! "pub2" "Pub Two" "(article (h1 \"Q\"))" "published")
|
||
(host/blog-seed! "urgent" "Urgent" "(article (h1 \"u\"))" "published")
|
||
(host/blog-relate! "pub2" "urgent" "tagged")
|
||
(host/blog-put! "pub3" "Pub Three" "(article (h1 \"R\"))" "published") ;; no field, no tag
|
||
(list (get (host/blog--publish-activity "pub2") :category)
|
||
(get (host/blog--publish-activity "pub3") :category)))
|
||
(list "urgent" "urgent"))
|
||
(host-bl-test "publish-activity of a missing post is nil"
|
||
(host/blog--publish-activity "nope-nope-nope") nil)
|
||
;; P0.4: the marshaller maps the canonical shape → next/'s Erlang proplist (for the RA runner).
|
||
(host-bl-test "activity->erl marshals canonical → next/ proplist ({type,object:{type,slug,category}})"
|
||
(begin
|
||
(host/blog-put! "pub4" "P4" "(article (h1 \"m\"))" "published")
|
||
(host/blog--set-field-values! "pub4" {"category" "newsletter"})
|
||
(let ((e (host/blog--activity->erl (host/blog--publish-activity "pub4"))))
|
||
(list (get e :type) (get (get e :object) :type)
|
||
(get (get e :object) :slug) (get (get e :object) :category))))
|
||
(list "create" "article" "pub4" "newsletter"))
|
||
;; P0 review regression: field-writes must PRECEDE the transition, else the publish activity
|
||
;; branches on the stale category. (edit-submit now sets fields before maybe-publish!.)
|
||
(host-bl-test "publish reads the FRESH category (fields set before the transition fires)"
|
||
(begin
|
||
(set! host/blog--flow-log (list))
|
||
(persist/backend-kv-put host/blog-store host/blog--flowlog-key (list))
|
||
(host/blog-put! "p04r" "R" "(article (h1 \"r\"))" "draft") ;; a draft, no category yet
|
||
(host/blog--set-field-values! "p04r" {"category" "newsletter"}) ;; fields FIRST (the fix order)
|
||
(host/blog--maybe-publish! "p04r" "draft" "published") ;; then the transition
|
||
(map (fn (e) (get e "verb")) host/blog--flow-log))
|
||
(list "validate" "digest")) ;; newsletter→digest, not stale→notify
|
||
;; P0.2: the publish WORKFLOW as an execute-fold DAG — branches on category, needs {effect,branch},
|
||
;; binds to the synchronous execute-fold runner (derived, not chosen).
|
||
(host-bl-test "publish-DAG: category branch (newsletter→digest) via the execute-fold"
|
||
(begin
|
||
(host/blog-put! "pdag1" "P" "(article (h1 \"x\"))" "published")
|
||
(host/blog--set-field-values! "pdag1" {"category" "newsletter"})
|
||
(let ((act (host/blog--publish-activity "pdag1")))
|
||
(map (fn (e) (get e :verb))
|
||
(get ((get host/flow--exec-runner :run) host/blog--publish-dag {:ctx (host/blog--publish-ctx act)}) :effects))))
|
||
(list "validate" "digest"))
|
||
(host-bl-test "publish-DAG: urgent→notify now, other→skip"
|
||
(list (map (fn (e) (get e :verb)) (get ((get host/flow--exec-runner :run) host/blog--publish-dag {:ctx {"category" "urgent" "slug" "s"}}) :effects))
|
||
(map (fn (e) (get e :verb)) (get ((get host/flow--exec-runner :run) host/blog--publish-dag {:ctx {"category" "draft" "slug" "s"}}) :effects)))
|
||
(list (list "validate" "notify") (list "validate" "skip")))
|
||
(host-bl-test "publish-DAG requires {effect,branch} and binds to the sync runner (derived)"
|
||
(list (host/flow--required-caps host/blog--publish-dag)
|
||
(get (host/flow--bind host/flow--exec-runner host/blog--publish-dag) :ok))
|
||
(list (list "effect" "branch") true))
|
||
;; P0.3: the draft→published TRANSITION fires the publish flow THROUGH THE SEAM (engine = the
|
||
;; execute-fold runner + on-publish registry + transport + host driver) → effects land in the flow log.
|
||
(set! host/blog--flow-log (list))
|
||
(set! host/blog--activity-log (list))
|
||
(host-bl-test "P0.3: draft→published fires the publish flow through the seam → effects logged"
|
||
(begin
|
||
(host/blog-put! "p03a" "P" "(article (h1 \"x\"))" "published")
|
||
(host/blog--set-field-values! "p03a" {"category" "newsletter"})
|
||
(host/blog--maybe-publish! "p03a" "draft" "published")
|
||
(list (map (fn (e) (get e :verb)) host/blog--flow-log) (len host/blog--activity-log)))
|
||
(list (list "validate" "digest") 1))
|
||
(host-bl-test "P0.3: published→published does NOT re-fire (fire-once on the transition)"
|
||
(begin
|
||
(host/blog--maybe-publish! "p03a" "published" "published")
|
||
(list (map (fn (e) (get e :verb)) host/blog--flow-log) (len host/blog--activity-log)))
|
||
(list (list "validate" "digest") 1))
|
||
(host-bl-test "P0.3: a →draft transition does not fire"
|
||
(begin (host/blog--maybe-publish! "p03a" "published" "draft") (len host/blog--activity-log)) 1)
|
||
(host-bl-test "P0.3: a fresh nil→published (new post) fires, urgent→notify"
|
||
(begin
|
||
(host/blog-put! "p03b" "U" "(article (h1 \"u\"))" "published")
|
||
(host/blog--set-field-values! "p03b" {"category" "urgent"})
|
||
(host/blog--maybe-publish! "p03b" nil "published")
|
||
(map (fn (e) (get e "verb")) host/blog--flow-log))
|
||
(list "validate" "digest" "validate" "notify"))
|
||
;; P0.3b: the flow log is DURABLE — it round-trips through the blog store (survives a restart).
|
||
(host-bl-test "P0.3b: the flow log persists + reloads from the store (string-keyed, no split)"
|
||
(begin
|
||
(set! host/blog--flow-log (list))
|
||
(persist/backend-kv-put host/blog-store host/blog--flowlog-key (list)) ;; reset durable
|
||
(host/blog-put! "p03d" "D" "(article (h1 \"d\"))" "published")
|
||
(host/blog--set-field-values! "p03d" {"category" "newsletter"})
|
||
(host/blog--maybe-publish! "p03d" "draft" "published") ;; fires → persists
|
||
(let ((before (map (fn (e) (get e "verb")) host/blog--flow-log)))
|
||
(begin
|
||
(set! host/blog--flow-log (list)) ;; simulate a restart
|
||
(host/blog-load-flowlog!) ;; reload from the store
|
||
(list before (map (fn (e) (get e "verb")) host/blog--flow-log)))))
|
||
(list (list "validate" "digest") (list "validate" "digest")))
|
||
|
||
(define
|
||
host-bl-tests-run!
|
||
(fn ()
|
||
{:total (+ host-bl-pass host-bl-fail)
|
||
:passed host-bl-pass :failed host-bl-fail :fails host-bl-fails}))
|