coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
1eec131101d23ef77230112309966aa3eb3a5f1b
rose-ash/lib/host/blog.sx
giles 1eec131101 host: view + edit the SX source of each blog post (blog 47/47, 213 total) 
Posts ARE SX source, so expose it: a public raw-source view and a guarded
in-browser source editor.

- GET /<slug>/source  — raw sx_content as text/plain (public; a published
  post's source isn't secret).
- GET /<slug>/edit    — edit form pre-filled with the post's title, raw source
  (in a textarea, render-to-html-escaped so it shows verbatim), and status
  (current value pre-selected). Guarded (editor only). Slug is preserved.
- POST /<slug>/edit   — save the edited source; same write-time validation as
  create (unparseable body -> 400, post left intact); 303 back to the post.
- post page gains "view source · edit · all posts" footer links.

Routing: /:slug/source + /:slug/edit are two-segment patterns; the router
consumes :param as exactly one segment and requires a full match, so /:slug
does not shadow them (asserted). 14 new blog tests cover view (200/text-plain/
raw body/404/no-shadow) and edit (401 unauth GET+POST, 200 form, source shown,
303 save, persisted, slug preserved, 400 malformed, 404 missing).

Verified live on blog.rose-ash.com: view source, guarded edit form, save
round-trip (rendered post + source both reflect the edit).

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

366 lines
18 KiB
Plaintext
Raw Blame History

;; 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.
;;
;; 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.
;; ── 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--key (fn (slug) (str "blog:" slug)))
;; 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) " ")))))
;; ── records ─────────────────────────────────────────────────────────
(define host/blog-get
(fn (slug) (persist/backend-kv-get host/blog-store (host/blog--key slug))))
(define host/blog-exists?
(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) (persist/backend-kv-delete host/blog-store (host/blog--key slug))))
(define host/blog-seed!
(fn (slug title sx-content status)
(when (not (host/blog-exists? slug)) (host/blog-put! slug title sx-content status))))
;; all blog slugs (kv keys are "blog:<slug>")
(define host/blog-slugs
(fn ()
(reduce
(fn (acc k)
(if (starts-with? k "blog:") (append acc (list (substr k 5))) acc))
(list)
(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))))
;; ── render ──────────────────────────────────────────────────────────
;; A post's sx_content is SX element markup -> HTML via render-page (which supplies
;; the server env so components resolve + keyword attrs are kept).
;;
;; Rendered PER BLOCK and guarded: the editor wraps content in a (<> ...) fragment
;; of blocks, some of which the host can't render (the legacy editor emits bare
;; ~kg-md cards while the components are ~kg_cards/kg-md — drift we don't paper over
;; with aliases). Rendering each block under its own guard means the real prose
;; (p/h1/ul/...) shows and only the unsupported block degrades to a placeholder —
;; and a bad block never crashes the handler (-> 502).
(define host/blog--render-node
(fn (node)
(guard (e (true "<div class=\"blk-unsupported\"><em>(unsupported block)</em></div>"))
(render-page node))))
(define host/blog-render
(fn (record)
(let ((sx (get record :sx-content)))
(if (and sx (not (= sx "")))
(let ((tree (parse-safe sx)))
(cond
((nil? tree) "<p><em>(unparseable content)</em></p>")
((and (= (type-of tree) "list") (> (len tree) 0)
(= (str (first tree)) "<>"))
(join "" (map host/blog--render-node (rest tree))))
(else (host/blog--render-node tree))))
(str "<p>(empty post)</p>")))))
;; ── page shell ──────────────────────────────────────────────────────
;; A page is an SX element tree, rendered via render-page (5.1). The handler
;; builds the tree (running any dynamic logic in the full evaluator, e.g. a posts
;; loop) and render-page renders the static result — no embedded HTML strings,
;; only the doctype prefix render-to-html doesn't emit. `body` is an SX node.
(define host/blog--page
(fn (title body)
(str "<!doctype html>"
(render-page
(quasiquote
(html
(head (meta :charset "utf-8") (title (unquote title)))
(body (unquote body))))))))
;; ── read handlers ───────────────────────────────────────────────────
;; Post body is rendered per-block (a guarded HTML string) then injected raw.
(define host/blog-post
(fn (req)
(let ((slug (dream-param req "slug")))
(let ((r (host/blog-get slug)))
(if r
(dream-html
(host/blog--page (get r :title)
(quasiquote
(div
(article (raw! (unquote (host/blog-render r))))
(p :style "margin-top:2em;font-size:0.9em;opacity:0.8"
(a :href (unquote (str "/" slug "/source")) "view source")
" · "
(a :href (unquote (str "/" slug "/edit")) "edit")
" · "
(a :href "/" "all posts"))))))
(dream-html-status 404
(host/blog--page "Not found"
(quasiquote
(div (h1 "404")
(p (unquote (str "No published post: " slug))))))))))))
(define host/blog-home
(fn (req)
(let ((posts (host/blog-list)))
(let ((items
(map
(fn (p)
(quasiquote
(li (a :href (unquote (str "/" (get p :slug) "/"))
(unquote (get p :title))))))
posts)))
(let ((listing (if (> (len posts) 0)
(list (quote ul) items)
(quote (p "No posts yet.")))))
(dream-html
(host/blog--page "Blog"
(quasiquote
(div (h1 "Posts")
(unquote listing)
(p (a :href "/new" "+ New post")))))))))))
(define host/blog-index (fn (req) (host/ok (host/blog-list))))
;; GET /<slug>/source — the raw sx_content as text/plain. Posts ARE SX source, so
;; this just hands back the stored markup (public; a published post's source is
;; not secret). 404 if the post is absent.
(define host/blog-source
(fn (req)
(let ((slug (dream-param req "slug")))
(let ((r (host/blog-get slug)))
(if r
(dream-response 200 {:content-type "text/plain; charset=utf-8"}
(or (get r :sx-content) ""))
(dream-html-status 404
(host/blog--page "Not found"
(quasiquote (div (h1 "404") (p (unquote (str "No post: " slug))))))))))))
;; ── create page (GET /new) — clean minimal form as an SX tree ───────
;; No legacy JS editor, no external assets, no shims. The rich WYSIWYG is a
;; future native SX-island editor (Phase 5.2+). Posts to /new.
(define host/blog-new-form
(fn (req)
(dream-html
(host/blog--page "New post"
(quasiquote
(div
(h1 "New post")
(form :method "post" :action "/new"
(p (input :name "title" :placeholder "Title"
:style "font-size:1.4em;width:100%"))
(p (textarea :name "sx_content" :rows "12"
:style "width:100%;font-family:monospace"
:placeholder "(p \"Your post as SX markup\")"))
(p (select :name "status"
(option :value "draft" "Draft")
(option :value "published" "Published"))
" "
(button :type "submit" "Publish")))
(p (a :href "/" "all posts"))))))))
;; ── write-time validation ───────────────────────────────────────────
;; sx_content must be storable as renderable SX: empty is allowed (an empty post),
;; otherwise it must parse. parse-safe returns nil on malformed input (the kernel
;; parser raises a native Parse_error an SX guard can't catch), so this rejects a
;; bad body at write time instead of letting it 500 on read. Mirrors the read-path
;; guard in host/blog-render — bad content never enters the durable store.
(define host/blog-content-ok?
(fn (sx)
(or (nil? sx) (= sx "") (not (nil? (parse-safe sx))))))
;; ── 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; rejects a missing title or unparseable
;; 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")))
(cond
((or (nil? title) (= title ""))
(dream-html-status 400
(host/blog--page "Error"
(quasiquote (div (h1 "Error") (p "Title is required.")
(p (a :href "/new" "Back")))))))
((not (host/blog-content-ok? sx-content))
(dream-html-status 400
(host/blog--page "Error"
(quasiquote (div (h1 "Error") (p "Post body is not valid SX markup.")
(p (a :href "/new" "Back")))))))
(else
(let ((slug (host/blog-slugify title)))
(begin
(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>
(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")))))
;; GET /<slug>/edit — edit form pre-filled with the post's current title, raw
;; sx_content (in a textarea — render-to-html escapes the text child, so the
;; browser shows the source verbatim), and status (current value pre-selected).
;; Guarded: only an editor reaches the editor. Keeps the slug (edits don't re-slug).
(define host/blog-edit-form
(fn (req)
(let ((slug (dream-param req "slug")))
(let ((r (host/blog-get slug)))
(if (nil? r)
(dream-html-status 404
(host/blog--page "Not found"
(quasiquote (div (h1 "404") (p (unquote (str "No post: " slug)))))))
(let ((status (get r :status)))
(let ((mk-opt
(fn (val label)
(if (= val status)
(quasiquote (option :value (unquote val) :selected "selected" (unquote label)))
(quasiquote (option :value (unquote val) (unquote label)))))))
(dream-html
(host/blog--page (str "Edit: " (get r :title))
(quasiquote
(div
(h1 (unquote (str "Edit: " (get r :title))))
(form :method "post" :action (unquote (str "/" slug "/edit"))
(p (input :name "title" :value (unquote (get r :title))
:style "font-size:1.4em;width:100%"))
(p (textarea :name "sx_content" :rows "16"
:style "width:100%;font-family:monospace"
(unquote (or (get r :sx-content) ""))))
(p (select :name "status"
(unquote (mk-opt "draft" "Draft"))
(unquote (mk-opt "published" "Published")))
" "
(button :type "submit" "Save")))
(p (a :href (unquote (str "/" slug "/")) "view post")
" · "
(a :href (unquote (str "/" slug "/source")) "view source")))))))))))))
;; POST /<slug>/edit — save the edited source. Same write-time validation as the
;; create paths (unparseable body -> 400, post left intact). Slug is preserved.
(define host/blog-edit-submit
(fn (req)
(let ((slug (dream-param req "slug")))
(let ((r (host/blog-get slug)))
(if (nil? r)
(dream-html-status 404
(host/blog--page "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))))
(if (host/blog-content-ok? sx-content)
(begin
(host/blog-put! slug title sx-content status)
(dream-redirect (str "/" slug "/")))
(dream-html-status 400
(host/blog--page "Error"
(quasiquote (div (h1 "Error") (p "Post body is not valid SX markup.")
(p (a :href (unquote (str "/" slug "/edit")) "Back")))))))))))))
;; ── routes ──────────────────────────────────────────────────────────
;; 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/source" host/blog-source)
(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)))
(define host/blog-write-routes
(fn (resolve)
(list
(dream-post "/new" (host/blog--protect resolve host/blog-form-submit))
(dream-get "/:slug/edit" (host/blog--protect resolve host/blog-edit-form))
(dream-post "/:slug/edit" (host/blog--protect resolve host/blog-edit-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)))))
;; EXPERIMENTAL: create-only, UNGUARDED — POST /new form ingest with error
;; trapping but NO auth, for validating the editor->host publish loop on the
;; experimental subdomain. Create-only by design (no PUT/DELETE), so the worst
;; case is junk posts, not overwrite/delete. GATE before any real use.
(define host/blog-open-create-routes
(list
(dream-post "/new" (host/pipeline (list host/wrap-errors) host/blog-form-submit))))
Reference in New Issue View Git Blame Copy Permalink