coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

host: layer 2 — types declare composition fields (a block editor per field)

Browse Source 
:body was hardwired; now a TYPE declares which of its fields are compositions
({:name "body" :type "Composition"}), and an object may carry several (:body, :aside, :body-1).
The edit page renders ONE block editor per declared field (host/blog--block-editors →
host/blog--composition-fields → the type's Composition fields, default ["body"]); each editor
is independent, targets #comp-<field>, and its cards get field-qualified slugs
(<container>__<field>__<name>). Every block op takes a `field` (threaded via a hidden "field"
input, so routes are unchanged); the response re-renders just that field's editor.

STORAGE: compositions moved into a STRING-KEYED sub-dict :comps (like :field-values) —
string keys round-trip through persist cleanly, whereas a mix of a keyword :body and a string
"body" top-level key does NOT survive serialization as one key (it splits the data). body-of/
set-body! delegate to comp-of/set-comp! with "body" + a legacy top-level :body read fallback,
so existing bodies still render (the demos reseed into :comps on boot).

blog 174/174, full host conformance 403/403 (+ tests: a Landing type with two Composition
fields → two independent #comp-body/#comp-aside editors; block-add! to a named field; default
[body]). Editor still renders any node kind (no "unknown block"); #block-editor wrapper kept
so the Playwright selectors hold.

Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
This commit is contained in:
giles
2026-07-01 11:07:21 +00:00
parent b056469be1
commit 616c3cf966
2 changed files with 177 additions and 104 deletions
Download Patch File Download Diff File Expand all files Collapse all files

234
lib/host/blog.sx
View File

@@ -481,6 +481,19 @@
(host/blog-fields-of t)))
(list)
(host/blog-types-of slug))))
;; the COMPOSITION fields an object has — the fields its (transitive) types declare with
;; :type "Composition" (each edited by its own block editor). Default ["body"] if a type
;; declares none, so every object still has one root composition. This is layer 2: "types
;; declare which fields are compositions" (the schema for the object's structure).
(define host/blog--composition-fields
(fn (slug)
(let ((cf (reduce (fn (acc f) (if (= (get f :type) "Composition") (concat acc (list (str (get f :name)))) acc))
(list) (host/blog--fields-for-post slug))))
(if (empty? cf) (list "body") cf))))
;; the SCALAR (non-composition) fields — the generic edit form's inputs (compositions get a
;; block editor instead of a text input).
(define host/blog--scalar-fields
(fn (slug) (filter (fn (f) (not (= (get f :type) "Composition"))) (host/blog--fields-for-post slug))))
;; render one labelled input per field, pre-filled from `values`. Widget per value-type
;; (textarea for Text, else a typed <input>). Pure — takes pre-fetched fields + values.
(define host/blog--field-inputs
@@ -516,11 +529,8 @@
;; A record may carry a :body — a composition node (seq/par/alt/each over object refs)
;; rendered by the render-fold (lib/host/compose.sx) against a context. When present it
;; supersedes :sx-content. This is fold #1; the same object renders differently per context.
(define host/blog-body-of (fn (slug) (get (host/blog-get slug) :body)))
(define host/blog--set-body!
(fn (slug body)
(let ((r (host/blog-get slug)))
(when r (host/blog--write! slug (merge r {:body body}))))))
(define host/blog-body-of (fn (slug) (host/blog--comp-of slug "body")))
(define host/blog--set-body! (fn (slug body) (host/blog--set-comp! slug "body" body)))
;; The resolver for the composition `each` graph-query source (compose.sx asks the context
;; for "query"). `(query REL TYPE)` -> the objects related to TYPE by REL, as full records
;; so the per-item template can field them. Today the supported relation is is-a (TYPE's
@@ -731,13 +741,30 @@
;; CONDITIONAL (alt+when — the "or": show the first branch whose condition holds), or a
;; REPEATER (each — the loop: render a template per graph-query result). seq is the "and".
;; The editor edits this inline tree; leaves stay external refs. (composition-objects.md.)
(define host/blog-body-nodes
(fn (slug)
(let ((body (host/blog-body-of slug)))
(if (and (= (type-of body) "list") (= (str (first body)) "seq"))
(rest body) (list)))))
(define host/blog--set-body-nodes!
(fn (slug nodes) (host/blog--set-body! slug (cons (quote seq) nodes))))
;; a composition FIELD's value on an object — inline, part of the CID. A type declares which
;; of its fields are compositions (host/blog--composition-fields); an object may carry several
;; (:body, :aside, …), each edited by its own block editor. Compositions live in a STRING-KEYED
;; sub-dict :comps (string keys round-trip through persist cleanly, unlike a mix of keyword and
;; string top-level keys). The default "body" field falls back to a legacy top-level :body.
(define host/blog--comps (fn (rec) (or (get rec :comps) {})))
(define host/blog--comp-of
(fn (slug field)
(let ((r (host/blog-get slug)))
(let ((c (get (host/blog--comps r) field)))
(if (nil? c) (if (= field "body") (get r :body) nil) c)))))
(define host/blog--set-comp!
(fn (slug field v)
(let ((r (host/blog-get slug)))
(when r (host/blog--write! slug (assoc r :comps (assoc (host/blog--comps r) field v)))))))
(define host/blog--comp-nodes
(fn (slug field)
(let ((c (host/blog--comp-of slug field)))
(if (and (= (type-of c) "list") (= (str (first c)) "seq")) (rest c) (list)))))
(define host/blog--set-comp-nodes!
(fn (slug field nodes) (host/blog--set-comp! slug field (cons (quote seq) nodes))))
;; back-compat: the default "body" field.
(define host/blog-body-nodes (fn (slug) (host/blog--comp-nodes slug "body")))
(define host/blog--set-body-nodes! (fn (slug nodes) (host/blog--set-comp-nodes! slug "body" nodes)))
;; the value at index k of a list (any element type).
(define host/blog--nth
(fn (xs k) (let loop ((i 0) (ys xs))
@@ -770,7 +797,7 @@
(fn (container slug)
(if (starts-with? slug (str container "__")) (substr slug (+ (len container) 2)) slug)))
(define host/blog--append-node!
(fn (slug node) (host/blog--set-body-nodes! slug (concat (host/blog-body-nodes slug) (list node)))))
(fn (slug field node) (host/blog--set-comp-nodes! slug field (concat (host/blog--comp-nodes slug field) (list node)))))
;; the kind of a body node, for the editor: "card" | "cond" | "each" | "other".
(define host/blog--node-kind
(fn (node)
@@ -863,55 +890,55 @@
(else "auth")))
"auth")))
;; add a CARD block to `field`: (ref <field-relative>). Returns the new card's storage slug.
;; add a CARD block to a composition `field`: (ref <field-relative>). Returns the card slug.
(define host/blog-block-add!
(fn (slug ctype fields)
(let ((cslug (host/blog--new-card! slug "body" ctype fields)))
(begin (host/blog--append-node! slug (list (quote ref) (host/blog--slug->ref slug cslug))) cslug))))
(fn (slug field ctype fields)
(let ((cslug (host/blog--new-card! slug field ctype fields)))
(begin (host/blog--append-node! slug field (list (quote ref) (host/blog--slug->ref slug cslug))) cslug))))
;; add a CONDITIONAL (or) block: (alt (when <pred> (ref A)) (else (ref B))) — A/B relative refs.
(define host/blog-block-add-cond!
(fn (slug ckey)
(let ((a (host/blog--slug->ref slug (host/blog--new-card! slug "body" "card-text" {"text" "shown when the condition holds"})))
(b (host/blog--slug->ref slug (host/blog--new-card! slug "body" "card-text" {"text" "shown otherwise"}))))
(host/blog--append-node! slug
(fn (slug field ckey)
(let ((a (host/blog--slug->ref slug (host/blog--new-card! slug field "card-text" {"text" "shown when the condition holds"})))
(b (host/blog--slug->ref slug (host/blog--new-card! slug field "card-text" {"text" "shown otherwise"}))))
(host/blog--append-node! slug field
(list (quote alt)
(list (quote when) (host/blog--cond->pred ckey) (list (quote ref) a))
(list (quote else) (list (quote ref) b)))))))
;; add a REPEATER (each) block: (each (query is-a TYPE) (ref <template>)) — template relative.
(define host/blog-block-add-each!
(fn (slug type)
(let ((t (host/blog--slug->ref slug (host/blog--new-card! slug "body" "card-text" {"text" "rendered once per item"}))))
(host/blog--append-node! slug
(fn (slug field type)
(let ((t (host/blog--slug->ref slug (host/blog--new-card! slug field "card-text" {"text" "rendered once per item"}))))
(host/blog--append-node! slug field
(list (quote each)
(list (quote query) (string->symbol "is-a") (string->symbol type))
(list (quote ref) t))))))
;; move / remove a block by its INDEX (blocks aren't all single refs, so index-addressed).
;; move / remove a block in `field` by its INDEX (blocks aren't all single refs).
(define host/blog-block-move-idx!
(fn (slug i dir)
(let ((nodes (host/blog-body-nodes slug)))
(fn (slug field i dir)
(let ((nodes (host/blog--comp-nodes slug field)))
(let ((j (if (= dir "up") (- i 1) (+ i 1))))
(when (and (>= i 0) (< i (len nodes)) (>= j 0) (< j (len nodes)))
(host/blog--set-body-nodes! slug
(host/blog--set-comp-nodes! slug field
(map-indexed (fn (k n) (cond ((= k i) (host/blog--nth nodes j))
((= k j) (host/blog--nth nodes i))
(else n))) nodes)))))))
(define host/blog-block-remove-idx!
(fn (slug i)
(let ((nodes (host/blog-body-nodes slug)))
(fn (slug field i)
(let ((nodes (host/blog--comp-nodes slug field)))
(when (and (>= i 0) (< i (len nodes)))
(begin
;; refs are field-relative; contains edges are keyed by SLUG — resolve before dropping.
(for-each (fn (r) (host/blog-unrelate! slug (host/blog--resolve-ref r {"container" slug}) "contains"))
(host/blog--node-refs (host/blog--nth nodes i)))
(host/blog--set-body-nodes! slug (host/blog--remove-at nodes i)))))))
(host/blog--set-comp-nodes! slug field (host/blog--remove-at nodes i)))))))
;; change a conditional block's `when` condition (its then/else branches are kept).
(define host/blog-block-set-cond!
(fn (slug i ckey)
(let ((nodes (host/blog-body-nodes slug)))
(fn (slug field i ckey)
(let ((nodes (host/blog--comp-nodes slug field)))
(when (and (>= i 0) (< i (len nodes)) (= (host/blog--node-kind (host/blog--nth nodes i)) "cond"))
(let ((node (host/blog--nth nodes i)))
(let ((wb (first (rest node))) (eb (first (rest (rest node)))))
(host/blog--set-body-nodes! slug
(host/blog--set-comp-nodes! slug field
(map-indexed
(fn (k n) (if (= k i)
(list (quote alt)
@@ -1564,22 +1591,28 @@
;; #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).
;; index-addressed control button (move up/down, remove, set-cond) -> re-renders #block-editor.
;; every block-editor form carries a hidden "field" (which composition field it edits) and
;; targets #comp-<field>, so an object with several composition fields gets several editors
;; that don't collide. host/blog--fld makes the hidden input; host/blog--tgt the target id.
(define host/blog--fld (fn (field) (quasiquote (input :type "hidden" :name "field" :value (unquote field)))))
(define host/blog--tgt (fn (field) (str "#comp-" field)))
(define host/blog--block-btn
(fn (slug idx action dir label)
(fn (slug field idx action dir label)
(let ((url (str "/" slug "/blocks/" idx "/" action)))
(quasiquote
;; :sx-post (NOT sx-disable) so the click is a text/sx round-trip through the engine —
;; the handler returns the re-rendered #block-editor and sx-swap="outerHTML" replaces it.
;; :sx-post -> a text/sx round-trip; the handler returns the re-rendered field editor
;; and sx-swap="outerHTML" replaces #comp-<field>.
(form :method "post" :action (unquote url) :style "display:inline;margin:0 0.1em"
:sx-post (unquote url) :sx-target "#block-editor" :sx-swap "outerHTML"
:sx-post (unquote url) :sx-target (unquote (host/blog--tgt field)) :sx-swap "outerHTML"
(unquote (host/blog--fld field))
(unquote (if (= dir "") "" (quasiquote (input :type "hidden" :name "dir" :value (unquote dir)))))
(button :type "submit" (unquote label)))))))
(define host/blog--block-ctrls
(fn (slug idx)
(fn (slug field idx)
(quasiquote (span :style "white-space:nowrap"
(unquote (host/blog--block-btn slug idx "move" "up" "↑"))
(unquote (host/blog--block-btn slug idx "move" "down" "↓"))
(unquote (host/blog--block-btn slug idx "remove" "" "remove"))))))
(unquote (host/blog--block-btn slug field idx "move" "up" "↑"))
(unquote (host/blog--block-btn slug field idx "move" "down" "↓"))
(unquote (host/blog--block-btn slug field idx "remove" "" "remove"))))))
;; a ✎ edit-fields link + preview for a card REF — refs are field-relative, resolved to the
;; card's own /<cslug>/edit page (external object; editing it is CID-neutral to the container).
(define host/blog--ref-chip
@@ -1588,82 +1621,92 @@
(quasiquote (span
(a :href (unquote (str "/" cslug "/edit")) "✎")
" " (span :style "color:#555" (unquote (host/blog--block-preview (host/blog-field-values-of cslug)))))))))
;; the condition <select> for a conditional block (submit re-renders the editor).
;; the condition <select> for a conditional block (submit re-renders the field editor).
(define host/blog--cond-form
(fn (slug idx cur)
(fn (slug field idx cur)
(let ((url (str "/" slug "/blocks/" idx "/cond"))
(opt (fn (v l cur) (if (= v cur)
(quasiquote (option :value (unquote v) :selected "selected" (unquote l)))
(quasiquote (option :value (unquote v) (unquote l)))))))
(quasiquote
(form :method "post" :action (unquote url) :style "display:inline"
:sx-post (unquote url) :sx-target "#block-editor" :sx-swap "outerHTML"
:sx-post (unquote url) :sx-target (unquote (host/blog--tgt field)) :sx-swap "outerHTML"
(unquote (host/blog--fld field))
(select :name "cond"
(unquote (opt "auth" "logged in" cur))
(unquote (opt "device:mobile" "on mobile" cur))
(unquote (opt "device:desktop" "on desktop" cur))
(unquote (opt "locale:fr" "locale = fr" cur)))
(button :type "submit" "set"))))))
;; a block row rendered by KIND — card / conditional (or) / repeater (each).
;; a block row rendered by KIND — card / conditional (or) / repeater (each) / inline.
(define host/blog--block-row
(fn (slug idx node)
(fn (slug field idx node)
(let ((kind (host/blog--node-kind node))
(rs "display:flex;gap:0.5em;align-items:center;border:1px solid #ddd;padding:0.4em;margin:0.2em 0"))
(cond
;; CONDITIONAL: the condition <select> + a display of each branch (ref chip OR inline).
((= kind "cond")
(quasiquote (li :style (unquote rs)
(b :style "min-width:5em" "if")
(span :style "flex:1"
(unquote (host/blog--cond-form slug idx (host/blog--pred->ckey (host/blog--node-pred node))))
(unquote (host/blog--cond-form slug field idx (host/blog--pred->ckey (host/blog--node-pred node))))
" → " (unquote (host/blog--branch-display slug (first (rest node))))
" · else → " (unquote (host/blog--branch-display slug (first (rest (rest node))))))
(unquote (host/blog--block-ctrls slug idx)))))
;; REPEATER: the query type + a display of the per-item template (ref OR inline).
(unquote (host/blog--block-ctrls slug field idx)))))
((= kind "each")
(quasiquote (li :style (unquote rs)
(b :style "min-width:5em" "for each")
(span :style "flex:1"
(code (unquote (host/blog--node-each-type node)))
" → " (unquote (host/blog--node-display slug (host/blog--nth node (- (len node) 1)))))
(unquote (host/blog--block-ctrls slug idx)))))
;; every other kind (card / text / layout / field / group / other) — a labelled row
;; with a preview + controls. No composition node falls through to "unknown".
(unquote (host/blog--block-ctrls slug field idx)))))
(else (quasiquote (li :style (unquote rs)
(b :style "min-width:5em" (unquote kind))
(span :style "flex:1;color:#555;overflow:hidden" (unquote (host/blog--node-display slug node)))
(unquote (host/blog--block-ctrls slug idx)))))))))
(unquote (host/blog--block-ctrls slug field idx)))))))))
;; ONE composition field's block editor (id #comp-<field>). host/blog--block-editors renders
;; one per field the object's type declares (layer 2).
(define host/blog--block-editor
(fn (slug)
(let ((nodes (host/blog-body-nodes slug)))
(let ((rows (map-indexed (fn (i n) (host/blog--block-row slug i n)) nodes)))
(fn (slug field)
(let ((nodes (host/blog--comp-nodes slug field)))
(let ((rows (map-indexed (fn (i n) (host/blog--block-row slug field i n)) nodes)))
(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 (composition)")
(div :id (unquote (str "comp-" field)) :style "margin-top:1.5em;border-top:1px solid #ccc;padding-top:1em"
(h3 :style "font-size:1em;margin:0 0 0.3em" (unquote (str ":" field " (composition)")))
(unquote (if (> (len nodes) 0) (cons (quote ul) rows) (quote (p :style "color:#999" "No blocks yet."))))
;; add a CARD block (the "and"/content leaf). Options are DIRECT <select> children.
;; add a CARD block. Options are DIRECT <select> children.
(form :method "post" :action (unquote (str "/" slug "/blocks/add"))
:sx-post (unquote (str "/" slug "/blocks/add")) :sx-target "#block-editor" :sx-swap "outerHTML"
:sx-post (unquote (str "/" slug "/blocks/add")) :sx-target (unquote (host/blog--tgt field)) :sx-swap "outerHTML"
(unquote (host/blog--fld field))
(select :name "ctype"
(option :value "card-heading" "heading") (option :value "card-text" "text")
(option :value "card-quote" "quote") (option :value "card-code" "code")
(option :value "card-callout" "callout"))
" " (input :name "text" :placeholder "text…" :style "width:40%")
" " (button :type "submit" "+ card"))
;; add a CONDITIONAL (or) block — alt+when over the live context.
;; add a CONDITIONAL (or) block.
(form :method "post" :action (unquote (str "/" slug "/blocks/add-cond"))
:sx-post (unquote (str "/" slug "/blocks/add-cond")) :sx-target "#block-editor" :sx-swap "outerHTML"
:sx-post (unquote (str "/" slug "/blocks/add-cond")) :sx-target (unquote (host/blog--tgt field)) :sx-swap "outerHTML"
:style "margin-top:0.3em"
(unquote (host/blog--fld field))
(select :name "cond"
(option :value "auth" "logged in") (option :value "device:mobile" "on mobile")
(option :value "device:desktop" "on desktop") (option :value "locale:fr" "locale = fr"))
" " (button :type "submit" "+ conditional (or)"))
;; add a REPEATER (each) block — iterate a graph query.
;; add a REPEATER (each) block.
(form :method "post" :action (unquote (str "/" slug "/blocks/add-each"))
:sx-post (unquote (str "/" slug "/blocks/add-each")) :sx-target "#block-editor" :sx-swap "outerHTML"
:sx-post (unquote (str "/" slug "/blocks/add-each")) :sx-target (unquote (host/blog--tgt field)) :sx-swap "outerHTML"
:style "margin-top:0.3em"
(unquote (host/blog--fld field))
(input :name "type" :placeholder "type name (e.g. compose-item)" :style "width:40%")
" " (button :type "submit" "+ repeater (each)"))))))))
;; the edit page's composition section (#block-editor): one block editor per composition
;; field the type declares (layer 2 — types define the object's structure).
(define host/blog--block-editors
(fn (slug)
(quasiquote
(div :id "block-editor"
(unquote (cons (quote div)
(map (fn (f) (host/blog--block-editor slug f)) (host/blog--composition-fields slug))))))))
;; ── read handlers ───────────────────────────────────────────────────
;; Post body is rendered per-block (a guarded HTML string) then injected raw.
@@ -1677,12 +1720,14 @@
;; 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 (;; composition objects: a record with a :body renders via the render-fold
;; (host/comp-render) against a context (auth from the principal); else the
;; legacy sx_content path. The SAME object renders differently per context.
(body-html (if (get r :body)
(host/comp-render (get r :body) (host/blog--comp-ctx principal req slug))
(host/blog-render r)))
(let (;; composition objects: render EACH composition field the type declares
;; (default just :body) via the render-fold, in field order, against a
;; context (auth/device/locale + the container). Else the legacy sx_content.
(body-html
(let ((ctx (host/blog--comp-ctx principal req slug)))
(let ((rendered (reduce (fn (acc f) (str acc (host/comp-render (host/blog--comp-of slug f) ctx)))
"" (host/blog--composition-fields slug))))
(if (= rendered "") (host/blog-render r) rendered))))
;; 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))))
@@ -2051,15 +2096,18 @@
;; 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).
;; every block op names its composition field (a hidden "field" input; default "body"), so
;; the response re-renders THAT field's editor (#comp-<field>).
(define host/blog--block-field (fn (req) (or (host/field req "field") "body")))
(define host/blog--block-resp
(fn (req slug)
(fn (req slug field)
(if (host/blog--editor-swap-req? req)
(dream-html (render-page (host/blog--block-editor slug)))
(dream-html (render-page (host/blog--block-editor slug field)))
(dream-redirect (str "/" slug "/edit")))))
(define host/blog--block-idx (fn (req) (parse-int (or (dream-param req "idx") "0") 0)))
(define host/blog-block-add-submit
(fn (req)
(let ((slug (dream-param req "slug"))
(let ((slug (dream-param req "slug")) (field (host/blog--block-field req))
(ctype (or (host/field req "ctype") "card-text"))
(text (or (host/field req "text") "")))
(begin
@@ -2067,34 +2115,34 @@
;; 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
(host/blog-block-add! slug field ctype
(if (= ctype "card-heading") {"level" "2" "text" text} {"text" text})))
(host/blog--block-resp req slug)))))
(host/blog--block-resp req slug field)))))
(define host/blog-block-add-cond-submit
(fn (req)
(let ((slug (dream-param req "slug")) (ckey (or (host/field req "cond") "auth")))
(begin (when (host/blog-exists? slug) (host/blog-block-add-cond! slug ckey))
(host/blog--block-resp req slug)))))
(let ((slug (dream-param req "slug")) (field (host/blog--block-field req)) (ckey (or (host/field req "cond") "auth")))
(begin (when (host/blog-exists? slug) (host/blog-block-add-cond! slug field ckey))
(host/blog--block-resp req slug field)))))
(define host/blog-block-add-each-submit
(fn (req)
(let ((slug (dream-param req "slug")) (type (host/blog-slugify (or (host/field req "type") ""))))
(begin (when (and (host/blog-exists? slug) (not (= type ""))) (host/blog-block-add-each! slug type))
(host/blog--block-resp req slug)))))
(let ((slug (dream-param req "slug")) (field (host/blog--block-field req)) (type (host/blog-slugify (or (host/field req "type") ""))))
(begin (when (and (host/blog-exists? slug) (not (= type ""))) (host/blog-block-add-each! slug field type))
(host/blog--block-resp req slug field)))))
(define host/blog-block-remove-submit
(fn (req)
(let ((slug (dream-param req "slug")))
(begin (when (host/blog-exists? slug) (host/blog-block-remove-idx! slug (host/blog--block-idx req)))
(host/blog--block-resp req slug)))))
(let ((slug (dream-param req "slug")) (field (host/blog--block-field req)))
(begin (when (host/blog-exists? slug) (host/blog-block-remove-idx! slug field (host/blog--block-idx req)))
(host/blog--block-resp req slug field)))))
(define host/blog-block-move-submit
(fn (req)
(let ((slug (dream-param req "slug")) (dir (or (host/field req "dir") "up")))
(begin (when (host/blog-exists? slug) (host/blog-block-move-idx! slug (host/blog--block-idx req) dir))
(host/blog--block-resp req slug)))))
(let ((slug (dream-param req "slug")) (field (host/blog--block-field req)) (dir (or (host/field req "dir") "up")))
(begin (when (host/blog-exists? slug) (host/blog-block-move-idx! slug field (host/blog--block-idx req) dir))
(host/blog--block-resp req slug field)))))
(define host/blog-block-cond-submit
(fn (req)
(let ((slug (dream-param req "slug")) (ckey (or (host/field req "cond") "auth")))
(begin (when (host/blog-exists? slug) (host/blog-block-set-cond! slug (host/blog--block-idx req) ckey))
(host/blog--block-resp req slug)))))
(let ((slug (dream-param req "slug")) (field (host/blog--block-field req)) (ckey (or (host/field req "cond") "auth")))
(begin (when (host/blog-exists? slug) (host/blog-block-set-cond! slug field (host/blog--block-idx req) ckey))
(host/blog--block-resp req slug field)))))
;; 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
@@ -2112,7 +2160,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))
(block-editor (host/blog--block-editors 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))

47
lib/host/tests/blog.sx
View File

@@ -828,22 +828,22 @@
(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"})))
(let ((c0 (host/blog-block-add! "bdoc" "body" "card-text" {"text" "first"}))
(c1 (host/blog-block-add! "bdoc" "body" "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 "body__b0" "body__b1") true true))
(host-bl-test "block-move-idx! reorders the body by index (no-op at the ends)"
(begin
(host/blog-block-move-idx! "bdoc" 1 "up") ;; node 1 before node 0
(host/blog-block-move-idx! "bdoc" "body" 1 "up") ;; node 1 before node 0
(let ((after-up (host/blog-body-refs "bdoc")))
(host/blog-block-move-idx! "bdoc" 0 "up") ;; index 0 up -> no-op
(host/blog-block-move-idx! "bdoc" "body" 0 "up") ;; index 0 up -> no-op
(list after-up (host/blog-body-refs "bdoc"))))
(list (list "body__b1" "body__b0") (list "body__b1" "body__b0")))
(host-bl-test "block-remove-idx! drops the node + its contained card's contains edge"
(begin
(host/blog-block-remove-idx! "bdoc" 0) ;; node 0 is now body__b1
(host/blog-block-remove-idx! "bdoc" "body" 0) ;; node 0 is now body__b1
(list (host/blog-body-refs "bdoc") (contains? (host/blog-out "bdoc" "contains") "bdoc__body__b1")))
(list (list "body__b0") false))
(host-bl-test "the edit page shows the block editor (#block-editor + an add-block form)"
@@ -862,7 +862,7 @@
(begin
(host/blog-put! "cdoc2" "C2" "(article)" "published")
(host/blog--set-body! "cdoc2" (quote (seq)))
(host/blog-block-add-cond! "cdoc2" "device:mobile")
(host/blog-block-add-cond! "cdoc2" "body" "device:mobile")
(let ((n (host/blog--nth (host/blog-body-nodes "cdoc2") 0)))
(list (host/blog--node-kind n)
(host/blog--pred->ckey (host/blog--node-pred n))
@@ -870,13 +870,13 @@
(list "cond" "device:mobile" 2))
(host-bl-test "block-set-cond! changes the condition (branches kept)"
(begin
(host/blog-block-set-cond! "cdoc2" 0 "locale:fr")
(host/blog-block-set-cond! "cdoc2" "body" 0 "locale:fr")
(let ((n (host/blog--nth (host/blog-body-nodes "cdoc2") 0)))
(list (host/blog--pred->ckey (host/blog--node-pred n)) (host/blog--node-kind n))))
(list "locale:fr" "cond"))
(host-bl-test "block-add-each! appends an (each (query is-a TYPE) (ref …)) repeater"
(begin
(host/blog-block-add-each! "cdoc2" "compose-item")
(host/blog-block-add-each! "cdoc2" "body" "compose-item")
(let ((n (host/blog--nth (host/blog-body-nodes "cdoc2") 1)))
(list (host/blog--node-kind n) (host/blog--node-each-type n))))
(list "each" "compose-item"))
@@ -886,17 +886,42 @@
(begin
(host/blog-put! "cdoc3" "C3" "(article)" "published")
(host/blog--set-body! "cdoc3" (quote (seq)))
(host/blog-block-add-cond! "cdoc3" "auth")
(host/blog-block-add-cond! "cdoc3" "body" "auth")
(let ((body (host/blog-body-of "cdoc3")))
(list (contains? (host/comp-render body (host/blog--comp-ctx "u" nil "cdoc3")) "shown when the condition holds")
(contains? (host/comp-render body (host/blog--comp-ctx nil nil "cdoc3")) "shown otherwise"))))
(list true true))
;; the editor offers all three block kinds.
(host-bl-test "the block editor offers card + conditional + repeater add forms"
(let ((html (render-page (host/blog--block-editor "cdoc2"))))
(let ((html (render-page (host/blog--block-editor "cdoc2" "body"))))
(list (contains? html "+ card") (contains? html "+ conditional")
(contains? html "+ repeater") (contains? html "for each")))
(list true true true true))
;; -- LAYER 2: a TYPE declares which fields are compositions; the editor renders one block
;; editor per field, each an independent composition (its own cards, field-qualified slugs). --
(host-bl-test "a type declaring TWO composition fields yields two independent block editors"
(begin
(host/blog-seed! "landing-type" "Landing" "(p)" "published")
(host/blog-relate! "landing-type" "type" "subtype-of")
(host/blog--set-fields! "landing-type"
(list {:name "body" :type "Composition"} {:name "aside" :type "Composition"}))
(host/blog-put! "land1" "L1" "(article)" "published")
(host/blog-relate! "land1" "landing-type" "is-a")
(let ((cf (host/blog--composition-fields "land1"))
(html (render-page (host/blog--block-editors "land1"))))
(list cf (contains? html "id=\"comp-body\"") (contains? html "id=\"comp-aside\"")
(contains? html ":aside (composition)"))))
(list (list "body" "aside") true true true))
(host-bl-test "block-add! writes to the NAMED field; fields are independent (slug carries it)"
(begin
(host/blog-block-add! "land1" "aside" "card-text" {"text" "sidebar"})
(host/blog-block-add! "land1" "body" "card-text" {"text" "main"})
(list (len (host/blog--comp-nodes "land1" "aside")) (len (host/blog--comp-nodes "land1" "body"))
(host/blog-is-a? "land1__aside__b0" "card-text") (host/blog-is-a? "land1__body__b0" "card-text")))
(list 1 1 true true))
(host-bl-test "composition-fields defaults to [body] when the type declares none"
(begin (host/blog-put! "plain1" "P" "(p)" "published") (host/blog--composition-fields "plain1"))
(list "body"))
;; the editor renders a HAND-AUTHORED composition (text/row/alt-with-text) WITHOUT falling
;; through to "(unknown block)" — every node kind gets a labelled row (the compose-demo case).
(host-bl-test "the block editor renders text/layout/inline-alt nodes (no unknown block)"
@@ -908,7 +933,7 @@
(alt (when (has "auth") (text "member")) (else (text "guest")))
(row (text "A") (text "B"))
(each (query is-a compose-item) (seq (text "x"))))))
(let ((html (render-page (host/blog--block-editor "mixdoc"))))
(let ((html (render-page (host/blog--block-editor "mixdoc" "body"))))
(list (contains? html "unknown block")
(contains? html "text") (contains? html "layout") (contains? html "for each"))))
(list false true true true))