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))) (host/blog-fields-of t)))
(list) (list)
(host/blog-types-of slug)))) (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 ;; 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. ;; (textarea for Text, else a typed <input>). Pure — takes pre-fetched fields + values.
(define host/blog--field-inputs (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) ;; 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 ;; 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. ;; 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-body-of (fn (slug) (host/blog--comp-of slug "body")))
(define host/blog--set-body! (define host/blog--set-body! (fn (slug body) (host/blog--set-comp! slug "body" body)))
(fn (slug body)
(let ((r (host/blog-get slug)))
(when r (host/blog--write! slug (merge r {:body body}))))))
;; The resolver for the composition `each` graph-query source (compose.sx asks the context ;; 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 ;; 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 ;; 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 ;; 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". ;; 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.) ;; The editor edits this inline tree; leaves stay external refs. (composition-objects.md.)
(define host/blog-body-nodes ;; a composition FIELD's value on an object — inline, part of the CID. A type declares which
(fn (slug) ;; of its fields are compositions (host/blog--composition-fields); an object may carry several
(let ((body (host/blog-body-of slug))) ;; (:body, :aside, …), each edited by its own block editor. Compositions live in a STRING-KEYED
(if (and (= (type-of body) "list") (= (str (first body)) "seq")) ;; sub-dict :comps (string keys round-trip through persist cleanly, unlike a mix of keyword and
(rest body) (list))))) ;; string top-level keys). The default "body" field falls back to a legacy top-level :body.
(define host/blog--set-body-nodes! (define host/blog--comps (fn (rec) (or (get rec :comps) {})))
(fn (slug nodes) (host/blog--set-body! slug (cons (quote seq) nodes)))) (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). ;; the value at index k of a list (any element type).
(define host/blog--nth (define host/blog--nth
(fn (xs k) (let loop ((i 0) (ys xs)) (fn (xs k) (let loop ((i 0) (ys xs))
@@ -770,7 +797,7 @@
(fn (container slug) (fn (container slug)
(if (starts-with? slug (str container "__")) (substr slug (+ (len container) 2)) slug))) (if (starts-with? slug (str container "__")) (substr slug (+ (len container) 2)) slug)))
(define host/blog--append-node! (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". ;; the kind of a body node, for the editor: "card" | "cond" | "each" | "other".
(define host/blog--node-kind (define host/blog--node-kind
(fn (node) (fn (node)
@@ -863,55 +890,55 @@
(else "auth"))) (else "auth")))
"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! (define host/blog-block-add!
(fn (slug ctype fields) (fn (slug field ctype fields)
(let ((cslug (host/blog--new-card! slug "body" ctype fields))) (let ((cslug (host/blog--new-card! slug field ctype fields)))
(begin (host/blog--append-node! slug (list (quote ref) (host/blog--slug->ref slug cslug))) cslug)))) (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. ;; add a CONDITIONAL (or) block: (alt (when <pred> (ref A)) (else (ref B))) — A/B relative refs.
(define host/blog-block-add-cond! (define host/blog-block-add-cond!
(fn (slug ckey) (fn (slug field ckey)
(let ((a (host/blog--slug->ref slug (host/blog--new-card! slug "body" "card-text" {"text" "shown when the condition holds"}))) (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 "body" "card-text" {"text" "shown otherwise"})))) (b (host/blog--slug->ref slug (host/blog--new-card! slug field "card-text" {"text" "shown otherwise"}))))
(host/blog--append-node! slug (host/blog--append-node! slug field
(list (quote alt) (list (quote alt)
(list (quote when) (host/blog--cond->pred ckey) (list (quote ref) a)) (list (quote when) (host/blog--cond->pred ckey) (list (quote ref) a))
(list (quote else) (list (quote ref) b))))))) (list (quote else) (list (quote ref) b)))))))
;; add a REPEATER (each) block: (each (query is-a TYPE) (ref <template>)) — template relative. ;; add a REPEATER (each) block: (each (query is-a TYPE) (ref <template>)) — template relative.
(define host/blog-block-add-each! (define host/blog-block-add-each!
(fn (slug type) (fn (slug field type)
(let ((t (host/blog--slug->ref slug (host/blog--new-card! slug "body" "card-text" {"text" "rendered once per item"})))) (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 (host/blog--append-node! slug field
(list (quote each) (list (quote each)
(list (quote query) (string->symbol "is-a") (string->symbol type)) (list (quote query) (string->symbol "is-a") (string->symbol type))
(list (quote ref) t)))))) (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! (define host/blog-block-move-idx!
(fn (slug i dir) (fn (slug field i dir)
(let ((nodes (host/blog-body-nodes slug))) (let ((nodes (host/blog--comp-nodes slug field)))
(let ((j (if (= dir "up") (- i 1) (+ i 1)))) (let ((j (if (= dir "up") (- i 1) (+ i 1))))
(when (and (>= i 0) (< i (len nodes)) (>= j 0) (< j (len nodes))) (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)) (map-indexed (fn (k n) (cond ((= k i) (host/blog--nth nodes j))
((= k j) (host/blog--nth nodes i)) ((= k j) (host/blog--nth nodes i))
(else n))) nodes))))))) (else n))) nodes)))))))
(define host/blog-block-remove-idx! (define host/blog-block-remove-idx!
(fn (slug i) (fn (slug field i)
(let ((nodes (host/blog-body-nodes slug))) (let ((nodes (host/blog--comp-nodes slug field)))
(when (and (>= i 0) (< i (len nodes))) (when (and (>= i 0) (< i (len nodes)))
(begin (begin
;; refs are field-relative; contains edges are keyed by SLUG — resolve before dropping. ;; 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")) (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--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). ;; change a conditional block's `when` condition (its then/else branches are kept).
(define host/blog-block-set-cond! (define host/blog-block-set-cond!
(fn (slug i ckey) (fn (slug field i ckey)
(let ((nodes (host/blog-body-nodes slug))) (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")) (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 ((node (host/blog--nth nodes i)))
(let ((wb (first (rest node))) (eb (first (rest (rest node))))) (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 (map-indexed
(fn (k n) (if (= k i) (fn (k n) (if (= k i)
(list (quote alt) (list (quote alt)
@@ -1564,22 +1591,28 @@
;; #block-editor with the re-render (live reorder/add/remove). Wrapped for the swap target. ;; #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). ;; 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. ;; 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 (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))) (let ((url (str "/" slug "/blocks/" idx "/" action)))
(quasiquote (quasiquote
;; :sx-post (NOT sx-disable) so the click is a text/sx round-trip through the engine — ;; :sx-post -> a text/sx round-trip; the handler returns the re-rendered field editor
;; the handler returns the re-rendered #block-editor and sx-swap="outerHTML" replaces it. ;; and sx-swap="outerHTML" replaces #comp-<field>.
(form :method "post" :action (unquote url) :style "display:inline;margin:0 0.1em" (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))))) (unquote (if (= dir "") "" (quasiquote (input :type "hidden" :name "dir" :value (unquote dir)))))
(button :type "submit" (unquote label))))))) (button :type "submit" (unquote label)))))))
(define host/blog--block-ctrls (define host/blog--block-ctrls
(fn (slug idx) (fn (slug field idx)
(quasiquote (span :style "white-space:nowrap" (quasiquote (span :style "white-space:nowrap"
(unquote (host/blog--block-btn slug idx "move" "up" "↑")) (unquote (host/blog--block-btn slug field idx "move" "up" "↑"))
(unquote (host/blog--block-btn slug idx "move" "down" "↓")) (unquote (host/blog--block-btn slug field idx "move" "down" "↓"))
(unquote (host/blog--block-btn slug idx "remove" "" "remove")))))) (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 ;; 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). ;; card's own /<cslug>/edit page (external object; editing it is CID-neutral to the container).
(define host/blog--ref-chip (define host/blog--ref-chip
@@ -1588,82 +1621,92 @@
(quasiquote (span (quasiquote (span
(a :href (unquote (str "/" cslug "/edit")) "✎") (a :href (unquote (str "/" cslug "/edit")) "✎")
" " (span :style "color:#555" (unquote (host/blog--block-preview (host/blog-field-values-of cslug))))))))) " " (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 (define host/blog--cond-form
(fn (slug idx cur) (fn (slug field idx cur)
(let ((url (str "/" slug "/blocks/" idx "/cond")) (let ((url (str "/" slug "/blocks/" idx "/cond"))
(opt (fn (v l cur) (if (= v cur) (opt (fn (v l cur) (if (= v cur)
(quasiquote (option :value (unquote v) :selected "selected" (unquote l))) (quasiquote (option :value (unquote v) :selected "selected" (unquote l)))
(quasiquote (option :value (unquote v) (unquote l))))))) (quasiquote (option :value (unquote v) (unquote l)))))))
(quasiquote (quasiquote
(form :method "post" :action (unquote url) :style "display:inline" (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" (select :name "cond"
(unquote (opt "auth" "logged in" cur)) (unquote (opt "auth" "logged in" cur))
(unquote (opt "device:mobile" "on mobile" cur)) (unquote (opt "device:mobile" "on mobile" cur))
(unquote (opt "device:desktop" "on desktop" cur)) (unquote (opt "device:desktop" "on desktop" cur))
(unquote (opt "locale:fr" "locale = fr" cur))) (unquote (opt "locale:fr" "locale = fr" cur)))
(button :type "submit" "set")))))) (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 (define host/blog--block-row
(fn (slug idx node) (fn (slug field idx node)
(let ((kind (host/blog--node-kind 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")) (rs "display:flex;gap:0.5em;align-items:center;border:1px solid #ddd;padding:0.4em;margin:0.2em 0"))
(cond (cond
;; CONDITIONAL: the condition <select> + a display of each branch (ref chip OR inline).
((= kind "cond") ((= kind "cond")
(quasiquote (li :style (unquote rs) (quasiquote (li :style (unquote rs)
(b :style "min-width:5em" "if") (b :style "min-width:5em" "if")
(span :style "flex:1" (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)))) " → " (unquote (host/blog--branch-display slug (first (rest node))))
" · else → " (unquote (host/blog--branch-display slug (first (rest (rest node)))))) " · else → " (unquote (host/blog--branch-display slug (first (rest (rest node))))))
(unquote (host/blog--block-ctrls slug idx))))) (unquote (host/blog--block-ctrls slug field idx)))))
;; REPEATER: the query type + a display of the per-item template (ref OR inline).
((= kind "each") ((= kind "each")
(quasiquote (li :style (unquote rs) (quasiquote (li :style (unquote rs)
(b :style "min-width:5em" "for each") (b :style "min-width:5em" "for each")
(span :style "flex:1" (span :style "flex:1"
(code (unquote (host/blog--node-each-type node))) (code (unquote (host/blog--node-each-type node)))
" → " (unquote (host/blog--node-display slug (host/blog--nth node (- (len node) 1))))) " → " (unquote (host/blog--node-display slug (host/blog--nth node (- (len node) 1)))))
(unquote (host/blog--block-ctrls slug idx))))) (unquote (host/blog--block-ctrls slug field idx)))))
;; every other kind (card / text / layout / field / group / other) — a labelled row
;; with a preview + controls. No composition node falls through to "unknown".
(else (quasiquote (li :style (unquote rs) (else (quasiquote (li :style (unquote rs)
(b :style "min-width:5em" (unquote kind)) (b :style "min-width:5em" (unquote kind))
(span :style "flex:1;color:#555;overflow:hidden" (unquote (host/blog--node-display slug node))) (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 (define host/blog--block-editor
(fn (slug) (fn (slug field)
(let ((nodes (host/blog-body-nodes slug))) (let ((nodes (host/blog--comp-nodes slug field)))
(let ((rows (map-indexed (fn (i n) (host/blog--block-row slug i n)) nodes))) (let ((rows (map-indexed (fn (i n) (host/blog--block-row slug field i n)) nodes)))
(quasiquote (quasiquote
(div :id "block-editor" :style "margin-top:1.5em;border-top:1px solid #ccc;padding-top:1em" (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" "Blocks (composition)") (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.")))) (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")) (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" (select :name "ctype"
(option :value "card-heading" "heading") (option :value "card-text" "text") (option :value "card-heading" "heading") (option :value "card-text" "text")
(option :value "card-quote" "quote") (option :value "card-code" "code") (option :value "card-quote" "quote") (option :value "card-code" "code")
(option :value "card-callout" "callout")) (option :value "card-callout" "callout"))
" " (input :name "text" :placeholder "text…" :style "width:40%") " " (input :name "text" :placeholder "text…" :style "width:40%")
" " (button :type "submit" "+ card")) " " (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")) (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" :style "margin-top:0.3em"
(unquote (host/blog--fld field))
(select :name "cond" (select :name "cond"
(option :value "auth" "logged in") (option :value "device:mobile" "on mobile") (option :value "auth" "logged in") (option :value "device:mobile" "on mobile")
(option :value "device:desktop" "on desktop") (option :value "locale:fr" "locale = fr")) (option :value "device:desktop" "on desktop") (option :value "locale:fr" "locale = fr"))
" " (button :type "submit" "+ conditional (or)")) " " (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")) (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" :style "margin-top:0.3em"
(unquote (host/blog--fld field))
(input :name "type" :placeholder "type name (e.g. compose-item)" :style "width:40%") (input :name "type" :placeholder "type name (e.g. compose-item)" :style "width:40%")
" " (button :type "submit" "+ repeater (each)")))))))) " " (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 ─────────────────────────────────────────────────── ;; ── read handlers ───────────────────────────────────────────────────
;; Post body is rendered per-block (a guarded HTML string) then injected raw. ;; 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 ;; the quasiquote. IO must run in the handler body, never while the page
;; tree is built (a perform there raises VmSuspended under http-listen). ;; tree is built (a perform there raises VmSuspended under http-listen).
(let ((principal (host/current-principal req))) (let ((principal (host/current-principal req)))
(let (;; composition objects: a record with a :body renders via the render-fold (let (;; composition objects: render EACH composition field the type declares
;; (host/comp-render) against a context (auth from the principal); else the ;; (default just :body) via the render-fold, in field order, against a
;; legacy sx_content path. The SAME object renders differently per context. ;; context (auth/device/locale + the container). Else the legacy sx_content.
(body-html (if (get r :body) (body-html
(host/comp-render (get r :body) (host/blog--comp-ctx principal req slug)) (let ((ctx (host/blog--comp-ctx principal req slug)))
(host/blog-render r))) (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 …) ;; all relation blocks (Related, Tags, Types, Tagged-with-this …)
;; come from iterating the registry — one section, registry-driven. ;; come from iterating the registry — one section, registry-driven.
(relations (host/blog--relations-or-hint slug (not (nil? principal)))) (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 ;; 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). ;; 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 (define host/blog--block-resp
(fn (req slug) (fn (req slug field)
(if (host/blog--editor-swap-req? req) (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"))))) (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-idx (fn (req) (parse-int (or (dream-param req "idx") "0") 0)))
(define host/blog-block-add-submit (define host/blog-block-add-submit
(fn (req) (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")) (ctype (or (host/field req "ctype") "card-text"))
(text (or (host/field req "text") ""))) (text (or (host/field req "text") "")))
(begin (begin
@@ -2067,34 +2115,34 @@
;; subtype-of, NOT is-a, so the down-closure of "card" is the valid set). ;; subtype-of, NOT is-a, so the down-closure of "card" is the valid set).
(when (and (host/blog-exists? slug) (when (and (host/blog-exists? slug)
(contains? (host/blog--subtype-closure (list "card") :in) ctype)) (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}))) (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 (define host/blog-block-add-cond-submit
(fn (req) (fn (req)
(let ((slug (dream-param req "slug")) (ckey (or (host/field req "cond") "auth"))) (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 ckey)) (begin (when (host/blog-exists? slug) (host/blog-block-add-cond! slug field ckey))
(host/blog--block-resp req slug))))) (host/blog--block-resp req slug field)))))
(define host/blog-block-add-each-submit (define host/blog-block-add-each-submit
(fn (req) (fn (req)
(let ((slug (dream-param req "slug")) (type (host/blog-slugify (or (host/field req "type") "")))) (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 type)) (begin (when (and (host/blog-exists? slug) (not (= type ""))) (host/blog-block-add-each! slug field type))
(host/blog--block-resp req slug))))) (host/blog--block-resp req slug field)))))
(define host/blog-block-remove-submit (define host/blog-block-remove-submit
(fn (req) (fn (req)
(let ((slug (dream-param 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 (host/blog--block-idx 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))))) (host/blog--block-resp req slug field)))))
(define host/blog-block-move-submit (define host/blog-block-move-submit
(fn (req) (fn (req)
(let ((slug (dream-param req "slug")) (dir (or (host/field req "dir") "up"))) (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 (host/blog--block-idx req) dir)) (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))))) (host/blog--block-resp req slug field)))))
(define host/blog-block-cond-submit (define host/blog-block-cond-submit
(fn (req) (fn (req)
(let ((slug (dream-param req "slug")) (ckey (or (host/field req "cond") "auth"))) (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 (host/blog--block-idx req) ckey)) (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))))) (host/blog--block-resp req slug field)))))
;; GET /<slug>/edit — edit form pre-filled with the post's current title, raw ;; 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 ;; 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 ;; the relation editors + tag toggle do durable reads — compute them
;; here, not in the quasiquote, so IO stays in the handler body. ;; here, not in the quasiquote, so IO stays in the handler body.
(let ((relation-editors (host/blog--relation-editors slug)) (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)) (tag-toggle (host/blog--is-tag-toggle slug))
(post-fields (host/blog--fields-for-post slug)) (post-fields (host/blog--fields-for-post slug))
(field-values (host/blog-field-values-of slug)) (field-values (host/blog-field-values-of slug))

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

@@ -828,22 +828,22 @@
(begin (begin
(host/blog-put! "bdoc" "BDoc" "(article)" "published") (host/blog-put! "bdoc" "BDoc" "(article)" "published")
(host/blog--set-body! "bdoc" (quote (seq))) (host/blog--set-body! "bdoc" (quote (seq)))
(let ((c0 (host/blog-block-add! "bdoc" "card-text" {"text" "first"})) (let ((c0 (host/blog-block-add! "bdoc" "body" "card-text" {"text" "first"}))
(c1 (host/blog-block-add! "bdoc" "card-heading" {"level" "2" "text" "a head"}))) (c1 (host/blog-block-add! "bdoc" "body" "card-heading" {"level" "2" "text" "a head"})))
(list (host/blog-body-refs "bdoc") (list (host/blog-body-refs "bdoc")
(host/blog-is-a? c0 "card-text") (host/blog-is-a? c0 "card-text")
(contains? (host/blog-out "bdoc" "contains") c1)))) (contains? (host/blog-out "bdoc" "contains") c1))))
(list (list "body__b0" "body__b1") true true)) (list (list "body__b0" "body__b1") true true))
(host-bl-test "block-move-idx! reorders the body by index (no-op at the ends)" (host-bl-test "block-move-idx! reorders the body by index (no-op at the ends)"
(begin (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"))) (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 after-up (host/blog-body-refs "bdoc"))))
(list (list "body__b1" "body__b0") (list "body__b1" "body__b0"))) (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" (host-bl-test "block-remove-idx! drops the node + its contained card's contains edge"
(begin (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 (host/blog-body-refs "bdoc") (contains? (host/blog-out "bdoc" "contains") "bdoc__body__b1")))
(list (list "body__b0") false)) (list (list "body__b0") false))
(host-bl-test "the edit page shows the block editor (#block-editor + an add-block form)" (host-bl-test "the edit page shows the block editor (#block-editor + an add-block form)"
@@ -862,7 +862,7 @@
(begin (begin
(host/blog-put! "cdoc2" "C2" "(article)" "published") (host/blog-put! "cdoc2" "C2" "(article)" "published")
(host/blog--set-body! "cdoc2" (quote (seq))) (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))) (let ((n (host/blog--nth (host/blog-body-nodes "cdoc2") 0)))
(list (host/blog--node-kind n) (list (host/blog--node-kind n)
(host/blog--pred->ckey (host/blog--node-pred n)) (host/blog--pred->ckey (host/blog--node-pred n))
@@ -870,13 +870,13 @@
(list "cond" "device:mobile" 2)) (list "cond" "device:mobile" 2))
(host-bl-test "block-set-cond! changes the condition (branches kept)" (host-bl-test "block-set-cond! changes the condition (branches kept)"
(begin (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))) (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 (host/blog--pred->ckey (host/blog--node-pred n)) (host/blog--node-kind n))))
(list "locale:fr" "cond")) (list "locale:fr" "cond"))
(host-bl-test "block-add-each! appends an (each (query is-a TYPE) (ref …)) repeater" (host-bl-test "block-add-each! appends an (each (query is-a TYPE) (ref …)) repeater"
(begin (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))) (let ((n (host/blog--nth (host/blog-body-nodes "cdoc2") 1)))
(list (host/blog--node-kind n) (host/blog--node-each-type n)))) (list (host/blog--node-kind n) (host/blog--node-each-type n))))
(list "each" "compose-item")) (list "each" "compose-item"))
@@ -886,17 +886,42 @@
(begin (begin
(host/blog-put! "cdoc3" "C3" "(article)" "published") (host/blog-put! "cdoc3" "C3" "(article)" "published")
(host/blog--set-body! "cdoc3" (quote (seq))) (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"))) (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") (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")))) (contains? (host/comp-render body (host/blog--comp-ctx nil nil "cdoc3")) "shown otherwise"))))
(list true true)) (list true true))
;; the editor offers all three block kinds. ;; the editor offers all three block kinds.
(host-bl-test "the block editor offers card + conditional + repeater add forms" (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") (list (contains? html "+ card") (contains? html "+ conditional")
(contains? html "+ repeater") (contains? html "for each"))) (contains? html "+ repeater") (contains? html "for each")))
(list true true true true)) (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 ;; 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). ;; 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)" (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"))) (alt (when (has "auth") (text "member")) (else (text "guest")))
(row (text "A") (text "B")) (row (text "A") (text "B"))
(each (query is-a compose-item) (seq (text "x")))))) (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") (list (contains? html "unknown block")
(contains? html "text") (contains? html "layout") (contains? html "for each")))) (contains? html "text") (contains? html "layout") (contains? html "for each"))))
(list false true true true)) (list false true true true))