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 "subtype-of" :label "Subtype of" :symmetric false :candidates "types"
                        :inverse-label "Subtypes"}
    {: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")))

;; ── typing: is-a + subtype-of with subsumption ──────────────────────
;; Typing is just relating to a type, and types ARE posts. A post DECLARES its
;; types with is-a edges; types form a hierarchy with subtype-of edges. is-a
;; (instance-of) is NOT transitive on its own, but subsumption is: an instance of
;; a subtype is an instance of the supertype. So a post's full type set is its
;; declared types PLUS every subtype-of-ancestor of each (relations/descendants
;; follows subtype-of transitively). Keeps the Datalog ruleset minimal — the
;; closure is composed host-side.
(define host/blog--uniq
  (fn (xs) (reduce (fn (acc x) (if (contains? acc x) acc (concat acc (list x)))) (list) xs)))

(define host/blog-types-of
  (fn (slug)
    (host/blog--uniq
      (reduce
        (fn (acc t)
          (concat (concat acc (list t))
            (host/blog--edge-slugs
              (relations/descendants (host/blog--node t) (string->symbol "subtype-of")))))
        (list)
        (host/blog-out slug "is-a")))))

;; is this post (transitively) of the given type-slug?
(define host/blog-is-a? (fn (slug type) (contains? (host/blog-types-of slug) type)))

;; all posts that are (transitively) instances of `type`: instances of the type
;; itself plus instances of any of its subtypes. Computed in O(#subtypes) relation
;; queries, NOT one type-resolution per post — the efficient way to enumerate a
;; type's members (e.g. "all tags") for the picker.
(define host/blog-instances-of
  (fn (type)
    (let ((subtypes
            (concat (list type)
              (host/blog--edge-slugs
                (relations/ancestors (host/blog--node type) (string->symbol "subtype-of"))))))
      (host/blog--uniq
        (reduce (fn (acc t) (concat acc (host/blog-in t "is-a"))) (list) subtypes)))))

;; ── tags (a tag is a post that is-a tag) ────────────────────────────
(define host/blog-is-tag? (fn (slug) (host/blog-is-a? slug "tag")))
(define host/blog-tags (fn (slug) (host/blog-out slug "tagged")))          ;; a post's tags
(define host/blog-tagged-with (fn (tag) (host/blog-in tag "tagged")))      ;; posts with a tag

;; ── gradual validation seam ─────────────────────────────────────────
;; A type-post optionally carries a schema: a predicate over content. The map is
;; empty for now — validation is gradual, types accrue schemas later — but the
;; hook lives here so enforcement is a one-line addition, never a retrofit. A post
;; is type-valid when every schema implied by its types accepts the content; with
;; no schemas this is vacuously true, so it costs nothing until a type opts in.
(define host/blog-type-schemas {})
(define host/blog-schema-of (fn (type-slug) (get host/blog-type-schemas type-slug)))
(define host/blog-type-valid?
  (fn (slug content)
    (every?
      (fn (t) (let ((s (host/blog-schema-of t))) (or (nil? s) (s content))))
      (host/blog-types-of slug))))

;; Seed the root type-posts: "type" (the root) and "tag" (a kind of type). Types
;; ARE posts, so these are real posts that document themselves; tag subtype-of
;; type means anything that is-a tag is, transitively, a type. Idempotent — safe
;; to call on every boot (host/blog-seed! no-ops if present, edges are sets).
(define host/blog-seed-types!
  (fn ()
    (begin
      (host/blog-seed! "type" "Type"
        "(article (h1 \"Type\") (p \"The root type. Types are posts — so this is a post that documents the idea of a type. A post declares its types with is-a edges; types form a hierarchy with subtype-of edges.\"))"
        "published")
      (host/blog-seed! "tag" "Tag"
        "(article (h1 \"Tag\") (p \"A tag is a kind of type (tag subtype-of type), so anything that is-a tag is also a type. A post is tagged with a tag; a tag post documents the tag and lists what is tagged with it.\"))"
        "published")
      (host/blog-relate! "tag" "type" "subtype-of"))))

;; ── 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)
;; The candidate POOL for a kind comes from its registry :candidates: "all" posts,
;; or the members of a type ("tags" = instances of tag, "types" = instances of
;; type). Enumerating a type's members is O(#subtypes), not O(#posts).
(define host/blog--candidate-pool
  (fn (candidates)
    (cond
      ((= candidates "tags") (host/blog-instances-of "tag"))
      ((= candidates "types") (host/blog-instances-of "type"))
      (else (host/blog-slugs)))))

(define host/blog--relate-candidates
  (fn (slug q kind)
    (let ((spec (host/blog--kind-spec kind)))
      (let ((pool (host/blog--candidate-pool (get spec :candidates)))
            (already (host/blog-out slug kind))
            (ql (lower (or q ""))))
        ;; pool is slugs; resolve titles, drop self + already-linked, filter by q
        (let ((cands
                (filter
                  (fn (p)
                    (or (= ql "")
                        (contains? (lower (get p :title)) ql)
                        (contains? (get p :slug) ql)))
                  (map (fn (s) {:slug s :title (get (host/blog-get s) :title)})
                    (filter (fn (s) (and (not (= s slug)) (not (contains? already s)))) pool)))))
          ;; 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 under `kind`.
(define host/blog--picker-item
  (fn (slug p kind)
    (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)))
          (input :type "hidden" :name "kind" :value (unquote kind))
          (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?kind=&q=&offset= — one page of candidate rows for a
;; kind as an HTML fragment (the <li>s the picker script appends). Public read; the
;; relate action stays guarded.
(define host/blog-relate-options
  (fn (req)
    (let ((slug (dream-param req "slug"))
          (kind (or (dream-query-param req "kind") "related"))
          ;; dream's query parser does not %-decode values (its form parser does),
          ;; so a filter like "Item 13" arrives as "Item%2013" — decode it.
          (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 kind) offset)
                    host/blog--picker-limit)))
        (dream-html
          (join "" (map (fn (p) (render-page (host/blog--picker-item slug p kind))) page)))))))

;; GET /relate-picker.js — progressive-enhancement glue. MULTI-INSTANCE: wires
;; every .relate-picker box on the page (a Related picker + a Tags picker can
;; coexist), reading data-slug + data-kind from each. Debounced live filter +
;; scroll-to-load-more against /<slug>/relate-options. The host serves static HTML
;; (no SX hydration), so the interactive layer is this small cached script.
(define host/blog-picker-js-src
  "(function(){function wire(box){var f=box.querySelector('.rp-filter');if(!f)return;var r=box.querySelector('.rp-results');var slug=box.getAttribute('data-slug'),kind=box.getAttribute('data-kind')||'related',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?kind='+encodeURIComponent(kind)+'&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);}var boxes=document.querySelectorAll('.relate-picker');for(var i=0;i<boxes.length;i++){wire(boxes[i]);}})();")
(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))))))))

;; ── registry-driven relation rendering (post page) ──────────────────
;; One labelled block of links from records ({:slug :title}), or "" when empty.
;; Records are pre-fetched, so the tree is built from in-memory data only.
(define host/blog--edges-block
  (fn (records label)
    (if (> (len records) 0)
      (let ((items (map (fn (p)
                          (quasiquote
                            (li (a :href (unquote (str "/" (get p :slug) "/"))
                                  (unquote (get p :title))))))
                     records)))
        (quasiquote
          (div :style "margin-top:2em"
            (h3 (unquote label))
            (unquote (list (quote ul) items)))))
      "")))

;; nodes -> {:slug :title} records, existence-filtered against a shared key set.
(define host/blog--recs
  (fn (existing nodes)
    (map (fn (s) {:slug s :title (get (host/blog-get s) :title)})
      (filter (fn (s) (contains? existing s))
        (map (fn (n) (substr (symbol->string n) 5))
          (filter (fn (n) (starts-with? (symbol->string n) "blog:")) nodes))))))

;; ALL of a post's relation blocks, generated by ITERATING the registry: each
;; kind contributes its outgoing block (label) and, if it has an inverse, its
;; incoming block (inverse-label). Empty blocks are dropped. So adding a kind to
;; the registry makes it render automatically — no handler edit. One kv-keys read
;; up front; the relation lookups are in-memory. Returns a wrapper div, or "".
(define host/blog--relation-blocks
  (fn (slug)
    (let ((existing (host/blog-slugs))
          (node (host/blog--node slug)))
      (let ((blocks
              (reduce
                (fn (acc spec)
                  (let ((k (string->symbol (get spec :kind))))
                    (let ((out-b (host/blog--edges-block
                                   (host/blog--recs existing (relations/children node k))
                                   (get spec :label)))
                          (in-b (if (get spec :inverse-label)
                                  (host/blog--edges-block
                                    (host/blog--recs existing (relations/parents node k))
                                    (get spec :inverse-label))
                                  "")))
                      (concat acc (filter (fn (b) (not (= b ""))) (list out-b in-b))))))
                (list)
                host/blog-rel-kinds)))
        (if (> (len blocks) 0) (cons (quote div) blocks) "")))))

;; the relation section for the post page: the blocks, or — when empty and the
;; viewer is logged in — a subtle "add some" hint; nothing for anonymous viewers.
(define host/blog--relations-or-hint
  (fn (slug logged-in)
    (let ((blocks (host/blog--relation-blocks slug)))
      (cond
        ((not (= blocks "")) blocks)
        (logged-in
          (quasiquote
            (p :style "margin-top:2em;font-size:0.9em;opacity:0.7"
              "No relations yet — "
              (a :href (unquote (str "/" slug "/edit")) "add some") ".")))
        (else "")))))

;; Kind-aware relation editor for the edit page: current links (each with a
;; kind-scoped remove), plus a filterable picker (a .relate-picker box the shared
;; /relate-picker.js wires by data-kind). The picker's candidates come from the
;; kind's registry :candidates ("all" / tags / types). One editor per kind.
(define host/blog--relation-editor
  (fn (slug kind)
    ;; current edges read up front (a perform) — NOT inside the quasiquote, where
    ;; a perform would raise VmSuspended under http-listen.
    (let ((spec (host/blog--kind-spec kind))
          (current (host/blog-out slug kind)))
      (quasiquote
        (div :style "margin-top:2em;border-top:1px solid #ccc;padding-top:1em"
          (h3 (unquote (get spec :label)))
          (unquote
            (if (> (len current) 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))
                             (input :type "hidden" :name "kind" :value (unquote kind))
                             (button :type "submit" "remove")))))
                  current))
              (quote (p :style "opacity:0.7" "None yet."))))
          (div :class "relate-picker" :data-slug (unquote slug) :data-kind (unquote kind)
            (input :type "text" :class "rp-filter" :placeholder "filter…" :autocomplete "off"
              :style "width:100%;padding:0.4em;box-sizing:border-box")
            (ul :class "rp-results"
              :style "list-style:none;padding:0;margin:0.5em 0;max-height:240px;overflow:auto;border:1px solid #ddd")))))))

;; "Is this post a tag?" toggle — marking a post a tag is just an is-a edge to the
;; "tag" type-post, so it reuses the relate/unrelate routes (no new endpoint).
(define host/blog--is-tag-toggle
  (fn (slug)
    (if (host/blog-is-tag? slug)
      (quasiquote
        (p (span "This post is a tag ✓  ")
          (form :method "post" :style "display:inline"
            :action (unquote (str "/" slug "/unrelate"))
            (input :type "hidden" :name "other" :value "tag")
            (input :type "hidden" :name "kind" :value "is-a")
            (button :type "submit" "remove tag status"))))
      (quasiquote
        (form :method "post" :action (unquote (str "/" slug "/relate"))
          (input :type "hidden" :name "other" :value "tag")
          (input :type "hidden" :name "kind" :value "is-a")
          (button :type "submit" "Make this a tag"))))))

;; One editor per registry kind, wrapped in a div — the edit page's relation
;; section, generated by ITERATING the registry (add a kind -> it gets an editor).
(define host/blog--relation-editors
  (fn (slug)
    (cons (quote div)
      (map (fn (spec) (host/blog--relation-editor slug (get spec :kind)))
        host/blog-rel-kinds))))

;; ── 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 everything that does durable reads — body, related block, AND
          ;; the auth footer (a durable session read now) — in let bindings BEFORE
          ;; the quasiquote. IO must run in the handler body, never while the page
          ;; tree is built (a perform there raises VmSuspended under http-listen).
          (let ((principal (host/current-principal req)))
            (let ((body-html (host/blog-render r))
                  ;; all relation blocks (Related, Tags, Types, Tagged-with-this …)
                  ;; come from iterating the registry — one section, registry-driven.
                  (relations (host/blog--relations-or-hint slug (not (nil? principal))))
                  (auth-foot (host/auth-footer req)))
              (dream-html
                (host/blog--page (get r :title)
                  (quasiquote
                    (div
                      (article (raw! (unquote body-html)))
                      (unquote relations)
                      (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 auth-foot))))))))
          (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."))))
              ;; auth-footer does a durable session read — bind it BEFORE the
              ;; quasiquote (a perform during tree-build raises VmSuspended).
              (auth-foot (host/auth-footer req)))
          (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 auth-foot)))))))))))

(define host/blog-index (fn (req) (host/ok (host/blog-list))))

;; GET /tags — index of every tag (a post that is-a tag). Tags are posts, so each
;; links to its own page (which documents the tag + lists what's tagged with it).
(define host/blog-tags-index
  (fn (req)
    ;; pre-fetch records (slug+title) BEFORE the quasiquote — host/blog-get is a
    ;; durable read; a perform during tree-build raises VmSuspended.
    (let ((recs (map (fn (s) {:slug s :title (get (host/blog-get s) :title)})
                  (sort (host/blog-instances-of "tag"))))
          (auth-foot (host/auth-footer req)))
      (let ((items (map (fn (p)
                          (quasiquote
                            (li (a :href (unquote (str "/" (get p :slug) "/"))
                                  (unquote (get p :title))))))
                     recs)))
        (dream-html
          (host/blog--page "Tags"
            (quasiquote
              (div (h1 "Tags")
                (unquote (if (> (len recs) 0)
                           (list (quote ul) items)
                           (quote (p "No tags yet."))))
                (p :style "margin-top:2em;font-size:0.9em;opacity:0.8"
                  (a :href "/" "all posts") " · " (unquote auth-foot))))))))))

;; 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)))
            ;; the relation editors + tag toggle do durable reads — compute them
            ;; here, not in the quasiquote, so IO stays in the handler body.
            (let ((relation-editors (host/blog--relation-editors slug))
                  (tag-toggle (host/blog--is-tag-toggle 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")))
                      (div :style "margin-top:2em;border-top:1px solid #ccc;padding-top:1em"
                        (unquote tag-toggle))
                      (unquote relation-editors)
                      ;; one shared picker script wires every .relate-picker box
                      (raw! "<script src=\"/relate-picker.js\"></script>")
                      (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))))
            ;; parse-valid AND type-valid (the post's types' schemas accept the
            ;; content — vacuous until a type opts into a schema).
            (if (and (host/blog-content-ok? sx-content)
                     (host/blog-type-valid? slug 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 "/tags" host/blog-tags-index)
    (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))))