giles
bdc7e02fbc
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 37s
Three composing pieces that make the blog SPA correct and resilient.
Content-addressed module cache (lib/host/static.sx, serve.sh, blog.sx shell,
conformance.sh): index each web-stack .sxbc by the content hash in its head,
serve GET /sx/h/{hash} immutable text/sx, and emit <script data-sx-manifest>
{file->hash} so the WASM client loads modules content-addressed (localStorage +
immutable) instead of path + max-age. serve.sh builds the index at boot;
conformance.sh now loads static.sx before blog.sx (the shell calls
host/static-manifest-json).
Declarative relate picker (lib/host/blog.sx, lib/dream/form.sx): replace the
inline /relate-picker.js blob — which never ran on swapped-in content, so the
candidate list was empty after a boosted nav to /<slug>/edit — with a declarative
SX-htmx form: sx-get relate-options on "load" + debounced "input", innerHTML-swap
the results ul; infinite scroll via a server-emitted "load more" sentinel
(sx-trigger revealed, sx-swap outerHTML) that pages the rest, q preserved via a
new symmetric dr/url-encode. The engine re-binds these triggers on swapped
content, so the picker populates on full load AND boosted SPA nav. Candidate
relate forms get :sx-disable (plain POST->303->reload, their original behavior;
the engine would otherwise boost them and swap the redirect unreliably).
sx-retry "exponential:1000:30000" on the form+sentinel retries a dropped/offline
fetch forever (the cap bounds the interval, not the attempts).
SIGPIPE hardening (hosts/ocaml/bin/sx_server.ml): the native http-listen server
had no SIGPIPE handler, so a client aborting an in-flight fetch (the engine
cancels superseded requests on a debounced filter/fast nav) closed the socket
mid-write and killed the whole process (exit 141). Ignore SIGPIPE so the failed
write becomes a catchable Sys_error the per-connection handler already swallows.
Tests: host conformance 272/272; relate-picker.spec.js 5/5 incl. a boosted-nav
populate regression; spa-check 4/4.
Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
480 lines
25 KiB
Plaintext
480 lines
25 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 "json 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 --
|
||
(host-bl-test "json create -> 201"
|
||
(dream-status (host-bl-wapp (host-bl-send "POST" "/posts" "Bearer good" "application/json"
|
||
"{\"title\":\"Json Post\",\"sx_content\":\"(p \\\"jp\\\")\",\"status\":\"draft\"}")))
|
||
201)
|
||
(host-bl-test "json create unpermitted -> 403"
|
||
(dream-status (host-bl-wapp (host-bl-send "POST" "/posts" "Bearer weak" "application/json"
|
||
"{\"title\":\"Nope\"}")))
|
||
403)
|
||
(host-bl-test "json create duplicate -> 409"
|
||
(dream-status (host-bl-wapp (host-bl-send "POST" "/posts" "Bearer good" "application/json"
|
||
"{\"slug\":\"json-post\",\"title\":\"Json Post\"}")))
|
||
409)
|
||
(host-bl-test "json create no title -> 400"
|
||
(dream-status (host-bl-wapp (host-bl-send "POST" "/posts" "Bearer good" "application/json" "{}")))
|
||
400)
|
||
(host-bl-test "update -> 200"
|
||
(dream-status (host-bl-wapp (host-bl-send "PUT" "/posts/json-post" "Bearer good" "application/json"
|
||
"{\"sx_content\":\"(p \\\"edited\\\")\"}")))
|
||
200)
|
||
(host-bl-test "update changed content"
|
||
(contains? (dream-resp-body (host-bl-wapp (host-bl-req "/json-post/"))) "edited")
|
||
true)
|
||
(host-bl-test "update missing -> 404"
|
||
(dream-status (host-bl-wapp (host-bl-send "PUT" "/posts/ghost" "Bearer good" "application/json" "{}")))
|
||
404)
|
||
(host-bl-test "delete -> 200"
|
||
(dream-status (host-bl-wapp (host-bl-send "DELETE" "/posts/json-post" "Bearer good" "" "")))
|
||
200)
|
||
(host-bl-test "deleted -> 404" (dream-status (host-bl-wapp (host-bl-req "/json-post/"))) 404)
|
||
(host-bl-test "delete missing -> 404"
|
||
(dream-status (host-bl-wapp (host-bl-send "DELETE" "/posts/ghost" "Bearer good" "" "")))
|
||
404)
|
||
|
||
;; -- 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)
|
||
(host-bl-test "json create malformed sx_content -> 400"
|
||
(dream-status (host-bl-wapp (host-bl-send "POST" "/posts" "Bearer good" "application/json"
|
||
"{\"title\":\"Bad Json\",\"sx_content\":\"<h1 broken)\"}")))
|
||
400)
|
||
(host-bl-test "rejected json post was not stored"
|
||
(dream-status (host-bl-wapp (host-bl-req "/bad-json/")))
|
||
404)
|
||
(host-bl-test "json update malformed sx_content -> 400"
|
||
(dream-status (host-bl-wapp (host-bl-send "PUT" "/posts/my-first-post" "Bearer good"
|
||
"application/json" "{\"sx_content\":\"<h1 broken)\"}")))
|
||
400)
|
||
(host-bl-test "rejected update left content intact"
|
||
(contains? (dream-resp-body (host-bl-wapp (host-bl-req "/my-first-post/"))) "<h1>My First Post</h1>")
|
||
true)
|
||
|
||
;; -- 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.
|
||
(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))
|
||
(host-bl-test "delete cleans up related edges"
|
||
(begin
|
||
(host-bl-wapp (host-bl-send "POST" "/my-first-post/relate" "Bearer good"
|
||
"application/x-www-form-urlencoded" "other=another-one"))
|
||
(host-bl-wapp (host-bl-send "DELETE" "/posts/another-one" "Bearer good" "" ""))
|
||
(contains? (host/blog-related "my-first-post") "another-one"))
|
||
false)
|
||
|
||
;; -- 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"))))
|
||
(list (contains? html "/alpha-post/relate-options")
|
||
(contains? html "input delay:200ms, load")
|
||
(contains? html "rp-related-results")))
|
||
(list true 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))
|
||
(host-bl-test "relate-options omits the load-more sentinel on a short last page"
|
||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/alpha-post/relate-options"))) "rp-more")
|
||
false)
|
||
(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)
|
||
|
||
;; -- Phase 3: tags as posts -- (ocaml is-a tag, from the seed-types test above)
|
||
(host-bl-test "is-tag?: a post that is-a tag is a tag; others are not"
|
||
(list (host/blog-is-tag? "ocaml") (host/blog-is-tag? "ppost"))
|
||
(list true false))
|
||
(host-bl-test "instances-of tag includes the tag posts"
|
||
(contains? (host/blog-instances-of "tag") "ocaml") true)
|
||
(host-bl-test "tag a post: it appears in tags + tagged-with (inverse)"
|
||
(begin
|
||
(host/blog-relate! "ppost" "ocaml" "tagged") ;; ppost tagged ocaml
|
||
(list (contains? (host/blog-tags "ppost") "ocaml")
|
||
(contains? (host/blog-tagged-with "ocaml") "ppost")))
|
||
(list true true))
|
||
(host-bl-test "tagged picker offers only tags (kind=tagged)"
|
||
(let ((body (dream-resp-body (host-bl-app (host-bl-req "/particle/relate-options?kind=tagged")))))
|
||
(list (contains? body ">OCaml<") (contains? body ">P Article<")))
|
||
(list true false))
|
||
(host-bl-test "related picker still offers all posts (kind defaults to related)"
|
||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/particle/relate-options"))) ">P Doc<")
|
||
true)
|
||
(host-bl-test "is-a-tag toggle marks a post a tag via /relate kind=is-a"
|
||
(begin
|
||
(host-bl-wapp (host-bl-send "POST" "/pdoc/relate" "Bearer good"
|
||
"application/x-www-form-urlencoded" "other=tag&kind=is-a"))
|
||
(host/blog-is-tag? "pdoc"))
|
||
true)
|
||
|
||
;; -- 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))
|
||
(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)
|
||
|
||
(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}))
|