coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

host: SX-native wire — reads + write bodies are text/sx, JSON CRUD deleted

Browse Source 
Greenfield SX-native pivot (NOT a strangler): the host speaks SX/SXTP end to end;
JSON only at the future ActivityPub federation edge.

- OUTPUT: host/json-status -> host/sx-status — every host/ok/host/error response is
  text/sx via the serialize primitive (NOT application/json). Flips feed, relations,
  blog reads. Tests assert the SX envelope ({:ok true :data ...}).
- DELETE the blog JSON CRUD /posts (POST/PUT/DELETE) + bearer-based host/blog--protect:
  a pure old-contract REST mirror. Create/edit go through the HTML editor forms;
  programmatic writes speak SXTP. FOLLOW-UP: no browser delete route yet (was JSON-only,
  no UI) — add POST /:slug/delete + cascade edge cleanup when the metamodel UI needs it.
- INPUT: host/sx-body (sxtp.sx) parses a text/sx request body to a string-keyed dict
  (parse-safe + sxtp/-normalize). feed POST + relations attach/detach read it.
- UNIFIED field reader host/fields / host/field: text/sx body OR urlencoded form by
  content-type. The blog form handlers (new/edit/relate/unrelate) + login read through
  it — additive, urlencoded still works (no-engine / bootstrap fallback).

Conformance 290/290 (11 suites). Retires the strangler framing in the plan; adds the
'SX all the way out' wire table. The engine half (browser posts text/sx) follows.

Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
This commit is contained in:
giles
2026-06-30 11:07:30 +00:00
parent ad86f3051e
commit 999249b944
14 changed files with 145 additions and 221 deletions
Download Patch File Download Diff File Expand all files Collapse all files

119
lib/host/blog.sx
View File

@@ -7,13 +7,13 @@
;;
;; GET / HTML index of posts (public)
;; GET /<slug>/ rendered post (public) -> HTML / 404
;; GET /posts JSON list (public) -> [{slug,title,status}]
;; GET /posts SX list (public) -> {:ok true :data ({:slug …} …)}
;; 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").
;; POST /new form ingest from the editor (guarded)
;; POST /<slug>/edit form ingest, edit an existing post (guarded)
;; Reads anonymous; writes behind the auth+ACL pipeline ("edit" on "blog"). The
;; JSON CRUD /posts (POST/PUT/DELETE) was deleted in the SX-native pivot — the wire
;; is SX/SXTP (host/ok emits text/sx), writes go through the form ingest.
;; Depends on spec/render + web/adapter-html (render-to-html), lib/persist/*
;; (durable KV), lib/dream/* (+ form), lib/host/{handler,middleware}.sx.
@@ -1042,9 +1042,9 @@
;; body with a 400 HTML page (this path serves a browser form).
(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")))
(let ((title (host/field req "title"))
(sx-content (host/field req "sx_content"))
(status (or (host/field req "status") "published")))
(cond
((or (nil? title) (= title ""))
(host/blog--resp req 400
@@ -1062,67 +1062,13 @@
(host/blog-put! slug title (or sx-content "") status)
(dream-redirect (str "/" slug "/")))))))))
;; 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 ((title (get p :title)))
(cond
((or (nil? title) (= title "")) (host/error 400 "title required"))
((not (host/blog-content-ok? (get p :sx_content)))
(host/error 400 "invalid sx_content"))
(else
(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 "invalid payload")))))
;; 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")
(let ((r (host/blog-get slug)))
(cond
((nil? r) (host/error 404 "no such post"))
((not (host/blog-content-ok? (get p :sx_content)))
(host/error 400 "invalid sx_content"))
(else
(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 400 "invalid payload")))))
;; DELETE /posts/<slug>
;; drop every edge touching `slug`, across all kinds + both directions, so a
;; deleted post leaves no dangling links anywhere in the graph.
(define host/blog--drop-all-edges!
(fn (slug)
(for-each
(fn (spec)
(let ((kind (get spec :kind)))
(begin
(for-each (fn (o) (host/blog-unrelate! slug o kind)) (host/blog-out slug kind))
(for-each (fn (o) (host/blog-unrelate! o slug kind)) (host/blog-in slug kind)))))
host/blog-rel-kinds)))
(define host/blog-delete-handler
(fn (req)
(let ((slug (dream-param req "slug")))
(if (host/blog-exists? slug)
(begin
(host/blog--drop-all-edges! slug)
(host/blog-delete! slug)
(host/ok {:slug slug :deleted true}))
(host/error 404 "no such post")))))
;; The JSON CRUD /posts (create/update/delete) was DELETED in the greenfield
;; SX-native pivot (plans/relations-as-posts.md, "SX all the way out") — it was a
;; pure old-contract REST mirror. Create + edit go through the HTML editor forms
;; (POST /new, POST /:slug/edit); programmatic writes will speak SXTP. FOLLOW-UP:
;; there is no browser delete route yet (delete was JSON-only and had no UI) — add
;; POST /:slug/delete + cascade edge cleanup (drop every edge touching the slug,
;; both directions, all kinds) when the metamodel UI needs it.
;; POST /<slug>/relate — relate this post to another (form `other` = slug, `kind` =
;; relation kind, default "related"). Validated: kind must be a known kind and the
@@ -1131,8 +1077,8 @@
(define host/blog-relate-submit
(fn (req)
(let ((slug (dream-param req "slug"))
(other (dream-form-field req "other"))
(kind (or (dream-form-field req "kind") "related")))
(other (host/field req "other"))
(kind (or (host/field req "kind") "related")))
(if (nil? (host/blog-get slug))
(host/blog--resp req 404
(host/blog--page req "Not found"
@@ -1161,8 +1107,8 @@
(define host/blog-unrelate-submit
(fn (req)
(let ((slug (dream-param req "slug"))
(other (dream-form-field req "other"))
(kind (or (dream-form-field req "kind") "related")))
(other (host/field req "other"))
(kind (or (host/field req "kind") "related")))
(begin
(when (and other (not (= other "")) (host/blog--kind-spec kind))
(host/blog-unrelate! slug other kind))
@@ -1230,9 +1176,9 @@
(host/blog--resp req 404
(host/blog--page req "Not found"
(quasiquote (div (h1 "404") (p (unquote (str "No post: " slug)))))))
(let ((title (or (dream-form-field req "title") (get r :title)))
(sx-content (or (dream-form-field req "sx_content") ""))
(status (or (dream-form-field req "status") (get r :status))))
(let ((title (or (host/field req "title") (get r :title)))
(sx-content (or (host/field req "sx_content") ""))
(status (or (host/field req "status") (get r :status))))
;; collect issues up front (perform): unparseable markup, then each
;; schema requirement the post's types impose. Empty = save.
(let ((issues (if (host/blog-content-ok? sx-content)
@@ -1264,17 +1210,9 @@
(dream-get "/:slug/relate-options" host/blog-relate-options)
(dream-get "/:slug" host/blog-post)))
;; 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
(list
host/wrap-errors
(host/require-user resolve)
(host/require-permission "edit" (fn (req) "blog")))
h)))
;; Browser variant: identical ACL gate, but an unauthenticated request REDIRECTS
;; Guarded writes: HTML editor form ingest behind auth+ACL. (The JSON CRUD that
;; used a bearer-based host/blog--protect was deleted in the SX-native pivot.)
;; Browser gate: identical ACL, but an unauthenticated request REDIRECTS
;; to the login page (host/require-login) rather than returning a raw JSON 401 —
;; the form/edit pages are HTML, so a logged-out click should land on /login and
;; return here afterwards.
@@ -1293,10 +1231,7 @@
(dream-get "/:slug/edit" (host/blog--protect-html resolve host/blog-edit-form))
(dream-post "/:slug/edit" (host/blog--protect-html resolve host/blog-edit-submit))
(dream-post "/:slug/relate" (host/blog--protect-html resolve host/blog-relate-submit))
(dream-post "/:slug/unrelate" (host/blog--protect-html resolve host/blog-unrelate-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)))))
(dream-post "/:slug/unrelate" (host/blog--protect-html resolve host/blog-unrelate-submit)))))
;; EXPERIMENTAL: create-only, UNGUARDED — POST /new form ingest with error
;; trapping but NO auth, for validating the editor->host publish loop on the