giles
b056469be1
The block editor assumed cards-as-objects leaves (ref/alt-with-refs/each-with-ref), so a hand-authored composition (the compose-demo: text/row/alt-with-text/each-with-inline) fell through to "(unknown block)" for every text/row node. Now every node kind gets a labelled row + preview + move/remove controls: card (✎ chip), text (its content), layout (row/grid + item count), field, group, and a graceful "other". Conditionals/repeaters display each branch via host/blog--node-display (a ref → ✎ chip, else the inline text/summary) instead of assuming a ref. host/blog--node-kind extended (text/layout/field/group); +node-display/+branch-display. TEST-FIRST: a mixed body (text + alt-with-text + row + each-with-inline) asserts the editor has NO "unknown block" and labels text/layout/for-each. RED before, GREEN after. blog 171/171. Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
2245 lines
125 KiB
Plaintext
2245 lines
125 KiB
Plaintext
;; lib/host/blog.sx — Blog domain on the host, on the EDITOR's content model.
|
||
;; The SX post editor (blog/sx/editor.sx) emits `sx_content`: SX element markup
|
||
;; (e.g. "(article (h1 \"T\") (p \"body\" (strong \"x\")))"), NOT content-on-sx
|
||
;; CtDoc blocks. So a post here is a record {slug,title,sx_content,status} stored
|
||
;; in the durable persist KV, and a post page is `render-to-html (parse sx_content)`
|
||
;; — server-side, static, no client runtime needed to view a published post.
|
||
;;
|
||
;; GET / HTML index of posts (public)
|
||
;; GET /<slug>/ rendered post (public) -> HTML / 404
|
||
;; GET /posts SX list (public) -> {:ok true :data ({:slug …} …)}
|
||
;; GET /new HTML create form (public chrome)
|
||
;; POST /new form ingest from the editor (guarded)
|
||
;; POST /<slug>/edit form ingest, edit an existing post (guarded)
|
||
;; Reads anonymous; writes behind the auth+ACL pipeline ("edit" on "blog"). The
|
||
;; JSON CRUD /posts (POST/PUT/DELETE) was deleted in the SX-native pivot — the wire
|
||
;; is SX/SXTP (host/ok emits text/sx), writes go through the form ingest.
|
||
;; Depends on spec/render + web/adapter-html (render-to-html), lib/persist/*
|
||
;; (durable KV), lib/dream/* (+ form), lib/host/{handler,middleware}.sx.
|
||
|
||
;; ── store (durable persist KV, injectable) ──────────────────────────
|
||
(define host/blog-store (persist/open))
|
||
(define host/blog-use-store! (fn (b) (set! host/blog-store b)))
|
||
(define host/blog--key (fn (slug) (str "blog:" slug)))
|
||
|
||
;; ── content-addressing: a universal CID over the canonical form ─────
|
||
;; Every object (content/type/relation/constraint post) carries a stable :cid =
|
||
;; hash of its CONTENT. The runtime has no hash primitive, so the canon serializer
|
||
;; and a tail-recursive double-hash are built here. Canon SORTS keys, so the CID is
|
||
;; identical across processes regardless of dict insertion / hash-seed order. The
|
||
;; :slug (a mutable name) and any prior :cid are excluded — the CID hashes content
|
||
;; only. git-shaped: slug = mutable name -> CID = immutable content identity.
|
||
(define host/blog--canon
|
||
(fn (v)
|
||
(let ((t (type-of v)))
|
||
(cond
|
||
((= t "dict")
|
||
(str "{" (join "|"
|
||
(map (fn (k) (str k "=" (host/blog--canon (get v k))))
|
||
(filter (fn (k) (and (not (= k "slug")) (not (= k "cid"))))
|
||
(sort (keys v))))) "}"))
|
||
((= t "list") (str "[" (join "|" (map host/blog--canon v)) "]"))
|
||
((= t "nil") "~")
|
||
(else (str v))))))
|
||
(define host/blog--hash-go
|
||
(fn (s i n h1 h2)
|
||
(if (>= i n)
|
||
(str h1 "-" h2)
|
||
(let ((c (char-code (substr s i 1))))
|
||
(host/blog--hash-go s (+ i 1) n
|
||
(mod (+ (* h1 131) c) 1000000007)
|
||
(mod (+ (* h2 137) c) 998244353))))))
|
||
(define host/blog--cid-of
|
||
(fn (rec) (let ((s (host/blog--canon rec))) (str "z" (host/blog--hash-go s 0 (len s) 7 11)))))
|
||
;; the single choke point for every record write: stamps the content CID, then puts.
|
||
(define host/blog--write!
|
||
(fn (slug rec)
|
||
(persist/backend-kv-put host/blog-store (host/blog--key slug)
|
||
(merge rec {:cid (host/blog--cid-of rec)}))))
|
||
|
||
;; slug from a title: lowercase, words joined by '-'. (Punctuation kept simple.)
|
||
(define host/blog-slugify
|
||
(fn (title)
|
||
(join "-" (filter (fn (w) (not (= w ""))) (split (lower title) " ")))))
|
||
|
||
;; ── records ─────────────────────────────────────────────────────────
|
||
(define host/blog-get
|
||
(fn (slug) (persist/backend-kv-get host/blog-store (host/blog--key slug))))
|
||
(define host/blog-exists?
|
||
(fn (slug) (persist/backend-kv-has? host/blog-store (host/blog--key slug))))
|
||
;; A write preserves any extra slots already on the record (:rel for relation-posts,
|
||
;; :schema for refinement types) — merging over the previous record — so editing a
|
||
;; post's title/content/status doesn't nuke the metadata that lives alongside it.
|
||
(define host/blog-put!
|
||
(fn (slug title sx-content status)
|
||
(let ((prev (host/blog-get slug)))
|
||
(host/blog--write! slug
|
||
(merge (if prev prev {})
|
||
{:slug slug :title title :sx-content sx-content :status status})))))
|
||
(define host/blog-delete!
|
||
(fn (slug) (persist/backend-kv-delete host/blog-store (host/blog--key slug))))
|
||
(define host/blog-seed!
|
||
(fn (slug title sx-content status)
|
||
(when (not (host/blog-exists? slug)) (host/blog-put! slug title sx-content status))))
|
||
|
||
;; all blog slugs (kv keys are "blog:<slug>")
|
||
(define host/blog-slugs
|
||
(fn ()
|
||
(reduce
|
||
(fn (acc k)
|
||
(if (starts-with? k "blog:") (append acc (list (substr k 5))) acc))
|
||
(list)
|
||
(persist/backend-kv-keys host/blog-store))))
|
||
(define host/blog-list
|
||
(fn ()
|
||
(map
|
||
(fn (slug)
|
||
(let ((r (host/blog-get slug)))
|
||
{:slug slug :title (get r :title) :status (get r :status)}))
|
||
(host/blog-slugs))))
|
||
|
||
;; a post's content CID — its global, location-independent identity (nil if unknown).
|
||
(define host/blog-cid (fn (slug) (get (host/blog-get slug) :cid)))
|
||
;; reverse lookup: a slug whose record has this CID (nil if none). Scan; not for renders.
|
||
(define host/blog-by-cid
|
||
(fn (cid)
|
||
(reduce
|
||
(fn (acc slug) (if acc acc (if (= (host/blog-cid slug) cid) slug acc)))
|
||
nil (host/blog-slugs))))
|
||
|
||
;; ── render ──────────────────────────────────────────────────────────
|
||
;; A post's sx_content is SX element markup -> HTML via render-page (which supplies
|
||
;; the server env so components resolve + keyword attrs are kept).
|
||
;;
|
||
;; Rendered PER BLOCK and guarded: the editor wraps content in a (<> ...) fragment
|
||
;; of blocks, some of which the host can't render (the legacy editor emits bare
|
||
;; ~kg-md cards while the components are ~kg_cards/kg-md — drift we don't paper over
|
||
;; with aliases). Rendering each block under its own guard means the real prose
|
||
;; (p/h1/ul/...) shows and only the unsupported block degrades to a placeholder —
|
||
;; and a bad block never crashes the handler (-> 502).
|
||
(define host/blog--render-node
|
||
(fn (node)
|
||
(guard (e (true "<div class=\"blk-unsupported\"><em>(unsupported block)</em></div>"))
|
||
(render-page node))))
|
||
(define host/blog-render
|
||
(fn (record)
|
||
(let ((sx (get record :sx-content)))
|
||
(if (and sx (not (= sx "")))
|
||
(let ((tree (parse-safe sx)))
|
||
(cond
|
||
((nil? tree) "<p><em>(unparseable content)</em></p>")
|
||
((and (= (type-of tree) "list") (> (len tree) 0)
|
||
(= (str (first tree)) "<>"))
|
||
(join "" (map host/blog--render-node (rest tree))))
|
||
(else (host/blog--render-node tree))))
|
||
(str "<p>(empty post)</p>")))))
|
||
;; ── related posts (blog × relations) ────────────────────────────────
|
||
;; Every link between posts is a typed edge in the relations graph (lib/relations):
|
||
;; node = "blog:<slug>", kind = a relation kind. "related" is symmetric; directed
|
||
;; kinds (is-a, tagged) carry meaning by direction. The registry below is the one
|
||
;; place that knows each kind's direction, label, and candidate set — relate, the
|
||
;; picker, and rendering all read from it (see plans/typed-posts-and-relations.md).
|
||
;; "Typing is just relating to a type": classification is an is-a/tagged edge to a
|
||
;; type-post, and types ARE posts (same blog:<slug> namespace).
|
||
(define host/blog--node (fn (slug) (string->symbol (str "blog:" slug))))
|
||
|
||
;; Relations are POSTS (plans/relations-as-posts.md). Each relation-post is-a
|
||
;; `relation` and owns its metadata in a :rel slot {:symmetric :label
|
||
;; :inverse-label}. To keep RENDER paths perform-free — a durable read inside the
|
||
;; http-listen render VM raises VmSuspended — the relation specs are loaded into an
|
||
;; in-memory cache at boot, exactly like edges (host/blog-load-edges!). kind-spec /
|
||
;; rel-kinds / kind-symmetric? then read the cache (pure); the relation-posts stay
|
||
;; the durable source of truth. host/blog-load-rel-kinds! re-reads them.
|
||
(define host/blog--rel-cache (dict))
|
||
;; cache one relation-post's :rel metadata (+ :kind), keyed by slug.
|
||
(define host/blog--cache-rel!
|
||
(fn (kind)
|
||
(let ((m (get (host/blog-get kind) :rel)))
|
||
(when m (dict-set! host/blog--rel-cache kind (merge {:kind kind} m))))))
|
||
;; host/blog-rel-kinds is a VALUE (the list of relation specs), populated at boot by
|
||
;; load-rel-kinds! — like slice 1's static registry, which mapped fine on the live
|
||
;; serving JIT. (Computing it as a function that map/for-each-es a function-produced
|
||
;; list silently lost 3 of 4 relations on the live JIT — see plans/relations-as-posts.md
|
||
;; / plans/jit-bytecode-correctness.md. Both the cache loads and the list build are
|
||
;; therefore UNROLLED — no iteration over the relation list.) Metadata still lives on
|
||
;; the relation-posts; add a relation = a seed-rel! + a line in each unrolled list.
|
||
(define host/blog-rel-kinds (list))
|
||
;; UNROLLED, and it must STAY unrolled: load-rel-kinds! runs at BOOT, where it is
|
||
;; JIT-compiled but the http-listen IO resolver is NOT yet installed (that happens when
|
||
;; serving starts). The serving-JIT HO-callback-perform fix (81177d0e) only engages WITH
|
||
;; the resolver, so a dynamic loader (map/for-each/reduce over instances-of "relation"
|
||
;; with a durable read per item) silently returns [] at boot — verified 2026-06-30:
|
||
;; dynamic loader -> /meta Relations(0). So the cache loads + the list are UNROLLED (no
|
||
;; HO over a function-produced list). A new relation is a seed-rel! + a line here; or
|
||
;; appended at RUNTIME (where the resolver IS installed) — see host/blog-meta-new-relation.
|
||
(define host/blog-load-rel-kinds!
|
||
(fn ()
|
||
(begin
|
||
(host/blog--cache-rel! "related")
|
||
(host/blog--cache-rel! "is-a")
|
||
(host/blog--cache-rel! "subtype-of")
|
||
(host/blog--cache-rel! "tagged")
|
||
(set! host/blog-rel-kinds
|
||
(list (get host/blog--rel-cache "related") (get host/blog--rel-cache "is-a")
|
||
(get host/blog--rel-cache "subtype-of") (get host/blog--rel-cache "tagged"))))))
|
||
;; spec = the cached :rel metadata + :kind; nil for a non-relation (relate validates).
|
||
(define host/blog--kind-spec (fn (kind) (get host/blog--rel-cache kind)))
|
||
(define host/blog--kind-symmetric?
|
||
(fn (kind) (let ((s (host/blog--kind-spec kind))) (and s (get s :symmetric)))))
|
||
|
||
;; ── edges (parameterised by kind, DURABLE, KV-only) ─────────────────
|
||
;; The blog graph is the durable KV: every edge is a row "edge:<src>|<kind>|<dst>" in the
|
||
;; blog store, and ALL reads walk those rows directly (host/blog--all-edges / -out / -in /
|
||
;; --subtype-closure). It is NOT mirrored into lib/relations: relations/relate re-saturates
|
||
;; the whole Datalog ruleset on EVERY write (super-linear in the fact base — profiled at
|
||
;; 1→3→6s per edge as the graph grows), and since typing now reads direct KV edges, nothing
|
||
;; in the blog domain reads lib/relations, so the mirror was pure (very expensive) dead
|
||
;; weight. KV-only edge writes are ~20ms flat. '|' is a safe delimiter — slugs are
|
||
;; [a-z0-9-], kinds are registry names. (host/relations.sx, the relations DOMAIN service, is
|
||
;; separate: its own "type:id" nodes in lib/relations, untouched by this.)
|
||
(define host/blog--edge-key (fn (src kind dst) (str "edge:" src "|" kind "|" dst)))
|
||
|
||
(define host/blog--add-edge!
|
||
(fn (src dst kind)
|
||
(persist/backend-kv-put host/blog-store (host/blog--edge-key src kind dst) 1)))
|
||
(define host/blog--del-edge!
|
||
(fn (src dst kind)
|
||
(persist/backend-kv-delete host/blog-store (host/blog--edge-key src kind dst))))
|
||
|
||
;; A symmetric kind writes both directions, so children alone read it from either
|
||
;; side; a directed kind writes one edge (the inverse is host/blog-in).
|
||
(define host/blog-relate!
|
||
(fn (a b kind)
|
||
(begin
|
||
(host/blog--add-edge! a b kind)
|
||
(when (host/blog--kind-symmetric? kind) (host/blog--add-edge! b a kind)))))
|
||
(define host/blog-unrelate!
|
||
(fn (a b kind)
|
||
(begin
|
||
(host/blog--del-edge! a b kind)
|
||
(when (host/blog--kind-symmetric? kind) (host/blog--del-edge! b a kind)))))
|
||
|
||
;; No-op: the durable KV edge rows ARE the graph and every read walks them directly, so
|
||
;; there is no in-memory lib/relations graph to rebuild on boot. (Kept as a callable seam —
|
||
;; serve.sh calls it after pointing the store at the durable backend — in case a future
|
||
;; index/cache needs warming.) Previously this replayed every edge into lib/relations via
|
||
;; relations/relate, which re-saturated the Datalog ruleset per edge: O(edges²) boot cost.
|
||
(define host/blog-load-edges! (fn () nil))
|
||
|
||
;; nodes -> existing blog slugs: strip "blog:", drop non-blog and deleted targets.
|
||
;; Existence is one kv-keys read (host/blog-slugs), NOT a perform per candidate —
|
||
;; keeping IO out of the inner filter (and out of the page-render quasiquote).
|
||
(define host/blog--edge-slugs
|
||
(fn (nodes)
|
||
(let ((existing (host/blog-slugs)))
|
||
(filter (fn (s) (contains? existing s))
|
||
(map (fn (n) (substr (symbol->string n) 5))
|
||
(filter (fn (n) (starts-with? (symbol->string n) "blog:")) nodes))))))
|
||
|
||
;; DIRECT edges come from the durable edge store, NOT lib/relations: each relations
|
||
;; query re-runs the (CEK-interpreted) ruleset — ~seconds even on a tiny graph —
|
||
;; whereas the edge:<src>|<kind>|<dst> KV rows are a cheap string scan. lib/relations
|
||
;; is reserved for TRANSITIVE queries (descendants/ancestors). The two are always
|
||
;; in sync: host/blog-relate! writes both, and a plain blog edge has no derived
|
||
;; effective edges, so KV == relations/children for direct lookups.
|
||
(define host/blog--parse-edge-key
|
||
(fn (k)
|
||
(if (starts-with? k "edge:")
|
||
(let ((body (substr k 5)))
|
||
(let ((p1 (index-of body "|")))
|
||
(if (< p1 0) nil
|
||
(let ((rest (substr body (+ p1 1))))
|
||
(let ((p2 (index-of rest "|")))
|
||
(if (< p2 0) nil
|
||
{:src (substr body 0 p1)
|
||
:kind (substr rest 0 p2)
|
||
:dst (substr rest (+ p2 1))}))))))
|
||
nil)))
|
||
(define host/blog--all-edges
|
||
(fn ()
|
||
(filter (fn (e) (not (nil? e)))
|
||
(map host/blog--parse-edge-key (persist/backend-kv-keys host/blog-store)))))
|
||
|
||
;; outgoing targets / incoming sources of `slug` under `kind`, as existing slugs.
|
||
(define host/blog-out
|
||
(fn (slug kind)
|
||
(let ((existing (host/blog-slugs)))
|
||
(filter (fn (s) (contains? existing s))
|
||
(reduce (fn (acc e)
|
||
(if (and (= (get e :src) slug) (= (get e :kind) kind))
|
||
(concat acc (list (get e :dst))) acc))
|
||
(list) (host/blog--all-edges))))))
|
||
(define host/blog-in
|
||
(fn (slug kind)
|
||
(let ((existing (host/blog-slugs)))
|
||
(filter (fn (s) (contains? existing s))
|
||
(reduce (fn (acc e)
|
||
(if (and (= (get e :dst) slug) (= (get e :kind) kind))
|
||
(concat acc (list (get e :src))) acc))
|
||
(list) (host/blog--all-edges))))))
|
||
|
||
;; back-compat: "related posts" is just the symmetric "related" kind.
|
||
(define host/blog-related (fn (slug) (host/blog-out slug "related")))
|
||
|
||
;; ── typing: is-a + subtype-of with subsumption ──────────────────────
|
||
;; Typing is just relating to a type, and types ARE posts. A post DECLARES its
|
||
;; types with is-a edges; types form a hierarchy with subtype-of edges. is-a
|
||
;; (instance-of) is NOT transitive on its own, but subsumption is: an instance of
|
||
;; a subtype is an instance of the supertype. So a post's full type set is its
|
||
;; declared types PLUS every subtype-of-ancestor of each.
|
||
;;
|
||
;; PERF: the subtype closure is computed HOST-SIDE by a BFS over the DIRECT subtype-of
|
||
;; edges (the edge:* KV rows), NOT via lib/relations descendants/ancestors. Each lib/
|
||
;; relations query re-saturates the whole (CEK-interpreted) Datalog ruleset — ~seconds
|
||
;; even on a tiny graph — and typing is on the hottest path (is-a?/types-of/instances-of
|
||
;; run per post, per picker, per render), so re-saturation made the blog suite + live
|
||
;; pages CPU-bound. The closure is the SAME transitive set; one edge-store snapshot drives
|
||
;; the whole BFS (O(edges), cycle-safe). KV == relations for direct edges (host/blog-relate!
|
||
;; writes both), so this is exact, not an approximation.
|
||
(define host/blog--uniq
|
||
(fn (xs) (reduce (fn (acc x) (if (contains? acc x) acc (concat acc (list x)))) (list) xs)))
|
||
|
||
;; transitive closure over DIRECT subtype-of edges from `roots` (roots included), with NO
|
||
;; Datalog. dir :out = follow src->dst (the supertypes of roots); dir :in = follow dst->src
|
||
;; (the subtypes of roots). One host/blog--all-edges snapshot; BFS with a `seen` guard.
|
||
(define host/blog--subtype-closure
|
||
(fn (roots dir)
|
||
(let ((edges (host/blog--all-edges)) (existing (host/blog-slugs)))
|
||
(let ((step
|
||
(fn (n)
|
||
(filter (fn (s) (contains? existing s))
|
||
(reduce (fn (acc e)
|
||
(if (and (= (get e :kind) "subtype-of")
|
||
(= (get e (if (= dir :out) :src :dst)) n))
|
||
(concat acc (list (get e (if (= dir :out) :dst :src)))) acc))
|
||
(list) edges)))))
|
||
(let loop ((frontier roots) (seen (list)))
|
||
(if (empty? frontier)
|
||
seen
|
||
(let ((n (first frontier)))
|
||
(if (contains? seen n)
|
||
(loop (rest frontier) seen)
|
||
(loop (concat (rest frontier) (step n)) (concat seen (list n)))))))))))
|
||
|
||
(define host/blog-types-of
|
||
(fn (slug)
|
||
(host/blog--uniq (host/blog--subtype-closure (host/blog-out slug "is-a") :out))))
|
||
|
||
;; is this post (transitively) of the given type-slug?
|
||
(define host/blog-is-a? (fn (slug type) (contains? (host/blog-types-of slug) type)))
|
||
|
||
;; all posts that are (transitively) instances of `type`: instances of the type
|
||
;; itself plus instances of any of its subtypes. O(edges) over one snapshot — the
|
||
;; efficient way to enumerate a type's members (e.g. "all tags") for the picker.
|
||
(define host/blog-instances-of
|
||
(fn (type)
|
||
(host/blog--uniq
|
||
(reduce (fn (acc t) (concat acc (host/blog-in t "is-a")))
|
||
(list) (host/blog--subtype-closure (list type) :in)))))
|
||
|
||
;; All type-posts: the subtype-of hierarchy rooted at "type" (type + its transitive
|
||
;; subtypes). This is "the types you've DEFINED" — distinct from host/blog-instances-of
|
||
;; "type" (which is the is-a INSTANCES of the type, i.e. typed content, not the type
|
||
;; definitions; the definitions are linked by subtype-of). Used by the metamodel editor.
|
||
(define host/blog-type-defs
|
||
(fn () (host/blog--uniq (host/blog--subtype-closure (list "type") :in))))
|
||
|
||
;; ── Slice 4: type ALGEBRA — intersection (∧) and union (∨) types ─────
|
||
;; An algebraic type is a post with operand edges: a `conj` edge per intersection
|
||
;; member, a `disj` edge per union member. Its EXTENT is its operands' extents combined
|
||
;; by set intersection / union, recursively — so types compose into an algebra in the
|
||
;; same graph (meta-circular: an algebraic type is just another post). Binary today
|
||
;; (nth 0/1, no fold over operands — robust on the serving JIT); n-ary is a follow-up.
|
||
;; is-a-expr? generalises is-a? to type expressions.
|
||
(define host/blog--set-intersect
|
||
(fn (xs ys) (filter (fn (x) (contains? ys x)) xs)))
|
||
;; operand edges live in the KV ONLY (read back via host/blog-out), NOT in lib/relations:
|
||
;; conj/disj are structural, and feeding extra kinds into the Datalog graph blows up its
|
||
;; per-query re-saturation. host/blog-load-edges! skips them on replay for the same reason.
|
||
(define host/blog--add-edge-kv!
|
||
(fn (src dst kind)
|
||
(persist/backend-kv-put host/blog-store (host/blog--edge-key src kind dst) 1)))
|
||
(define host/blog-make-and!
|
||
(fn (t a b)
|
||
(begin
|
||
(host/blog-seed! t t
|
||
(str "(article (h1 \"" t "\") (p \"An intersection type (" a " ∧ " b ") — its instances are exactly those that are instances of BOTH.\"))")
|
||
"published")
|
||
(host/blog--add-edge-kv! t a "conj")
|
||
(host/blog--add-edge-kv! t b "conj"))))
|
||
(define host/blog-make-or!
|
||
(fn (t a b)
|
||
(begin
|
||
(host/blog-seed! t t
|
||
(str "(article (h1 \"" t "\") (p \"A union type (" a " ∨ " b ") — its instances are those that are instances of EITHER.\"))")
|
||
"published")
|
||
(host/blog--add-edge-kv! t a "disj")
|
||
(host/blog--add-edge-kv! t b "disj"))))
|
||
;; the EXTENT of a type expression: operands' extents combined by set ops (recursive).
|
||
;; A plain type (no operands) falls through to its instances.
|
||
(define host/blog-instances-of-expr
|
||
(fn (t)
|
||
(let ((conj (host/blog-out t "conj"))
|
||
(disj (host/blog-out t "disj")))
|
||
(cond
|
||
((>= (len conj) 2)
|
||
(host/blog--set-intersect (host/blog-instances-of-expr (nth conj 0))
|
||
(host/blog-instances-of-expr (nth conj 1))))
|
||
((>= (len disj) 2)
|
||
(host/blog--uniq (concat (host/blog-instances-of-expr (nth disj 0))
|
||
(host/blog-instances-of-expr (nth disj 1)))))
|
||
(else (host/blog-instances-of t))))))
|
||
;; is `slug` a member of the type expression `t`? Generalises is-a? to the algebra.
|
||
(define host/blog-is-a-expr?
|
||
(fn (slug t) (contains? (host/blog-instances-of-expr t) slug)))
|
||
|
||
;; ── tags (a tag is a post that is-a tag) ────────────────────────────
|
||
(define host/blog-is-tag? (fn (slug) (host/blog-is-a? slug "tag")))
|
||
(define host/blog-tags (fn (slug) (host/blog-out slug "tagged"))) ;; a post's tags
|
||
(define host/blog-tagged-with (fn (tag) (host/blog-in tag "tagged"))) ;; posts with a tag
|
||
|
||
;; ── gradual validation: refinement types (schemas ON the type-post) ──
|
||
;; A type-post may carry a SCHEMA in a :schema slot: a list of rules
|
||
;; {:block <tag> :msg <why>}, each requiring the content to contain (anywhere) an
|
||
;; element of that tag — i.e. a refinement type {x : T | x has these blocks}. A post
|
||
;; is checked against the schema of every type it is-a; a type with no schema imposes
|
||
;; nothing (gradual). Schemas are declarative data (not opaque predicates), so they
|
||
;; yield a specific, human error AND live on the type-post (Slice 5) — make a new
|
||
;; refinement type by giving its post a :schema (host/blog--set-schema!).
|
||
;; schema-of reads the type-post; only the SAVE path calls it (a write request, where
|
||
;; a durable read is fine — never in a render, which would VmSuspend).
|
||
(define host/blog-schema-of (fn (type-slug) (get (host/blog-get type-slug) :schema)))
|
||
;; attach/replace a type-post's :schema (idempotent; preserves the rest of the record).
|
||
;; Used at boot to install schemas on type-posts — incl. migrating ones seeded before
|
||
;; schemas lived on the post (a single read+write, not a loop, so boot-JIT-safe).
|
||
(define host/blog--set-schema!
|
||
(fn (slug schema)
|
||
(let ((r (host/blog-get slug)))
|
||
(when r
|
||
(host/blog--write! slug (merge r {:schema schema}))))))
|
||
|
||
;; ── Slice 8: typed scalar FIELDS on a type (the keystone for the UI) ─
|
||
;; A type declares :fields — a list of {:name :type [:widget] [:required]} specs. A
|
||
;; field holds a typed VALUE on an instance (vs a relation, which is an edge to a post).
|
||
;; value-type names map to a default input widget; fields drive BOTH the generic edit
|
||
;; form (one input per field) AND the render template. Direct fields for now; inheritance
|
||
;; through subtype-of is a follow-up. See plans/relations-as-posts.md ("Types define the UI").
|
||
(define host/blog-value-types
|
||
{"String" {:widget "text"}
|
||
"Text" {:widget "textarea"}
|
||
"URL" {:widget "url"}
|
||
"Int" {:widget "number"}
|
||
"Date" {:widget "date"}
|
||
"Bool" {:widget "checkbox"}})
|
||
;; the input widget for a field: its explicit :widget, else its value-type's default,
|
||
;; else "text" (an unknown value-type degrades to a plain text input).
|
||
(define host/blog--widget-for
|
||
(fn (field)
|
||
(or (get field :widget)
|
||
(let ((vt (get host/blog-value-types (get field :type))))
|
||
(if vt (get vt :widget) "text")))))
|
||
;; a type-post's declared fields (empty list if none).
|
||
(define host/blog-fields-of
|
||
(fn (type-slug) (or (get (host/blog-get type-slug) :fields) (list))))
|
||
;; attach/replace a type-post's :fields (idempotent; preserves the rest of the record).
|
||
(define host/blog--set-fields!
|
||
(fn (slug fields)
|
||
(let ((r (host/blog-get slug)))
|
||
(when r
|
||
(host/blog--write! slug (merge r {:fields fields}))))))
|
||
;; "name:Type, name:Type" — a one-line summary of a field list (for /meta). "—" if none.
|
||
(define host/blog--fields-summary
|
||
(fn (fields)
|
||
(if (and fields (> (len fields) 0))
|
||
(join ", " (map (fn (f) (str (get f :name) ":" (get f :type))) fields))
|
||
"—")))
|
||
|
||
;; ── Slice 8b: field VALUES on an instance + the generic, type-driven form ──
|
||
;; An instance carries :field-values = {field-name -> value}. The fields applicable to
|
||
;; a post are the union of the fields declared by every type it is-a (deduped by name) —
|
||
;; so the SAME form is generated from the type definitions, no per-type code. This IS
|
||
;; "the editor maps onto the types": host/blog--field-inputs turns a type's fields into
|
||
;; the edit inputs; host/blog-edit-submit reads them back. Display-via-template is next.
|
||
(define host/blog-field-values-of
|
||
(fn (slug) (or (get (host/blog-get slug) :field-values) {})))
|
||
(define host/blog--set-field-values!
|
||
(fn (slug vals)
|
||
(let ((r (host/blog-get slug)))
|
||
(when r (host/blog--write! slug (merge r {:field-values vals}))))))
|
||
;; the fields applicable to a post = union over its (transitive) types' fields, deduped
|
||
;; by name. One durable graph read (types-of) up front — call in a handler let, not a render.
|
||
(define host/blog--fields-for-post
|
||
(fn (slug)
|
||
(reduce
|
||
(fn (acc t)
|
||
(reduce
|
||
(fn (a f)
|
||
(if (contains? (map (fn (g) (get g :name)) a) (get f :name))
|
||
a
|
||
(concat a (list f))))
|
||
acc
|
||
(host/blog-fields-of t)))
|
||
(list)
|
||
(host/blog-types-of 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
|
||
(fn (fields values)
|
||
(map (fn (f)
|
||
(let ((nm (get f :name)) (w (host/blog--widget-for f)))
|
||
(let ((val (or (get values nm) "")))
|
||
(quasiquote
|
||
(p (label :style "display:block;font-size:0.85em;opacity:0.7"
|
||
(unquote (str nm " (" (get f :type) ")")))
|
||
(unquote
|
||
(if (= w "textarea")
|
||
(quasiquote (textarea :name (unquote (str "field-" nm)) :rows "3"
|
||
:style "width:100%" (unquote val)))
|
||
(quasiquote (input :type (unquote w) :name (unquote (str "field-" nm))
|
||
:value (unquote val) :style "width:100%")))))))))
|
||
fields)))
|
||
|
||
;; ── Slice 8c: render TEMPLATE per type (fields drive the page, not just the form) ──
|
||
;; A type may declare a :template — a parameterised SX tree (stored as source) where
|
||
;; (field "name") placeholders resolve to the instance's field-values at render. So ONE
|
||
;; field definition drives BOTH the edit form (above) AND the rendered page. The template
|
||
;; is DATA (editable, meta-circular); a type with no template renders nothing extra. See
|
||
;; plans/relations-as-posts.md ("Types define the UI").
|
||
(define host/blog-template-of
|
||
(fn (type-slug) (get (host/blog-get type-slug) :template)))
|
||
(define host/blog--set-template!
|
||
(fn (slug template)
|
||
(let ((r (host/blog-get slug)))
|
||
(when r (host/blog--write! slug (merge r {:template template}))))))
|
||
|
||
;; ── composition objects (plans/composition-objects.md) ──────────────
|
||
;; 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}))))))
|
||
;; 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
|
||
;; transitive instances, via host/blog-instances-of); the dispatch leaves room for more.
|
||
;; This is the DATA-DRIVEN each source — the object's `each` is the query, the render is
|
||
;; the run over whatever the graph currently holds.
|
||
(define host/blog--comp-query
|
||
(fn (qargs ctx)
|
||
(let ((rel (str (first qargs))) (type (str (first (rest qargs)))))
|
||
(cond
|
||
((= rel "is-a") (map host/blog-get (host/blog-instances-of type)))
|
||
(else (list))))))
|
||
;; live context values, read PURELY from the request headers (no perform) so the SAME
|
||
;; object renders responsively/personalised per request — `(alt (when (eq "device" "mobile")
|
||
;; …) …)` is a responsive layout, `(when (eq "locale" "fr") …)` a localised variant.
|
||
(define host/blog--device-of
|
||
(fn (req)
|
||
(let ((ua (str (or (dream-header req "user-agent") ""))))
|
||
(if (or (contains? ua "Mobile") (contains? ua "Android") (contains? ua "iPhone"))
|
||
"mobile" "desktop"))))
|
||
(define host/blog--locale-of
|
||
(fn (req)
|
||
(let ((al (str (or (dream-header req "accept-language") ""))))
|
||
(if (>= (len al) 2) (substr al 0 2) "en"))))
|
||
;; ── 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 (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 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 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
|
||
"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,
|
||
;; content-addressed card OBJECTS. host/blog--decompose! splits an (article …) tree into
|
||
;; one card object per top-level block (is-a the mapped card-type + its field-values),
|
||
;; links each by an ordered `contains` edge, and sets the post's :body to (seq (ref c0)
|
||
;; (ref c1) …). The render-fold then transcludes each card via its type template. This is
|
||
;; the cards-as-objects decision made real for the importer (plans/composition-objects.md).
|
||
|
||
;; the text content of a block element: its string children joined, skipping :attr pairs,
|
||
;; recursing into nested elements. Carries prose into a card field (good enough for import).
|
||
(define host/blog--args-text
|
||
(fn (args)
|
||
(cond
|
||
((empty? args) "")
|
||
((= (type-of (first args)) "keyword") (host/blog--args-text (rest (rest args))))
|
||
(else (str (host/blog--elem-text (first args)) (host/blog--args-text (rest args)))))))
|
||
(define host/blog--elem-text
|
||
(fn (node)
|
||
(cond
|
||
((= (type-of node) "string") node)
|
||
((and (= (type-of node) "list") (> (len node) 0)) (host/blog--args-text (rest node)))
|
||
(else ""))))
|
||
;; the value of an :attr on an element (e.g. img :src), "" if absent.
|
||
(define host/blog--elem-attr
|
||
(fn (node key)
|
||
(let loop ((args (if (= (type-of node) "list") (rest node) (list))))
|
||
(cond
|
||
((empty? args) "")
|
||
((and (= (type-of (first args)) "keyword") (= (str (first args)) key))
|
||
(if (empty? (rest args)) "" (str (first (rest args)))))
|
||
((= (type-of (first args)) "keyword") (loop (rest (rest args))))
|
||
(else (loop (rest args)))))))
|
||
;; map an element tag to a card-type (the block vocabulary). Unknown tags -> text card.
|
||
(define host/blog--tag->card-type
|
||
(fn (tag)
|
||
(cond
|
||
((or (= tag "h1") (= tag "h2") (= tag "h3") (= tag "h4")) "card-heading")
|
||
((= tag "img") "card-image")
|
||
((= tag "blockquote") "card-quote")
|
||
((or (= tag "pre") (= tag "code")) "card-code")
|
||
(else "card-text"))))
|
||
;; the field-values for a card-type extracted from the original block element.
|
||
(define host/blog--block-fields
|
||
(fn (orig-tag ctype block)
|
||
(cond
|
||
((= ctype "card-heading") {"level" (if (>= (len orig-tag) 2) (substr orig-tag 1) "2")
|
||
"text" (host/blog--elem-text block)})
|
||
((= ctype "card-image") {"src" (host/blog--elem-attr block "src")
|
||
"alt" (host/blog--elem-attr block "alt") "caption" ""})
|
||
((= ctype "card-code") {"code" (host/blog--elem-text block) "language" ""})
|
||
((= ctype "card-quote") {"text" (host/blog--elem-text block) "cite" ""})
|
||
(else {"text" (host/blog--elem-text block)}))))
|
||
;; decompose a post's content-tree into card objects + a contains body. Idempotent
|
||
;; (seed!/relate!/set-body! are sets; re-import overwrites the same __bN card objects).
|
||
(define host/blog--decompose!
|
||
(fn (post-slug content-tree)
|
||
(let ((blocks (if (and (= (type-of content-tree) "list") (> (len content-tree) 0))
|
||
(filter (fn (b) (= (type-of b) "list")) (rest content-tree))
|
||
(list))))
|
||
(when (not (empty? blocks))
|
||
(let ((refs
|
||
(map-indexed
|
||
(fn (i block)
|
||
(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
|
||
;; renders when transcluded (typed-block ignores status).
|
||
(host/blog-seed! cslug ctype "(article (h1 \"card\"))" "block")
|
||
(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) (host/blog--slug->ref post-slug cslug))))))
|
||
blocks)))
|
||
(host/blog--set-body! post-slug (cons (quote seq) refs)))))))
|
||
|
||
;; ── block-editor model: edit a post's :body (its composition of card refs) ───────────
|
||
;; The body is (seq (ref c0) (ref c1) …); these ops add / remove / reorder its blocks and
|
||
;; keep the ordered `contains` edges in step. The :body seq is the ORDER authority, the
|
||
;; contains edges the membership set. Per-block FIELD editing is free: a card is an object,
|
||
;; so its fields are edited via the card's own /<cslug>/edit page. (composition step 6.)
|
||
(define host/blog-body-refs
|
||
(fn (slug)
|
||
(let ((body (host/blog-body-of slug)))
|
||
(if (and (= (type-of body) "list") (= (str (first body)) "seq"))
|
||
(reduce (fn (acc n)
|
||
(if (and (= (type-of n) "list") (= (str (first n)) "ref"))
|
||
(concat acc (list (str (first (rest n))))) acc))
|
||
(list) (rest body))
|
||
(list)))))
|
||
(define host/blog--set-body-refs!
|
||
(fn (slug refs)
|
||
(host/blog--set-body! slug (cons (quote seq) (map (fn (r) (list (quote ref) r)) refs)))))
|
||
(define host/blog--next-block-idx
|
||
(fn (slug)
|
||
(let loop ((i 0))
|
||
(if (host/blog-exists? (str slug "__b" i)) (loop (+ i 1)) i))))
|
||
;; 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
|
||
(host/blog--set-body-refs! slug
|
||
(filter (fn (r) (not (= r cslug))) (host/blog-body-refs slug)))
|
||
(host/blog-unrelate! slug cslug "contains"))))
|
||
(define host/blog--nth-ref
|
||
(fn (xs k)
|
||
(let loop ((i 0) (ys xs))
|
||
(cond ((empty? ys) nil) ((= i k) (first ys)) (else (loop (+ i 1) (rest ys)))))))
|
||
(define host/blog--ref-index
|
||
(fn (xs x)
|
||
(let loop ((i 0) (ys xs))
|
||
(cond ((empty? ys) -1) ((= (first ys) x) i) (else (loop (+ i 1) (rest ys)))))))
|
||
(define host/blog-block-move!
|
||
(fn (slug cslug dir)
|
||
(let ((refs (host/blog-body-refs slug)))
|
||
(let ((i (host/blog--ref-index refs cslug)))
|
||
(let ((j (if (= dir "up") (- i 1) (+ i 1))))
|
||
(when (and (>= i 0) (>= j 0) (< j (len refs)))
|
||
(host/blog--set-body-refs! slug
|
||
(map-indexed (fn (k r) (cond ((= k i) (host/blog--nth-ref refs j))
|
||
((= k j) (host/blog--nth-ref refs i))
|
||
(else r))) refs))))))))
|
||
;; the card-type of a card object (its declared is-a target); "card" if none.
|
||
(define host/blog--primary-card-type
|
||
(fn (cslug) (let ((ts (host/blog-out cslug "is-a"))) (if (empty? ts) "card" (first ts)))))
|
||
;; a short text preview of a card's content from its field-values.
|
||
(define host/blog--block-preview
|
||
(fn (vals)
|
||
(let ((t (str (or (get vals "text") (get vals "src") (get vals "code") (get vals "url") ""))))
|
||
(if (> (len t) 60) (str (substr t 0 60) "…") t))))
|
||
|
||
;; ── 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")
|
||
((= h "text") "text")
|
||
((or (= h "row") (= h "grid")) "layout")
|
||
((or (= h "field") (= h "val")) "field")
|
||
((= h "seq") "group")
|
||
(else "other")))
|
||
"other")))
|
||
;; a short human display of ANY composition node — for the editor rows. A ref becomes a
|
||
;; ✎ edit-chip; text/field/val show their content; a container shows its item count.
|
||
(define host/blog--node-display
|
||
(fn (slug node)
|
||
(if (= (type-of node) "list")
|
||
(let ((h (str (first node))))
|
||
(cond
|
||
((= h "ref") (host/blog--ref-chip slug (str (first (rest node)))))
|
||
((= h "text") (let ((t (str (first (rest node))))) (if (> (len t) 50) (str (substr t 0 50) "…") t)))
|
||
((or (= h "field") (= h "val")) (str h " " (str (first (rest node)))))
|
||
((or (= h "seq") (= h "row") (= h "grid")) (str h " (" (len (rest node)) ")"))
|
||
(else h)))
|
||
(str node))))
|
||
;; the display of a conditional/repeater BRANCH — its last element (a ref, text, or group).
|
||
(define host/blog--branch-display
|
||
(fn (slug branch)
|
||
(host/blog--node-display slug (host/blog--nth branch (- (len branch) 1)))))
|
||
;; 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!
|
||
(fn ()
|
||
(begin
|
||
;; a demo type + two instances, so the each(query …) below iterates REAL graph data —
|
||
;; the list isn't baked into the body, it's whatever is-a compose-item right now.
|
||
(host/blog-seed! "compose-item" "Compose Item" "(article (h1 \"Compose Item\"))" "published")
|
||
(host/blog-relate! "compose-item" "type" "subtype-of")
|
||
(host/blog-seed! "compose-item-revel" "Revel Show" "(article (h1 \"Revel Show\"))" "published")
|
||
(host/blog-seed! "compose-item-pub" "Pub Night" "(article (h1 \"Pub Night\"))" "published")
|
||
(host/blog-relate! "compose-item-revel" "compose-item" "is-a")
|
||
(host/blog-relate! "compose-item-pub" "compose-item" "is-a")
|
||
(host/blog-seed! "compose-demo" "Composition Demo"
|
||
"(article (h1 \"Composition Demo\") (p \"Rendered via the composition fold.\"))" "published")
|
||
(host/blog--set-body! "compose-demo"
|
||
(quote (seq
|
||
(text "<p>This whole page is <b>one composition object</b>, rendered by the fold — it renders differently depending on context.</p>")
|
||
(alt (when (has "auth") (text "<p style=\"color:green\"><b>Members:</b> you are logged in.</p>"))
|
||
(else (text "<p style=\"color:#999\"><i>Log in to see the member-only block.</i></p>")))
|
||
;; live context: a responsive variant chosen by the request's device (User-Agent).
|
||
(alt (when (eq "device" "mobile") (text "<p>📱 <b>Mobile layout</b> (device from the request).</p>"))
|
||
(else (text "<p>🖥️ <b>Desktop layout</b> (device from the request).</p>")))
|
||
(text "<h3>Two columns (par)</h3>")
|
||
(row (text "<div style=\"flex:1;border:1px solid #ccc;padding:0.5em\">Column A</div>")
|
||
(text "<div style=\"flex:1;border:1px solid #ccc;padding:0.5em\">Column B</div>"))
|
||
(text "<h3>A list (each over a graph query)</h3><ul>")
|
||
(each (query is-a compose-item)
|
||
(seq (text "<li><a href=\"/") (val :slug) (text "\">") (field :title) (text "</a></li>")))
|
||
(text "</ul>")))))))
|
||
;; A live demo of the EXECUTE-fold (the second fold): ONE composition object whose :body is
|
||
;; a WORKFLOW — the SAME structure the render-fold renders, folded by execute -> an effect
|
||
;; log. Parallels /compose-demo (render). GET /workflow-demo runs it and shows the effects.
|
||
(define host/blog-seed-workflow-demo!
|
||
(fn ()
|
||
(begin
|
||
(host/blog-seed! "workflow-demo" "Workflow Demo" "(article (h1 \"Workflow\"))" "published")
|
||
(host/blog--set-body! "workflow-demo"
|
||
(quote (seq
|
||
(effect validate (field :slug))
|
||
(alt (when (eq "status" "ready") (effect publish (field :slug)))
|
||
(else (effect hold (field :slug))))
|
||
(each (items {:to "alice@x"} {:to "bob@x"}) (effect notify (field :to)))))))))
|
||
;; GET /workflow-demo — run the workflow object through the execute-fold and render its
|
||
;; effect log. The same object's :body, folded by RENDER, would produce HTML; folded by
|
||
;; EXECUTE it produces this plan of effects. The behaviour model IS an execute-fold.
|
||
(define host/blog-workflow-demo
|
||
(fn (req)
|
||
(let ((effects (host/exec-run (host/blog-body-of "workflow-demo") {"slug" "post-1" "status" "ready"})))
|
||
(let ((rows (map (fn (e) (quasiquote
|
||
(li (b (unquote (get e :verb))) " "
|
||
(unquote (str (get e :args)))))) effects)))
|
||
(host/blog--resp req 200
|
||
(host/blog--page req "Workflow Demo"
|
||
(quasiquote
|
||
(div (h1 "Workflow Demo")
|
||
(p "This is ONE composition object (its :body). The render-fold would turn it into HTML; the "
|
||
(b "execute-fold") " turns the SAME structure into a plan of effects — leaves are effects, "
|
||
(code "seq") " = steps, " (code "alt") " = branch, " (code "each") " = for-each:")
|
||
(unquote (cons (quote ol) rows))
|
||
(p :style "margin-top:1em;color:#555"
|
||
"(validate → branch on status=ready → notify each recipient. The behaviour model is an execute-fold over a composition object — the same object the block editor authors.)")
|
||
(p (a :href "/compose-demo/" "→ the render-fold demo (same algebra, folded to HTML)"))))))))))
|
||
;; replace every (field "name") node in a parsed template tree with values[name] ("" if
|
||
;; absent). Pure: a tree-walk over the already-parsed template + pre-fetched values.
|
||
(define host/blog--instantiate
|
||
(fn (node values)
|
||
(if (and (= (type-of node) "list") (> (len node) 0))
|
||
(if (= (str (first node)) "field")
|
||
(or (get values (first (rest node))) "")
|
||
(map (fn (c) (host/blog--instantiate c values)) node))
|
||
node)))
|
||
;; the rendered typed block for a post: for each type it is-a that declares a :template,
|
||
;; parse + instantiate with the post's field-values. (div …) of the results, or "" if none.
|
||
;; Durable reads (types-of, template-of, field-values) — call in a handler let, not a render.
|
||
(define host/blog--typed-block
|
||
(fn (slug)
|
||
(let ((values (host/blog-field-values-of slug))
|
||
(templates (reduce (fn (acc t)
|
||
(let ((tpl (host/blog-template-of t)))
|
||
(if tpl (concat acc (list tpl)) acc)))
|
||
(list) (host/blog-types-of slug))))
|
||
(if (> (len templates) 0)
|
||
(cons (quote div)
|
||
(map (fn (tpl) (host/blog--instantiate (parse-safe tpl) values)) templates))
|
||
""))))
|
||
|
||
;; every element tag in a parsed content tree, recursively (the heads of nested
|
||
;; lists) — so "requires h1" matches an h1 even inside an article/section wrapper.
|
||
(define host/blog--all-tags
|
||
(fn (tree)
|
||
(if (and (= (type-of tree) "list") (> (len tree) 0))
|
||
(concat (list (str (first tree)))
|
||
(reduce (fn (acc c) (concat acc (host/blog--all-tags c))) (list) (rest tree)))
|
||
(list))))
|
||
|
||
;; the :msg of each required :block a schema asks for but the content lacks.
|
||
(define host/blog--schema-issues
|
||
(fn (schema content)
|
||
(let ((tags (host/blog--all-tags (parse-safe content))))
|
||
(reduce
|
||
(fn (acc rule)
|
||
(if (contains? tags (get rule :block)) acc (concat acc (list (get rule :msg)))))
|
||
(list) schema))))
|
||
|
||
;; all schema issues for a post = the union over every type it is-a that carries a
|
||
;; schema. Empty = valid; vacuous (and cheap) when no type has a schema.
|
||
(define host/blog-type-issues
|
||
(fn (slug content)
|
||
(reduce
|
||
(fn (acc t)
|
||
(let ((s (host/blog-schema-of t)))
|
||
(if s (concat acc (host/blog--schema-issues s content)) acc)))
|
||
(list) (host/blog-types-of slug))))
|
||
(define host/blog-type-valid?
|
||
(fn (slug content) (= (len (host/blog-type-issues slug content)) 0)))
|
||
|
||
;; Seed a relation-post: a post that is-a `relation` and carries its metadata in a
|
||
;; :rel slot. Idempotent (the record is written once; the is-a edge is a set).
|
||
(define host/blog--seed-rel!
|
||
(fn (slug title symmetric label inverse-label)
|
||
(begin
|
||
(when (not (host/blog-exists? slug))
|
||
(host/blog--write! slug
|
||
{:slug slug :title title
|
||
:sx-content (str "(article (h1 \"" title "\") (p \"A relation — posts link to each other through it. Its symmetry and labels live on this post.\"))")
|
||
:status "published"
|
||
:rel {:symmetric symmetric :label label :inverse-label inverse-label}}))
|
||
(host/blog-relate! slug "relation" "is-a"))))
|
||
|
||
;; ── cards-as-types (the blog content vocabulary) ────────────────────
|
||
;; Seed a card-type: a type-post subtype-of "card" with its own fields. The kg-card /
|
||
;; content-on-sx block vocabulary becomes the metamodel's card types, so the editor's
|
||
;; card palette + a post's body blocks are driven by type definitions, and the radar
|
||
;; migrator (plans/NOTE-blog-types-for-radar.md) maps old Ghost cards onto these.
|
||
(define host/blog--seed-card-type!
|
||
(fn (slug title fields template)
|
||
(begin
|
||
(host/blog-seed! slug title
|
||
(str "(article (h1 \"" title "\") (p \"A " title " card — a kind of content block. Its fields define what the editor collects and the template renders.\"))")
|
||
"published")
|
||
(host/blog-relate! slug "card" "subtype-of")
|
||
(host/blog--set-fields! slug fields)
|
||
;; a card type carries a render :template (SX tree with (field "name") placeholders),
|
||
;; so a card OBJECT renders via the SAME typed-block path articles use — and a `(ref)`
|
||
;; in a post body transcludes it. This is what makes cards-as-objects render.
|
||
(when template (host/blog--set-template! slug template)))))
|
||
|
||
;; Seed the root type-posts: "type" (the root) and "tag" (a kind of type). Types
|
||
;; ARE posts, so these are real posts that document themselves; tag subtype-of
|
||
;; type means anything that is-a tag is, transitively, a type. Idempotent — safe
|
||
;; to call on every boot (host/blog-seed! no-ops if present, edges are sets).
|
||
(define host/blog-seed-types!
|
||
(fn ()
|
||
(begin
|
||
;; relations are posts too — `relation` is their root; each relation-post
|
||
;; is-a relation and owns its symmetry + labels (plans/relations-as-posts.md).
|
||
(host/blog-seed! "relation" "Relation"
|
||
"(article (h1 \"Relation\") (p \"The root of relations. A relation is a typed edge between posts; each relation-post declares its symmetry and labels, and a type anchors its object end (which gives the picker its candidates).\"))"
|
||
"published")
|
||
(host/blog--seed-rel! "related" "related" true "Related posts" nil)
|
||
(host/blog--seed-rel! "is-a" "is a" false "Types" "Instances")
|
||
(host/blog--seed-rel! "subtype-of" "subtype of" false "Subtype of" "Subtypes")
|
||
(host/blog--seed-rel! "tagged" "tagged" false "Tags" "Tagged with this")
|
||
(host/blog-seed! "type" "Type"
|
||
"(article (h1 \"Type\") (p \"The root type. Types are posts — so this is a post that documents the idea of a type. A post declares its types with is-a edges; types form a hierarchy with subtype-of edges.\"))"
|
||
"published")
|
||
(host/blog-seed! "tag" "Tag"
|
||
"(article (h1 \"Tag\") (p \"A tag is a kind of type (tag subtype-of type), so anything that is-a tag is also a type. A post is tagged with a tag; a tag post documents the tag and lists what is tagged with it.\"))"
|
||
"published")
|
||
(host/blog-relate! "tag" "type" "subtype-of")
|
||
;; "article" — a type WITH a schema (requires a heading). Posts that is-a
|
||
;; article are validated against it on save (gradual typing in action).
|
||
(host/blog-seed! "article" "Article"
|
||
"(article (h1 \"Article\") (p \"A kind of post that must have a heading. A post that is-a article is checked against this type's schema on save — gradual typing: declaring the type adds the requirement, and the next edit must satisfy it.\"))"
|
||
"published")
|
||
(host/blog-relate! "article" "type" "subtype-of")
|
||
;; article's schema lives ON the article post now (Slice 5) — install/migrate it.
|
||
(host/blog--set-schema! "article" (list {:block "h1" :msg "an article needs a heading (h1)"}))
|
||
;; article's typed FIELDS (Slice 8) — these drive the generic edit form + the render
|
||
;; template: a subtitle (plain text) and an optional hero image URL.
|
||
(host/blog--set-fields! "article"
|
||
(list {:name "subtitle" :type "String"}
|
||
{:name "hero" :type "URL"}))
|
||
;; article's render TEMPLATE (Slice 8c) — the subtitle field shown as a standfirst
|
||
;; above the body. (field "subtitle") resolves to the instance's value at render.
|
||
(host/blog--set-template! "article"
|
||
"(p :style \"font-style:italic;color:#555;margin:0 0 1em;font-size:1.1em\" (field \"subtitle\"))")
|
||
;; ── cards-as-types: the blog content block vocabulary (kg-cards / content-on-sx
|
||
;; block kinds) as metamodel types. "card" is the root; each card kind is a subtype
|
||
;; with its own fields. These define the editor's card palette + the radar migrator's
|
||
;; target vocabulary (plans/NOTE-blog-types-for-radar.md). Instances-as-blocks vs
|
||
;; instances-as-posts is a later decision; this is the vocabulary.
|
||
(host/blog-seed! "card" "Card"
|
||
"(article (h1 \"Card\") (p \"A content block — the building unit of a post body. Each card kind is a type with its own fields; the editor collects them and the template renders them.\"))"
|
||
"published")
|
||
(host/blog-relate! "card" "type" "subtype-of")
|
||
(host/blog--seed-card-type! "card-heading" "Heading"
|
||
(list {:name "level" :type "Int"} {:name "text" :type "String"})
|
||
"(h2 (field \"text\"))")
|
||
(host/blog--seed-card-type! "card-text" "Text"
|
||
(list {:name "text" :type "Text"})
|
||
"(p (field \"text\"))")
|
||
(host/blog--seed-card-type! "card-image" "Image"
|
||
(list {:name "src" :type "URL"} {:name "alt" :type "String"} {:name "caption" :type "String"})
|
||
"(figure (img :src (field \"src\") :alt (field \"alt\")) (figcaption (field \"caption\")))")
|
||
(host/blog--seed-card-type! "card-quote" "Quote"
|
||
(list {:name "text" :type "Text"} {:name "cite" :type "String"})
|
||
"(blockquote (field \"text\"))")
|
||
(host/blog--seed-card-type! "card-code" "Code"
|
||
(list {:name "language" :type "String"} {:name "code" :type "Text"})
|
||
"(pre (code (field \"code\")))")
|
||
(host/blog--seed-card-type! "card-embed" "Embed"
|
||
(list {:name "url" :type "URL"} {:name "caption" :type "String"})
|
||
"(div :class \"embed\" (field \"url\"))")
|
||
(host/blog--seed-card-type! "card-callout" "Callout"
|
||
(list {:name "style" :type "String"} {:name "text" :type "Text"})
|
||
"(div :class \"callout\" (field \"text\"))")
|
||
;; relation DECLARATIONS (see plans/relations-as-posts.md). A type-post declares
|
||
;; which relation it anchors at its OBJECT end ("you may point at me with R"); the
|
||
;; picker's candidate set is the down-closure of a relation's anchors through the
|
||
;; type graph, so the candidates for a relation are exactly the posts that inherit
|
||
;; its declaration. `type` anchors is-a + subtype-of (you point at a type), `tag`
|
||
;; anchors tagged (you point at a tag). `related` has no anchor → every post.
|
||
(host/blog-relate! "type" "is-a" "declares")
|
||
(host/blog-relate! "type" "subtype-of" "declares")
|
||
(host/blog-relate! "tag" "tagged" "declares"))))
|
||
|
||
;; ── relate picker (filterable, paginated candidate list) ────────────
|
||
;; Candidates to relate `slug` to: every post except itself and ones already
|
||
;; related, narrowed by `q` (case-insensitive substring of title or slug),
|
||
;; title-sorted. One page is `host/blog--picker-limit` rows from `offset`.
|
||
(define host/blog--picker-limit 20)
|
||
;; Down-closure: every post reachable from `roots` by walking INVERSE is-a ∪
|
||
;; subtype-of edges (i.e. instances and subtypes, transitively), roots included.
|
||
;; This is "everything that is, transitively, an instance-or-subtype of a root".
|
||
;; BFS over direct edges (host/blog-in); `seen` makes it cycle-safe and terminating.
|
||
(define host/blog--reach-down
|
||
(fn (roots)
|
||
(let loop ((frontier roots) (seen (list)))
|
||
(if (empty? frontier)
|
||
seen
|
||
(let ((t (first frontier)))
|
||
(if (contains? seen t)
|
||
(loop (rest frontier) seen)
|
||
(loop
|
||
(concat (rest frontier)
|
||
(concat (host/blog-in t "is-a") (host/blog-in t "subtype-of")))
|
||
(concat seen (list t)))))))))
|
||
|
||
;; The candidate POOL for relating under `kind` is DECLARATION-driven (see
|
||
;; plans/relations-as-posts.md): the down-closure of the posts that DECLARE `kind`
|
||
;; at their object end. So is-a/subtype-of (anchored by `type`) offer the whole type
|
||
;; closure — roots AND instances — and `tagged` (anchored by `tag`) offers the tags.
|
||
;; A relation with no declaration (e.g. `related`) offers every post.
|
||
(define host/blog--candidate-pool
|
||
(fn (kind)
|
||
(let ((anchors (host/blog-in kind "declares")))
|
||
(if (empty? anchors)
|
||
(host/blog-slugs)
|
||
(host/blog--reach-down anchors)))))
|
||
|
||
;; Slice 3 — typed relations: a post is a valid OBJECT (target end) of `kind` iff it's
|
||
;; in the relation's declared candidate set (the down-closure of kind's declares-anchors
|
||
;; — the target-type constraint). The SAME set the picker offers, so the picker and
|
||
;; the relate endpoint agree by construction. A relation with no anchor (`related`)
|
||
;; accepts any existing post. This is what turns "candidate set" into an enforced
|
||
;; relation schema: is-a's object must be a type, tagged's must be a tag, etc.
|
||
(define host/blog--valid-object?
|
||
(fn (kind other)
|
||
(contains? (host/blog--candidate-pool kind) other)))
|
||
|
||
(define host/blog--title (fn (s) (get (host/blog-get s) :title))) ;; one durable read
|
||
|
||
;; One PAGE of candidates (records {:slug :title}) for relating `slug` under `kind`.
|
||
;; Slice 2.5 — title reads are O(page), not O(pool): the available candidate SLUGS are
|
||
;; computed + slug-sorted with NO per-candidate read; then titles are fetched only for
|
||
;; the rows actually returned. On the unfiltered path (q="" — the initial picker load
|
||
;; AND every editor server-fill) that's ~`limit` reads instead of one-per-post, which
|
||
;; was the durable-read churn under http-listen. A filter (q≠"") still resolves titles
|
||
;; across the pool, since it matches on the title — but that's the interactive path.
|
||
(define host/blog--relate-candidates
|
||
(fn (slug q kind offset limit)
|
||
(let ((pool (host/blog--candidate-pool kind))
|
||
(already (host/blog-out slug kind))
|
||
(ql (lower (or q ""))))
|
||
(let ((avail (sort (filter (fn (s) (and (not (= s slug)) (not (contains? already s)))) pool))))
|
||
(if (= ql "")
|
||
;; no filter: page by slug, then read titles for just the page
|
||
(map (fn (s) {:slug s :title (host/blog--title s)})
|
||
(take (drop avail offset) limit))
|
||
;; filter: resolve titles, match on title|slug, then page
|
||
(let ((recs (map (fn (s) {:slug s :title (host/blog--title s)}) avail)))
|
||
(take
|
||
(drop
|
||
(filter (fn (r) (or (contains? (lower (get r :title)) ql)
|
||
(contains? (get r :slug) ql)))
|
||
recs)
|
||
offset)
|
||
limit)))))))
|
||
|
||
;; One candidate row: a tiny form whose button adds the relation under `kind`.
|
||
(define host/blog--picker-item
|
||
(fn (slug p kind)
|
||
(quasiquote
|
||
(li :id (unquote (str "cand-" kind "-" (get p :slug)))
|
||
:style "border-bottom:1px solid #eee"
|
||
;; AJAX relate: sx-post the relation, then sx-swap="outerHTML" re-renders the
|
||
;; WHOLE relation editor for this kind (its sx-target #rel-editor-KIND) — the
|
||
;; just-related post moves into the current-relations list and out of the
|
||
;; candidate pool, and the fresh picker re-loads its candidates. (A bare
|
||
;; delete of this row added the relation server-side but never showed it in
|
||
;; the current list; re-rendering the editor keeps BOTH lists in sync.)
|
||
;; method+action stay for the no-JS fallback (plain POST -> 303 -> reload).
|
||
(form :method "post" :style "margin:0"
|
||
:action (unquote (str "/" slug "/relate"))
|
||
:sx-post (unquote (str "/" slug "/relate"))
|
||
:sx-target (unquote (str "#rel-editor-" kind))
|
||
:sx-swap "outerHTML"
|
||
(input :type "hidden" :name "other" :value (unquote (get p :slug)))
|
||
(input :type "hidden" :name "kind" :value (unquote kind))
|
||
(button :type "submit"
|
||
:style "width:100%;text-align:left;background:none;border:none;padding:0.5em;cursor:pointer"
|
||
(unquote (get p :title))))))))
|
||
|
||
;; The infinite-scroll "load more" sentinel: an <li> that, when scrolled into view
|
||
;; (sx-trigger "revealed"), GETs the NEXT page and replaces ITSELF (sx-swap
|
||
;; outerHTML, default self-target) with those rows + the next sentinel. This is the
|
||
;; SX-htmx engine doing the paging — no client JS. q is %-encoded back into the URL
|
||
;; so the filter is preserved across pages.
|
||
(define host/blog--picker-more
|
||
(fn (slug kind q next)
|
||
(quasiquote
|
||
(li :class "rp-more"
|
||
:style "list-style:none;padding:0.5em;text-align:center;opacity:0.6"
|
||
:sx-get (unquote (str "/" slug "/relate-options?kind=" kind
|
||
"&q=" (dr/url-encode q) "&offset=" next))
|
||
:sx-trigger "revealed"
|
||
:sx-swap "outerHTML"
|
||
;; a dropped/offline page-fetch retries with exponential backoff (1s→30s)
|
||
;; until it succeeds, so a flaky connection self-heals as you scroll.
|
||
:sx-retry "exponential:1000:30000"
|
||
"Loading more…"))))
|
||
|
||
;; GET /<slug>/relate-options?kind=&q=&offset= — one page of candidate rows for a
|
||
;; kind as an HTML fragment, swapped into the picker by the SX-htmx engine. A full
|
||
;; page is followed by a "load more" sentinel (above); the last page is not. Public
|
||
;; read; the relate action stays guarded.
|
||
(define host/blog-relate-options
|
||
(fn (req)
|
||
(let ((slug (dream-param req "slug"))
|
||
(kind (or (dream-query-param req "kind") "related"))
|
||
;; dream's query parser does not %-decode values (its form parser does),
|
||
;; so a filter like "Item 13" arrives as "Item%2013" — decode it.
|
||
(q (dr/url-decode (or (dream-query-param req "q") "")))
|
||
(offset (host/query-int req "offset" 0)))
|
||
(let ((page (host/blog--relate-candidates slug q kind offset host/blog--picker-limit)))
|
||
(let ((rows (join "" (map (fn (p) (render-page (host/blog--picker-item slug p kind))) page)))
|
||
(more (if (= (len page) host/blog--picker-limit)
|
||
(render-page (host/blog--picker-more slug kind q (+ offset host/blog--picker-limit)))
|
||
"")))
|
||
(dream-html (str rows more)))))))
|
||
|
||
|
||
;; ── page shell ──────────────────────────────────────────────────────
|
||
;; A page is an SX element tree, rendered via render-page (5.1). The handler
|
||
;; builds the tree (running any dynamic logic in the full evaluator, e.g. a posts
|
||
;; loop) and render-page renders the static result — no embedded HTML strings,
|
||
;; only the doctype prefix render-to-html doesn't emit. `body` is an SX node.
|
||
;; SPA shell. The blog is a single-page app: the page boots the WASM OCaml kernel
|
||
;; (the SAME evaluator as the server) + the SX-htmx engine (web/engine.sx), and
|
||
;; `sx-boost="#content"` turns every in-page link/form into a fragment swap into
|
||
;; #content — no full reloads, history handled. A boosted request carries the
|
||
;; SX-Request:true header; we then return ONLY the inner content (so the engine
|
||
;; swaps it straight into #content). A direct / no-JS request gets the full shell,
|
||
;; so the blog degrades gracefully to plain server-rendered pages.
|
||
(define host/blog--spa-req? (fn (req) (= (dream-header req "sx-request") "true")))
|
||
|
||
;; An AJAX editor swap (the picker's relate / the editor's remove) vs. a plain
|
||
;; boosted form. The engine sends an SX-Target header for an sx-post form
|
||
;; (sx-target=#rel-editor-…), but NOT for a plain boosted form (the is-a-tag
|
||
;; toggle). So this tells "return the re-rendered editor fragment" apart from
|
||
;; "redirect + re-render #content" (the toggle / no-JS path).
|
||
(define host/blog--editor-swap-req?
|
||
(fn (req)
|
||
(and (host/blog--spa-req? req)
|
||
(let ((t (dream-header req "sx-target"))) (and t (not (= t "")))))))
|
||
|
||
(define host/blog--page
|
||
(fn (req title body)
|
||
(if (host/blog--spa-req? req)
|
||
;; SPA fragment: SX WIRE FORMAT (text/sx), not HTML. The WASM kernel parses
|
||
;; + renders it client-side into #content (the engine's handle-sx-response).
|
||
;; No server-side HTML render on the boosted path.
|
||
(serialize body)
|
||
;; full SPA shell: WASM kernel + platform + boosted #content (server HTML
|
||
;; for first load / no-JS / SEO)
|
||
(str "<!doctype html>"
|
||
(render-page
|
||
(quasiquote
|
||
(html
|
||
(head (meta :charset "utf-8") (title (unquote title))
|
||
;; content-addressed module manifest: {file -> hash}. The client's
|
||
;; loadBytecodeFile reads this and fetches each web-stack module
|
||
;; immutably from /sx/h/{hash} (localStorage-cached, never stale)
|
||
;; instead of /static/wasm/sx/*.sxbc with max-age.
|
||
(script :type "application/json" :data-sx-manifest "1"
|
||
(raw! (unquote (host/static-manifest-json))))
|
||
(script :src "/static/wasm/sx_browser.bc.wasm.js")
|
||
(script :src "/static/wasm/sx-platform.js")
|
||
;; Visible failure state for the SX engine's .sx-error class (added
|
||
;; on a failed/offline fetch, cleared on the next success). Without
|
||
;; it a stuck retry is invisible — the picker just sits "Loading…".
|
||
(style (raw! (unquote (str
|
||
".rp-more.sx-error{color:#b00}"
|
||
".rp-more.sx-error::after{content:\" — offline, retrying…\"}"
|
||
".relate-picker.sx-error .rp-results::before{"
|
||
"content:\"Connection problem — retrying…\";display:block;"
|
||
"padding:.5em;color:#b00;font-size:.9em}")))))
|
||
(body
|
||
;; sx-boost must be on a DESCENDANT of <body> (process-boosted
|
||
;; queries [sx-boost] WITHIN the body, so it can't sit on body
|
||
;; itself). The wrapper boosts every link/form inside, targeting
|
||
;; #content; #content is the swap target.
|
||
(div :sx-boost "#content"
|
||
;; persistent top nav OUTSIDE #content, so it survives every
|
||
;; content swap; the Home link is boosted (SPA nav to /).
|
||
(nav :style "padding:0.75em 0;border-bottom:1px solid #ccc;margin-bottom:1em"
|
||
(a :href "/" :style "font-weight:bold;text-decoration:none" "Home"))
|
||
(div :id "content" (unquote body)))))))))))
|
||
|
||
;; Wrap a host/blog--page result in a response with the matching content-type:
|
||
;; text/sx for a boosted (SPA) request (the WASM kernel renders it), text/html
|
||
;; for a full-page request. Replaces the old dream-html/-status wrappers so the
|
||
;; boosted path ships SX instead of server-rendered HTML.
|
||
(define host/blog--resp
|
||
(fn (req status str)
|
||
(dream-response status
|
||
{:content-type
|
||
(if (host/blog--spa-req? req) "text/sx; charset=utf-8" "text/html; charset=utf-8")}
|
||
str)))
|
||
|
||
;; ── registry-driven relation rendering (post page) ──────────────────
|
||
;; One labelled block of links from records ({:slug :title}), or "" when empty.
|
||
;; Records are pre-fetched, so the tree is built from in-memory data only.
|
||
(define host/blog--edges-block
|
||
(fn (records label)
|
||
(if (> (len records) 0)
|
||
(let ((items (map (fn (p)
|
||
(quasiquote
|
||
(li (a :href (unquote (str "/" (get p :slug) "/"))
|
||
(unquote (get p :title))))))
|
||
records)))
|
||
(quasiquote
|
||
(div :style "margin-top:2em"
|
||
(h3 (unquote label))
|
||
(unquote (cons (quote ul) items)))))
|
||
"")))
|
||
|
||
;; nodes -> {:slug :title} records, existence-filtered against a shared key set.
|
||
(define host/blog--recs
|
||
(fn (existing nodes)
|
||
(map (fn (s) {:slug s :title (get (host/blog-get s) :title)})
|
||
(filter (fn (s) (contains? existing s))
|
||
(map (fn (n) (substr (symbol->string n) 5))
|
||
(filter (fn (n) (starts-with? (symbol->string n) "blog:")) nodes))))))
|
||
|
||
;; The relation blocks shown on a POST page — a CURATED, fixed set: Related (out),
|
||
;; Tags (out), Tagged-with-this (in). PERFORMANCE: read the KV key list ONCE and
|
||
;; derive both the post set and the edges from it in memory, instead of letting
|
||
;; each host/blog-out/in re-scan the store. Every durable read is a perform routed
|
||
;; through cek_run_with_io (costly deep in the call stack), so the post page must
|
||
;; minimise them — this does ONE kv-keys plus a host/blog-get per linked post.
|
||
(define host/blog--post-relation-specs
|
||
(list {:kind "related" :dir "out" :label "Related posts"}
|
||
{:kind "tagged" :dir "out" :label "Tags"}
|
||
{:kind "tagged" :dir "in" :label "Tagged with this"}))
|
||
;; in-memory: the slug list (out: dst, in: src) for `slug` under `kind` from
|
||
;; pre-parsed edges — no perform.
|
||
(define host/blog--edges-for
|
||
(fn (edges slug kind dir)
|
||
(reduce
|
||
(fn (acc e)
|
||
(if (= (get e :kind) kind)
|
||
(if (= dir "out")
|
||
(if (= (get e :src) slug) (concat acc (list (get e :dst))) acc)
|
||
(if (= (get e :dst) slug) (concat acc (list (get e :src))) acc))
|
||
acc))
|
||
(list) edges)))
|
||
;; slug list -> {:slug :title} records (existence-filtered), one host/blog-get each.
|
||
(define host/blog--recs-slugs
|
||
(fn (existing slugs)
|
||
(map (fn (s) {:slug s :title (get (host/blog-get s) :title)})
|
||
(filter (fn (s) (contains? existing s)) slugs))))
|
||
(define host/blog--relation-blocks
|
||
(fn (slug)
|
||
(let ((keys (persist/backend-kv-keys host/blog-store))) ;; ONE durable read
|
||
(let ((existing (reduce (fn (acc k)
|
||
(if (starts-with? k "blog:")
|
||
(concat acc (list (substr k 5))) acc))
|
||
(list) keys))
|
||
(edges (filter (fn (e) (not (nil? e)))
|
||
(map host/blog--parse-edge-key keys))))
|
||
(let ((blocks
|
||
(reduce
|
||
(fn (acc spec)
|
||
(let ((b (host/blog--edges-block
|
||
(host/blog--recs-slugs existing
|
||
(host/blog--edges-for edges slug (get spec :kind) (get spec :dir)))
|
||
(get spec :label))))
|
||
(if (= b "") acc (concat acc (list b)))))
|
||
(list)
|
||
host/blog--post-relation-specs)))
|
||
(if (> (len blocks) 0) (cons (quote div) blocks) ""))))))
|
||
|
||
;; the relation section for the post page: the blocks, or — when empty and the
|
||
;; viewer is logged in — a subtle "add some" hint; nothing for anonymous viewers.
|
||
(define host/blog--relations-or-hint
|
||
(fn (slug logged-in)
|
||
(let ((blocks (host/blog--relation-blocks slug)))
|
||
(cond
|
||
((not (= blocks "")) blocks)
|
||
(logged-in
|
||
(quasiquote
|
||
(p :style "margin-top:2em;font-size:0.9em;opacity:0.7"
|
||
"No relations yet — "
|
||
(a :href (unquote (str "/" slug "/edit")) "add some") ".")))
|
||
(else "")))))
|
||
|
||
;; Kind-aware relation editor for the edit page: current links (each with a
|
||
;; kind-scoped remove), plus a filterable picker (a declarative SX-htmx form, one
|
||
;; per kind). The picker's candidates come from the kind's registry :candidates
|
||
;; ("all" / tags / types).
|
||
(define host/blog--relation-editor
|
||
(fn (slug kind with-cands)
|
||
;; current edges read up front (a perform) — NOT inside the quasiquote, where
|
||
;; a perform would raise VmSuspended under http-listen.
|
||
(let ((spec (host/blog--kind-spec kind))
|
||
(current (host/blog-out slug kind))
|
||
;; results <ul>. When `with-cands` (the relate/unrelate fragment), the first
|
||
;; page of candidates is server-rendered in, so the re-rendered picker is
|
||
;; never briefly empty (the load trigger then re-fetches the same page and
|
||
;; morphs it in, invisibly). On the INITIAL edit page it renders EMPTY and the
|
||
;; load trigger fills it — server-rendering candidates for EVERY kind's picker
|
||
;; would do a durable read per candidate × every editor, blowing the
|
||
;; http-listen render budget (VmSuspended). Built by cons so candidate
|
||
;; li-trees splice in as children (component args would evaluate them).
|
||
(results-ul
|
||
(let ((rows (if with-cands
|
||
(let ((cands (host/blog--relate-candidates slug "" kind 0 host/blog--picker-limit)))
|
||
(append
|
||
(map (fn (p) (host/blog--picker-item slug p kind)) cands)
|
||
(if (= (len cands) host/blog--picker-limit)
|
||
(list (host/blog--picker-more slug kind "" host/blog--picker-limit))
|
||
(list))))
|
||
(list))))
|
||
(cons (quote ul)
|
||
(append
|
||
(quasiquote (:id (unquote (str "rp-" kind "-results"))
|
||
:class "rp-results"
|
||
:style "list-style:none;padding:0;margin:0.5em 0;border:1px solid #ddd"))
|
||
rows)))))
|
||
(quasiquote
|
||
;; #rel-editor-KIND wraps the WHOLE editor (current list + picker) so relate
|
||
;; and unrelate can re-render it with one outerHTML swap — keeping the two
|
||
;; lists in sync. The fresh picker re-loads its candidates (an explicit
|
||
;; outerHTML swap installs a NEW form the engine binds, unlike the old
|
||
;; redirect that morphed the stale picker and left it empty).
|
||
(div :id (unquote (str "rel-editor-" kind))
|
||
:style "margin-top:2em;border-top:1px solid #ccc;padding-top:1em"
|
||
(h3 (unquote (get spec :label)))
|
||
(unquote
|
||
(if (> (len current) 0)
|
||
(cons (quote ul)
|
||
(map (fn (s)
|
||
(quasiquote
|
||
;; remove: sx-post the unrelate, then sx-swap="outerHTML"
|
||
;; re-renders this kind's editor (its sx-target
|
||
;; #rel-editor-KIND) — the row leaves the current list and
|
||
;; the post returns to the candidate pool, both in sync,
|
||
;; with the picker NOT cleared. method+action stay for no-JS.
|
||
(li (a :href (unquote (str "/" s "/")) (unquote s)) " "
|
||
(form :method "post" :style "display:inline"
|
||
:action (unquote (str "/" slug "/unrelate"))
|
||
:sx-post (unquote (str "/" slug "/unrelate"))
|
||
:sx-target (unquote (str "#rel-editor-" kind))
|
||
:sx-swap "outerHTML"
|
||
(input :type "hidden" :name "other" :value (unquote s))
|
||
(input :type "hidden" :name "kind" :value (unquote kind))
|
||
(button :type "submit" "remove")))))
|
||
current))
|
||
(quote (p :style "opacity:0.7" "None yet."))))
|
||
;; The picker, rendered INLINE (not via the ~relate-picker component) so the
|
||
;; first page of candidates is server-rendered into the results <ul> — the
|
||
;; re-rendered editor shows them immediately, no empty flash. Same declarative
|
||
;; SX-htmx form: GET relate-options, innerHTML-swap the results on a debounced
|
||
;; "input" and on "load"; sx-retry self-heals a dropped fetch.
|
||
(form
|
||
:class "relate-picker"
|
||
:data-slug (unquote slug)
|
||
:data-kind (unquote kind)
|
||
:sx-get (unquote (str "/" slug "/relate-options"))
|
||
:sx-trigger "input delay:200ms, load"
|
||
:sx-target (unquote (str "#rp-" kind "-results"))
|
||
:sx-swap "innerHTML"
|
||
:sx-retry "exponential:1000:30000"
|
||
:style "margin:0"
|
||
(input :type "hidden" :name "kind" :value (unquote kind))
|
||
(input :type "text" :name "q" :class "rp-filter" :placeholder "filter…"
|
||
:autocomplete "off" :style "width:100%;padding:0.4em;box-sizing:border-box")
|
||
(unquote results-ul)))))))
|
||
|
||
;; "Is this post a tag?" toggle — marking a post a tag is just an is-a edge to the
|
||
;; "tag" type-post, so it reuses the relate/unrelate routes (no new endpoint).
|
||
(define host/blog--is-tag-toggle
|
||
(fn (slug)
|
||
(if (host/blog-is-tag? slug)
|
||
(quasiquote
|
||
(p (span "This post is a tag ✓ ")
|
||
(form :method "post" :style "display:inline"
|
||
:action (unquote (str "/" slug "/unrelate"))
|
||
(input :type "hidden" :name "other" :value "tag")
|
||
(input :type "hidden" :name "kind" :value "is-a")
|
||
(button :type "submit" "remove tag status"))))
|
||
(quasiquote
|
||
(form :method "post" :action (unquote (str "/" slug "/relate"))
|
||
(input :type "hidden" :name "other" :value "tag")
|
||
(input :type "hidden" :name "kind" :value "is-a")
|
||
(button :type "submit" "Make this a tag"))))))
|
||
|
||
;; One editor per registry kind, wrapped in a div — the edit page's relation
|
||
;; section, generated by ITERATING the registry (add a kind -> it gets an editor).
|
||
(define host/blog--relation-editors
|
||
(fn (slug)
|
||
(cons (quote div)
|
||
;; false: the initial edit page renders empty pickers (the load trigger fills
|
||
;; each), keeping this render cheap. The relate/unrelate FRAGMENT passes true.
|
||
(map (fn (spec) (host/blog--relation-editor slug (get spec :kind) false))
|
||
host/blog-rel-kinds))))
|
||
|
||
;; ── block editor: edit the post :body composition (insert/reorder/remove blocks) ─────
|
||
;; A row per block (type + preview + up/down/remove + a link to edit the card's fields) and
|
||
;; an add-block form. Each control sx-posts its route, sx-swap="outerHTML" replacing
|
||
;; #block-editor with the re-render (live reorder/add/remove). Wrapped for the swap target.
|
||
;; one sx-post button-form targeting #block-editor (dir passed as a hidden field).
|
||
;; index-addressed control button (move up/down, remove, set-cond) -> re-renders #block-editor.
|
||
(define host/blog--block-btn
|
||
(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 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-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
|
||
(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
|
||
;; 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--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).
|
||
((= 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".
|
||
(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)))))))))
|
||
(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)))
|
||
(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)")
|
||
(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"
|
||
(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.
|
||
(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.
|
||
(define host/blog-post
|
||
(fn (req)
|
||
(let ((slug (dream-param req "slug")))
|
||
(let ((r (host/blog-get slug)))
|
||
(if r
|
||
;; Compute everything that does durable reads — body, related block, AND
|
||
;; the auth footer (a durable session read now) — in let bindings BEFORE
|
||
;; the quasiquote. IO must run in the handler body, never while the page
|
||
;; tree is built (a perform there raises VmSuspended under http-listen).
|
||
(let ((principal (host/current-principal req)))
|
||
(let (;; 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)))
|
||
;; 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))))
|
||
;; the typed render-template block (Slice 8c) — field values shown via
|
||
;; the post's types' templates. A durable read, so pre-fetch it here.
|
||
(typed-block (host/blog--typed-block slug))
|
||
(auth-foot (host/auth-footer req)))
|
||
(host/blog--resp req 200
|
||
(host/blog--page req (get r :title)
|
||
(quasiquote
|
||
(div
|
||
(unquote typed-block)
|
||
(article (raw! (unquote body-html)))
|
||
(unquote relations)
|
||
(p :style "margin-top:2em;font-size:0.9em;opacity:0.8"
|
||
(a :href (unquote (str "/" slug "/source")) "view source")
|
||
" · "
|
||
(a :href (unquote (str "/" slug "/edit")) "edit")
|
||
" · "
|
||
(a :href "/" "all posts")
|
||
" · "
|
||
(unquote auth-foot))))))))
|
||
(host/blog--resp req 404
|
||
(host/blog--page req "Not found"
|
||
(quasiquote
|
||
(div (h1 "404")
|
||
(p (unquote (str "No published post: " slug))))))))))))
|
||
|
||
(define host/blog-home
|
||
(fn (req)
|
||
;; only PUBLISHED posts list on the home page — drafts and "block" card objects
|
||
;; (the decomposed cards-as-objects) are stored but not surfaced as top-level posts.
|
||
(let ((posts (filter (fn (p) (= (get p :status) "published")) (host/blog-list))))
|
||
(let ((items
|
||
(map
|
||
(fn (p)
|
||
(quasiquote
|
||
(li (a :href (unquote (str "/" (get p :slug) "/"))
|
||
(unquote (get p :title))))))
|
||
posts)))
|
||
(let ((listing (if (> (len posts) 0)
|
||
(cons (quote ul) items)
|
||
(quote (p "No posts yet."))))
|
||
;; auth-footer does a durable session read — bind it BEFORE the
|
||
;; quasiquote (a perform during tree-build raises VmSuspended).
|
||
(auth-foot (host/auth-footer req)))
|
||
(host/blog--resp req 200
|
||
(host/blog--page req "Blog"
|
||
(quasiquote
|
||
(div (h1 "Posts")
|
||
(unquote listing)
|
||
(p (a :href "/new" "+ New post"))
|
||
(p :style "margin-top:2em;font-size:0.9em;opacity:0.8"
|
||
(a :href "/meta" "metamodel") " · " (a :href "/tags" "tags")
|
||
" · " (unquote auth-foot)))))))))))
|
||
|
||
(define host/blog-index (fn (req) (host/ok (host/blog-list))))
|
||
|
||
;; GET /tags — index of every tag (a post that is-a tag). Tags are posts, so each
|
||
;; links to its own page (which documents the tag + lists what's tagged with it).
|
||
(define host/blog-tags-index
|
||
(fn (req)
|
||
;; pre-fetch records (slug+title) BEFORE the quasiquote — host/blog-get is a
|
||
;; durable read; a perform during tree-build raises VmSuspended.
|
||
(let ((recs (map (fn (s) {:slug s :title (get (host/blog-get s) :title)})
|
||
(sort (host/blog-instances-of "tag"))))
|
||
(auth-foot (host/auth-footer req)))
|
||
(let ((items (map (fn (p)
|
||
(quasiquote
|
||
(li (a :href (unquote (str "/" (get p :slug) "/"))
|
||
(unquote (get p :title))))))
|
||
recs)))
|
||
(host/blog--resp req 200
|
||
(host/blog--page req "Tags"
|
||
(quasiquote
|
||
(div (h1 "Tags")
|
||
(unquote (if (> (len recs) 0)
|
||
(cons (quote ul) items)
|
||
(quote (p "No tags yet."))))
|
||
(p :style "margin-top:2em;font-size:0.9em;opacity:0.8"
|
||
(a :href "/" "all posts") " · " (unquote auth-foot))))))))))
|
||
|
||
;; ── metamodel overview (GET /meta) ─────────────────────────────────
|
||
;; The "see the system you've defined" page: every type-post (with its schema's
|
||
;; required blocks) and every relation-post (with its signature). Types + relations
|
||
;; are themselves posts, so each row links to the post that defines it. Pure read;
|
||
;; durable reads pre-fetched into let bindings BEFORE the quasiquote (a perform during
|
||
;; tree-build raises VmSuspended), and relations come from the boot-populated
|
||
;; host/blog-rel-kinds VALUE (no perform). The surface the metamodel editor hangs off.
|
||
(define host/blog--schema-summary
|
||
(fn (schema)
|
||
(if (and schema (> (len schema) 0))
|
||
(join ", " (map (fn (rule) (get rule :block)) schema))
|
||
"—")))
|
||
(define host/blog-meta-index
|
||
(fn (req)
|
||
(let ((type-recs
|
||
(map (fn (s)
|
||
(let ((r (host/blog-get s)))
|
||
{:slug s :title (get r :title) :schema (get r :schema) :fields (get r :fields)}))
|
||
(sort (host/blog-type-defs))))
|
||
(rel-specs host/blog-rel-kinds)
|
||
(auth-foot (host/auth-footer req)))
|
||
(let ((type-rows
|
||
(map (fn (p)
|
||
(quasiquote
|
||
(tr (td (a :href (unquote (str "/" (get p :slug) "/"))
|
||
(unquote (get p :title))))
|
||
(td (unquote (host/blog--fields-summary (get p :fields))))
|
||
(td (unquote (host/blog--schema-summary (get p :schema)))))))
|
||
type-recs))
|
||
(rel-rows
|
||
(map (fn (spec)
|
||
(quasiquote
|
||
(tr (td (unquote (get spec :kind)))
|
||
(td (unquote (or (get spec :label) "")))
|
||
(td (unquote (if (get spec :symmetric) "symmetric" "directed")))
|
||
(td (unquote (or (get spec :inverse-label) "—"))))))
|
||
rel-specs)))
|
||
(host/blog--resp req 200
|
||
(host/blog--page req "Metamodel"
|
||
(quasiquote
|
||
(div
|
||
(h1 "Metamodel")
|
||
(p "The types and relations that define this system. Each is itself a post — click through to its definition.")
|
||
(h2 (unquote (str "Types (" (len type-recs) ")")))
|
||
(unquote (if (> (len type-recs) 0)
|
||
(cons (quote table)
|
||
(cons (quote (tr (th "Type") (th "Fields") (th "Required blocks"))) type-rows))
|
||
(quote (p "No types yet."))))
|
||
(form :method "post" :action "/meta/new-type" :style "margin:0.5em 0 1.5em"
|
||
(input :name "title" :placeholder "New type name" :style "padding:0.3em")
|
||
" " (button :type "submit" "+ Type"))
|
||
(h2 (unquote (str "Relations (" (len rel-specs) ")")))
|
||
(unquote (if (> (len rel-specs) 0)
|
||
(cons (quote table)
|
||
(cons (quote (tr (th "Relation") (th "Label") (th "Kind") (th "Inverse"))) rel-rows))
|
||
(quote (p "No relations yet."))))
|
||
(form :method "post" :action "/meta/new-relation" :style "margin:0.5em 0 1.5em"
|
||
(input :name "title" :placeholder "New relation name" :style "padding:0.3em")
|
||
" " (input :name "label" :placeholder "label (optional)" :style "padding:0.3em")
|
||
" " (label (input :type "checkbox" :name "symmetric") " symmetric")
|
||
" " (button :type "submit" "+ Relation"))
|
||
(p :style "margin-top:2em;font-size:0.9em;opacity:0.8"
|
||
(a :href "/" "all posts") " · " (a :href "/tags" "tags")
|
||
" · " (unquote auth-foot))))))))))
|
||
|
||
;; POST /meta/new-type — DEFINE A TYPE THROUGH THE UI (metamodel editor, surface 1):
|
||
;; create a published post that is subtype-of "type", so it appears in host/blog-type-defs
|
||
;; / the /meta Types list and can then be given fields + a schema + a template. Guarded
|
||
;; like the other writes. Empty / already-existing title -> harmless no-op, then redirect.
|
||
(define host/blog-meta-new-type
|
||
(fn (req)
|
||
(let ((title (host/field req "title")))
|
||
(when (and title (not (= title "")))
|
||
(let ((slug (host/blog-slugify title)))
|
||
(begin
|
||
(when (not (host/blog-exists? slug))
|
||
(host/blog-put! slug title
|
||
(str "(article (h1 \"" title "\") (p \"A type. Posts that is-a " title " are its instances; give it fields, a schema and a template to shape them.\"))")
|
||
"published"))
|
||
(host/blog-relate! slug "type" "subtype-of"))))
|
||
(dream-redirect "/meta"))))
|
||
|
||
;; POST /meta/new-relation — DEFINE A RELATION THROUGH THE UI (metamodel editor):
|
||
;; create a relation-post (is-a relation, carrying its :rel metadata) and register it.
|
||
;; SESSION-SCOPED (2026-06-30): the relation-post + any edges it gets persist durably,
|
||
;; but the rel-kinds REGISTRY entry is added by a runtime concat (safe — the serving
|
||
;; handler has the IO resolver) and is LOST on restart, because the boot loader
|
||
;; (host/blog-load-rel-kinds!) is unrolled and can't dynamically enumerate under
|
||
;; JIT-at-boot (the kernel boot-resolver gap — flagged to the sx-vm-extensions loop in
|
||
;; plans/NOTE-render-diff-for-vm-ext.md). Re-creating the relation re-registers it.
|
||
(define host/blog-meta-new-relation
|
||
(fn (req)
|
||
(let ((title (host/field req "title"))
|
||
(label (host/field req "label"))
|
||
(symmetric (= (host/field req "symmetric") "on")))
|
||
(when (and title (not (= title "")))
|
||
(let ((slug (host/blog-slugify title)))
|
||
(begin
|
||
(host/blog--seed-rel! slug title symmetric
|
||
(if (or (nil? label) (= label "")) title label) nil)
|
||
(host/blog--cache-rel! slug)
|
||
(set! host/blog-rel-kinds
|
||
(concat host/blog-rel-kinds (list (get host/blog--rel-cache slug)))))))
|
||
(dream-redirect "/meta"))))
|
||
|
||
;; ── typed Ghost import (the radar genesis-import seam) ──────────────
|
||
;; Import ONE Ghost post (a dict of its columns, string keys) as a TYPED host post:
|
||
;; the {slug,title,sx_content,status} record + is-a article + Ghost columns mapped onto
|
||
;; article :field-values (custom_excerpt->subtitle, feature_image->hero) + tags landed as
|
||
;; tag-posts with tagged edges. The Ghost body is ALREADY sx_content (the Python
|
||
;; lexical_to_sx migration produced (~kg_cards/kg-*) markup), so we just carry it. So an
|
||
;; old Ghost post lands not as bare markup but as a first-class typed Article — fields on
|
||
;; the edit form, subtitle as a rendered standfirst, tags in the graph. Idempotent
|
||
;; (put!/seed!/relate! are sets). Contract: plans/NOTE-blog-types-for-radar.md.
|
||
(define host/blog-import-post!
|
||
(fn (gp)
|
||
(let ((slug (get gp "slug")) (title (get gp "title")))
|
||
(begin
|
||
(host/blog-put! slug title (or (get gp "sx_content") "") (or (get gp "status") "published"))
|
||
(host/blog-relate! slug "article" "is-a")
|
||
(host/blog--set-field-values! slug
|
||
{"subtitle" (or (get gp "custom_excerpt") (get gp "excerpt") "")
|
||
"hero" (or (get gp "feature_image") "")})
|
||
(for-each
|
||
(fn (tag)
|
||
(let ((tslug (host/blog-slugify tag)))
|
||
(begin
|
||
(host/blog-seed! tslug tag (str "(article (h1 \"" tag "\"))") "published")
|
||
(host/blog-relate! tslug "tag" "is-a")
|
||
(host/blog-relate! slug tslug "tagged"))))
|
||
(or (get gp "tags") (list)))
|
||
;; cards-as-objects: decompose the Ghost body into card objects + a `contains`
|
||
;; body, so the post renders via the composition fold (its :body supersedes the
|
||
;; opaque sx_content). parse-safe degrades to nil on bad input -> decompose no-ops.
|
||
(host/blog--decompose! slug (parse-safe (or (get gp "sx_content") "")))
|
||
slug))))
|
||
;; Import a batch; returns the imported slugs.
|
||
(define host/blog-import-all!
|
||
(fn (posts) (map host/blog-import-post! posts)))
|
||
;; POST /import — the genesis-import endpoint. Body = a text/sx LIST of Ghost post dicts
|
||
;; (radar's Postgres reader serialises rows to this); imports each as a typed post.
|
||
;; -> {:ok true :data {:imported N :slugs (...)}}. Guarded (admin). Runs in the serving
|
||
;; handler (IO resolver installed) so the per-post / per-tag loops are JIT-safe.
|
||
(define host/blog-import-handler
|
||
(fn (req)
|
||
(let ((raw (dream-body req)))
|
||
(let ((posts (if (or (nil? raw) (= raw "")) (list) (sxtp/-normalize (parse-safe raw)))))
|
||
(if (= (type-of posts) "list")
|
||
(host/ok {:imported (len posts) :slugs (host/blog-import-all! posts)})
|
||
(host/error 400 "expected a text/sx list of Ghost post dicts"))))))
|
||
|
||
;; GET /<slug>/source — the raw sx_content as text/plain. Posts ARE SX source, so
|
||
;; this just hands back the stored markup (public; a published post's source is
|
||
;; not secret). 404 if the post is absent.
|
||
(define host/blog-source
|
||
(fn (req)
|
||
(let ((slug (dream-param req "slug")))
|
||
(let ((r (host/blog-get slug)))
|
||
(if r
|
||
(dream-response 200 {:content-type "text/plain; charset=utf-8"}
|
||
(or (get r :sx-content) ""))
|
||
(host/blog--resp req 404
|
||
(host/blog--page req "Not found"
|
||
(quasiquote (div (h1 "404") (p (unquote (str "No post: " slug))))))))))))
|
||
|
||
;; ── create page (GET /new) — clean minimal form as an SX tree ───────
|
||
;; No legacy JS editor, no external assets, no shims. The rich WYSIWYG is a
|
||
;; future native SX-island editor (Phase 5.2+). Posts to /new.
|
||
(define host/blog-new-form
|
||
(fn (req)
|
||
(host/blog--resp req 200
|
||
(host/blog--page req "New post"
|
||
(quasiquote
|
||
(div
|
||
(h1 "New post")
|
||
(form :method "post" :action "/new"
|
||
(p (input :name "title" :placeholder "Title"
|
||
:style "font-size:1.4em;width:100%"))
|
||
(p (textarea :name "sx_content" :rows "12"
|
||
:style "width:100%;font-family:monospace"
|
||
:placeholder "(p \"Your post as SX markup\")"))
|
||
(p (select :name "status"
|
||
(option :value "draft" "Draft")
|
||
(option :value "published" "Published"))
|
||
" "
|
||
(button :type "submit" "Publish")))
|
||
(p (a :href "/" "all posts"))))))))
|
||
|
||
;; ── write-time validation ───────────────────────────────────────────
|
||
;; sx_content must be storable as renderable SX: empty is allowed (an empty post),
|
||
;; otherwise it must parse. parse-safe returns nil on malformed input (the kernel
|
||
;; parser raises a native Parse_error an SX guard can't catch), so this rejects a
|
||
;; bad body at write time instead of letting it 500 on read. Mirrors the read-path
|
||
;; guard in host/blog-render — bad content never enters the durable store.
|
||
(define host/blog-content-ok?
|
||
(fn (sx)
|
||
(or (nil? sx) (= sx "") (not (nil? (parse-safe sx))))))
|
||
|
||
;; ── write handlers ──────────────────────────────────────────────────
|
||
;; POST /new — form-urlencoded ingest (the editor's submit shape: title,
|
||
;; sx_content, status, custom_excerpt, csrf_token). Slug derived from the title.
|
||
;; Redirects to the new post on success; rejects a missing title or unparseable
|
||
;; body with a 400 HTML page (this path serves a browser form).
|
||
(define host/blog-form-submit
|
||
(fn (req)
|
||
(let ((title (host/field req "title"))
|
||
(sx-content (host/field req "sx_content"))
|
||
(status (or (host/field req "status") "published")))
|
||
(cond
|
||
((or (nil? title) (= title ""))
|
||
(host/blog--resp req 400
|
||
(host/blog--page req "Error"
|
||
(quasiquote (div (h1 "Error") (p "Title is required.")
|
||
(p (a :href "/new" "Back")))))))
|
||
((not (host/blog-content-ok? sx-content))
|
||
(host/blog--resp req 400
|
||
(host/blog--page req "Error"
|
||
(quasiquote (div (h1 "Error") (p "Post body is not valid SX markup.")
|
||
(p (a :href "/new" "Back")))))))
|
||
(else
|
||
(let ((slug (host/blog-slugify title)))
|
||
(begin
|
||
(host/blog-put! slug title (or sx-content "") status)
|
||
(dream-redirect (str "/" slug "/")))))))))
|
||
|
||
;; The JSON CRUD /posts (create/update/delete) was DELETED in the greenfield
|
||
;; SX-native pivot (plans/relations-as-posts.md, "SX all the way out") — it was a
|
||
;; pure old-contract REST mirror. Create + edit go through the HTML editor forms
|
||
;; (POST /new, POST /:slug/edit); programmatic writes will speak SXTP. FOLLOW-UP:
|
||
;; there is no browser delete route yet (delete was JSON-only and had no UI) — add
|
||
;; POST /:slug/delete + cascade edge cleanup (drop every edge touching the slug,
|
||
;; both directions, all kinds) when the metamodel UI needs it.
|
||
|
||
;; POST /<slug>/relate — relate this post to another (form `other` = slug, `kind` =
|
||
;; relation kind, default "related"). Validated: kind must be a known kind and the
|
||
;; other post must exist and differ; otherwise a no-op. Redirects back to the edit
|
||
;; page. Guarded like the other browser write routes.
|
||
(define host/blog-relate-submit
|
||
(fn (req)
|
||
(let ((slug (dream-param req "slug"))
|
||
(other (host/field req "other"))
|
||
(kind (or (host/field req "kind") "related")))
|
||
(if (nil? (host/blog-get slug))
|
||
(host/blog--resp req 404
|
||
(host/blog--page req "Not found"
|
||
(quasiquote (div (h1 "404") (p (unquote (str "No post: " slug)))))))
|
||
(begin
|
||
;; …and `other` must satisfy the relation's TARGET-TYPE CONSTRAINT
|
||
;; (host/blog--valid-object?): you can only declare `slug is-a <a type>`,
|
||
;; tag with `<a tag>`, etc. The picker never offers an invalid target, so
|
||
;; this enforces the same schema against crafted/API requests; an invalid
|
||
;; relate is a silent no-op (consistent with the other guards here).
|
||
(when (and other (not (= other "")) (not (= other slug))
|
||
(host/blog--kind-spec kind) (host/blog-exists? other)
|
||
(host/blog--valid-object? kind other))
|
||
(host/blog-relate! slug other kind))
|
||
;; AJAX (the picker's sx-post, carries SX-Target): return the re-rendered
|
||
;; editor for this kind so its sx-swap="outerHTML" replaces #rel-editor-KIND
|
||
;; — the just-related post shows in the current list and the picker refreshes
|
||
;; its candidates. text/html so the client's DOMParser swap path renders the
|
||
;; already-expanded fragment. Plain boosted form / no-JS still redirects.
|
||
(if (host/blog--editor-swap-req? req)
|
||
(dream-html (render-page (host/blog--relation-editor slug kind true)))
|
||
(dream-redirect (str "/" slug "/edit"))))))))
|
||
|
||
;; POST /<slug>/unrelate — remove the relation to `other` under `kind` (default
|
||
;; "related"). Idempotent.
|
||
(define host/blog-unrelate-submit
|
||
(fn (req)
|
||
(let ((slug (dream-param req "slug"))
|
||
(other (host/field req "other"))
|
||
(kind (or (host/field req "kind") "related")))
|
||
(begin
|
||
(when (and other (not (= other "")) (host/blog--kind-spec kind))
|
||
(host/blog-unrelate! slug other kind))
|
||
;; AJAX remove (the editor's sx-post, carries SX-Target): return the
|
||
;; re-rendered editor for this kind so its sx-swap="outerHTML" replaces
|
||
;; #rel-editor-KIND — the row leaves the current list, the post returns to the
|
||
;; (re-loaded) candidate pool, and the picker is NOT cleared. A plain boosted
|
||
;; form (the tag toggle) or a no-JS POST still redirects + re-renders #content.
|
||
(if (host/blog--editor-swap-req? req)
|
||
(dream-html (render-page (host/blog--relation-editor slug kind true)))
|
||
(dream-redirect (str "/" slug "/edit")))))))
|
||
|
||
;; POST /<slug>/blocks/add|remove|move — structural edits to the post :body. Each does the
|
||
;; durable op then returns the re-rendered #block-editor (AJAX swap) or redirects (no-JS).
|
||
(define host/blog--block-resp
|
||
(fn (req slug)
|
||
(if (host/blog--editor-swap-req? req)
|
||
(dream-html (render-page (host/blog--block-editor slug)))
|
||
(dream-redirect (str "/" slug "/edit")))))
|
||
(define host/blog--block-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"))
|
||
(ctype (or (host/field req "ctype") "card-text"))
|
||
(text (or (host/field req "text") "")))
|
||
(begin
|
||
;; ctype must be a card type — a subtype of "card" (card types are linked by
|
||
;; subtype-of, NOT is-a, so the down-closure of "card" is the valid set).
|
||
(when (and (host/blog-exists? slug)
|
||
(contains? (host/blog--subtype-closure (list "card") :in) ctype))
|
||
(host/blog-block-add! slug ctype
|
||
(if (= ctype "card-heading") {"level" "2" "text" text} {"text" text})))
|
||
(host/blog--block-resp req slug)))))
|
||
(define host/blog-block-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")))
|
||
(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")) (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
|
||
;; sx_content (in a textarea — render-to-html escapes the text child, so the
|
||
;; browser shows the source verbatim), and status (current value pre-selected).
|
||
;; Guarded: only an editor reaches the editor. Keeps the slug (edits don't re-slug).
|
||
(define host/blog-edit-form
|
||
(fn (req)
|
||
(let ((slug (dream-param req "slug")))
|
||
(let ((r (host/blog-get slug)))
|
||
(if (nil? r)
|
||
(host/blog--resp req 404
|
||
(host/blog--page req "Not found"
|
||
(quasiquote (div (h1 "404") (p (unquote (str "No post: " slug)))))))
|
||
(let ((status (get r :status)))
|
||
;; the relation editors + tag toggle do durable reads — compute them
|
||
;; here, not in the quasiquote, so IO stays in the handler body.
|
||
(let ((relation-editors (host/blog--relation-editors slug))
|
||
(block-editor (host/blog--block-editor slug))
|
||
(tag-toggle (host/blog--is-tag-toggle slug))
|
||
(post-fields (host/blog--fields-for-post slug))
|
||
(field-values (host/blog-field-values-of slug))
|
||
(mk-opt
|
||
(fn (val label)
|
||
(if (= val status)
|
||
(quasiquote (option :value (unquote val) :selected "selected" (unquote label)))
|
||
(quasiquote (option :value (unquote val) (unquote label)))))))
|
||
(host/blog--resp req 200
|
||
(host/blog--page req (str "Edit: " (get r :title))
|
||
(quasiquote
|
||
(div
|
||
(h1 (unquote (str "Edit: " (get r :title))))
|
||
(form :method "post" :action (unquote (str "/" slug "/edit"))
|
||
(p (input :name "title" :value (unquote (get r :title))
|
||
:style "font-size:1.4em;width:100%"))
|
||
(p (textarea :name "sx_content" :rows "16"
|
||
:style "width:100%;font-family:monospace"
|
||
(unquote (or (get r :sx-content) ""))))
|
||
(unquote (if (> (len post-fields) 0)
|
||
(cons (quote div)
|
||
(cons (quote (h3 :style "font-size:1em;margin:1em 0 0.3em" "Fields"))
|
||
(host/blog--field-inputs post-fields field-values)))
|
||
""))
|
||
(p (select :name "status"
|
||
(unquote (mk-opt "draft" "Draft"))
|
||
(unquote (mk-opt "published" "Published")))
|
||
" "
|
||
(button :type "submit" "Save")))
|
||
(div :style "margin-top:2em;border-top:1px solid #ccc;padding-top:1em"
|
||
(unquote tag-toggle))
|
||
(unquote block-editor)
|
||
(unquote relation-editors)
|
||
(p :style "margin-top:1.5em"
|
||
(a :href (unquote (str "/" slug "/")) "view post")
|
||
" · "
|
||
(a :href (unquote (str "/" slug "/source")) "view source")))))))))))))
|
||
|
||
;; POST /<slug>/edit — save the edited source. Same write-time validation as the
|
||
;; create paths (unparseable body -> 400, post left intact). Slug is preserved.
|
||
(define host/blog-edit-submit
|
||
(fn (req)
|
||
(let ((slug (dream-param req "slug")) (r (host/blog-get (dream-param req "slug"))))
|
||
(if (nil? r)
|
||
(host/blog--resp req 404
|
||
(host/blog--page req "Not found"
|
||
(quasiquote (div (h1 "404") (p (unquote (str "No post: " slug)))))))
|
||
(let ((title (or (host/field req "title") (get r :title)))
|
||
(sx-content (or (host/field req "sx_content") ""))
|
||
(status (or (host/field req "status") (get r :status)))
|
||
(post-fields (host/blog--fields-for-post slug)))
|
||
;; collect issues up front (perform): unparseable markup, then each
|
||
;; schema requirement the post's types impose. Empty = save.
|
||
(let ((issues (if (host/blog-content-ok? sx-content)
|
||
(host/blog-type-issues slug sx-content)
|
||
(list "Post body is not valid SX markup."))))
|
||
(if (= (len issues) 0)
|
||
(begin
|
||
(host/blog-put! slug title sx-content status)
|
||
;; store the typed field values from the generic, type-driven form (Slice 8b)
|
||
(host/blog--set-field-values! slug
|
||
(reduce (fn (acc f)
|
||
(assoc acc (get f :name)
|
||
(or (host/field req (str "field-" (get f :name))) "")))
|
||
{} post-fields))
|
||
(dream-redirect (str "/" slug "/")))
|
||
(let ((issue-items (map (fn (i) (quasiquote (li (unquote i)))) issues)))
|
||
(host/blog--resp req 400
|
||
(host/blog--page req "Cannot save"
|
||
(quasiquote
|
||
(div (h1 "Cannot save")
|
||
(p "This post can't be saved yet:")
|
||
(unquote (cons (quote ul) issue-items))
|
||
(p (a :href (unquote (str "/" slug "/edit")) "Back"))))))))))))))
|
||
|
||
;; ── routes ──────────────────────────────────────────────────────────
|
||
;; Public reads + the create form. /, /posts, /new BEFORE /:slug (catch-all).
|
||
;; MUST be mounted LAST in the app so domain routes (/feed, /health) win.
|
||
(define host/blog-routes
|
||
(list
|
||
(dream-get "/" host/blog-home)
|
||
(dream-get "/posts" host/blog-index)
|
||
(dream-get "/new" host/blog-new-form)
|
||
(dream-get "/tags" host/blog-tags-index)
|
||
(dream-get "/meta" host/blog-meta-index)
|
||
(dream-get "/workflow-demo" host/blog-workflow-demo)
|
||
(dream-get "/:slug/source" host/blog-source)
|
||
(dream-get "/:slug/relate-options" host/blog-relate-options)
|
||
(dream-get "/:slug" host/blog-post)))
|
||
|
||
;; Guarded writes: HTML editor form ingest behind auth+ACL. (The JSON CRUD that
|
||
;; used a bearer-based host/blog--protect was deleted in the SX-native pivot.)
|
||
;; Browser gate: identical ACL, but an unauthenticated request REDIRECTS
|
||
;; to the login page (host/require-login) rather than returning a raw JSON 401 —
|
||
;; the form/edit pages are HTML, so a logged-out click should land on /login and
|
||
;; return here afterwards.
|
||
(define host/blog--protect-html
|
||
(fn (resolve h)
|
||
(host/pipeline
|
||
(list
|
||
host/wrap-errors
|
||
(host/require-login resolve)
|
||
(host/require-permission "edit" (fn (req) "blog")))
|
||
h)))
|
||
(define host/blog-write-routes
|
||
(fn (resolve)
|
||
(list
|
||
(dream-post "/new" (host/blog--protect-html resolve host/blog-form-submit))
|
||
(dream-get "/:slug/edit" (host/blog--protect-html resolve host/blog-edit-form))
|
||
(dream-post "/:slug/edit" (host/blog--protect-html resolve host/blog-edit-submit))
|
||
(dream-post "/:slug/blocks/add" (host/blog--protect-html resolve host/blog-block-add-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))
|
||
(dream-post "/meta/new-relation" (host/blog--protect-html resolve host/blog-meta-new-relation))
|
||
(dream-post "/import" (host/blog--protect-html resolve host/blog-import-handler)))))
|
||
|
||
;; EXPERIMENTAL: create-only, UNGUARDED — POST /new form ingest with error
|
||
;; trapping but NO auth, for validating the editor->host publish loop on the
|
||
;; experimental subdomain. Create-only by design (no PUT/DELETE), so the worst
|
||
;; case is junk posts, not overwrite/delete. GATE before any real use.
|
||
(define host/blog-open-create-routes
|
||
(list
|
||
(dream-post "/new" (host/pipeline (list host/wrap-errors) host/blog-form-submit))))
|