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

host: composition editor for and/or/each + relative-addressed refs (resolve-in-context)

Browse Source 
The block editor now edits the object's ONE root composition (:body) as three block kinds —
CARD (a ref leaf, the "and"/content), CONDITIONAL (alt+when, the "or": render the first
branch whose live-context condition holds), and REPEATER (each: render a template per graph
query). The render-fold already interprets seq/alt/when/each/ref, so authored compositions
render for free; this adds the editing model + UI.

ADDRESSING (per the design discussion — refs are IPNS-like, not frozen CIDs): refs are
RELATIVE-STORED + RESOLVE-IN-CONTEXT. A :body stores (ref "body__b0") (field-relative); the
render context carries the CONTAINER (the object being rendered) and the resolver combines
them -> the card's storage slug <container>__<field>__<name>. So a body is portable (doesn't
pin the container's name), and editing a card updates everything that refs it for free (no
cascade). A cross-domain ref is absolute with an authority ("market:…"); the resolver
dispatches on the prefix (local today, fetch_data/AP later). A compat shim resolves an older
absolute ref directly. (Snapshot-to-absolute-CID stays a future on-demand op; the CID —
hash(record incl :body) — is the immutable layer over this naming layer.)

MODEL: host/blog--{card-slug,resolve-ref,slug->ref,new-card!,node-kind,node-refs,node-pred,
node-each-type,cond->pred,pred->ckey}; block-add!/add-cond!/add-each!; index-addressed
block-move-idx!/remove-idx!/set-cond! (alt/each aren't single refs). UI: host/blog--block-row
renders by kind (card / "if <cond> → … else → …" / "for each <type> → …") with a condition
<select> + ✎ links to each card's own /<cslug>/edit (external object, CID-neutral). Routes:
POST /:slug/blocks/{add, add-cond, add-each, :idx/{move,remove,cond}}.

Types-define-structure is the next layer (a type declares its composition field(s) + block
grammar). Full host conformance 399/399 (blog 170, incl. 5 new and/or/each tests: add-cond/
add-each/set-cond, a conditional rendering the context-chosen branch, the 3-form editor).

Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
This commit is contained in:
giles
2026-07-01 10:08:12 +00:00
parent 01e0b5db41
commit 39c3def2e7
2 changed files with 390 additions and 87 deletions
Download Patch File Download Diff File Expand all files Collapse all files

392
lib/host/blog.sx
View File

@@ -545,24 +545,53 @@
(fn (req)
(let ((al (str (or (dream-header req "accept-language") ""))))
(if (>= (len al) 2) (substr al 0 2) "en"))))
;; the `ref` transclude resolver (compose.sx asks the context for "ref"): render the
;; referenced object. A decomposed card object is-a a card-type with field-values + the
;; card-type carries a :template, so it renders via the SAME typed-block path articles
;; use; render-page turns that SX tree into HTML. Empty for an absent / template-less ref.
;; ── ref addressing: relative-stored, resolve-in-context (IPNS-like) ─────────────────
;; A ref in a :body is RELATIVE by default — a field-path like "body__b0" (logical: body/b0),
;; resolved against the object being rendered (the "container" in the context). So the same
;; body is portable: it doesn't pin the container's name. A card's storage slug is
;; <container>__<field>__<name> (routing-safe — a single URL segment). A cross-domain ref is
;; ABSOLUTE with an authority: "market:obj__field__card" — the resolver dispatches on the
;; prefix (local today; fetch_data / ActivityPub for a remote authority later). A snapshot/
;; publish op (future) freezes all refs to absolute CIDs. This is the naming layer; the CID
;; (content hash of the record, incl :body) is the immutable-identity layer on top.
(define host/blog--card-slug
(fn (container field name) (str container "__" field "__" name)))
;; resolve a ref string (relative field-path, or authority:slug) to a LOCAL storage slug,
;; or "" if it's a remote authority we can't fetch yet.
(define host/blog--resolve-ref
(fn (refstr ctx)
(let ((container (str (or (get ctx "container") ""))))
(if (contains? refstr ":")
(let ((p (index-of refstr ":")))
(let ((auth (substr refstr 0 p)) (rest-slug (substr refstr (+ p 1))))
(if (or (= auth "blog") (= auth container)) rest-slug ""))) ;; local authority -> the slug; remote -> unresolved (seam)
(if (= container "") refstr
;; relative resolution: <container>__<ref>. COMPAT: an older body may store an
;; ABSOLUTE ref (the full card slug) — if the relative form is absent but the ref
;; already names an existing object, use it directly.
(let ((rel (str container "__" refstr)))
(if (host/blog-exists? rel) rel (if (host/blog-exists? refstr) refstr rel))))))))
;; the `ref` transclude resolver (compose.sx asks the context for "ref"): RESOLVE the ref in
;; context, then render the resolved card object. A card is-a a card-type with field-values +
;; the card-type carries a :template, so it renders via the SAME typed-block path articles
;; use; render-page turns that SX tree into HTML. Empty for an absent / remote / bare ref.
(define host/blog--comp-ref
(fn (slug ctx)
(let ((tb (host/blog--typed-block slug)))
(if (= tb "") "" (render-page tb)))))
(fn (refstr ctx)
(let ((slug (host/blog--resolve-ref refstr ctx)))
(if (= slug "") ""
(let ((tb (host/blog--typed-block slug)))
(if (= tb "") "" (render-page tb)))))))
;; the render context for a :body: auth from the principal + live device/locale from the
;; request + the graph-query resolver + the transclude resolver. The context is the
;; EXECUTION environment — the object (its when-variants) is the definition; this picks
;; which path renders.
;; request + the graph-query resolver + the transclude resolver + the CONTAINER (the object
;; being rendered, so relative refs resolve). The context is the EXECUTION environment — the
;; object (its when-variants) is the definition; this picks which path renders.
(define host/blog--comp-ctx
(fn (principal req)
(fn (principal req container)
(merge
(merge (if (nil? principal) {} {"auth" "yes"})
(if (nil? req) {} {"device" (host/blog--device-of req) "locale" (host/blog--locale-of req)}))
{"query" host/blog--comp-query "ref" host/blog--comp-ref})))
{"query" host/blog--comp-query "ref" host/blog--comp-ref
"container" (or container "")})))
;; ── cards-as-objects: decompose content into card OBJECTS + a `contains` body ────────
;; A post body is not one opaque sx_content string but a `contains` DAG of separate,
@@ -627,7 +656,7 @@
(let ((refs
(map-indexed
(fn (i block)
(let ((orig-tag (str (first block))) (cslug (str post-slug "__b" i)))
(let ((orig-tag (str (first block))) (cslug (host/blog--card-slug post-slug "body" (str "b" i))))
(let ((ctype (host/blog--tag->card-type orig-tag)))
(begin
;; status "block" hides the card object from listings; it still
@@ -636,7 +665,7 @@
(host/blog-relate! cslug ctype "is-a")
(host/blog--set-field-values! cslug (host/blog--block-fields orig-tag ctype block))
(host/blog-relate! post-slug cslug "contains")
(list (quote ref) cslug)))))
(list (quote ref) (host/blog--slug->ref post-slug cslug))))))
blocks)))
(host/blog--set-body! post-slug (cons (quote seq) refs)))))))
@@ -661,16 +690,8 @@
(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))))
;; legacy card-only remove (by ref slug) — kept for card-only callers/tests; the node-based
;; editor uses host/blog-block-remove-idx! (index-addressed, preserves alt/each nodes).
(define host/blog-block-remove!
(fn (slug cslug)
(begin
@@ -703,6 +724,177 @@
(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))))
;; ── and/or/each authoring: the :body's top-level nodes are BLOCKS of three kinds ─────
;; The :body IS the object's one root composition (inline, part of its CID). Its top-level
;; nodes are blocks: a CARD (ref -> an external card object via a `contains` edge), 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".
;; 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))))
;; the value at index k of a list (any element type).
(define host/blog--nth
(fn (xs k) (let loop ((i 0) (ys xs))
(cond ((empty? ys) nil) ((= i k) (first ys)) (else (loop (+ i 1) (rest ys)))))))
;; a copy of xs without index i.
(define host/blog--remove-at
(fn (xs i) (let loop ((k 0) (ys xs) (acc (list)))
(if (empty? ys) acc
(loop (+ k 1) (rest ys) (if (= k i) acc (concat acc (list (first ys)))))))))
;; a fresh card object (is-a ctype + fields), contains-linked to `slug`; returns its slug.
;; Every block kind's leaves are card objects made this way.
;; a fresh, uniquely-named card in <container>/<field>. Returns its STORAGE SLUG
;; (<container>__<field>__b<i>); callers store the RELATIVE ref via host/blog--slug->ref.
(define host/blog--next-card-name
(fn (container field)
(let loop ((i 0))
(if (host/blog-exists? (host/blog--card-slug container field (str "b" i))) (loop (+ i 1)) (str "b" i)))))
(define host/blog--new-card!
(fn (container field ctype fields)
(let ((cslug (host/blog--card-slug container field (host/blog--next-card-name container field))))
(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! container cslug "contains")
cslug))))
;; a card's RELATIVE ref (field-path) from its storage slug: <container>__<field>__<name>
;; -> <field>__<name>. What's stored in a :body (resolve-in-context re-prepends container).
(define host/blog--slug->ref
(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)))))
;; the kind of a body node, for the editor: "card" | "cond" | "each" | "other".
(define host/blog--node-kind
(fn (node)
(if (= (type-of node) "list")
(let ((h (str (first node))))
(cond ((= h "ref") "card") ((= h "alt") "cond") ((= h "each") "each") (else "other")))
"other")))
;; every ref slug a node (transitively) contains — for `contains`-edge cleanup on remove.
(define host/blog--node-refs
(fn (node)
(if (= (type-of node) "list")
(if (= (str (first node)) "ref")
(list (str (first (rest node))))
(reduce (fn (acc n) (concat acc (host/blog--node-refs n))) (list) (rest node)))
(list))))
;; a `when` condition key <-> its predicate. A small decidable set over the live context
;; (auth/device/locale) — this is where responsive/personalised authoring surfaces.
(define host/blog--cond->pred
(fn (ckey)
(cond
((= ckey "auth") (list (quote has) "auth"))
((= ckey "device:mobile") (list (quote eq) "device" "mobile"))
((= ckey "device:desktop") (list (quote eq) "device" "desktop"))
((= ckey "locale:fr") (list (quote eq) "locale" "fr"))
(else (list (quote has) "auth")))))
(define host/blog--pred->label
(fn (pred)
(if (= (type-of pred) "list")
(let ((op (str (first pred))))
(cond
((= op "has") (str "has " (str (first (rest pred)))))
((= op "eq") (str (str (first (rest pred))) " = " (str (first (rest (rest pred))))))
(else "?")))
"?")))
;; the when-predicate of a conditional node (alt (when P …) …), or nil.
(define host/blog--node-pred
(fn (node)
(if (and (= (host/blog--node-kind node) "cond") (>= (len (rest node)) 1))
(let ((wb (first (rest node)))) (if (= (str (first wb)) "when") (first (rest wb)) nil))
nil)))
;; the query TYPE of a repeater node (each (query is-a T) …), or "".
(define host/blog--node-each-type
(fn (node)
(if (and (= (host/blog--node-kind node) "each") (>= (len (rest node)) 1))
(let ((src (first (rest node))))
(if (and (= (type-of src) "list") (= (str (first src)) "query")) (str (first (rest (rest src)))) ""))
"")))
;; the ref inside a branch — its last element (ref …); "" if none. Used to read the then/
;; else refs of a conditional and the template ref of a repeater.
(define host/blog--branch-ref
(fn (branch)
(let ((n (host/blog--nth branch (- (len branch) 1))))
(if (and (= (type-of n) "list") (= (str (first n)) "ref")) (str (first (rest n))) ""))))
(define host/blog--cond-then (fn (node) (host/blog--branch-ref (first (rest node)))))
(define host/blog--cond-else (fn (node) (host/blog--branch-ref (first (rest (rest node))))))
(define host/blog--each-tmpl (fn (node) (host/blog--branch-ref node)))
;; a ckey (for the cond <select>) from a predicate — the inverse of host/blog--cond->pred.
(define host/blog--pred->ckey
(fn (pred)
(if (= (type-of pred) "list")
(let ((op (str (first pred))))
(cond
((= op "has") "auth")
((and (= op "eq") (= (str (first (rest pred))) "device") (= (str (first (rest (rest pred)))) "mobile")) "device:mobile")
((and (= op "eq") (= (str (first (rest pred))) "device")) "device:desktop")
((and (= op "eq") (= (str (first (rest pred))) "locale")) "locale:fr")
(else "auth")))
"auth")))
;; add a CARD block to `field`: (ref <field-relative>). Returns the new card's storage 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))))
;; 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
(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
(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).
(define host/blog-block-move-idx!
(fn (slug i dir)
(let ((nodes (host/blog-body-nodes slug)))
(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
(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)))
(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)))))))
;; 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)))
(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
(map-indexed
(fn (k n) (if (= k i)
(list (quote alt)
(list (quote when) (host/blog--cond->pred ckey) (first (rest (rest wb)))) eb)
n))
nodes))))))))
;; 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!
@@ -1348,51 +1540,105 @@
;; 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).
;; index-addressed control button (move up/down, remove, set-cond) -> re-renders #block-editor.
(define host/blog--block-btn
(fn (slug cslug action dir label)
(let ((url (str "/" slug "/blocks/" cslug "/" action)))
(fn (slug idx action dir label)
(let ((url (str "/" slug "/blocks/" idx "/" action)))
(quasiquote
;; :sx-post (NOT sx-disable) so the click is a text/sx form round-trip through the
;; engine — the handler returns the re-rendered #block-editor and sx-swap="outerHTML"
;; replaces it live (no reload). The explicit :sx-post overrides any boost target.
(form :method "post" :action (unquote url) :style "display:inline;margin:0"
;; :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.
(form :method "post" :action (unquote url) :style "display:inline;margin:0 0.1em"
:sx-post (unquote url) :sx-target "#block-editor" :sx-swap "outerHTML"
(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)))
(define host/blog--block-ctrls
(fn (slug 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"))))))
;; 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
(fn (slug ref)
(let ((cslug (host/blog--resolve-ref ref {"container" slug})))
(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).
(define host/blog--cond-form
(fn (slug 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
(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")))))))
(form :method "post" :action (unquote url) :style "display:inline"
:sx-post (unquote url) :sx-target "#block-editor" :sx-swap "outerHTML"
(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).
(define host/blog--block-row
(fn (slug 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
((= kind "card")
(quasiquote (li :style (unquote rs)
(b :style "min-width:5em" "card")
(span :style "flex:1" (unquote (host/blog--ref-chip slug (str (first (rest node))))))
(unquote (host/blog--block-ctrls slug idx)))))
((= 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--ref-chip slug (host/blog--cond-then node)))
" · else → " (unquote (host/blog--ref-chip slug (host/blog--cond-else node))))
(unquote (host/blog--block-ctrls slug 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--ref-chip slug (host/blog--each-tmpl node))))
(unquote (host/blog--block-ctrls slug idx)))))
(else (quasiquote (li :style (unquote rs) "(unknown block)")))))))
(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)))
(let ((nodes (host/blog-body-nodes slug)))
(let ((rows (map-indexed (fn (i n) (host/blog--block-row slug 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")
(unquote (if (> (len refs) 0) (cons (quote ul) rows) (quote (p :style "color:#999" "No blocks yet."))))
(h3 :style "font-size:1em;margin:0 0 0.3em" "Blocks (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.
(form :method "post" :action (unquote (str "/" slug "/blocks/add"))
:sx-post (unquote (str "/" slug "/blocks/add")) :sx-target "#block-editor" :sx-swap "outerHTML"
;; options MUST be DIRECT children of <select> — a wrapper (e.g. a span to splice
;; a dynamic list) leaves the dropdown empty when the DOM is built programmatically
;; on a boosted swap (a full-page HTML parse would hoist them out, masking it). The
;; card types are a fixed set, so inline them.
(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-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:50%")
" " (button :type "submit" "+ add block"))))))))
" " (input :name "text" :placeholder "text…" :style "width:40%")
" " (button :type "submit" "+ card"))
;; add a CONDITIONAL (or) block — alt+when over the live context.
(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"
:style "margin-top:0.3em"
(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.
(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"
:style "margin-top:0.3em"
(input :name "type" :placeholder "type name (e.g. compose-item)" :style "width:40%")
" " (button :type "submit" "+ repeater (each)"))))))))
;; ── read handlers ───────────────────────────────────────────────────
;; Post body is rendered per-block (a guarded HTML string) then injected raw.
@@ -1410,7 +1656,7 @@
;; (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))
(host/comp-render (get r :body) (host/blog--comp-ctx principal req slug))
(host/blog-render r)))
;; all relation blocks (Related, Tags, Types, Tagged-with-this …)
;; come from iterating the registry — one section, registry-driven.
@@ -1785,6 +2031,7 @@
(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-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"))
@@ -1798,18 +2045,30 @@
(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-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)))))
(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)))))
(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))
(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)))))
(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))
(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)))))
(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)))))
;; GET /<slug>/edit — edit form pre-filled with the post's current title, raw
@@ -1940,8 +2199,11 @@
(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/blocks/add-cond" (host/blog--protect-html resolve host/blog-block-add-cond-submit))
(dream-post "/:slug/blocks/add-each" (host/blog--protect-html resolve host/blog-block-add-each-submit))
(dream-post "/:slug/blocks/:idx/remove" (host/blog--protect-html resolve host/blog-block-remove-submit))
(dream-post "/:slug/blocks/:idx/move" (host/blog--protect-html resolve host/blog-block-move-submit))
(dream-post "/:slug/blocks/:idx/cond" (host/blog--protect-html resolve host/blog-block-cond-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))

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

@@ -770,7 +770,7 @@
(let ((out (host/comp-render
(quote (each (query is-a qtype)
(seq (text "<a href=\"/") (val :slug) (text "\">") (field :title) (text "</a>"))))
(host/blog--comp-ctx nil nil))))
(host/blog--comp-ctx nil nil nil))))
;; field wraps in <span> (display); val is raw (for the href attribute).
(list (contains? out "Item One") (contains? out "Item Two")
(contains? out "/qi-1") (contains? out "<span>Item One</span>"))))
@@ -779,21 +779,21 @@
(host-bl-test "each(query is-a TYPE) with no instances renders empty"
(host/comp-render
(quote (each (query is-a no-such-type) (field :title)))
(host/blog--comp-ctx nil nil))
(host/blog--comp-ctx nil nil nil))
"")
;; -- live context: the SAME object renders a responsive variant per request (device from
;; the User-Agent, locale from Accept-Language) — context is the execution environment. --
(host-bl-test "comp-ctx reads device + locale from the request headers"
(let ((mob (host/blog--comp-ctx nil (dream-request "GET" "/x" {"user-agent" "X iPhone Y" "accept-language" "fr-FR,fr"} "")))
(desk (host/blog--comp-ctx nil (dream-request "GET" "/x" {"user-agent" "Mozilla Linux" "accept-language" "en-US"} ""))))
(let ((mob (host/blog--comp-ctx nil (dream-request "GET" "/x" {"user-agent" "X iPhone Y" "accept-language" "fr-FR,fr"} "") nil))
(desk (host/blog--comp-ctx nil (dream-request "GET" "/x" {"user-agent" "Mozilla Linux" "accept-language" "en-US"} "") nil)))
(list (get mob "device") (get mob "locale") (get desk "device") (get desk "locale")))
(list "mobile" "fr" "desktop" "en"))
(host-bl-test "one object renders a device-specific variant via (alt (when (eq device …)))"
(let ((body (quote (alt (when (eq "device" "mobile") (text "M")) (else (text "D")))))
(mob (dream-request "GET" "/x" {"user-agent" "iPhone"} ""))
(desk (dream-request "GET" "/x" {"user-agent" "Linux"} "")))
(list (host/comp-render body (host/blog--comp-ctx nil mob))
(host/comp-render body (host/blog--comp-ctx nil desk))))
(list (host/comp-render body (host/blog--comp-ctx nil mob nil))
(host/comp-render body (host/blog--comp-ctx nil desk nil))))
(list "M" "D"))
;; -- cards-as-objects: the importer decomposes content into card OBJECTS + a contains body
;; (not one opaque sx_content string). Each top-level block becomes a stored card object
@@ -805,11 +805,11 @@
"sx_content" "(article (h1 \"Heading One\") (p \"Para text.\") (img :src \"p.jpg\" :alt \"alt\"))"
"status" "published"})
(list (len (host/blog-out "imp-x" "contains"))
(host/blog-is-a? "imp-x__b0" "card-heading")
(host/blog-is-a? "imp-x__b1" "card-text")
(host/blog-is-a? "imp-x__b2" "card-image")
(get (host/blog-field-values-of "imp-x__b0") "text")
(get (host/blog-field-values-of "imp-x__b2") "src")))
(host/blog-is-a? "imp-x__body__b0" "card-heading")
(host/blog-is-a? "imp-x__body__b1" "card-text")
(host/blog-is-a? "imp-x__body__b2" "card-image")
(get (host/blog-field-values-of "imp-x__body__b0") "text")
(get (host/blog-field-values-of "imp-x__body__b2") "src")))
(list 3 true true true "Heading One" "p.jpg"))
(host-bl-test "a decomposed post :body is a (seq (ref …) …) composition"
(let ((body (host/blog-body-of "imp-x")))
@@ -817,7 +817,7 @@
(list "seq" 3 "ref"))
;; the card objects are status "block" — stored but NOT listed as top-level posts.
(host-bl-test "decomposed card objects do not appear on the published home index"
(contains? (dream-resp-body (host-bl-app (host-bl-req "/"))) "imp-x__b0") false)
(contains? (dream-resp-body (host-bl-app (host-bl-req "/"))) "imp-x__body__b0") false)
;; the post page renders the cards by TRANSCLUSION (ref -> card-type template).
(host-bl-test "decomposed post page renders the transcluded cards"
(let ((html (dream-resp-body (host-bl-app (host-bl-req "/imp-x/")))))
@@ -833,22 +833,22 @@
(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)"
(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! "bdoc" "bdoc__b1" "up") ;; b1 before b0
(host/blog-block-move-idx! "bdoc" 1 "up") ;; node 1 before node 0
(let ((after-up (host/blog-body-refs "bdoc")))
(host/blog-block-move! "bdoc" "bdoc__b1" "up") ;; b1 already first -> no-op
(host/blog-block-move-idx! "bdoc" 0 "up") ;; index 0 up -> 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"
(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! "bdoc" "bdoc__b1")
(list (host/blog-body-refs "bdoc") (contains? (host/blog-out "bdoc" "contains") "bdoc__b1")))
(list (list "bdoc__b0") false))
(host/blog-block-remove-idx! "bdoc" 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)"
(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 (contains? html "block-editor") (contains? html "+ card")))
(list true true))
(host-bl-test "POST /bdoc/blocks/add (auth) adds a block -> body grows"
(begin
@@ -856,6 +856,47 @@
"application/x-www-form-urlencoded" "ctype=card-text&text=added+block"))
(len (host/blog-body-refs "bdoc")))
2)
;; -- and/or/each authoring: card (and) / conditional (or) / repeater (each) blocks over the
;; type-defined :body composition. Refs are field-relative; contains edges track the cards. --
(host-bl-test "block-add-cond! appends an (alt (when …) (else …)) with then/else cards"
(begin
(host/blog-put! "cdoc2" "C2" "(article)" "published")
(host/blog--set-body! "cdoc2" (quote (seq)))
(host/blog-block-add-cond! "cdoc2" "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))
(len (host/blog-out "cdoc2" "contains"))))) ;; two cards contained
(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")
(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")
(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"))
;; the WHOLE point: a conditional block renders its chosen branch per the live context, via
;; the SAME render-fold. (End-to-end: alt+when over "device", cards resolved by relative ref.)
(host-bl-test "a conditional block renders the branch chosen by context"
(begin
(host/blog-put! "cdoc3" "C3" "(article)" "published")
(host/blog--set-body! "cdoc3" (quote (seq)))
(host/blog-block-add-cond! "cdoc3" "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"))))
(list (contains? html "+ card") (contains? html "+ conditional")
(contains? html "+ repeater") (contains? html "for each")))
(list true true true true))
;; -- /workflow-demo: ONE composition object run through the EXECUTE-fold (step 7 live). The
;; same :body structure the render-fold renders, folded to an effect log (status=ready ->
;; validate, publish, notify each — not hold). --