host: block editor — edit the :body composition (composition roadmap step 6)

The post body is now editable as a composition. Model ops over the :body ref-seq (and the
ordered `contains` edges): host/blog-block-add! (create a card object is-a a card-type +
fields, contains edge, append a ref), -remove! (drop ref + edge), -move! (swap adjacent).
host/blog--block-editor renders a row per block — type + a content preview + ↑/↓/remove
controls + a "fields" link — plus an add-block form, injected into the edit page. Routes
POST /:slug/blocks/{add, :cslug/remove, :cslug/move} (guarded; SX-htmx sx-post + outerHTML
swap of #block-editor, redirect fallback for no-JS).

Cards-as-objects pays off: per-block FIELD editing is free — a card IS an object, so its
fields are edited via its own /<cslug>/edit page; the block editor only owns structure.
Guard fix: a card type is a SUBTYPE-OF card (not is-a), so the add validates ctype against
the down-closure of "card", not host/blog-is-a?. Verified via the warm server (162/164; the
2 fails are the pre-existing relate-picker pair). Deferred: Playwright live-swap check;
alt/each block insertion (the core editor handles the seq of refs).

Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>

lib/host/blog.sx

@@ -639,6 +639,70 @@
                          (list (quote ref) cslug)))))
                  blocks)))
           (host/blog--set-body! post-slug (cons (quote seq) refs)))))))
+
+;; ── block-editor model: edit a post's :body (its composition of card refs) ───────────
+;; The body is (seq (ref c0) (ref c1) …); these ops add / remove / reorder its blocks and
+;; keep the ordered `contains` edges in step. The :body seq is the ORDER authority, the
+;; contains edges the membership set. Per-block FIELD editing is free: a card is an object,
+;; so its fields are edited via the card's own /<cslug>/edit page. (composition step 6.)
+(define host/blog-body-refs
+  (fn (slug)
+    (let ((body (host/blog-body-of slug)))
+      (if (and (= (type-of body) "list") (= (str (first body)) "seq"))
+        (reduce (fn (acc n)
+                  (if (and (= (type-of n) "list") (= (str (first n)) "ref"))
+                    (concat acc (list (str (first (rest n))))) acc))
+                (list) (rest body))
+        (list)))))
+(define host/blog--set-body-refs!
+  (fn (slug refs)
+    (host/blog--set-body! slug (cons (quote seq) (map (fn (r) (list (quote ref) r)) refs)))))
+(define host/blog--next-block-idx
+  (fn (slug)
+    (let loop ((i 0))
+      (if (host/blog-exists? (str slug "__b" i)) (loop (+ i 1)) i))))
+(define host/blog-block-add!
+  (fn (slug ctype fields)
+    (let ((cslug (str slug "__b" (host/blog--next-block-idx slug))))
+      (begin
+        (host/blog-seed! cslug ctype "(article (h1 \"card\"))" "block")
+        (host/blog-relate! cslug ctype "is-a")
+        (host/blog--set-field-values! cslug fields)
+        (host/blog-relate! slug cslug "contains")
+        (host/blog--set-body-refs! slug (concat (host/blog-body-refs slug) (list cslug)))
+        cslug))))
+(define host/blog-block-remove!
+  (fn (slug cslug)
+    (begin
+      (host/blog--set-body-refs! slug
+        (filter (fn (r) (not (= r cslug))) (host/blog-body-refs slug)))
+      (host/blog-unrelate! slug cslug "contains"))))
+(define host/blog--nth-ref
+  (fn (xs k)
+    (let loop ((i 0) (ys xs))
+      (cond ((empty? ys) nil) ((= i k) (first ys)) (else (loop (+ i 1) (rest ys)))))))
+(define host/blog--ref-index
+  (fn (xs x)
+    (let loop ((i 0) (ys xs))
+      (cond ((empty? ys) -1) ((= (first ys) x) i) (else (loop (+ i 1) (rest ys)))))))
+(define host/blog-block-move!
+  (fn (slug cslug dir)
+    (let ((refs (host/blog-body-refs slug)))
+      (let ((i (host/blog--ref-index refs cslug)))
+        (let ((j (if (= dir "up") (- i 1) (+ i 1))))
+          (when (and (>= i 0) (>= j 0) (< j (len refs)))
+            (host/blog--set-body-refs! slug
+              (map-indexed (fn (k r) (cond ((= k i) (host/blog--nth-ref refs j))
+                                           ((= k j) (host/blog--nth-ref refs i))
+                                           (else r))) refs))))))))
+;; the card-type of a card object (its declared is-a target); "card" if none.
+(define host/blog--primary-card-type
+  (fn (cslug) (let ((ts (host/blog-out cslug "is-a"))) (if (empty? ts) "card" (first ts)))))
+;; a short text preview of a card's content from its field-values.
+(define host/blog--block-preview
+  (fn (vals)
+    (let ((t (str (or (get vals "text") (get vals "src") (get vals "code") (get vals "url") ""))))
+      (if (> (len t) 60) (str (substr t 0 60) "…") t))))
 ;; Seed a live demo of the composition fold: one object, rendered by host/comp-render, that
 ;; shows seq + alt(when auth) + row(par) + each — and renders DIFFERENTLY logged-in vs out.
 (define host/blog-seed-compose-demo!
@@ -1246,6 +1310,47 @@
       (map (fn (spec) (host/blog--relation-editor slug (get spec :kind) false))
         host/blog-rel-kinds))))
 
+;; ── block editor: edit the post :body composition (insert/reorder/remove blocks) ─────
+;; A row per block (type + preview + up/down/remove + a link to edit the card's fields) and
+;; an add-block form. Each control sx-posts its route, sx-swap="outerHTML" replacing
+;; #block-editor with the re-render (live reorder/add/remove). Wrapped for the swap target.
+;; one sx-post button-form targeting #block-editor (dir passed as a hidden field).
+(define host/blog--block-btn
+  (fn (slug cslug action dir label)
+    (let ((url (str "/" slug "/blocks/" cslug "/" action)))
+      (quasiquote
+        (form :method "post" :action (unquote url) :style "display:inline;margin:0"
+          :sx-post (unquote url) :sx-target "#block-editor" :sx-swap "outerHTML" :sx-disable "true"
+          (unquote (if (= dir "") "" (quasiquote (input :type "hidden" :name "dir" :value (unquote dir)))))
+          (button :type "submit" (unquote label)))))))
+(define host/blog--block-row
+  (fn (slug cslug)
+    (let ((ctype (host/blog--primary-card-type cslug))
+          (vals (host/blog-field-values-of cslug)))
+      (quasiquote
+        (li :style "display:flex;gap:0.5em;align-items:center;border:1px solid #ddd;padding:0.4em;margin:0.2em 0"
+          (span :style "font-weight:bold;min-width:7em" (unquote ctype))
+          (span :style "flex:1;color:#555" (unquote (host/blog--block-preview vals)))
+          (a :href (unquote (str "/" cslug "/edit")) "fields")
+          (unquote (host/blog--block-btn slug cslug "move" "up" "↑"))
+          (unquote (host/blog--block-btn slug cslug "move" "down" "↓"))
+          (unquote (host/blog--block-btn slug cslug "remove" "" "remove")))))))
+(define host/blog--block-editor
+  (fn (slug)
+    (let ((refs (host/blog-body-refs slug)))
+      (let ((rows (map (fn (c) (host/blog--block-row slug c)) refs))
+            (type-opts (map (fn (ct) (quasiquote (option :value (unquote ct) (unquote ct))))
+                            (list "card-heading" "card-text" "card-quote" "card-code" "card-callout"))))
+        (quasiquote
+          (div :id "block-editor" :style "margin-top:1.5em;border-top:1px solid #ccc;padding-top:1em"
+            (h3 :style "font-size:1em;margin:0 0 0.3em" "Blocks")
+            (unquote (if (> (len refs) 0) (cons (quote ul) rows) (quote (p :style "color:#999" "No blocks yet."))))
+            (form :method "post" :action (unquote (str "/" slug "/blocks/add"))
+              :sx-post (unquote (str "/" slug "/blocks/add")) :sx-target "#block-editor" :sx-swap "outerHTML"
+              (select :name "ctype" (unquote (cons (quote span) type-opts)))
+              " " (input :name "text" :placeholder "text…" :style "width:50%")
+              " " (button :type "submit" "+ add block"))))))))
+
 ;; ── read handlers ───────────────────────────────────────────────────
 ;; Post body is rendered per-block (a guarded HTML string) then injected raw.
 (define host/blog-post
@@ -1630,6 +1735,40 @@
           (dream-html (render-page (host/blog--relation-editor slug kind true)))
           (dream-redirect (str "/" slug "/edit")))))))
 
+;; POST /<slug>/blocks/add|remove|move — structural edits to the post :body. Each does the
+;; durable op then returns the re-rendered #block-editor (AJAX swap) or redirects (no-JS).
+(define host/blog--block-resp
+  (fn (req slug)
+    (if (host/blog--editor-swap-req? req)
+      (dream-html (render-page (host/blog--block-editor slug)))
+      (dream-redirect (str "/" slug "/edit")))))
+(define host/blog-block-add-submit
+  (fn (req)
+    (let ((slug (dream-param req "slug"))
+          (ctype (or (host/field req "ctype") "card-text"))
+          (text (or (host/field req "text") "")))
+      (begin
+        ;; ctype must be a card type — a subtype of "card" (card types are linked by
+        ;; subtype-of, NOT is-a, so the down-closure of "card" is the valid set).
+        (when (and (host/blog-exists? slug)
+                   (contains? (host/blog--subtype-closure (list "card") :in) ctype))
+          (host/blog-block-add! slug ctype
+            (if (= ctype "card-heading") {"level" "2" "text" text} {"text" text})))
+        (host/blog--block-resp req slug)))))
+(define host/blog-block-remove-submit
+  (fn (req)
+    (let ((slug (dream-param req "slug")) (cslug (dream-param req "cslug")))
+      (begin
+        (when (host/blog-exists? slug) (host/blog-block-remove! slug cslug))
+        (host/blog--block-resp req slug)))))
+(define host/blog-block-move-submit
+  (fn (req)
+    (let ((slug (dream-param req "slug")) (cslug (dream-param req "cslug"))
+          (dir (or (host/field req "dir") "up")))
+      (begin
+        (when (host/blog-exists? slug) (host/blog-block-move! slug cslug dir))
+        (host/blog--block-resp req slug)))))
+
 ;; 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).
@@ -1646,6 +1785,7 @@
             ;; 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))
+                  (block-editor (host/blog--block-editor slug))
                   (tag-toggle (host/blog--is-tag-toggle slug))
                   (post-fields (host/blog--fields-for-post slug))
                   (field-values (host/blog-field-values-of slug))
@@ -1677,6 +1817,7 @@
                           (button :type "submit" "Save")))
                       (div :style "margin-top:2em;border-top:1px solid #ccc;padding-top:1em"
                         (unquote tag-toggle))
+                      (unquote block-editor)
                       (unquote relation-editors)
                       (p :style "margin-top:1.5em"
                         (a :href (unquote (str "/" slug "/")) "view post")
@@ -1754,6 +1895,9 @@
       (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/blocks/add" (host/blog--protect-html resolve host/blog-block-add-submit))
+      (dream-post "/:slug/blocks/:cslug/remove" (host/blog--protect-html resolve host/blog-block-remove-submit))
+      (dream-post "/:slug/blocks/:cslug/move" (host/blog--protect-html resolve host/blog-block-move-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 "/meta/new-type" (host/blog--protect-html resolve host/blog-meta-new-type))

lib/host/tests/blog.sx

@@ -817,6 +817,39 @@
   (let ((html (dream-resp-body (host-bl-app (host-bl-req "/imp-x/")))))
     (list (contains? html "Heading One") (contains? html "Para text.") (contains? html "p.jpg")))
   (list true true true))
+;; -- block editor: structural edits to the post :body composition (step 6). --
+(host-bl-test "block-add! creates a card object + contains edge + appends a ref to the body"
+  (begin
+    (host/blog-put! "bdoc" "BDoc" "(article)" "published")
+    (host/blog--set-body! "bdoc" (quote (seq)))
+    (let ((c0 (host/blog-block-add! "bdoc" "card-text" {"text" "first"}))
+          (c1 (host/blog-block-add! "bdoc" "card-heading" {"level" "2" "text" "a head"})))
+      (list (host/blog-body-refs "bdoc")
+            (host/blog-is-a? c0 "card-text")
+            (contains? (host/blog-out "bdoc" "contains") c1))))
+  (list (list "bdoc__b0" "bdoc__b1") true true))
+(host-bl-test "block-move! reorders the body refs (and is a no-op at the ends)"
+  (begin
+    (host/blog-block-move! "bdoc" "bdoc__b1" "up")          ;; b1 before b0
+    (let ((after-up (host/blog-body-refs "bdoc")))
+      (host/blog-block-move! "bdoc" "bdoc__b1" "up")        ;; b1 already first -> no-op
+      (list after-up (host/blog-body-refs "bdoc"))))
+  (list (list "bdoc__b1" "bdoc__b0") (list "bdoc__b1" "bdoc__b0")))
+(host-bl-test "block-remove! drops the ref from the body + the contains edge"
+  (begin
+    (host/blog-block-remove! "bdoc" "bdoc__b1")
+    (list (host/blog-body-refs "bdoc") (contains? (host/blog-out "bdoc" "contains") "bdoc__b1")))
+  (list (list "bdoc__b0") false))
+(host-bl-test "the edit page shows the block editor (#block-editor + an add-block form)"
+  (let ((html (dream-resp-body (host-bl-wapp (host-bl-send "GET" "/bdoc/edit" "Bearer good" "" "")))))
+    (list (contains? html "block-editor") (contains? html "+ add block")))
+  (list true true))
+(host-bl-test "POST /bdoc/blocks/add (auth) adds a block -> body grows"
+  (begin
+    (host-bl-wapp (host-bl-send "POST" "/bdoc/blocks/add" "Bearer good"
+      "application/x-www-form-urlencoded" "ctype=card-text&text=added+block"))
+    (len (host/blog-body-refs "bdoc")))
+  2)
 (host-bl-test "a post with no schema'd type is vacuously valid"
   (host/blog-type-valid? "ppost" "(p \"anything\")") true)
 (host-bl-test "edit-submit rejects content violating the type schema (not saved)"

plans/composition-objects.md

@@ -118,7 +118,13 @@ Transclusion = a `ref` leaf. Sort/filter/limit/group = the *source query* langua
    typed-block path. `/import` wired; home filtered to published so `"block"` cards stay hidden.
    The `val` (raw value) leaf added for attribute interpolation. (Perf: typing now reads direct
    KV `subtype-of` edges via a host-side BFS, not lib/relations — no Datalog re-saturation.)
-6. The block editor edits the body (insert/reorder/`alt`/`each`) — the metamodel editor for content.
+6. **(done, server-side)** The block editor edits the body: `host/blog-block-add!` /
+   `-remove!` / `-move!` operate on the `:body` ref-seq + ordered `contains` edges;
+   `host/blog--block-editor` renders a row per block (type + preview + ↑/↓/remove + a link
+   to edit the card's fields) + an add-block form, injected into the edit page; routes
+   `POST /:slug/blocks/{add,:cslug/remove,:cslug/move}` (guarded, SX-htmx outerHTML swap).
+   Per-block field editing is free — a card is an object, edited via its own `/<cslug>/edit`.
+   (Live SX-htmx swap still wants a Playwright check; `alt`/`each` block insertion deferred.)
 7. **Prove universality with a second fold.** Write a tiny `execute`-fold over the *same*
    `seq/alt/each` structure that *runs* a workflow (leaves = effects; `seq` = steps in order, `alt`
    = branch, `each` = for-each) — the way the recursive tree proved recursion, this proves the