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 (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>")))))
;; ── related posts (blog × relations) ────────────────────────────────
;; Every link between posts is a typed edge in the relations graph (lib/relations):
;; node = "blog:<slug>", kind = a relation kind. "related" is symmetric; directed
;; kinds (is-a, tagged) carry meaning by direction. The registry below is the one
;; place that knows each kind's direction, label, and candidate set — relate, the
;; picker, and rendering all read from it (see plans/typed-posts-and-relations.md).
;; "Typing is just relating to a type": classification is an is-a/tagged edge to a
;; type-post, and types ARE posts (same blog:<slug> namespace).
(define host/blog--node (fn (slug) (string->symbol (str "blog:" slug))))

(define host/blog-rel-kinds
  (list
    {:kind "related" :label "Related posts" :symmetric true :candidates "all"}
    {:kind "is-a" :label "Types" :symmetric false :candidates "types"
                  :inverse-label "Instances"}
    {:kind "tagged" :label "Tags" :symmetric false :candidates "tags"
                    :inverse-label "Tagged with this"}))

;; registry lookup; nil for an unknown kind (relate validates against this)
(define host/blog--kind-spec
  (fn (kind)
    (reduce (fn (acc k) (if (= (get k :kind) kind) k acc)) nil host/blog-rel-kinds)))
(define host/blog--kind-symmetric?
  (fn (kind) (let ((s (host/blog--kind-spec kind))) (and s (get s :symmetric)))))

;; ── edges (parameterised by kind, DURABLE) ──────────────────────────
;; lib/relations holds the graph in memory (a Datalog cache that re-saturates per
;; query); it does NOT survive a restart. So the host owns the durable source of
;; truth: every physical edge is also a KV row "edge:<src>|<kind>|<dst>" in the
;; blog store, replayed into the in-memory graph on boot (host/blog-load-edges!).
;; '|' is a safe delimiter — slugs are [a-z0-9-], kinds are registry names.
(define host/blog--edge-key (fn (src kind dst) (str "edge:" src "|" kind "|" dst)))

(define host/blog--add-edge!
  (fn (src dst kind)
    (begin
      (relations/relate (host/blog--node src) (host/blog--node dst) (string->symbol kind))
      (persist/backend-kv-put host/blog-store (host/blog--edge-key src kind dst) 1))))
(define host/blog--del-edge!
  (fn (src dst kind)
    (begin
      (relations/unrelate (host/blog--node src) (host/blog--node dst) (string->symbol kind))
      (persist/backend-kv-delete host/blog-store (host/blog--edge-key src kind dst)))))

;; A symmetric kind writes both directions, so children alone read it from either
;; side; a directed kind writes one edge (the inverse is host/blog-in).
(define host/blog-relate!
  (fn (a b kind)
    (begin
      (host/blog--add-edge! a b kind)
      (when (host/blog--kind-symmetric? kind) (host/blog--add-edge! b a kind)))))
(define host/blog-unrelate!
  (fn (a b kind)
    (begin
      (host/blog--del-edge! a b kind)
      (when (host/blog--kind-symmetric? kind) (host/blog--del-edge! b a kind)))))

;; rebuild the in-memory graph from the durable edge store — called on boot, after
;; the store is pointed at the durable backend. Each "edge:<src>|<kind>|<dst>" key
;; is re-applied directly (both directions of a symmetric kind are stored, so no
;; symmetry re-derivation is needed here).
(define host/blog-load-edges!
  (fn ()
    (for-each
      (fn (key)
        (let ((body (substr key 5)))                 ;; drop "edge:"
          (let ((p1 (index-of body "|")))
            (when (>= p1 0)
              (let ((src (substr body 0 p1))
                    (tail (substr body (+ p1 1))))
                (let ((p2 (index-of tail "|")))
                  (when (>= p2 0)
                    (relations/relate
                      (host/blog--node src)
                      (host/blog--node (substr tail (+ p2 1)))
                      (string->symbol (substr tail 0 p2))))))))))
      (filter (fn (k) (starts-with? k "edge:"))
        (persist/backend-kv-keys host/blog-store)))))

;; nodes -> existing blog slugs: strip "blog:", drop non-blog and deleted targets.
;; Existence is one kv-keys read (host/blog-slugs), NOT a perform per candidate —
;; keeping IO out of the inner filter (and out of the page-render quasiquote).
(define host/blog--edge-slugs
  (fn (nodes)
    (let ((existing (host/blog-slugs)))
      (filter (fn (s) (contains? existing s))
        (map (fn (n) (substr (symbol->string n) 5))
          (filter (fn (n) (starts-with? (symbol->string n) "blog:")) nodes))))))

;; outgoing targets / incoming sources of `slug` under `kind`, as slug lists.
(define host/blog-out
  (fn (slug kind)
    (host/blog--edge-slugs (relations/children (host/blog--node slug) (string->symbol kind)))))
(define host/blog-in
  (fn (slug kind)
    (host/blog--edge-slugs (relations/parents (host/blog--node slug) (string->symbol kind)))))

;; back-compat: "related posts" is just the symmetric "related" kind.
(define host/blog-related (fn (slug) (host/blog-out slug "related")))

;; ── relate picker (filterable, paginated candidate list) ────────────
;; Candidates to relate `slug` to: every post except itself and ones already
;; related, narrowed by `q` (case-insensitive substring of title or slug),
;; title-sorted. One page is `host/blog--picker-limit` rows from `offset`.
(define host/blog--picker-limit 20)
(define host/blog--relate-candidates
  (fn (slug q)
    (let ((already (host/blog-related slug))
          (ql (lower (or q ""))))
      (let ((cands
              (filter
                (fn (p)
                  (and (not (= (get p :slug) slug))
                       (not (contains? already (get p :slug)))
                       (or (= ql "")
                           (contains? (lower (get p :title)) ql)
                           (contains? (get p :slug) ql))))
                (host/blog-list))))
        ;; title-sort via [title slug] pairs (sort compares the title first)
        (map (fn (pair) {:slug (nth pair 1) :title (nth pair 0)})
          (sort (map (fn (p) (list (get p :title) (get p :slug))) cands)))))))

;; One candidate row: a tiny form whose button adds the relation (POST /relate).
(define host/blog--picker-item
  (fn (slug p)
    (quasiquote
      (li :style "border-bottom:1px solid #eee"
        (form :method "post" :style "margin:0"
          :action (unquote (str "/" slug "/relate"))
          (input :type "hidden" :name "other" :value (unquote (get p :slug)))
          (button :type "submit"
            :style "width:100%;text-align:left;background:none;border:none;padding:0.5em;cursor:pointer"
            (unquote (get p :title))))))))

;; GET /<slug>/relate-options?q=&offset= — one page of candidate rows as an HTML
;; fragment (the <li>s the picker script appends). Public read (same data as
;; /posts); the relate action itself stays guarded.
(define host/blog-relate-options
  (fn (req)
    (let ((slug (dream-param req "slug"))
          ;; dream's query parser does not %-decode values (its form parser does),
          ;; so a filter like "Item 13" arrives as "Item%2013" — decode it with
          ;; dream's own dr/url-decode before matching.
          (q (dr/url-decode (or (dream-query-param req "q") "")))
          (offset (host/query-int req "offset" 0)))
      (let ((page (take (drop (host/blog--relate-candidates slug q) offset)
                    host/blog--picker-limit)))
        (dream-html
          (join "" (map (fn (p) (render-page (host/blog--picker-item slug p))) page)))))))

;; GET /relate-picker.js — progressive-enhancement glue for the edit-page picker:
;; debounced live filter + scroll-to-load-more against /<slug>/relate-options. The
;; host serves static HTML (no SX hydration), so the interactive layer is a small
;; vanilla script served from this route (read once, cached).
(define host/blog-picker-js-src
  "(function(){var f=document.getElementById('relate-filter');if(!f)return;var r=document.getElementById('relate-results');var slug=f.getAttribute('data-slug'),off=0,q='',busy=false,done=false,pending=false,t;function load(reset){if(busy){if(reset)pending=true;return;}if(!reset&&done)return;busy=true;if(reset){off=0;done=false;}fetch('/'+slug+'/relate-options?q='+encodeURIComponent(q)+'&offset='+off).then(function(x){return x.text();}).then(function(h){var d=document.createElement('div');d.innerHTML=h;var n=d.children.length;if(reset)r.innerHTML='';while(d.firstChild)r.appendChild(d.firstChild);off+=n;done=n<20;busy=false;if(pending){pending=false;load(true);}}).catch(function(){busy=false;if(pending){pending=false;load(true);}});}f.addEventListener('input',function(){clearTimeout(t);t=setTimeout(function(){q=f.value.trim();load(true);},200);});r.addEventListener('scroll',function(){if(r.scrollTop+r.clientHeight>=r.scrollHeight-40){load(false);}});load(true);})();")
(define host/blog-picker-js
  (fn (req)
    (dream-response 200 {:content-type "application/javascript; charset=utf-8"}
      host/blog-picker-js-src)))

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

;; "Related posts" block for the post page: a list of links when there are any;
;; a subtle "add some" hint when there are none AND the viewer is logged in (an
;; editor); nothing for an anonymous viewer. Records (slug+title) are fetched up
;; front so the SX tree is built from in-memory data — no durable read happens
;; while the page tree is rendered.
(define host/blog--related-block
  (fn (slug logged-in)
    (let ((rel (map (fn (s) {:slug s :title (get (host/blog-get s) :title)})
                 (host/blog-related slug))))
      (cond
        ((> (len rel) 0)
          (let ((items
                  (map (fn (p)
                         (quasiquote
                           (li (a :href (unquote (str "/" (get p :slug) "/"))
                                 (unquote (get p :title))))))
                    rel)))
            (quasiquote
              (div :style "margin-top:2em"
                (h3 "Related posts")
                (unquote (list (quote ul) items))))))
        (logged-in
          (quasiquote
            (p :style "margin-top:2em;font-size:0.9em;opacity:0.7"
              "No related posts yet — "
              (a :href (unquote (str "/" slug "/edit")) "add some") ".")))
        (else "")))))

;; Related-posts editor for the edit page: current links each with a remove
;; button, plus an "add related" box (relate by slug; the submit validates it).
(define host/blog--related-editor
  (fn (slug)
    (let ((rel (host/blog-related slug)))
      (quasiquote
        (div :style "margin-top:2em;border-top:1px solid #ccc;padding-top:1em"
          (h3 "Related posts")
          (unquote
            (if (> (len rel) 0)
              (list (quote ul)
                (map (fn (s)
                       (quasiquote
                         (li (a :href (unquote (str "/" s "/")) (unquote s)) " "
                           (form :method "post" :style "display:inline"
                             :action (unquote (str "/" slug "/unrelate"))
                             (input :type "hidden" :name "other" :value (unquote s))
                             (button :type "submit" "remove")))))
                  rel))
              (quote (p :style "opacity:0.7" "None yet."))))
          ;; add: a filterable, infinite-scrolling picker. The filter input + the
          ;; results list are populated by /relate-picker.js (debounced filter,
          ;; scroll-to-load) hitting /<slug>/relate-options; each row's button
          ;; POSTs /relate. data-slug carries the post to the script.
          (h4 :style "margin-bottom:0.3em" "Add related")
          (input :type "text" :id "relate-filter" :data-slug (unquote slug)
            :placeholder "filter posts…" :autocomplete "off"
            :style "width:100%;padding:0.4em;box-sizing:border-box")
          (ul :id "relate-results"
            :style "list-style:none;padding:0;margin:0.5em 0;max-height:240px;overflow:auto;border:1px solid #ddd")
          (raw! "<script src=\"/relate-picker.js\"></script>"))))))

;; ── 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
          ;; Compute the rendered body + related block in let bindings BEFORE the
          ;; quasiquote — host/blog--related-block does durable reads, and IO must
          ;; happen in the handler body, not while the page tree is being built.
          (let ((body-html (host/blog-render r))
                (related-block (host/blog--related-block slug
                                 (not (nil? (host/current-principal req))))))
            (dream-html
              (host/blog--page (get r :title)
                (quasiquote
                  (div
                    (article (raw! (unquote body-html)))
                    (unquote related-block)
                    (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")
                      " · "
                      (unquote (host/auth-footer req))))))))
          (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"))
                  (p :style "margin-top:2em;font-size:0.9em;opacity:0.8"
                    (unquote (host/auth-footer req))))))))))))

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

;; 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
;; other post must exist and differ; otherwise a no-op. Redirects back to the edit
;; page. Guarded like the other browser write routes.
(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")))
      (if (nil? (host/blog-get slug))
        (dream-html-status 404
          (host/blog--page "Not found"
            (quasiquote (div (h1 "404") (p (unquote (str "No post: " slug)))))))
        (begin
          (when (and other (not (= other "")) (not (= other slug))
                     (host/blog--kind-spec kind) (host/blog-exists? other))
            (host/blog-relate! slug other kind))
          (dream-redirect (str "/" slug "/edit")))))))

;; POST /<slug>/unrelate — remove the relation to `other` under `kind` (default
;; "related"). Idempotent; redirects back to the edit page.
(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")))
      (begin
        (when (and other (not (= other "")) (host/blog--kind-spec kind))
          (host/blog-unrelate! slug other kind))
        (dream-redirect (str "/" slug "/edit"))))))

;; 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)))
            ;; related-editor does durable reads — compute it here, not in the
            ;; quasiquote, so IO stays in the handler body.
            (let ((related-editor (host/blog--related-editor slug))
                  (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")))
                      (unquote related-editor)
                      (p :style "margin-top:1.5em"
                        (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 "/relate-picker.js" host/blog-picker-js)
    (dream-get "/:slug/source" host/blog-source)
    (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
;; 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.
(define host/blog--protect-html
  (fn (resolve h)
    (host/pipeline
      (list
        host/wrap-errors
        (host/require-login resolve)
        (host/require-permission "edit" (fn (req) "blog")))
      h)))
(define host/blog-write-routes
  (fn (resolve)
    (list
      (dream-post "/new" (host/blog--protect-html resolve host/blog-form-submit))
      (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)))))

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