coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
ccbee8c1beb16674125658300a1a78d1c043b3cb
rose-ash/lib/host/tests/blog.sx
giles ccbee8c1be host: relate posts — "related posts" on blog × relations (blog 61/61, 230) 
Compose two already-migrated domains: a post is a relations-graph node
"blog:<slug>", and a "related" link is a symmetric pair of edges
(lib/relations). The post page shows a "Related posts" block; the edit page
gets an editor to add (by slug) and remove relations.

- host/blog-relate!/unrelate!/related: symmetric edges under kind "related";
  related slugs = blog children, existence-filtered against ONE kv-keys read.
- post page: "Related posts" links block; edit page: related editor (remove
  buttons + add-by-slug box).
- POST /:slug/relate, /:slug/unrelate — guarded browser routes (redirect to
  login like the other write routes); relate validates the other post exists.
- delete cleans up a post's related edges (no dangling links).

IO ORDERING (the live 500 that conformance missed): host/blog--related-block/
-editor do durable reads (perform). Performing inside the quasiquote, via
unquote, while the page tree renders raised Sx_vm.VmSuspended under http-listen;
the in-memory conformance store never performs, so it passed. Fix mirrors
host/blog-home: do the reads in the handler's let bindings BEFORE the
quasiquote, and check related-existence against a single host/blog-slugs read
rather than a perform per candidate inside filter.

9 relate tests (guard, symmetry, render, no-op on missing, unrelate both ways,
delete cleanup). Verified live: relate -> Related block both ways; unrelate
clears it; posts without relations and the whole site stay 200.

Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
2026-06-25 22:57:03 +00:00

268 lines
13 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 "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)
;; -- 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}))
Reference in New Issue View Git Blame Copy Permalink