diff --git a/lib/host/blog.sx b/lib/host/blog.sx index b6397409..775bb97e 100644 --- a/lib/host/blog.sx +++ b/lib/host/blog.sx @@ -1,30 +1,47 @@ ;; 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). Serving -;; GET // is FULLY DYNAMIC: the handler reads the post from the store and -;; renders it to HTML, per request — no in-memory view, no cached output. This is -;; possible because http-listen handlers now resolve per-request IO (the -;; cek_run_with_io kernel fix). The original strangler target (Quart blog -;; post_detail); published posts are world-visible, so this endpoint is ANONYMOUS. +;; 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 // read a post (public) -> rendered HTML / 404 +;; POST /posts create (guarded) -> 201 / 400 / 409 +;; PUT /posts/ update title+body (guarded)-> 200 / 400 / 404 +;; DELETE /posts/ 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. ;; -;; NOTE ON SPEED: content/html runs the interpreted Smalltalk-on-SX dispatch -;; (~2s for a tiny doc) because the JIT is not installed in this serving mode AND -;; currently miscompiles the Smalltalk evaluator's nested ASTs. Making the render -;; fast is a JIT-compiler fix (or a Smalltalk-interpreter optimisation), tracked -;; separately — it is NOT solved by caching the output. +;; A post is two blocks under stream "content:": a heading (id "-h") +;; and a body paragraph (id "-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.sx. +;; 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) ───────────────────── +;; ── store (durable source of truth, injectable) + logical clock ───── (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))) -;; ── publish + lookup (per-request, against the store) ─────────────── -;; Publish a simple post (title heading + body paragraph): append its insert ops -;; to the durable store. `at` is a caller-supplied logical timestamp. +;; content streams are keyed "content:"; recover the slug ("content:" = 8). +(define host/blog--stream-slug + (fn (stream) (if (starts-with? stream "content:") (substr stream 8) nil))) + +;; ── post helpers (per-request, against the store) ─────────────────── +(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"))) @@ -34,21 +51,49 @@ (op-insert (mk-text tid body) hid)) at)))) -;; Idempotent seed: publish only if the slug has no content yet (so a restart -;; replaying serve.sh doesn't append duplicate blocks to a persisted post). +;; 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). +(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. (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)))) ;; Materialise the post from the store by replaying its op-log; nil if no content. -;; Reads the durable store via per-request IO (works inside the handler thread). (define host/blog-lookup (fn (slug) (let ((doc (content/head host/blog-store slug))) (if (> (content/count doc) 0) doc nil)))) -;; ── handler: GET // -> rendered HTML (200) or 404 ───────────── +;; All posts with content, as [{:slug :title}]. +(define host/blog-list + (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))) + (list) + (persist/backend-streams host/blog-store)))) + +;; ── handlers ──────────────────────────────────────────────────────── +;; GET // -> rendered HTML (200) or 404. (define host/blog-post (fn (req) (let ((slug (dream-param req "slug"))) @@ -59,10 +104,74 @@ (str "Not found" "

404

No published post: " slug "

"))))))) -;; Anonymous read route. MUST be mounted LAST: the :slug pattern matches any -;; single-segment path, so domain routes (/feed, /health) take precedence. +;; GET /posts -> JSON list of posts. +(define host/blog-index (fn (req) (host/ok (host/blog-list)))) + +;; POST /posts -> create from JSON {slug,title,body}. 409 if it 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"))) + (host/error 400 "invalid payload"))))) + +;; PUT /posts/ -> update title+body from JSON {title,body}. 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")) + (host/error 400 "invalid payload"))))) + +;; DELETE /posts/ -> delete. 404 if absent. +(define host/blog-delete-handler + (fn (req) + (let ((slug (dream-param req "slug"))) + (if (host/blog-exists? slug) + (begin (host/blog-delete! slug) (host/ok {:slug slug :deleted true})) + (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). (define host/blog-routes - (list (dream-get "/:slug" host/blog-post))) + (list + (dream-get "/posts" host/blog-index) + (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. +(define host/blog--protect + (fn (resolve h) + (host/pipeline + (list + host/wrap-errors + (host/require-auth resolve) + (host/require-permission "edit" (fn (req) "blog"))) + h))) +(define host/blog-write-routes + (fn (resolve) + (list + (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!) diff --git a/lib/host/conformance.sh b/lib/host/conformance.sh index 7326cd52..9a13159c 100755 --- a/lib/host/conformance.sh +++ b/lib/host/conformance.sh @@ -117,6 +117,17 @@ emit_eval () { echo "(epoch $EPOCH)"; echo "(eval \"$1\")"; EPOCH=$((EPOCH+1)); OUTPUT=$(timeout 300 "$SX_SERVER" < "$TMPFILE" 2>&1 || true) +# Fail LOUD on any load/eval error. A test file that errors mid-load silently +# truncates its suite — the runner returns only the tests that ran before the +# error, so the suite reports a false green (e.g. "blog 13 passed, 0 failed" +# when 16 CRUD tests never ran). Catch the error markers and abort before the +# pass/fail tally can hide them. +if echo "$OUTPUT" | grep -qE 'Undefined symbol|Unhandled exception|\[load\][^|]*[Ee]rror|expected list, got|: error '; then + echo "FAIL: load/eval error detected — a suite may be silently truncated:" >&2 + echo "$OUTPUT" | grep -nE 'Undefined symbol|Unhandled exception|\[load\]|expected list, got|: error ' | head -20 >&2 + exit 1 +fi + TOTAL_PASS=0 TOTAL_FAIL=0 FAILED_SUITES=() diff --git a/lib/host/tests/blog.sx b/lib/host/tests/blog.sx index 7c934d77..91531ef8 100644 --- a/lib/host/tests/blog.sx +++ b/lib/host/tests/blog.sx @@ -82,6 +82,85 @@ (contains? (dream-resp-body (host-bl-app (host-bl-req "/feed"))) "\"ok\":true") true) +;; ── CRUD: list / create / update / delete (writes auth+ACL guarded) ─ +(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))) + +;; 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) + +;; 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.\"}"))) + 201) +;; created post renders at GET // +(host-bl-test "created post reads back as HTML" + (contains? (dream-resp-body (host-bl-wapp (host-bl-send "GET" "/hello/" nil ""))) "

Hello World

") + 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) +;; 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\"}"))) + 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\"}"))) + 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.\"}"))) + 200) +(host-bl-test "update changed the rendered post" + (contains? (dream-resp-body (host-bl-wapp (host-bl-send "GET" "/hello/" nil ""))) "

Edited Title

") + 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\"}"))) + 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" ""))) + 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 "delete missing -> 404" + (dream-status (host-bl-wapp (host-bl-send "DELETE" "/posts/ghost" "Bearer good" ""))) + 404) + (define host-bl-tests-run! (fn diff --git a/plans/host-on-sx.md b/plans/host-on-sx.md index 25ccbc5d..17f1734b 100644 --- a/plans/host-on-sx.md +++ b/plans/host-on-sx.md @@ -288,6 +288,32 @@ lib/host/sxtp.sx subsystem APIs (feed/search/commerce/… (docker stack + Caddy) remains. NEXT: golden harness, internal-HMAC, then promote into the stack behind a fresh subdomain. +## SX gotchas + how this loop guards against them + +The SX dev experience has real footguns. Most are statically detectable; the +tools exist (`sx_validate`, `deps-check`, `sx_format_check`) but must be *gated*. +Hit/relevant here: +- **Reserved-name shadowing** — `guard`/`bind`/`conj`/`disj` are special forms or + host primitives; a local binding of that name is silently shadowed by the form. + (`(let ((guard ...)))` made `(guard handler)` invoke the R7RS `guard` special + form → `first: expected list`.) Fix: namespace-prefix every helper + (`host/blog--protect`, never `guard`). +- **Silent test truncation** — a test file that errors mid-load returns only the + tests that ran before the error, reporting a FALSE GREEN ("blog 13 passed, 0 + failed" while 16 CRUD tests never ran). **GUARDED**: `conformance.sh` now greps + the run output for `Undefined symbol` / `Unhandled exception` / `expected list, + got` / `[load] … error` and aborts loudly before the tally can hide it. +- **`let` is parallel** (bindings can't see each other), **bodies need `(do …)`** + (only the last expr evaluates), **`append!` no-ops on map/rest-derived lists**, + **parsed keyword tokens ≠ string literals**. These produce wrong *results*, so + test coverage catches them as red (not silent) — provided the runner is honest, + which the truncation guard now ensures. + +Prevention ladder: parse (`sx_validate` after every edit) → unresolved/shadowed +symbols (`deps-check`, candidate pre-commit gate) → fail-loud runner (done) → +behavioural tests. A `deps-check`-style "binding shadows a special form" lint +would catch the reserved-name class before runtime — a worthwhile follow-up. + ## Blockers - **Live wiring to the native OCaml HTTP server** (Phase 3/4): the prod server in