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

;; Relations are POSTS (plans/relations-as-posts.md). Each relation-post is-a
;; `relation` and owns its metadata in a :rel slot {:symmetric :label
;; :inverse-label}. To keep RENDER paths perform-free — a durable read inside the
;; http-listen render VM raises VmSuspended — the relation specs are loaded into an
;; in-memory cache at boot, exactly like edges (host/blog-load-edges!). kind-spec /
;; rel-kinds / kind-symmetric? then read the cache (pure); the relation-posts stay
;; the durable source of truth. host/blog-load-rel-kinds! re-reads them.
(define host/blog--rel-cache (dict))
;; cache one relation-post's :rel metadata (+ :kind), keyed by slug.
(define host/blog--cache-rel!
  (fn (kind)
    (let ((m (get (host/blog-get kind) :rel)))
      (when m (dict-set! host/blog--rel-cache kind (merge {:kind kind} m))))))
;; host/blog-rel-kinds is a VALUE (the list of relation specs), populated at boot by
;; load-rel-kinds! — like slice 1's static registry, which mapped fine on the live
;; serving JIT. (Computing it as a function that map/for-each-es a function-produced
;; list silently lost 3 of 4 relations on the live JIT — see plans/relations-as-posts.md
;; / plans/jit-bytecode-correctness.md. Both the cache loads and the list build are
;; therefore UNROLLED — no iteration over the relation list.) Metadata still lives on
;; the relation-posts; add a relation = a seed-rel! + a line in each unrolled list.
(define host/blog-rel-kinds (list))
(define host/blog-load-rel-kinds!
  (fn ()
    (begin
      (host/blog--cache-rel! "related")
      (host/blog--cache-rel! "is-a")
      (host/blog--cache-rel! "subtype-of")
      (host/blog--cache-rel! "tagged")
      (set! host/blog-rel-kinds
        (list (get host/blog--rel-cache "related") (get host/blog--rel-cache "is-a")
              (get host/blog--rel-cache "subtype-of") (get host/blog--rel-cache "tagged"))))))
;; spec = the cached :rel metadata + :kind; nil for a non-relation (relate validates).
(define host/blog--kind-spec (fn (kind) (get host/blog--rel-cache kind)))
(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))))))

;; DIRECT edges come from the durable edge store, NOT lib/relations: each relations
;; query re-runs the (CEK-interpreted) ruleset — ~seconds even on a tiny graph —
;; whereas the edge:<src>|<kind>|<dst> KV rows are a cheap string scan. lib/relations
;; is reserved for TRANSITIVE queries (descendants/ancestors). The two are always
;; in sync: host/blog-relate! writes both, and a plain blog edge has no derived
;; effective edges, so KV == relations/children for direct lookups.
(define host/blog--parse-edge-key
  (fn (k)
    (if (starts-with? k "edge:")
      (let ((body (substr k 5)))
        (let ((p1 (index-of body "|")))
          (if (< p1 0) nil
            (let ((rest (substr body (+ p1 1))))
              (let ((p2 (index-of rest "|")))
                (if (< p2 0) nil
                  {:src (substr body 0 p1)
                   :kind (substr rest 0 p2)
                   :dst (substr rest (+ p2 1))}))))))
      nil)))
(define host/blog--all-edges
  (fn ()
    (filter (fn (e) (not (nil? e)))
      (map host/blog--parse-edge-key (persist/backend-kv-keys host/blog-store)))))

;; outgoing targets / incoming sources of `slug` under `kind`, as existing slugs.
(define host/blog-out
  (fn (slug kind)
    (let ((existing (host/blog-slugs)))
      (filter (fn (s) (contains? existing s))
        (reduce (fn (acc e)
                  (if (and (= (get e :src) slug) (= (get e :kind) kind))
                    (concat acc (list (get e :dst))) acc))
          (list) (host/blog--all-edges))))))
(define host/blog-in
  (fn (slug kind)
    (let ((existing (host/blog-slugs)))
      (filter (fn (s) (contains? existing s))
        (reduce (fn (acc e)
                  (if (and (= (get e :dst) slug) (= (get e :kind) kind))
                    (concat acc (list (get e :src))) acc))
          (list) (host/blog--all-edges))))))

;; 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: declarative type schemas ───────────────────
;; A type may carry a SCHEMA: a list of rules {:block <tag> :msg <why>}, each
;; requiring the content to contain (anywhere) an element of that tag. A post is
;; checked against the schema of every type it is-a; a type with no schema imposes
;; nothing (gradual). Schemas are declarative data (not opaque predicates) so they
;; yield a specific, human error — and could later be stored ON the type-post.
(define host/blog-type-schemas
  {:article (list {:block "h1" :msg "an article needs a heading (h1)"})})
(define host/blog-schema-of (fn (type-slug) (get host/blog-type-schemas type-slug)))

;; every element tag in a parsed content tree, recursively (the heads of nested
;; lists) — so "requires h1" matches an h1 even inside an article/section wrapper.
(define host/blog--all-tags
  (fn (tree)
    (if (and (= (type-of tree) "list") (> (len tree) 0))
      (concat (list (str (first tree)))
        (reduce (fn (acc c) (concat acc (host/blog--all-tags c))) (list) (rest tree)))
      (list))))

;; the :msg of each required :block a schema asks for but the content lacks.
(define host/blog--schema-issues
  (fn (schema content)
    (let ((tags (host/blog--all-tags (parse-safe content))))
      (reduce
        (fn (acc rule)
          (if (contains? tags (get rule :block)) acc (concat acc (list (get rule :msg)))))
        (list) schema))))

;; all schema issues for a post = the union over every type it is-a that carries a
;; schema. Empty = valid; vacuous (and cheap) when no type has a schema.
(define host/blog-type-issues
  (fn (slug content)
    (reduce
      (fn (acc t)
        (let ((s (host/blog-schema-of t)))
          (if s (concat acc (host/blog--schema-issues s content)) acc)))
      (list) (host/blog-types-of slug))))
(define host/blog-type-valid?
  (fn (slug content) (= (len (host/blog-type-issues slug content)) 0)))

;; Seed a relation-post: a post that is-a `relation` and carries its metadata in a
;; :rel slot. Idempotent (the record is written once; the is-a edge is a set).
(define host/blog--seed-rel!
  (fn (slug title symmetric label inverse-label)
    (begin
      (when (not (host/blog-exists? slug))
        (persist/backend-kv-put host/blog-store (host/blog--key slug)
          {:slug slug :title title
           :sx-content (str "(article (h1 \"" title "\") (p \"A relation — posts link to each other through it. Its symmetry and labels live on this post.\"))")
           :status "published"
           :rel {:symmetric symmetric :label label :inverse-label inverse-label}}))
      (host/blog-relate! slug "relation" "is-a"))))

;; 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
      ;; relations are posts too — `relation` is their root; each relation-post
      ;; is-a relation and owns its symmetry + labels (plans/relations-as-posts.md).
      (host/blog-seed! "relation" "Relation"
        "(article (h1 \"Relation\") (p \"The root of relations. A relation is a typed edge between posts; each relation-post declares its symmetry and labels, and a type anchors its object end (which gives the picker its candidates).\"))"
        "published")
      (host/blog--seed-rel! "related"    "related"    true  "Related posts" nil)
      (host/blog--seed-rel! "is-a"       "is a"       false "Types"         "Instances")
      (host/blog--seed-rel! "subtype-of" "subtype of" false "Subtype of"    "Subtypes")
      (host/blog--seed-rel! "tagged"     "tagged"     false "Tags"          "Tagged with this")
      (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")
      ;; "article" — a type WITH a schema (requires a heading). Posts that is-a
      ;; article are validated against it on save (gradual typing in action).
      (host/blog-seed! "article" "Article"
        "(article (h1 \"Article\") (p \"A kind of post that must have a heading. A post that is-a article is checked against this type's schema on save — gradual typing: declaring the type adds the requirement, and the next edit must satisfy it.\"))"
        "published")
      (host/blog-relate! "article" "type" "subtype-of")
      ;; relation DECLARATIONS (see plans/relations-as-posts.md). A type-post declares
      ;; which relation it anchors at its OBJECT end ("you may point at me with R"); the
      ;; picker's candidate set is the down-closure of a relation's anchors through the
      ;; type graph, so the candidates for a relation are exactly the posts that inherit
      ;; its declaration. `type` anchors is-a + subtype-of (you point at a type), `tag`
      ;; anchors tagged (you point at a tag). `related` has no anchor → every post.
      (host/blog-relate! "type" "is-a" "declares")
      (host/blog-relate! "type" "subtype-of" "declares")
      (host/blog-relate! "tag" "tagged" "declares"))))

;; ── 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)
;; Down-closure: every post reachable from `roots` by walking INVERSE is-a ∪
;; subtype-of edges (i.e. instances and subtypes, transitively), roots included.
;; This is "everything that is, transitively, an instance-or-subtype of a root".
;; BFS over direct edges (host/blog-in); `seen` makes it cycle-safe and terminating.
(define host/blog--reach-down
  (fn (roots)
    (let loop ((frontier roots) (seen (list)))
      (if (empty? frontier)
        seen
        (let ((t (first frontier)))
          (if (contains? seen t)
            (loop (rest frontier) seen)
            (loop
              (concat (rest frontier)
                (concat (host/blog-in t "is-a") (host/blog-in t "subtype-of")))
              (concat seen (list t)))))))))

;; The candidate POOL for relating under `kind` is DECLARATION-driven (see
;; plans/relations-as-posts.md): the down-closure of the posts that DECLARE `kind`
;; at their object end. So is-a/subtype-of (anchored by `type`) offer the whole type
;; closure — roots AND instances — and `tagged` (anchored by `tag`) offers the tags.
;; A relation with no declaration (e.g. `related`) offers every post.
(define host/blog--candidate-pool
  (fn (kind)
    (let ((anchors (host/blog-in kind "declares")))
      (if (empty? anchors)
        (host/blog-slugs)
        (host/blog--reach-down anchors)))))

;; Slice 3 — typed relations: a post is a valid OBJECT (target end) of `kind` iff it's
;; in the relation's declared candidate set (the down-closure of kind's declares-anchors
;; — the target-type constraint). The SAME set the picker offers, so the picker and
;; the relate endpoint agree by construction. A relation with no anchor (`related`)
;; accepts any existing post. This is what turns "candidate set" into an enforced
;; relation schema: is-a's object must be a type, tagged's must be a tag, etc.
(define host/blog--valid-object?
  (fn (kind other)
    (contains? (host/blog--candidate-pool kind) other)))

(define host/blog--title (fn (s) (get (host/blog-get s) :title)))   ;; one durable read

;; One PAGE of candidates (records {:slug :title}) for relating `slug` under `kind`.
;; Slice 2.5 — title reads are O(page), not O(pool): the available candidate SLUGS are
;; computed + slug-sorted with NO per-candidate read; then titles are fetched only for
;; the rows actually returned. On the unfiltered path (q="" — the initial picker load
;; AND every editor server-fill) that's ~`limit` reads instead of one-per-post, which
;; was the durable-read churn under http-listen. A filter (q≠"") still resolves titles
;; across the pool, since it matches on the title — but that's the interactive path.
(define host/blog--relate-candidates
  (fn (slug q kind offset limit)
    (let ((pool (host/blog--candidate-pool kind))
          (already (host/blog-out slug kind))
          (ql (lower (or q ""))))
      (let ((avail (sort (filter (fn (s) (and (not (= s slug)) (not (contains? already s)))) pool))))
        (if (= ql "")
          ;; no filter: page by slug, then read titles for just the page
          (map (fn (s) {:slug s :title (host/blog--title s)})
            (take (drop avail offset) limit))
          ;; filter: resolve titles, match on title|slug, then page
          (let ((recs (map (fn (s) {:slug s :title (host/blog--title s)}) avail)))
            (take
              (drop
                (filter (fn (r) (or (contains? (lower (get r :title)) ql)
                                    (contains? (get r :slug) ql)))
                  recs)
                offset)
              limit)))))))

;; One candidate row: a tiny form whose button adds the relation under `kind`.
(define host/blog--picker-item
  (fn (slug p kind)
    (quasiquote
      (li :id (unquote (str "cand-" kind "-" (get p :slug)))
          :style "border-bottom:1px solid #eee"
        ;; AJAX relate: sx-post the relation, then sx-swap="outerHTML" re-renders the
        ;; WHOLE relation editor for this kind (its sx-target #rel-editor-KIND) — the
        ;; just-related post moves into the current-relations list and out of the
        ;; candidate pool, and the fresh picker re-loads its candidates. (A bare
        ;; delete of this row added the relation server-side but never showed it in
        ;; the current list; re-rendering the editor keeps BOTH lists in sync.)
        ;; method+action stay for the no-JS fallback (plain POST -> 303 -> reload).
        (form :method "post" :style "margin:0"
          :action (unquote (str "/" slug "/relate"))
          :sx-post (unquote (str "/" slug "/relate"))
          :sx-target (unquote (str "#rel-editor-" kind))
          :sx-swap "outerHTML"
          (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))))))))

;; The infinite-scroll "load more" sentinel: an <li> that, when scrolled into view
;; (sx-trigger "revealed"), GETs the NEXT page and replaces ITSELF (sx-swap
;; outerHTML, default self-target) with those rows + the next sentinel. This is the
;; SX-htmx engine doing the paging — no client JS. q is %-encoded back into the URL
;; so the filter is preserved across pages.
(define host/blog--picker-more
  (fn (slug kind q next)
    (quasiquote
      (li :class "rp-more"
        :style "list-style:none;padding:0.5em;text-align:center;opacity:0.6"
        :sx-get (unquote (str "/" slug "/relate-options?kind=" kind
                           "&q=" (dr/url-encode q) "&offset=" next))
        :sx-trigger "revealed"
        :sx-swap "outerHTML"
        ;; a dropped/offline page-fetch retries with exponential backoff (1s→30s)
        ;; until it succeeds, so a flaky connection self-heals as you scroll.
        :sx-retry "exponential:1000:30000"
        "Loading more…"))))

;; GET /<slug>/relate-options?kind=&q=&offset= — one page of candidate rows for a
;; kind as an HTML fragment, swapped into the picker by the SX-htmx engine. A full
;; page is followed by a "load more" sentinel (above); the last page is not. 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 (host/blog--relate-candidates slug q kind offset host/blog--picker-limit)))
        (let ((rows (join "" (map (fn (p) (render-page (host/blog--picker-item slug p kind))) page)))
              (more (if (= (len page) host/blog--picker-limit)
                      (render-page (host/blog--picker-more slug kind q (+ offset host/blog--picker-limit)))
                      "")))
          (dream-html (str rows more)))))))


;; ── 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.
;; SPA shell. The blog is a single-page app: the page boots the WASM OCaml kernel
;; (the SAME evaluator as the server) + the SX-htmx engine (web/engine.sx), and
;; `sx-boost="#content"` turns every in-page link/form into a fragment swap into
;; #content — no full reloads, history handled. A boosted request carries the
;; SX-Request:true header; we then return ONLY the inner content (so the engine
;; swaps it straight into #content). A direct / no-JS request gets the full shell,
;; so the blog degrades gracefully to plain server-rendered pages.
(define host/blog--spa-req? (fn (req) (= (dream-header req "sx-request") "true")))

;; An AJAX editor swap (the picker's relate / the editor's remove) vs. a plain
;; boosted form. The engine sends an SX-Target header for an sx-post form
;; (sx-target=#rel-editor-…), but NOT for a plain boosted form (the is-a-tag
;; toggle). So this tells "return the re-rendered editor fragment" apart from
;; "redirect + re-render #content" (the toggle / no-JS path).
(define host/blog--editor-swap-req?
  (fn (req)
    (and (host/blog--spa-req? req)
         (let ((t (dream-header req "sx-target"))) (and t (not (= t "")))))))

(define host/blog--page
  (fn (req title body)
    (if (host/blog--spa-req? req)
      ;; SPA fragment: SX WIRE FORMAT (text/sx), not HTML. The WASM kernel parses
      ;; + renders it client-side into #content (the engine's handle-sx-response).
      ;; No server-side HTML render on the boosted path.
      (serialize body)
      ;; full SPA shell: WASM kernel + platform + boosted #content (server HTML
      ;; for first load / no-JS / SEO)
      (str "<!doctype html>"
        (render-page
          (quasiquote
            (html
              (head (meta :charset "utf-8") (title (unquote title))
                ;; content-addressed module manifest: {file -> hash}. The client's
                ;; loadBytecodeFile reads this and fetches each web-stack module
                ;; immutably from /sx/h/{hash} (localStorage-cached, never stale)
                ;; instead of /static/wasm/sx/*.sxbc with max-age.
                (script :type "application/json" :data-sx-manifest "1"
                  (raw! (unquote (host/static-manifest-json))))
                (script :src "/static/wasm/sx_browser.bc.wasm.js")
                (script :src "/static/wasm/sx-platform.js")
                ;; Visible failure state for the SX engine's .sx-error class (added
                ;; on a failed/offline fetch, cleared on the next success). Without
                ;; it a stuck retry is invisible — the picker just sits "Loading…".
                (style (raw! (unquote (str
                  ".rp-more.sx-error{color:#b00}"
                  ".rp-more.sx-error::after{content:\" — offline, retrying…\"}"
                  ".relate-picker.sx-error .rp-results::before{"
                    "content:\"Connection problem — retrying…\";display:block;"
                    "padding:.5em;color:#b00;font-size:.9em}")))))
              (body
                ;; sx-boost must be on a DESCENDANT of <body> (process-boosted
                ;; queries [sx-boost] WITHIN the body, so it can't sit on body
                ;; itself). The wrapper boosts every link/form inside, targeting
                ;; #content; #content is the swap target.
                (div :sx-boost "#content"
                  ;; persistent top nav OUTSIDE #content, so it survives every
                  ;; content swap; the Home link is boosted (SPA nav to /).
                  (nav :style "padding:0.75em 0;border-bottom:1px solid #ccc;margin-bottom:1em"
                    (a :href "/" :style "font-weight:bold;text-decoration:none" "Home"))
                  (div :id "content" (unquote body)))))))))))

;; Wrap a host/blog--page result in a response with the matching content-type:
;; text/sx for a boosted (SPA) request (the WASM kernel renders it), text/html
;; for a full-page request. Replaces the old dream-html/-status wrappers so the
;; boosted path ships SX instead of server-rendered HTML.
(define host/blog--resp
  (fn (req status str)
    (dream-response status
      {:content-type
        (if (host/blog--spa-req? req) "text/sx; charset=utf-8" "text/html; charset=utf-8")}
      str)))

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

;; The relation blocks shown on a POST page — a CURATED, fixed set: Related (out),
;; Tags (out), Tagged-with-this (in). PERFORMANCE: read the KV key list ONCE and
;; derive both the post set and the edges from it in memory, instead of letting
;; each host/blog-out/in re-scan the store. Every durable read is a perform routed
;; through cek_run_with_io (costly deep in the call stack), so the post page must
;; minimise them — this does ONE kv-keys plus a host/blog-get per linked post.
(define host/blog--post-relation-specs
  (list {:kind "related" :dir "out" :label "Related posts"}
        {:kind "tagged"  :dir "out" :label "Tags"}
        {:kind "tagged"  :dir "in"  :label "Tagged with this"}))
;; in-memory: the slug list (out: dst, in: src) for `slug` under `kind` from
;; pre-parsed edges — no perform.
(define host/blog--edges-for
  (fn (edges slug kind dir)
    (reduce
      (fn (acc e)
        (if (= (get e :kind) kind)
          (if (= dir "out")
            (if (= (get e :src) slug) (concat acc (list (get e :dst))) acc)
            (if (= (get e :dst) slug) (concat acc (list (get e :src))) acc))
          acc))
      (list) edges)))
;; slug list -> {:slug :title} records (existence-filtered), one host/blog-get each.
(define host/blog--recs-slugs
  (fn (existing slugs)
    (map (fn (s) {:slug s :title (get (host/blog-get s) :title)})
      (filter (fn (s) (contains? existing s)) slugs))))
(define host/blog--relation-blocks
  (fn (slug)
    (let ((keys (persist/backend-kv-keys host/blog-store)))   ;; ONE durable read
      (let ((existing (reduce (fn (acc k)
                                (if (starts-with? k "blog:")
                                  (concat acc (list (substr k 5))) acc))
                        (list) keys))
            (edges (filter (fn (e) (not (nil? e)))
                     (map host/blog--parse-edge-key keys))))
        (let ((blocks
                (reduce
                  (fn (acc spec)
                    (let ((b (host/blog--edges-block
                               (host/blog--recs-slugs existing
                                 (host/blog--edges-for edges slug (get spec :kind) (get spec :dir)))
                               (get spec :label))))
                      (if (= b "") acc (concat acc (list b)))))
                  (list)
                  host/blog--post-relation-specs)))
          (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 declarative SX-htmx form, one
;; per kind). The picker's candidates come from the kind's registry :candidates
;; ("all" / tags / types).
(define host/blog--relation-editor
  (fn (slug kind with-cands)
    ;; 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))
          ;; results <ul>. When `with-cands` (the relate/unrelate fragment), the first
          ;; page of candidates is server-rendered in, so the re-rendered picker is
          ;; never briefly empty (the load trigger then re-fetches the same page and
          ;; morphs it in, invisibly). On the INITIAL edit page it renders EMPTY and the
          ;; load trigger fills it — server-rendering candidates for EVERY kind's picker
          ;; would do a durable read per candidate × every editor, blowing the
          ;; http-listen render budget (VmSuspended). Built by cons so candidate
          ;; li-trees splice in as children (component args would evaluate them).
          (results-ul
            (let ((rows (if with-cands
                          (let ((cands (host/blog--relate-candidates slug "" kind 0 host/blog--picker-limit)))
                            (append
                              (map (fn (p) (host/blog--picker-item slug p kind)) cands)
                              (if (= (len cands) host/blog--picker-limit)
                                (list (host/blog--picker-more slug kind "" host/blog--picker-limit))
                                (list))))
                          (list))))
              (cons (quote ul)
                (append
                  (quasiquote (:id (unquote (str "rp-" kind "-results"))
                               :class "rp-results"
                               :style "list-style:none;padding:0;margin:0.5em 0;border:1px solid #ddd"))
                  rows)))))
      (quasiquote
        ;; #rel-editor-KIND wraps the WHOLE editor (current list + picker) so relate
        ;; and unrelate can re-render it with one outerHTML swap — keeping the two
        ;; lists in sync. The fresh picker re-loads its candidates (an explicit
        ;; outerHTML swap installs a NEW form the engine binds, unlike the old
        ;; redirect that morphed the stale picker and left it empty).
        (div :id (unquote (str "rel-editor-" kind))
             :style "margin-top:2em;border-top:1px solid #ccc;padding-top:1em"
          (h3 (unquote (get spec :label)))
          (unquote
            (if (> (len current) 0)
              (cons (quote ul)
                (map (fn (s)
                       (quasiquote
                         ;; remove: sx-post the unrelate, then sx-swap="outerHTML"
                         ;; re-renders this kind's editor (its sx-target
                         ;; #rel-editor-KIND) — the row leaves the current list and
                         ;; the post returns to the candidate pool, both in sync,
                         ;; with the picker NOT cleared. method+action stay for no-JS.
                         (li (a :href (unquote (str "/" s "/")) (unquote s)) " "
                           (form :method "post" :style "display:inline"
                             :action (unquote (str "/" slug "/unrelate"))
                             :sx-post (unquote (str "/" slug "/unrelate"))
                             :sx-target (unquote (str "#rel-editor-" kind))
                             :sx-swap "outerHTML"
                             (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."))))
          ;; The picker, rendered INLINE (not via the ~relate-picker component) so the
          ;; first page of candidates is server-rendered into the results <ul> — the
          ;; re-rendered editor shows them immediately, no empty flash. Same declarative
          ;; SX-htmx form: GET relate-options, innerHTML-swap the results on a debounced
          ;; "input" and on "load"; sx-retry self-heals a dropped fetch.
          (form
            :class "relate-picker"
            :data-slug (unquote slug)
            :data-kind (unquote kind)
            :sx-get (unquote (str "/" slug "/relate-options"))
            :sx-trigger "input delay:200ms, load"
            :sx-target (unquote (str "#rp-" kind "-results"))
            :sx-swap "innerHTML"
            :sx-retry "exponential:1000:30000"
            :style "margin:0"
            (input :type "hidden" :name "kind" :value (unquote kind))
            (input :type "text" :name "q" :class "rp-filter" :placeholder "filter…"
              :autocomplete "off" :style "width:100%;padding:0.4em;box-sizing:border-box")
            (unquote results-ul)))))))

;; "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)
      ;; false: the initial edit page renders empty pickers (the load trigger fills
      ;; each), keeping this render cheap. The relate/unrelate FRAGMENT passes true.
      (map (fn (spec) (host/blog--relation-editor slug (get spec :kind) false))
        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)))
              (host/blog--resp req 200
                (host/blog--page req (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))))))))
          (host/blog--resp req 404
            (host/blog--page req "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)
                         (cons (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)))
          (host/blog--resp req 200
            (host/blog--page req "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)))
        (host/blog--resp req 200
          (host/blog--page req "Tags"
            (quasiquote
              (div (h1 "Tags")
                (unquote (if (> (len recs) 0)
                           (cons (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) ""))
          (host/blog--resp req 404
            (host/blog--page req "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)
    (host/blog--resp req 200
      (host/blog--page req "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 ""))
          (host/blog--resp req 400
            (host/blog--page req "Error"
              (quasiquote (div (h1 "Error") (p "Title is required.")
                            (p (a :href "/new" "Back")))))))
        ((not (host/blog-content-ok? sx-content))
          (host/blog--resp req 400
            (host/blog--page req "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))
        (host/blog--resp req 404
          (host/blog--page req "Not found"
            (quasiquote (div (h1 "404") (p (unquote (str "No post: " slug)))))))
        (begin
          ;; …and `other` must satisfy the relation's TARGET-TYPE CONSTRAINT
          ;; (host/blog--valid-object?): you can only declare `slug is-a <a type>`,
          ;; tag with `<a tag>`, etc. The picker never offers an invalid target, so
          ;; this enforces the same schema against crafted/API requests; an invalid
          ;; relate is a silent no-op (consistent with the other guards here).
          (when (and other (not (= other "")) (not (= other slug))
                     (host/blog--kind-spec kind) (host/blog-exists? other)
                     (host/blog--valid-object? kind other))
            (host/blog-relate! slug other kind))
          ;; AJAX (the picker's sx-post, carries SX-Target): return the re-rendered
          ;; editor for this kind so its sx-swap="outerHTML" replaces #rel-editor-KIND
          ;; — the just-related post shows in the current list and the picker refreshes
          ;; its candidates. text/html so the client's DOMParser swap path renders the
          ;; already-expanded fragment. Plain boosted form / no-JS still redirects.
          (if (host/blog--editor-swap-req? req)
            (dream-html (render-page (host/blog--relation-editor slug kind true)))
            (dream-redirect (str "/" slug "/edit"))))))))

;; POST /<slug>/unrelate — remove the relation to `other` under `kind` (default
;; "related"). Idempotent.
(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))
        ;; AJAX remove (the editor's sx-post, carries SX-Target): return the
        ;; re-rendered editor for this kind so its sx-swap="outerHTML" replaces
        ;; #rel-editor-KIND — the row leaves the current list, the post returns to the
        ;; (re-loaded) candidate pool, and the picker is NOT cleared. A plain boosted
        ;; form (the tag toggle) or a no-JS POST still redirects + re-renders #content.
        (if (host/blog--editor-swap-req? req)
          (dream-html (render-page (host/blog--relation-editor slug kind true)))
          (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)
          (host/blog--resp req 404
            (host/blog--page req "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)))))))
              (host/blog--resp req 200
                (host/blog--page req (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)
                      (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")) (r (host/blog-get (dream-param req "slug"))))
      (if (nil? r)
        (host/blog--resp req 404
          (host/blog--page req "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))))
          ;; collect issues up front (perform): unparseable markup, then each
          ;; schema requirement the post's types impose. Empty = save.
          (let ((issues (if (host/blog-content-ok? sx-content)
                          (host/blog-type-issues slug sx-content)
                          (list "Post body is not valid SX markup."))))
            (if (= (len issues) 0)
              (begin
                (host/blog-put! slug title sx-content status)
                (dream-redirect (str "/" slug "/")))
              (let ((issue-items (map (fn (i) (quasiquote (li (unquote i)))) issues)))
                (host/blog--resp req 400
                  (host/blog--page req "Cannot save"
                    (quasiquote
                      (div (h1 "Cannot save")
                        (p "This post can't be saved yet:")
                        (unquote (cons (quote ul) issue-items))
                        (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 "/: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))))