coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
f8b96b3d8188e76264cdd40be0d245df52a4c6f1
rose-ash/lib/host/tests/blog.sx
giles f8b96b3d81 H6: durable activity dedup — same :id processed at most once, ever (TDD) 
Failing tests first (3 red: a redelivered activity reran its behavior — behavior/process starts
from an empty trace, so dedup evaporated per call). host/blog--process-local! now atomically
claims the :id on persist stream 'activities:processed' via ev/book! (the same append-expect
acquire as seats/votes) and returns a :deduped trace on duplicates. Store-backed → survives outbox
retries AND restarts. Prerequisite for non-idempotent effects (payment). Id-less activities process
unchecked.

blog suite 250/250 (+3).

Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
2026-07-03 10:45:55 +00:00

1542 lines
88 KiB
Plaintext
Raw Blame History

This file contains ambiguous Unicode characters
This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
;; 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/blog--load-behaviors!) ;; P1: gather types' declared behaviors into the registry (as boot does)
(host-bl-test "P1: load-behaviors! gathers the article type's declared on-publish binding"
(list (>= (len host/blog--behaviors) 1)
(contains? (map (fn (b) (get b "dag")) host/blog--behaviors) "publish"))
(list true true))
(host-bl-test "P1: match-behaviors resolves a create/article activity → a binding with a DERIVED runner"
(let ((ms (host/blog--match-behaviors {:verb "create" :object-type "article"})))
(list (len ms) (get (get (first ms) :runner) :capabilities)))
(list 1 (list "effect" "branch" "each")))
(host-bl-test "P1: a non-article activity matches nothing"
(len (host/blog--match-behaviors {:verb "create" :object-type "note"})) 0)
(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/P2: publish-activity is the CANONICAL seam shape (:verb :object=cid :object-type :slug :category); :id is per-event (create:cid)"
(begin
(host/blog-put! "pub1" "Pub One" "(article (h1 \"P\"))" "published")
(host/blog-relate! "pub1" "article" "is-a")
(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 :id) (str "create:" (get a :object))) (not (= (get a :object) (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
;; ── P2: state-change → activity emission (ALL events, not just publish) ──
(host-bl-test "P2: a relate emits an ADD activity with an EDGE-based id (DEBT #1 — no CID collision)"
(begin
(set! host/blog--activity-log (list))
(host/blog-put! "p2r" "R" "(article (h1 \"r\"))" "published")
(host/blog--emit-relation! "add" "p2r" "tagged" "urgent")
(let ((a (first host/blog--activity-log)))
(list (get a "verb") (get a "id"))))
(list "add" "add:p2r:tagged:urgent"))
(host-bl-test "P2: an unrelate emits a REMOVE activity (edge id, no CID)"
(begin
(set! host/blog--activity-log (list))
(host/blog--emit-relation! "remove" "p2r" "tagged" "urgent")
(let ((a (first host/blog--activity-log)))
(list (get a "verb") (get a "id"))))
(list "remove" "remove:p2r:tagged:urgent"))
(host-bl-test "P2: relation :id ≠ content :id — DIFFERENT edges on one object don't collide"
(list (get (host/blog--relation-activity "add" "x" "tagged" "a") :id)
(get (host/blog--relation-activity "add" "x" "tagged" "b") :id))
(list "add:x:tagged:a" "add:x:tagged:b"))
(host-bl-test "P2: the activity log is DURABLE (round-trips through the store)"
(begin
(set! host/blog--activity-log (list))
(persist/backend-kv-put host/blog-store host/blog--activitylog-key (list))
(host/blog--emit-relation! "add" "p2d" "related" "p2e")
(let ((before (len host/blog--activity-log)))
(begin (set! host/blog--activity-log (list)) (host/blog-load-activitylog!)
(list before (len host/blog--activity-log)))))
(list 1 1))
;; TA-live: a RECEIVED activity (a peer's, arriving via /inbox) fires OUR behaviors through the engine.
(host-bl-test "TA-live: a received create/article activity fires our on-create behavior"
(begin
(set! host/blog--flow-log (list))
(host/blog--receive! {:verb "create" :object-type "article" :category "urgent" :slug "remote1" :id "create:remote1"})
(map (fn (e) (get e "verb")) host/blog--flow-log))
(list "validate" "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 CREATE 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)
(get (first host/blog--activity-log) "verb")))
(list (list "validate" "digest") "create"))
(host-bl-test "P0.3/P2: published→published emits UPDATE (not a re-fired create — no new create effects)"
(begin
(set! host/blog--flow-log (list))
(set! host/blog--activity-log (list))
(host/blog--emit-content-change! "p03a" "published" "published")
(list (len host/blog--flow-log) (get (first host/blog--activity-log) "verb")))
(list 0 "update"))
(host-bl-test "P0.3: a →draft transition emits nothing (unobservable)"
(begin
(set! host/blog--activity-log (list))
(host/blog--emit-content-change! "p03a" "published" "draft")
(len host/blog--activity-log)) 0)
(host-bl-test "P0.3: a fresh nil→published (new post) fires create, urgent→notify"
(begin
(set! host/blog--flow-log (list))
(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" "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")))
;; ── HARDENING H1: internal endpoints (/ticket /order /person) are HMAC-gated ─────────────
;; With a fed-secret set, an UNSIGNED POST is 403 and creates nothing; a SIGNED one
;; (x-int-sig = sess-sig(secret, target)) works. Secret unset ("") = open (dev/test compat).
(host/blog-use-store! (persist/open))
(define host-bl-h1-secret "test-int-secret")
(host/blog--set-fed-secret! host-bl-h1-secret)
(define host-bl-h1-app (host/make-app (list host/blog-routes)))
(define host-bl-h1-post
(fn (target sig)
(host-bl-h1-app (dream-request "POST" target
(if sig {:x-int-sig (dr/sess-sig host-bl-h1-secret target)} {}) ""))))
(host-bl-test "H1: unsigned /ticket -> 403"
(dream-status (host-bl-h1-post "/ticket?showing=sh1&offering=sh1--adult&email=a@x.com" false)) 403)
(host-bl-test "H1: unsigned /ticket creates NO ticket"
(len (filter (fn (s) (starts-with? s "ticket-")) (host/blog-slugs))) 0)
(host-bl-test "H1: signed /ticket -> 200 ticket:*"
(starts-with? (dream-resp-body (host-bl-h1-post "/ticket?showing=sh1&offering=sh1--adult&email=a@x.com" true)) "ticket:")
true)
(host-bl-test "H1: unsigned /order -> 403"
(dream-status (host-bl-h1-post "/order?event=sh1" false)) 403)
(host-bl-test "H1: unsigned /person -> 403"
(dream-status (host-bl-h1-post "/person?email=a@x.com" false)) 403)
(host-bl-test "H1: signed /person -> 200 person:*"
(starts-with? (dream-resp-body (host-bl-h1-post "/person?email=a@x.com" true)) "person:")
true)
(host/blog--set-fed-secret! "")
(host-bl-test "H1: secret unset -> /person open (dev compat)"
(starts-with? (dream-resp-body (host-bl-h1-post "/person?email=b@x.com" false)) "person:")
true)
;; ── HARDENING H2: cinema/poll ADMIN ops require auth; customer ops stay public ────────────
;; new-film / new-showing / offering-* / add-poll / new-event live behind protect-html (like /new);
;; /vote and /buy-ticket remain public (voters + customers).
(host/blog-use-store! (persist/open))
(define host-bl-h2-app
(host/make-app (list (host/blog-write-routes host-bl-resolve) host/blog-routes)))
(define host-bl-h2-loc
(fn (method target auth body)
(or (dream-resp-header
(host-bl-h2-app (host-bl-send method target auth "application/x-www-form-urlencoded" body))
"location") "")))
(host-bl-test "H2: unauth /new-film -> login redirect"
(starts-with? (host-bl-h2-loc "POST" "/new-film" false "title=Sneaky") "/login") true)
(host-bl-test "H2: unauth /new-film creates NO film"
(contains? (host/blog-slugs) "sneaky") false)
(host-bl-test "H2: authed /new-film creates the film"
(begin (host-bl-h2-loc "POST" "/new-film" "Bearer good" "title=Legit Film")
(contains? (host/blog--out-raw "legit-film" "is-a") "film"))
true)
(host-bl-test "H2: unauth /new-showing -> login redirect"
(starts-with? (host-bl-h2-loc "POST" "/new-showing" false "film=legit-film&calendar=c1&time=t") "/login") true)
(host-bl-test "H2: unauth /add-poll -> login redirect"
(starts-with? (host-bl-h2-loc "POST" "/add-poll?post=x" false "question=Q&options=a,b") "/login") true)
(host-bl-test "H2: unauth /offering-add -> login redirect"
(starts-with? (host-bl-h2-loc "POST" "/offering-add?showing=x" false "tickettype=tt&price=1") "/login") true)
(host-bl-test "H2: unauth /new-event -> login redirect"
(starts-with? (host-bl-h2-loc "POST" "/new-event" false "title=E") "/login") true)
(host-bl-test "H2: /vote stays PUBLIC (no login redirect)"
(starts-with? (host-bl-h2-loc "POST" "/vote?poll=p&option=o" false "voter=v@x.com") "/login") false)
(host-bl-test "H2: /buy-ticket stays PUBLIC (no login redirect)"
(starts-with? (host-bl-h2-loc "POST" "/buy-ticket?showing=s&offering=o" false "email=v@x.com") "/login") false)
;; ── HARDENING H3: votes are ATOMIC claims on the persist stream (not edge-scan dedup) ─────
;; One vote per voter per poll enforced by an ev/book!-style acquire on stream "vote:<poll>" —
;; the same append-expect atomicity as seats. The edge is a projection; the stream is truth.
(host/blog-use-store! (persist/open))
(host/blog-put! "h3-poll" "Q" "(article (h1 \"p\"))" "published")
(host/blog-relate! "h3-poll" "poll" "is-a")
(for-each (fn (o) (begin (host/blog-put! o o "(article (h1 \"o\"))" "published")
(host/blog-relate! "h3-poll" o "option")))
(list "h3-opt-a" "h3-opt-b"))
(define host-bl-h3-vote
(fn (opt voter)
(host-bl-h2-app (dream-request "POST" (str "/vote?poll=h3-poll&option=" opt)
{:content-type "application/x-www-form-urlencoded"} (str "voter=" voter)))))
(host-bl-test "H3: first vote lands"
(begin (host-bl-h3-vote "h3-opt-a" "v1@x.com")
(contains? (host/blog--out-raw "h3-opt-a" "voted") "v1@x.com"))
true)
(host-bl-test "H3: second vote by same voter refused (different option)"
(begin (host-bl-h3-vote "h3-opt-b" "v1@x.com")
(contains? (host/blog--out-raw "h3-opt-b" "voted") "v1@x.com"))
false)
(host-bl-test "H3: the vote is on the persist stream (roster of vote:<poll>)"
(contains? (ev/roster host/blog-store "vote:h3-poll") "v1@x.com")
true)
(host-bl-test "H3: dedup is store-backed — survives edge removal (NOT an edge scan)"
(begin
(host-bl-h3-vote "h3-opt-a" "v2@x.com")
(host/blog-unrelate! "h3-opt-a" "v2@x.com" "voted") ;; wipe the projection
(host-bl-h3-vote "h3-opt-b" "v2@x.com") ;; revote attempt
(contains? (host/blog--out-raw "h3-opt-b" "voted") "v2@x.com"))
false)
;; ── HARDENING H4: P2 restored — cinema/poll state changes EMIT activities ─────────────────
;; Every mutation goes through host/blog--emit! (engine + durable activity log + outbox), so
;; federation followers + other peers' behaviors can react. Votes emit voter-ANONYMOUSLY.
(host/blog-use-store! (persist/open))
(define host-bl-h4-verbs
(fn () (map (fn (e) (get e "verb")) host/blog--activity-log)))
(define host-bl-h4-admin
(fn (target body)
(host-bl-h2-app (host-bl-send "POST" target "Bearer good" "application/x-www-form-urlencoded" body))))
(host-bl-test "H4: new-film emits create(film)"
(begin
(set! host/blog--activity-log (list))
(host-bl-h4-admin "/new-film" "title=Emit Film")
(map (fn (e) (list (get e "verb") (get e "object") (get e "type"))) host/blog--activity-log))
(list (list "create" "emit-film" "film")))
(host-bl-test "H4: new-showing emits schedule(showing)"
(begin
(set! host/blog--activity-log (list))
(host-bl-h4-admin "/new-showing" "film=emit-film&calendar=h4cal&time=t1")
(contains? (host-bl-h4-verbs) "schedule"))
true)
(host-bl-test "H4: offering-add emits offer(offering)"
(begin
(set! host/blog--activity-log (list))
(host-bl-h4-admin "/offering-add?showing=emit-film-h4cal-t1" "tickettype=h4-vip&price=9")
(contains? (host-bl-h4-verbs) "offer"))
true)
(host-bl-test "H4: offering-update emits update(offering)"
(begin
(set! host/blog--activity-log (list))
(host-bl-h4-admin "/offering-update?offering=emit-film-h4cal-t1--h4-vip" "price=12&cap=5")
(contains? (host-bl-h4-verbs) "update"))
true)
(host-bl-test "H4: add-poll emits create(poll)"
(begin
(set! host/blog--activity-log (list))
(host-bl-h4-admin "/add-poll?post=emit-film" "question=Q&options=a,b")
(contains? (host-bl-h4-verbs) "create"))
true)
(host-bl-test "H4: vote emits vote — voter NOT in the logged activity"
(begin
(set! host/blog--activity-log (list))
(let ((poll (first (host/blog--out-raw "emit-film" "has-poll"))))
(begin
(host-bl-h2-app (dream-request "POST" (str "/vote?poll=" poll "&option=" poll "-a")
{:content-type "application/x-www-form-urlencoded"} "voter=secret@x.com"))
(list (contains? (host-bl-h4-verbs) "vote")
(some (fn (e) (contains? (str e) "secret@x.com")) host/blog--activity-log)))))
(list true false))
;; ── HARDENING H5: hold→confirm→release — a failed mint must NOT consume the seat ──────────
;; The buy is two-phase: ev/hold! reserves; the mint (injectable seam host/blog--mint-ticket) runs
;; guarded; success → ev/confirm! + sold edges + a sell activity; failure/raise → ev/release!.
(host/blog-use-store! (persist/open))
(host/blog-put! "h5-show" "H5 Showing" "(article (h1 \"s\"))" "published")
(host/blog-relate! "h5-show" "showing" "is-a")
(host/blog--set-field-values! "h5-show" {"capacity" "2"})
(host/blog-put! "h5-show--adult" "adult @ h5" "(article (h1 \"o\"))" "published")
(host/blog-relate! "h5-show" "h5-show--adult" "offers")
(define host-bl-h5-shop-was host/blog--shop-base)
(define host-bl-h5-mint-was host/blog--mint-ticket)
(set! host/blog--shop-base "http://mock-shop")
(define host-bl-h5-buy
(fn (email)
(host-bl-h2-app (dream-request "POST" "/buy-ticket?showing=h5-show&offering=h5-show--adult"
{:content-type "application/x-www-form-urlencoded"} (str "email=" email)))))
(host-bl-test "H5: FAILED mint releases the seat (no leak)"
(begin
(set! host/blog--mint-ticket (fn (s o e) "")) ;; shop says no
(host-bl-h5-buy "leak@x.com")
(len (ev/roster host/blog-store "h5-show")))
0)
(host-bl-test "H5: RAISING mint also releases (guarded)"
(begin
(set! host/blog--mint-ticket (fn (s o e) (raise "shop down")))
(host-bl-h5-buy "crash@x.com")
(len (ev/roster host/blog-store "h5-show")))
0)
(host-bl-test "H5: successful mint confirms seat + sold edge + sell activity"
(begin
(set! host/blog--mint-ticket (fn (s o e) "ticket:h5-t1"))
(set! host/blog--activity-log (list))
(host-bl-h5-buy "ok@x.com")
(list (len (ev/roster host/blog-store "h5-show"))
(contains? (host/blog--out-raw "h5-show" "sold") "h5-t1")
(contains? (map (fn (e) (get e "verb")) host/blog--activity-log) "sell")))
(list 1 true true))
(set! host/blog--shop-base host-bl-h5-shop-was)
(set! host/blog--mint-ticket host-bl-h5-mint-was)
;; ── HARDENING H6: DURABLE activity dedup — same :id processed at most once, store-backed ──
;; behavior/process starts from an empty trace each call, so redelivery (outbox retry, restart
;; replay) reran behaviors. Now process-local! atomically claims the id on stream
;; "activities:processed" (ev/book! — same acquire as seats/votes) and skips duplicates.
;; Prerequisite for any NON-idempotent effect (payment).
(host/blog-use-store! (persist/open))
(host/blog-seed! "h6type" "h6type" "(article (h1 \"t\"))" "published")
(host/blog--register-dag! "h6-dag" (quote (effect h6-ping (field "slug"))))
(host/blog--set-type-behavior! "h6type" (list {"verb" "ping" "type" "h6type" "dag" "h6-dag"}))
(host/blog--load-behaviors!)
(set! host/blog--flow-log (list))
(define host-bl-h6-act
{:verb "ping" :actor "test" :object "h6x" :object-type "h6type" :slug "h6x"
:delta "ping" :id "ping:h6x"})
(host-bl-test "H6: same activity id processed twice -> behavior runs ONCE"
(begin
(host/blog--process-local! host-bl-h6-act)
(host/blog--process-local! host-bl-h6-act) ;; redelivery
(len (filter (fn (e) (= (get e "verb") "h6-ping")) host/blog--flow-log)))
1)
(host-bl-test "H6: the processed id is on the store (survives restarts)"
(contains? (ev/roster host/blog-store "activities:processed") "ping:h6x")
true)
(host-bl-test "H6: a DIFFERENT id still processes"
(begin
(host/blog--process-local! (assoc host-bl-h6-act :id "ping:h6y" :slug "h6y" :object "h6y"))
(len (filter (fn (e) (= (get e "verb") "h6-ping")) host/blog--flow-log)))
2)
(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}))
Reference in New Issue View Git Blame Copy Permalink