coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
cb2fc788d783a8609518e0344f7561de5634ffd2
rose-ash/lib/host/tests/blog.sx
giles cb2fc788d7 host: typed relations — Phase 2, type resolution with subsumption 
The spine: types ARE posts, and typing is transitive the right way. is-a
(instance-of) does NOT chain on its own, but subsumption does — an instance of a
subtype is an instance of the supertype.

- registry gains "subtype-of" (directed, transitive). host/blog-types-of(slug) =
  declared is-a targets PLUS every subtype-of-ancestor of each (composed host-side
  over relations/descendants — no new Datalog rules). host/blog-is-a?(slug,type)
  is transitive through subtype-of.
- host/blog-seed-types! seeds the root type-posts "type" and "tag" (real posts
  that document themselves) with tag subtype-of type, so anything is-a tag is
  transitively a type. Idempotent; wired into serve.sh.
- gradual-validation seam: host/blog-type-schemas (empty) + host/blog-schema-of +
  host/blog-type-valid? (vacuously true with no schemas) wired into edit-submit
  alongside the parse check — enforcement is a one-line add later, not a retrofit.

6 tests: types-of = declared + all subtype-of supertypes; is-a? transitive
through subtype-of; is-a alone does NOT chain; instance of tag is transitively a
type; type-valid vacuous with no schemas. 255/255.

Verified live: /type/ + /tag/ render as posts, tag subtype-of type survived a
recreate (durable), ocaml is-a tag.

Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
2026-06-28 16:49:00 +00:00

388 lines
20 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)
;; -- 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")
(host-bl-test "relate-picker.js served as javascript"
(dream-resp-header (host-bl-app (host-bl-req "/relate-picker.js")) "content-type")
"application/javascript; charset=utf-8")
(host-bl-test "relate-picker.js carries the fetch glue"
(contains? (dream-resp-body (host-bl-app (host-bl-req "/relate-picker.js"))) "relate-options") true)
(host-bl-test "related block: hint when logged-in + no relations"
(contains? (str (host/blog--related-block "gamma-post" true)) "add some") true)
(host-bl-test "related block: empty when anonymous + no relations"
(= (host/blog--related-block "gamma-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)
;; -- 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