rose-ash/lib/host/blog.sx

;; 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 (guard (e (true nil)) (parse 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 (article (raw! (unquote (host/blog-render r)))))))
          (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))))

;; ── 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 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 ((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> — 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)))
          (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>
(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 + 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: 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-auth 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-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))))