host: blog on the editor's sx_content model + render-to-html, 171/171
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 17s
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 17s
Pivot blog to the SX editor's content model. The editor (blog/sx/editor.sx)
emits sx_content = SX element markup, NOT content-on-sx CtDoc blocks. So a post
is now a {slug,title,sx_content,status} record in the durable persist KV, and a
post page is render-to-html(parse sx_content) — server-side, static, no client
runtime needed to view.
Endpoints: GET / (HTML index), /<slug>/ (rendered post), /posts (JSON list),
/new (create form); POST /new (form-urlencoded editor ingest, slug from title,
303 redirect), POST /posts (JSON create), PUT/DELETE /posts/<slug>. Writes
behind auth+ACL (edit/blog). Dropped the content-on-sx/Smalltalk preload chain;
added spec/render + web/adapter-html (render-to-html) + lib/dream/form.
BONUS: render-to-html is ~0ms (vs the 2s content-on-sx Smalltalk asHTML) — it
doesn't hit the JIT-miscompiled path, so blog rendering is no longer slow.
Live: blog.rose-ash.com/ lists posts, /welcome/ renders instantly. Reads live;
the form-ingest write path needs an auth decision before going live (browser
forms can't send bearer; needs session or a Caddy basicauth gate).
Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
This commit is contained in:
260
lib/host/blog.sx
260
lib/host/blog.sx
@@ -1,113 +1,87 @@
|
||||
;; lib/host/blog.sx — Blog domain on the host. Posts are content-on-sx documents
|
||||
;; whose source of truth is the durable SX store (persist op-log on disk). Full
|
||||
;; post CRUD, all dispatching to the content store per request (per-request IO):
|
||||
;; GET /posts list posts (public) -> JSON [{slug,title}]
|
||||
;; GET /<slug>/ read a post (public) -> rendered HTML / 404
|
||||
;; POST /posts create (guarded) -> 201 / 400 / 409
|
||||
;; PUT /posts/<slug> update title+body (guarded)-> 200 / 400 / 404
|
||||
;; DELETE /posts/<slug> delete (guarded) -> 200 / 404
|
||||
;; Reads are anonymous (published posts are world-visible); writes run behind the
|
||||
;; auth + ACL pipeline ("edit" on "blog"), like the editor would require.
|
||||
;; lib/host/blog.sx — Blog domain on the host, on the EDITOR's content model.
|
||||
;; The SX post editor (blog/sx/editor.sx) emits `sx_content`: SX element markup
|
||||
;; (e.g. "(article (h1 \"T\") (p \"body\" (strong \"x\")))"), NOT content-on-sx
|
||||
;; CtDoc blocks. So a post here is a record {slug,title,sx_content,status} stored
|
||||
;; in the durable persist KV, and a post page is `render-to-html (parse sx_content)`
|
||||
;; — server-side, static, no client runtime needed to view a published post.
|
||||
;;
|
||||
;; A post is two blocks under stream "content:<slug>": a heading (id "<slug>-h")
|
||||
;; and a body paragraph (id "<slug>-body"). create appends insert ops, update
|
||||
;; appends op-updates to those ids, delete truncates the stream. Materialising +
|
||||
;; rendering happens per request (interpreted Smalltalk render is ~2s — a JIT
|
||||
;; concern, tracked separately, NOT solved by caching).
|
||||
;; Depends on lib/content/* (+ Smalltalk + persist preloads) + lib/dream/* +
|
||||
;; lib/host/{handler,middleware}.sx.
|
||||
;; GET / HTML index of posts (public)
|
||||
;; GET /<slug>/ rendered post (public) -> HTML / 404
|
||||
;; GET /posts JSON list (public) -> [{slug,title,status}]
|
||||
;; GET /new HTML create form (public chrome)
|
||||
;; POST /new form-urlencoded ingest from the editor (guarded)
|
||||
;; POST /posts JSON create (guarded)
|
||||
;; PUT /posts/<slug> JSON update (guarded)
|
||||
;; DELETE /posts/<slug> delete (guarded)
|
||||
;; Reads anonymous; writes behind the auth+ACL pipeline ("edit" on "blog").
|
||||
;; Depends on spec/render + web/adapter-html (render-to-html), lib/persist/*
|
||||
;; (durable KV), lib/dream/* (+ form), lib/host/{handler,middleware}.sx.
|
||||
|
||||
;; Register content classes + render methods (idempotent); called at load below.
|
||||
(define host/blog-bootstrap!
|
||||
(fn () (begin (st-bootstrap-classes!) (content/bootstrap!))))
|
||||
|
||||
;; ── store (durable source of truth, injectable) + logical clock ─────
|
||||
;; ── store (durable persist KV, injectable) ──────────────────────────
|
||||
(define host/blog-store (persist/open))
|
||||
(define host/blog-use-store! (fn (b) (set! host/blog-store b)))
|
||||
(define host/blog-clock 0)
|
||||
(define host/blog-tick! (fn () (begin (set! host/blog-clock (+ host/blog-clock 1)) host/blog-clock)))
|
||||
(define host/blog--key (fn (slug) (str "blog:" slug)))
|
||||
|
||||
;; content streams are keyed "content:<slug>"; recover the slug ("content:" = 8).
|
||||
(define host/blog--stream-slug
|
||||
(fn (stream) (if (starts-with? stream "content:") (substr stream 8) nil)))
|
||||
;; slug from a title: lowercase, words joined by '-'. (Punctuation kept simple.)
|
||||
(define host/blog-slugify
|
||||
(fn (title)
|
||||
(join "-" (filter (fn (w) (not (= w ""))) (split (lower title) " ")))))
|
||||
|
||||
;; ── post helpers (per-request, against the store) ───────────────────
|
||||
;; ── records ─────────────────────────────────────────────────────────
|
||||
(define host/blog-get
|
||||
(fn (slug) (persist/backend-kv-get host/blog-store (host/blog--key slug))))
|
||||
(define host/blog-exists?
|
||||
(fn (slug) (> (content/count (content/head host/blog-store slug)) 0)))
|
||||
|
||||
;; First heading's text, else a placeholder.
|
||||
(define host/blog-title
|
||||
(fn (doc)
|
||||
(let ((hs (filter (fn (b) (= (blk-type b) "heading")) (content/blocks doc))))
|
||||
(if (> (len hs) 0) (str (blk-get (first hs) "text")) "(untitled)"))))
|
||||
|
||||
;; Create: append the post's insert ops to its stream.
|
||||
(define host/blog-publish!
|
||||
(fn (slug title body at)
|
||||
(let ((hid (str slug "-h")) (tid (str slug "-body")))
|
||||
(content/commit-all! host/blog-store slug
|
||||
(list
|
||||
(op-insert (mk-heading hid 1 title) nil)
|
||||
(op-insert (mk-text tid body) hid))
|
||||
at))))
|
||||
|
||||
;; Update: append op-updates to the post's heading + body blocks.
|
||||
(define host/blog-update!
|
||||
(fn (slug title body at)
|
||||
(let ((hid (str slug "-h")) (tid (str slug "-body")))
|
||||
(content/commit-all! host/blog-store slug
|
||||
(list (op-update hid "text" title) (op-update tid "text" body))
|
||||
at))))
|
||||
|
||||
;; Delete: truncate the post's stream (clears all content -> lookup nil -> 404).
|
||||
(fn (slug) (persist/backend-kv-has? host/blog-store (host/blog--key slug))))
|
||||
(define host/blog-put!
|
||||
(fn (slug title sx-content status)
|
||||
(persist/backend-kv-put host/blog-store (host/blog--key slug)
|
||||
{:slug slug :title title :sx-content sx-content :status status})))
|
||||
(define host/blog-delete!
|
||||
(fn (slug)
|
||||
(let ((stream (content/-stream slug)))
|
||||
(persist/truncate host/blog-store stream (persist/last-seq host/blog-store stream)))))
|
||||
|
||||
;; Idempotent seed: publish only if the slug has no content yet.
|
||||
(fn (slug) (persist/backend-kv-delete host/blog-store (host/blog--key slug))))
|
||||
(define host/blog-seed!
|
||||
(fn (slug title body at)
|
||||
(when (= (content/count (content/head host/blog-store slug)) 0)
|
||||
(host/blog-publish! slug title body at))))
|
||||
(fn (slug title sx-content status)
|
||||
(when (not (host/blog-exists? slug)) (host/blog-put! slug title sx-content status))))
|
||||
|
||||
;; Materialise the post from the store by replaying its op-log; nil if no content.
|
||||
(define host/blog-lookup
|
||||
(fn (slug)
|
||||
(let ((doc (content/head host/blog-store slug)))
|
||||
(if (> (content/count doc) 0) doc nil))))
|
||||
|
||||
;; All posts with content, as [{:slug :title}].
|
||||
(define host/blog-list
|
||||
;; all blog slugs (kv keys are "blog:<slug>")
|
||||
(define host/blog-slugs
|
||||
(fn ()
|
||||
(reduce
|
||||
(fn (acc stream)
|
||||
(let ((slug (host/blog--stream-slug stream)))
|
||||
(if slug
|
||||
(let ((doc (content/head host/blog-store slug)))
|
||||
(if (> (content/count doc) 0)
|
||||
(append acc (list {:slug slug :title (host/blog-title doc)}))
|
||||
acc))
|
||||
acc)))
|
||||
(fn (acc k)
|
||||
(if (starts-with? k "blog:") (append acc (list (substr k 5))) acc))
|
||||
(list)
|
||||
(persist/backend-streams host/blog-store))))
|
||||
(persist/backend-kv-keys host/blog-store))))
|
||||
(define host/blog-list
|
||||
(fn ()
|
||||
(map
|
||||
(fn (slug)
|
||||
(let ((r (host/blog-get slug)))
|
||||
{:slug slug :title (get r :title) :status (get r :status)}))
|
||||
(host/blog-slugs))))
|
||||
|
||||
;; ── handlers ────────────────────────────────────────────────────────
|
||||
;; GET /<slug>/ -> rendered HTML (200) or 404.
|
||||
;; ── render ──────────────────────────────────────────────────────────
|
||||
;; A post's sx_content is SX element markup -> HTML via the component renderer.
|
||||
(define host/blog-render
|
||||
(fn (record)
|
||||
(let ((sx (get record :sx-content)))
|
||||
(if (and sx (not (= sx "")))
|
||||
(render-to-html (parse sx))
|
||||
(str "<p>(empty post)</p>")))))
|
||||
(define host/blog--page
|
||||
(fn (title body)
|
||||
(str "<!doctype html><meta charset=\"utf-8\"><title>" title "</title>" body)))
|
||||
|
||||
;; ── read handlers ───────────────────────────────────────────────────
|
||||
(define host/blog-post
|
||||
(fn (req)
|
||||
(let ((slug (dream-param req "slug")))
|
||||
(let ((doc (host/blog-lookup slug)))
|
||||
(if doc
|
||||
(dream-html (content/html doc))
|
||||
(let ((r (host/blog-get slug)))
|
||||
(if r
|
||||
(dream-html
|
||||
(host/blog--page (get r :title) (host/blog-render r)))
|
||||
(dream-html-status 404
|
||||
(str "<!doctype html><title>Not found</title>"
|
||||
"<h1>404</h1><p>No published post: " slug "</p>")))))))
|
||||
(host/blog--page "Not found"
|
||||
(str "<h1>404</h1><p>No published post: " slug "</p>"))))))))
|
||||
|
||||
;; GET /posts -> JSON list of posts (API).
|
||||
(define host/blog-index (fn (req) (host/ok (host/blog-list))))
|
||||
|
||||
;; GET / -> HTML index page listing posts, each linking to /<slug>/.
|
||||
(define host/blog--li
|
||||
(fn (acc p)
|
||||
(str acc "<li><a href=\"/" (get p :slug) "/\">" (get p :title) "</a></li>")))
|
||||
@@ -115,44 +89,82 @@
|
||||
(fn (req)
|
||||
(let ((posts (host/blog-list)))
|
||||
(dream-html
|
||||
(str
|
||||
"<!doctype html><meta charset=\"utf-8\"><title>Blog</title>"
|
||||
"<h1>Posts</h1>"
|
||||
(if (> (len posts) 0)
|
||||
(str "<ul>" (reduce host/blog--li "" posts) "</ul>")
|
||||
"<p>No posts yet.</p>"))))))
|
||||
(host/blog--page "Blog"
|
||||
(str "<h1>Posts</h1>"
|
||||
(if (> (len posts) 0)
|
||||
(str "<ul>" (reduce host/blog--li "" posts) "</ul>")
|
||||
"<p>No posts yet.</p>")
|
||||
"<p><a href=\"/new\">+ New post</a></p>"))))))
|
||||
|
||||
;; POST /posts -> create from JSON {slug,title,body}. 409 if it exists.
|
||||
(define host/blog-index (fn (req) (host/ok (host/blog-list))))
|
||||
|
||||
;; ── create form (GET /new) — minimal chrome; the SX editor posts here too ──
|
||||
(define host/blog-new-form
|
||||
(fn (req)
|
||||
(dream-html
|
||||
(host/blog--page "New post"
|
||||
(str
|
||||
"<h1>New post</h1>"
|
||||
"<form method=\"post\" action=\"/new\">"
|
||||
"<p><input name=\"title\" placeholder=\"Title\" style=\"font-size:1.4em;width:100%\"></p>"
|
||||
"<p><textarea name=\"sx_content\" rows=\"12\" style=\"width:100%\" "
|
||||
"placeholder=\"(article (h1 "Title") (p "Body"))\"></textarea></p>"
|
||||
"<p><select name=\"status\"><option value=\"draft\">Draft</option>"
|
||||
"<option value=\"published\">Published</option></select> "
|
||||
"<button type=\"submit\">Publish</button></p>"
|
||||
"</form><p><a href=\"/\">← all posts</a></p>")))))
|
||||
|
||||
;; ── write handlers ──────────────────────────────────────────────────
|
||||
;; POST /new — form-urlencoded ingest (the editor's submit shape: title,
|
||||
;; sx_content, status, custom_excerpt, csrf_token). Slug derived from the title.
|
||||
;; Redirects to the new post on success.
|
||||
(define host/blog-form-submit
|
||||
(fn (req)
|
||||
(let ((title (dream-form-field req "title"))
|
||||
(sx-content (dream-form-field req "sx_content"))
|
||||
(status (or (dream-form-field req "status") "published")))
|
||||
(if (and title (not (= title "")))
|
||||
(let ((slug (host/blog-slugify title)))
|
||||
(begin
|
||||
(host/blog-put! slug title (or sx-content "") status)
|
||||
(dream-redirect (str "/" slug "/"))))
|
||||
(dream-html-status 400
|
||||
(host/blog--page "Error" "<p>Title is required. <a href=\"/new\">back</a></p>"))))))
|
||||
|
||||
;; POST /posts — JSON create {slug?,title,sx_content,status}. 409 if slug exists.
|
||||
(define host/blog-create
|
||||
(fn (req)
|
||||
(let ((p (dream-json-body req)))
|
||||
(if (= (type-of p) "dict")
|
||||
(let ((slug (get p :slug)) (title (get p :title)) (body (get p :body)))
|
||||
(if (and slug title body)
|
||||
(if (host/blog-exists? slug)
|
||||
(host/error 409 "post already exists")
|
||||
(begin
|
||||
(host/blog-publish! slug title body (host/blog-tick!))
|
||||
(host/ok-status 201 {:slug slug :title title})))
|
||||
(host/error 400 "slug, title, body required")))
|
||||
(let ((title (get p :title)))
|
||||
(if (and title (not (= title "")))
|
||||
(let ((slug (or (get p :slug) (host/blog-slugify title))))
|
||||
(if (host/blog-exists? slug)
|
||||
(host/error 409 "post already exists")
|
||||
(begin
|
||||
(host/blog-put! slug title (or (get p :sx_content) "")
|
||||
(or (get p :status) "published"))
|
||||
(host/ok-status 201 {:slug slug :title title}))))
|
||||
(host/error 400 "title required")))
|
||||
(host/error 400 "invalid payload")))))
|
||||
|
||||
;; PUT /posts/<slug> -> update title+body from JSON {title,body}. 404 if absent.
|
||||
;; PUT /posts/<slug> — JSON update {title?,sx_content?,status?}. 404 if absent.
|
||||
(define host/blog-update-handler
|
||||
(fn (req)
|
||||
(let ((slug (dream-param req "slug")) (p (dream-json-body req)))
|
||||
(if (= (type-of p) "dict")
|
||||
(if (host/blog-exists? slug)
|
||||
(let ((title (get p :title)) (body (get p :body)))
|
||||
(if (and title body)
|
||||
(begin
|
||||
(host/blog-update! slug title body (host/blog-tick!))
|
||||
(host/ok {:slug slug :title title :updated true}))
|
||||
(host/error 400 "title, body required")))
|
||||
(host/error 404 "no such post"))
|
||||
(let ((r (host/blog-get slug)))
|
||||
(if r
|
||||
(begin
|
||||
(host/blog-put! slug
|
||||
(or (get p :title) (get r :title))
|
||||
(or (get p :sx_content) (get r :sx-content))
|
||||
(or (get p :status) (get r :status)))
|
||||
(host/ok {:slug slug :updated true}))
|
||||
(host/error 404 "no such post")))
|
||||
(host/error 400 "invalid payload")))))
|
||||
|
||||
;; DELETE /posts/<slug> -> delete. 404 if absent.
|
||||
;; DELETE /posts/<slug>
|
||||
(define host/blog-delete-handler
|
||||
(fn (req)
|
||||
(let ((slug (dream-param req "slug")))
|
||||
@@ -161,19 +173,17 @@
|
||||
(host/error 404 "no such post")))))
|
||||
|
||||
;; ── routes ──────────────────────────────────────────────────────────
|
||||
;; Public reads: /posts (list) BEFORE /:slug (the catch-all), so a literal
|
||||
;; /posts isn't captured as a slug. MUST be mounted LAST in the app (the :slug
|
||||
;; pattern matches any single-segment path, so domain routes take precedence).
|
||||
;; Public reads + the create form. /, /posts, /new BEFORE /:slug (catch-all).
|
||||
;; MUST be mounted LAST in the app so domain routes (/feed, /health) win.
|
||||
(define host/blog-routes
|
||||
(list
|
||||
(dream-get "/" host/blog-home)
|
||||
(dream-get "/posts" host/blog-index)
|
||||
(dream-get "/new" host/blog-new-form)
|
||||
(dream-get "/:slug" host/blog-post)))
|
||||
|
||||
;; Guarded writes: create/update/delete behind auth + ACL ("edit","blog").
|
||||
;; resolve : token -> principal | nil (injected auth policy, like the feed writes).
|
||||
;; NB: the wrapper is named host/blog--protect, NOT `guard` — `guard` is a reserved
|
||||
;; CEK special form and a local binding of that name is shadowed by it.
|
||||
;; Guarded writes: form ingest + JSON create/update/delete behind auth+ACL.
|
||||
;; NB: helper is host/blog--protect, NOT `guard` (reserved special form).
|
||||
(define host/blog--protect
|
||||
(fn (resolve h)
|
||||
(host/pipeline
|
||||
@@ -185,9 +195,7 @@
|
||||
(define host/blog-write-routes
|
||||
(fn (resolve)
|
||||
(list
|
||||
(dream-post "/new" (host/blog--protect resolve host/blog-form-submit))
|
||||
(dream-post "/posts" (host/blog--protect resolve host/blog-create))
|
||||
(dream-put "/posts/:slug" (host/blog--protect resolve host/blog-update-handler))
|
||||
(dream-delete "/posts/:slug" (host/blog--protect resolve host/blog-delete-handler)))))
|
||||
|
||||
;; Self-bootstrap at load (content modules are loaded before this one).
|
||||
(host/blog-bootstrap!)
|
||||
|
||||
@@ -55,27 +55,19 @@ MODULES=(
|
||||
"lib/feed/normalize.sx"
|
||||
"lib/feed/stream.sx"
|
||||
"lib/feed/api.sx"
|
||||
"lib/smalltalk/tokenizer.sx"
|
||||
"lib/smalltalk/parser.sx"
|
||||
"lib/guest/reflective/class-chain.sx"
|
||||
"lib/smalltalk/runtime.sx"
|
||||
"lib/guest/reflective/env.sx"
|
||||
"lib/smalltalk/eval.sx"
|
||||
"lib/persist/event.sx"
|
||||
"lib/persist/backend.sx"
|
||||
"lib/persist/log.sx"
|
||||
"lib/persist/kv.sx"
|
||||
"lib/persist/api.sx"
|
||||
"lib/content/block.sx"
|
||||
"lib/content/doc.sx"
|
||||
"lib/content/render.sx"
|
||||
"lib/content/api.sx"
|
||||
"lib/content/store.sx"
|
||||
"lib/persist/durable.sx"
|
||||
"spec/render.sx"
|
||||
"web/adapter-html.sx"
|
||||
"lib/dream/types.sx"
|
||||
"lib/dream/json.sx"
|
||||
"lib/dream/auth.sx"
|
||||
"lib/dream/error.sx"
|
||||
"lib/dream/form.sx"
|
||||
"lib/dream/router.sx"
|
||||
"lib/host/handler.sx"
|
||||
"lib/host/middleware.sx"
|
||||
|
||||
@@ -60,27 +60,19 @@ MODULES=(
|
||||
"lib/feed/normalize.sx"
|
||||
"lib/feed/stream.sx"
|
||||
"lib/feed/api.sx"
|
||||
"lib/smalltalk/tokenizer.sx"
|
||||
"lib/smalltalk/parser.sx"
|
||||
"lib/guest/reflective/class-chain.sx"
|
||||
"lib/smalltalk/runtime.sx"
|
||||
"lib/guest/reflective/env.sx"
|
||||
"lib/smalltalk/eval.sx"
|
||||
"lib/persist/event.sx"
|
||||
"lib/persist/backend.sx"
|
||||
"lib/persist/log.sx"
|
||||
"lib/persist/kv.sx"
|
||||
"lib/persist/api.sx"
|
||||
"lib/content/block.sx"
|
||||
"lib/content/doc.sx"
|
||||
"lib/content/render.sx"
|
||||
"lib/content/api.sx"
|
||||
"lib/content/store.sx"
|
||||
"lib/persist/durable.sx"
|
||||
"spec/render.sx"
|
||||
"web/adapter-html.sx"
|
||||
"lib/dream/types.sx"
|
||||
"lib/dream/json.sx"
|
||||
"lib/dream/auth.sx"
|
||||
"lib/dream/error.sx"
|
||||
"lib/dream/form.sx"
|
||||
"lib/dream/router.sx"
|
||||
"lib/host/handler.sx"
|
||||
"lib/host/middleware.sx"
|
||||
@@ -98,15 +90,13 @@ EPOCH=1
|
||||
echo "(epoch $EPOCH)"; echo "(load \"$M\")"; EPOCH=$((EPOCH+1))
|
||||
done
|
||||
# Point the blog at the DURABLE file backend (persists under $SX_PERSIST_DIR),
|
||||
# then idempotently seed a welcome post — re-seeding is a no-op if it already
|
||||
# exists on disk, so restarts don't duplicate blocks.
|
||||
# then idempotently seed a welcome post (sx_content = SX element markup, the
|
||||
# editor's content model). Re-seeding is a no-op if the slug already exists.
|
||||
echo "(epoch $EPOCH)"
|
||||
echo "(eval \"(host/blog-use-store! (persist/durable-backend))\")"
|
||||
EPOCH=$((EPOCH+1))
|
||||
echo "(epoch $EPOCH)"
|
||||
# Idempotently seed the welcome post into the durable store (no-op if present).
|
||||
# Handlers read + render from the store per request (per-request IO).
|
||||
echo "(eval \"(host/blog-seed! \\\"welcome\\\" \\\"Welcome to the SX host\\\" \\\"This page is rendered by lib/host on the SX runtime, persisted in the SX store — no Quart.\\\" 1)\")"
|
||||
echo "(eval \"(host/blog-seed! \\\"welcome\\\" \\\"Welcome to the SX host\\\" \\\"(article (h1 \\\\\\\"Welcome to the SX host\\\\\\\") (p \\\\\\\"Rendered by lib/host via render-to-html, from the durable SX store.\\\\\\\"))\\\" \\\"published\\\")\")"
|
||||
EPOCH=$((EPOCH+1))
|
||||
echo "(epoch $EPOCH)"
|
||||
# Anonymous read endpoints: feed timeline + relations container reads + blog
|
||||
|
||||
@@ -1,185 +1,131 @@
|
||||
;; lib/host/tests/blog.sx — the blog published-post read endpoint. A registered
|
||||
;; post renders to HTML at GET /<slug>/; unknown slugs 404. Also pins route
|
||||
;; precedence: the catch-all :slug must NOT shadow domain routes mounted before it.
|
||||
;; 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)
|
||||
(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 {} "")))
|
||||
;; feed mounted BEFORE blog so /feed is not captured by the :slug catch-all.
|
||||
(define host-bl-app
|
||||
(host/make-app (list host/feed-routes host/blog-routes)))
|
||||
(define host-bl-app (host/make-app (list host/feed-routes host/blog-routes)))
|
||||
|
||||
;; ── publish a post to a fresh in-memory store (hermetic) ────────────
|
||||
;; ── 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-publish! "welcome" "Hello SX" "Served by lib/host." 1)
|
||||
(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 "/welcome/")))
|
||||
200)
|
||||
(host-bl-test
|
||||
"post content-type html"
|
||||
(contains? (dream-resp-header (host-bl-app (host-bl-req "/welcome/")) "content-type") "text/html")
|
||||
(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 heading"
|
||||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/welcome/"))) "<h1>Hello SX</h1>")
|
||||
(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 renders body"
|
||||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/welcome/"))) "Served by lib/host.")
|
||||
true)
|
||||
;; trailing slash optional — /welcome and /welcome/ both resolve
|
||||
(host-bl-test
|
||||
"no trailing slash also 200"
|
||||
(dream-status (host-bl-app (host-bl-req "/welcome")))
|
||||
200)
|
||||
|
||||
;; golden: endpoint body == the exact rendered HTML of the published post
|
||||
(host-bl-test
|
||||
"golden render"
|
||||
(dream-resp-body (host-bl-app (host-bl-req "/welcome/")))
|
||||
"<h1>Hello SX</h1><p>Served by lib/host.</p>")
|
||||
|
||||
;; persistence: the store holds 2 blocks (op-log replay), lookup materialises the
|
||||
;; doc from the store per call, and re-seeding is idempotent (no duplicate blocks).
|
||||
(host-bl-test "store has 2 blocks" (content/count (content/head host/blog-store "welcome")) 2)
|
||||
(host-bl-test "lookup materialises the doc" (content/count (host/blog-lookup "welcome")) 2)
|
||||
(host/blog-seed! "welcome" "Hello SX" "Served by lib/host." 2)
|
||||
(host-bl-test "re-seed is idempotent" (content/count (content/head host/blog-store "welcome")) 2)
|
||||
|
||||
;; ── unknown slug -> 404 ─────────────────────────────────────────────
|
||||
(host-bl-test
|
||||
"unknown slug 404"
|
||||
(dream-status (host-bl-app (host-bl-req "/nope/")))
|
||||
404)
|
||||
(host-bl-test
|
||||
"404 names the slug"
|
||||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/nope/"))) "nope")
|
||||
(host-bl-test "post title in page"
|
||||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/hello/"))) "<title>Hello World</title>")
|
||||
true)
|
||||
|
||||
;; ── route precedence: domain routes win over the :slug catch-all ────
|
||||
;; ── 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 served by feed, not blog 404"
|
||||
(dream-status (host-bl-app (host-bl-req "/feed")))
|
||||
200)
|
||||
(host-bl-test
|
||||
"/feed body is the feed envelope, not HTML"
|
||||
(host-bl-test "/feed not captured by :slug"
|
||||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/feed"))) "\"ok\":true")
|
||||
true)
|
||||
|
||||
;; ── CRUD: list / create / update / delete (writes auth+ACL guarded) ─
|
||||
;; ── 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 body)
|
||||
(dream-request method target (if auth {:authorization auth} {}) body)))
|
||||
(fn (method target auth ctype body)
|
||||
(dream-request method target
|
||||
(merge (if auth {:authorization auth} {}) (if ctype {:content-type ctype} {})) body)))
|
||||
|
||||
;; start from a clean store
|
||||
(host/blog-use-store! (persist/open))
|
||||
|
||||
;; list empty
|
||||
(host-bl-test "list empty -> data:[]"
|
||||
(contains? (dream-resp-body (host-bl-wapp (host-bl-send "GET" "/posts" nil ""))) "\"data\":[]")
|
||||
true)
|
||||
;; HTML home page when empty
|
||||
(host-bl-test "home / -> 200 html"
|
||||
(contains? (dream-resp-header (host-bl-wapp (host-bl-send "GET" "/" nil "")) "content-type") "text/html")
|
||||
true)
|
||||
(host-bl-test "empty home says no posts"
|
||||
(contains? (dream-resp-body (host-bl-wapp (host-bl-send "GET" "/" nil ""))) "No posts yet")
|
||||
;; -- editor form ingest (form-urlencoded, the editor's submit shape) --
|
||||
(host-bl-test "form ingest no auth -> 401"
|
||||
(dream-status (host-bl-wapp (host-bl-send "POST" "/new" nil
|
||||
"application/x-www-form-urlencoded" "title=X")))
|
||||
401)
|
||||
(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)
|
||||
|
||||
;; create requires auth
|
||||
(host-bl-test "create no auth -> 401"
|
||||
(dream-status (host-bl-wapp (host-bl-send "POST" "/posts" nil "{}")))
|
||||
401)
|
||||
(host-bl-test "create authed-unpermitted -> 403"
|
||||
(dream-status (host-bl-wapp (host-bl-send "POST" "/posts" "Bearer weak"
|
||||
"{\"slug\":\"hello\",\"title\":\"Hi\",\"body\":\"B\"}")))
|
||||
403)
|
||||
;; create permitted -> 201
|
||||
(host-bl-test "create -> 201"
|
||||
(dream-status (host-bl-wapp (host-bl-send "POST" "/posts" "Bearer good"
|
||||
"{\"slug\":\"hello\",\"title\":\"Hello World\",\"body\":\"First post.\"}")))
|
||||
;; -- 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)
|
||||
;; created post renders at GET /<slug>/
|
||||
(host-bl-test "created post reads back as HTML"
|
||||
(contains? (dream-resp-body (host-bl-wapp (host-bl-send "GET" "/hello/" nil ""))) "<h1>Hello World</h1>")
|
||||
true)
|
||||
;; appears in the list
|
||||
(host-bl-test "list shows created post"
|
||||
(contains? (dream-resp-body (host-bl-wapp (host-bl-send "GET" "/posts" nil ""))) "Hello World")
|
||||
true)
|
||||
;; home page lists it with a link to /<slug>/
|
||||
(host-bl-test "home lists post title"
|
||||
(contains? (dream-resp-body (host-bl-wapp (host-bl-send "GET" "/" nil ""))) "Hello World")
|
||||
true)
|
||||
(host-bl-test "home links to the post"
|
||||
(contains? (dream-resp-body (host-bl-wapp (host-bl-send "GET" "/" nil ""))) "href=\"/hello/\"")
|
||||
true)
|
||||
;; create duplicate -> 409
|
||||
(host-bl-test "create duplicate -> 409"
|
||||
(dream-status (host-bl-wapp (host-bl-send "POST" "/posts" "Bearer good"
|
||||
"{\"slug\":\"hello\",\"title\":\"X\",\"body\":\"Y\"}")))
|
||||
(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)
|
||||
;; missing fields -> 400
|
||||
(host-bl-test "create missing fields -> 400"
|
||||
(dream-status (host-bl-wapp (host-bl-send "POST" "/posts" "Bearer good" "{\"slug\":\"x\"}")))
|
||||
(host-bl-test "json create no title -> 400"
|
||||
(dream-status (host-bl-wapp (host-bl-send "POST" "/posts" "Bearer good" "application/json" "{}")))
|
||||
400)
|
||||
|
||||
;; update -> 200 and content changes
|
||||
(host-bl-test "update -> 200"
|
||||
(dream-status (host-bl-wapp (host-bl-send "PUT" "/posts/hello" "Bearer good"
|
||||
"{\"title\":\"Edited Title\",\"body\":\"Edited body.\"}")))
|
||||
(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 the rendered post"
|
||||
(contains? (dream-resp-body (host-bl-wapp (host-bl-send "GET" "/hello/" nil ""))) "<h1>Edited Title</h1>")
|
||||
(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 post -> 404"
|
||||
(dream-status (host-bl-wapp (host-bl-send "PUT" "/posts/ghost" "Bearer good"
|
||||
"{\"title\":\"T\",\"body\":\"B\"}")))
|
||||
(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 "update no auth -> 401"
|
||||
(dream-status (host-bl-wapp (host-bl-send "PUT" "/posts/hello" nil "{}")))
|
||||
401)
|
||||
|
||||
;; delete -> 200, then gone (404) and absent from list
|
||||
(host-bl-test "delete -> 200"
|
||||
(dream-status (host-bl-wapp (host-bl-send "DELETE" "/posts/hello" "Bearer good" "")))
|
||||
(dream-status (host-bl-wapp (host-bl-send "DELETE" "/posts/json-post" "Bearer good" "" "")))
|
||||
200)
|
||||
(host-bl-test "deleted post -> 404"
|
||||
(dream-status (host-bl-wapp (host-bl-send "GET" "/hello/" nil "")))
|
||||
404)
|
||||
(host-bl-test "deleted post gone from list"
|
||||
(contains? (dream-resp-body (host-bl-wapp (host-bl-send "GET" "/posts" nil ""))) "hello")
|
||||
false)
|
||||
(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" "")))
|
||||
(dream-status (host-bl-wapp (host-bl-send "DELETE" "/posts/ghost" "Bearer good" "" "")))
|
||||
404)
|
||||
|
||||
(define
|
||||
host-bl-tests-run!
|
||||
(fn
|
||||
()
|
||||
(fn ()
|
||||
{:total (+ host-bl-pass host-bl-fail)
|
||||
:passed host-bl-pass
|
||||
:failed host-bl-fail
|
||||
:fails host-bl-fails}))
|
||||
:passed host-bl-pass :failed host-bl-fail :fails host-bl-fails}))
|
||||
|
||||
@@ -36,10 +36,15 @@ host — no `ocaml-on-sx` dependency.
|
||||
|
||||
## Status (rolling)
|
||||
|
||||
`bash lib/host/conformance.sh` → **158/158** (9 suites: handler, middleware, sxtp,
|
||||
router, feed, relations, blog, server, ledger). Blog posts now persist in the
|
||||
durable SX store (`persist/durable-backend`, on-disk under `$SX_PERSIST_DIR`),
|
||||
materialised into an in-memory view at boot and served from there.
|
||||
`bash lib/host/conformance.sh` → **171/171** (9 suites: handler, middleware, sxtp,
|
||||
router, feed, relations, blog, server, ledger). **Blog now runs on the EDITOR's
|
||||
content model** (`sx_content` = SX element markup, what `blog/sx/editor.sx`
|
||||
emits), NOT content-on-sx CtDoc: a post is a `{slug,title,sx_content,status}`
|
||||
record in the durable persist **KV**, and a post page is `render-to-html (parse
|
||||
sx_content)`. Full CRUD + an editor form-ingest endpoint (`POST /new`,
|
||||
form-urlencoded) + JSON API, writes auth+ACL guarded. **`render-to-html` is fast
|
||||
(~0ms)** — it doesn't hit the JIT-miscompiled Smalltalk path, so blog rendering
|
||||
is no longer the 2s problem (that was content-on-sx's `asHTML`).
|
||||
|
||||
> **Per-request IO (kernel) — FIXED.** `http-listen` handlers used to run via
|
||||
> `Sx_runtime.sx_call` (bare CEK, no IO resolution), so a handler doing a durable
|
||||
|
||||
Reference in New Issue
Block a user