rose-ash/lib/host/blog.sx

;; 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.
;;
;; 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.

;; 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 ─────
(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)))

;; 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)))

;; ── 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")))
      (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).
(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.
(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
  (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 /<slug>/ -> rendered HTML (200) or 404.
(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))
          (dream-html-status 404
            (str "<!doctype html><title>Not found</title>"
              "<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>")))
(define host/blog-home
  (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>"))))))

;; 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/<slug> -> 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/<slug> -> 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 "/" host/blog-home)
    (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!)