coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
ee4dbf3be9bc7613478de0cd8ffc6d9a6de944dc
rose-ash/lib/host/blog.sx
giles ee4dbf3be9 offering editor: per-showing ticket types with prices + per-offering caps 
Each showing's offerings are now independently editable — the 'some / all / extra + special offer,
different prices, different caps' from the cinema model.

- host/blog--offering-editor: a collapsible '⚙ Manage offerings' panel on the showing page — per
  offering an inline price+cap Save form and a Remove button, plus an Add-offering form.
- host/blog-offering-update: edit an offering's price + cap.
- host/blog-offering-remove: unlink an offering from the showing (sold tickets keep their record).
- host/blog-offering-add: add an offering, CREATING the ticket type first if new (e.g. special-offer
  → seeds the ticket-type + is-a). host/blog--offering-showing resolves the parent showing.
- Per-offering CAP enforcement: host/blog--offering-available? (offering sold < its cap, else only the
  showing capacity limits it). buy-ticket checks it and tallies offering --sold--> ticket per offering;
  the tickets section shows 'type — £price (sold/cap)'.

This covers the layout-style variable caps too (seated / tables / standing = per-offering caps).

LIVE: on the Dune showing — set adult £12 cap 2, added special-offer £5 cap 1, removed u18; buying the
special-offer twice yields 1/1 sold (second blocked). blog 218/218.

Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
2026-07-03 08:43:31 +00:00

3505 lines
209 KiB
Plaintext
Raw Blame History

This file contains ambiguous Unicode characters
This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
;; 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))))
;; ── business logic as federated composition-flows (plans/business-logic-fed-flows.md) ──
;; P0.1/P0.4: the PUBLISH-ACTIVITY contract, in the CANONICAL SEAM SHAPE
;; {:verb :actor :object <cid> :object-type :slug :category :delta :id} — :object is a
;; content-addressed REFERENCE (the CID), not an inlined dict; :id is the dedup identity; :slug +
;; :category are the domain fields the publish-DAG's ctx reads. Each runner adapter MARSHALS this
;; to its substrate (host/blog--activity->erl → next/'s proplist for the Erlang runner, RA).
;; category (the DAG's branch: newsletter/urgent/else) comes from the "category" field-value, else
;; the first tag, else "urgent".
(define host/blog--post-category
(fn (slug)
(let ((fc (get (host/blog-field-values-of slug) "category")))
(if (and fc (not (= fc ""))) fc
(let ((tags (host/blog-out slug "tagged")))
(if (> (len tags) 0) (first tags) "urgent"))))))
;; a post's primary type (its first is-a), for the activity :object-type. Default "article".
(define host/blog--post-type
(fn (slug) (let ((ts (host/blog-out slug "is-a"))) (if (empty? ts) "article" (first ts)))))
;; P2: a CONTENT activity (Create on first publish, Update on a subsequent published edit). :id is
;; verb-namespaced (create:/update:) over the CID — per-EVENT identity, so an update never collides
;; with the create (DEBT #1 for content; relation events use an edge-based id below).
(define host/blog--content-activity
(fn (slug verb)
(let ((r (host/blog-get slug)))
(if (nil? r) nil
(let ((cid (host/blog-cid slug)))
{:verb verb :actor host/blog--actor
:object cid :object-type (host/blog--post-type slug)
:slug slug :category (host/blog--post-category slug)
:delta verb :id (str verb ":" cid)})))))
;; publishing = a Create content activity (the on-publish behavior binds to verb "create").
(define host/blog--publish-activity (fn (slug) (host/blog--content-activity slug "create")))
;; P2: a RELATION activity (Add/Remove). The object is the SUBJECT; the edge (kind→target) is carried
;; explicitly. :id is EDGE-based (DEBT #1) — a relation change doesn't shift the CID, so a CID-based
;; id would false-dedup across different edges on the same object.
(define host/blog--relation-activity
(fn (verb src kind dst)
{:verb verb :actor host/blog--actor
:object src :object-type (host/blog--post-type src)
:relation kind :target dst
:delta (str verb " " kind " " dst)
:id (str verb ":" src ":" kind ":" dst)}))
;; ── CROSS-DOMAIN (events): allocate a post to a calendar — a DIRECTED activity (:to the events peer).
;; It federates to events, whose calendar type declares an on-allocate behavior that links it.
(define host/blog--events-base "") ;; the events peer base URL (serve-set from SX_EVENTS_BASE)
(define host/blog--set-events-base! (fn (b) (set! host/blog--events-base b)))
(define host/blog--shop-base "") ;; the shop peer base URL (serve-set from SX_SHOP_BASE)
(define host/blog--set-shop-base! (fn (b) (set! host/blog--shop-base b)))
(define host/blog--identity-base "") ;; the identity peer base URL (serve-set from SX_IDENTITY_BASE)
(define host/blog--set-identity-base! (fn (b) (set! host/blog--identity-base b)))
;; buy a ticket for an event: a directed cross-domain call to the shop (POST /order/<event>) that
;; creates an order and returns "order:<id>"; we then link event--sold-->order. (Synchronous cross-
;; domain call, like the RA kernel — not everything is a federated activity; directed reads/writes
;; are fine.)
(define host/blog--http-order
(fn (event) (get (http-request "POST" (str host/blog--shop-base "/order?event=" event) {} "") "body")))
(define host/blog--allocate-activity
(fn (post calendar)
{:verb "allocate" :actor host/blog--actor
:object post :object-type (host/blog--post-type post) :slug post
:target calendar :to host/blog--events-base
:delta (str "allocate to " calendar) :id (str "allocate:" post ":" calendar)}))
;; the UI form to allocate THIS post to a calendar on the events peer (shown only when a peer is set).
(define host/blog--allocate-form
(fn (slug)
(if (= host/blog--events-base "") ""
(quasiquote
(form :method "post" :action (unquote (str "/" slug "/allocate"))
:style "margin:1.5em 0;padding:0.7em 1em;border:1px dashed #b9a;background:#fbf7fb;border-radius:4px;font-size:0.9em"
(b "📅 Allocate to a calendar: ")
(input :name "calendar" :value "main" :style "width:8em")
" " (button :type "submit" "Allocate on events")
" " (a :href "https://events.rose-ash.com/calendars" "→ view on events"))))))
;; MARSHAL the canonical activity → next/'s Erlang proplist shape, for the Erlang runner adapter
;; (RA). The seam activity is canonical; each runner adapter maps it to its substrate. Unused until
;; RA, defined + tested here so the reconcile is complete and RA has its bridge ready.
(define host/blog--activity->erl
(fn (a)
{:type (get a :verb)
:actor (get a :actor)
:id (get a :id)
:object {:type (get a :object-type) :slug (get a :slug) :category (get a :category)}}))
;; P0.2: the publish WORKFLOW as an EXECUTE-FOLD composition (host/execute.sx) — the SYNCHRONOUS
;; business flow. Validate, then BRANCH on category (newsletter → build a digest, urgent → notify
;; now, else skip). Content flow (effect/alt), NOT dataflow — so it's the execute-fold, not artdag.
;; Its required capabilities are {effect, branch} (host/flow--required-caps) → binds to the sync
;; execute-fold runner (which advertises {effect, branch, each}). A `wait` node would add {suspend}
;; and fail-fast against that runner (requiring the Erlang runner, RA). Runs against a ctx built
;; from the activity's object.
(define host/blog--publish-dag
(quote (seq
(effect validate (field "slug"))
(alt (when (eq "category" "newsletter") (effect digest (field "slug")))
(when (eq "category" "urgent") (effect notify (field "slug")))
(else (effect skip))))))
;; the ctx a publish activity presents to the publish-DAG (string keys — preds read ctx by key).
;; Reads the canonical activity's top-level :category + :slug (P0.4).
(define host/blog--publish-ctx
(fn (activity) {"category" (get activity :category) "slug" (get activity :slug)
"target" (get activity :target) "verb" (get activity :verb)}))
;; ── P1: types DECLARE behavior; the runner is DERIVED from the DAG's capabilities ──────
;; A type-post carries :behavior = a list of flat string-keyed bindings {"verb" "type" "dag"} (like
;; :type-relations). At boot they're gathered into a registry the trigger match consults. :dag NAMES
;; a registered behavior DAG; the runner is chosen by host/flow--select-runner over the fleet — an
;; {effect,branch} composition → exec-runner; a {suspend} DAG → RA once RA-live adds it to the fleet.
(define host/blog--dag-registry {"publish" host/blog--publish-dag}) ;; name -> behavior DAG
(define host/blog--dag-of (fn (name) (get host/blog--dag-registry name)))
(define host/blog--register-dag! (fn (name dag) (set! host/blog--dag-registry (assoc host/blog--dag-registry name dag))))
;; the runner fleet, cheapest-first. exec-runner locally; serve.sh appends the KERNEL runner (RA-live)
;; so a {suspend} DAG routes to the durable kernel. host/blog--kernel-base is the kernel URL (serve-set).
(define host/blog--runner-fleet (list host/flow--exec-runner))
(define host/blog--add-runner! (fn (r) (set! host/blog--runner-fleet (concat host/blog--runner-fleet (list r)))))
(define host/blog--kernel-base "")
;; ── the ACTOR MODEL — who WE are + who FOLLOWS us (fed-sx delivery is FOLLOWER-based, not a static
;; peer list). An emitted activity carries our :actor and delivers to our followers' inboxes. A peer
;; FOLLOWS us by POSTing a {verb:follow, actor, base} to our /inbox; we add it to our followers.
(define host/blog--actor "site") ;; our actor id (serve-set from SX_ACTOR)
(define host/blog--self-base "") ;; our base URL — followers POST to <base>/inbox (serve-set)
(define host/blog--set-actor! (fn (a base) (begin (set! host/blog--actor a) (set! host/blog--self-base base))))
(define host/blog--followers (list)) ;; [{actor, base}] — who follows us (we deliver here)
(define host/blog--followers-key "followers")
(define host/blog-load-followers!
(fn () (let ((v (persist/backend-kv-get host/blog-store host/blog--followers-key)))
(when (and v (= (type-of v) "list")) (set! host/blog--followers v)))))
(define host/blog--follows? (fn (base) (some (fn (f) (= (get f "base") base)) host/blog--followers)))
(define host/blog--add-follower!
(fn (actor base)
(when (and base (not (= base "")) (not (host/blog--follows? base)))
(begin (set! host/blog--followers (concat host/blog--followers (list {"actor" actor "base" base})))
(persist/backend-kv-put host/blog-store host/blog--followers-key host/blog--followers)))))
(define host/blog--delivery-bases (fn () (map (fn (f) (get f "base")) host/blog--followers)))
;; the actor we follow at boot / on each tick (serve-set from SX_FOLLOW; idempotent re-follow).
(define host/blog--follow-target "")
(define host/blog--set-follow-target! (fn (t) (set! host/blog--follow-target t)))
;; ── federation SIGNATURE: every POST we send is signed (shared-secret MAC over the body); /inbox
;; verifies before accepting. An empty secret disables verification (back-compat / open demo). ──
(define host/blog--fed-secret "")
(define host/blog--set-fed-secret! (fn (s) (set! host/blog--fed-secret s)))
(define host/blog--fed-sign (fn (body) (if (= host/blog--fed-secret "") "" (dr/sess-sig host/blog--fed-secret body))))
;; POST a wire to a peer's /inbox WITH a signature header (may raise; callers guard).
(define host/blog--fed-post
(fn (base wire)
(http-request "POST" (str base "/inbox")
{"content-type" "text/plain" "x-fed-sig" (host/blog--fed-sign wire)} wire)))
;; verify an inbound POST's signature (accept if no secret configured, else require a matching MAC).
(define host/blog--fed-verify?
(fn (req body)
(or (= host/blog--fed-secret "")
(= (str (or (dream-header req "x-fed-sig") "")) (dr/sess-sig host/blog--fed-secret body)))))
;; FOLLOW another actor: POST a follow to its /inbox announcing OUR actor + base, so it delivers to us.
(define host/blog--follow!
(fn (target-base)
(guard (e (true false))
(begin (host/blog--fed-post target-base (serialize {"verb" "follow" "actor" host/blog--actor "base" host/blog--self-base})) true))))
;; per-type behavior declaration, stored on the type-post (string-keyed → persist-safe).
(define host/blog--type-behavior (fn (type) (or (get (host/blog-get type) :behavior) (list))))
(define host/blog--set-type-behavior!
(fn (type bindings)
(let ((r (host/blog-get type))) (when r (host/blog--write! type (merge r {:behavior bindings}))))))
;; the behavior REGISTRY: every declared binding, gathered at boot (like load-edges!). Scans ALL
;; posts for a :behavior declaration — robust to is-type? state differences across the durable store
;; (a post without :behavior contributes nothing).
(define host/blog--behaviors (list))
(define host/blog--load-behaviors!
(fn ()
(set! host/blog--behaviors
(reduce (fn (acc t) (concat acc (host/blog--type-behavior t)))
(list) (host/blog-slugs)))))
;; match an activity against the registry → resolved bindings {:dag :runner}, runner DERIVED by caps.
;; (A binding whose DAG needs a capability no fleet runner has is SKIPPED — a soft bind failure.)
(define host/blog--match-behaviors
(fn (activity)
(reduce
(fn (acc b)
(if (and (= (get b "verb") (get activity :verb))
(= (get b "type") (get activity :object-type)))
(let ((dag (host/blog--dag-of (get b "dag"))))
(let ((runner (host/flow--select-runner host/blog--runner-fleet dag)))
(if (nil? runner) acc (concat acc (list {:dag dag :runner runner})))))
acc))
(list) host/blog--behaviors)))
;; ── P0.3: the seam WIRED on the live host ──────────────────────────────
;; The publish ENGINE = the execute-fold runner (flows.sx) + a local-SX on-publish trigger registry
;; + an in-process transport (the activity log = the event source) + the host driver (records each
;; effect in the flow log). Publishing a post (draft→published, fire-once) builds the activity and
;; runs it through behavior/process → the DAG's effects surface on /flows. In-memory logs for P0
;; (durable-store backing is the follow-up). Every piece is a seam adapter — swap the runner for
;; Erlang (RA) or the transport for fed-sx (TA) and this same wiring federates, unchanged.
(define host/blog--activity-log (list)) ;; every activity emitted (the event source)
(define host/blog--flow-log (list)) ;; what the flows DID (the driver's effect records)
(define host/blog--activitylog-key "activitylog")
;; P2: the transport LOGS every emitted activity DURABLY — a string-keyed record (verb/object/type/
;; delta/id, dodging the keyword/persist split), so /activities survives a restart. This is the
;; federated EVENT SOURCE; TA (fed-sx transport) will additionally push these to peers.
(define host/blog--transport
{:emit (fn (a)
(begin
(set! host/blog--activity-log
(concat host/blog--activity-log
(list {"verb" (get a :verb) "object" (get a :object) "type" (get a :object-type)
"delta" (get a :delta) "id" (get a :id)})))
(persist/backend-kv-put host/blog-store host/blog--activitylog-key host/blog--activity-log)))
:deliver (fn () (list))}) ;; nothing inbound yet — synchronous, local
;; P1: the trigger match consults the behavior REGISTRY (built from types' declarations), and each
;; matched binding carries its DERIVED runner (capability selection). Was a hardcoded create+article.
(define host/blog--triggers
{:register! (fn (spec dag hint) nil)
:match host/blog--match-behaviors})
;; P0.3b: the flow log is DURABLE — string-keyed records (dodge the keyword/persist top-level split),
;; persisted to the blog store under one key, so /flows survives a restart. Boot-loaded via
;; host/blog-load-flowlog!. (Whole-list rewrite per effect — fine at P0 volume; cap/rotate later.)
(define host/blog--flowlog-key "flowlog")
;; the DRIVER dispatches effect-as-data. Beyond logging, it PERFORMS known action-effects (closing
;; the loop — P4): a `relate` effect {:args (src kind dst)} mutates the relation graph, so a behavior
;; can create real cross-domain links (the events calendar behavior relates calendar→post).
(define host/blog--driver
{:dispatch (fn (eff)
(begin
(when (= (get eff :verb) "relate")
(let ((a (get eff :args)))
(host/blog-relate! (first a) (first (rest (rest a))) (first (rest a)))))
(set! host/blog--flow-log
(concat host/blog--flow-log (list {"verb" (get eff :verb) "args" (get eff :args)})))
(persist/backend-kv-put host/blog-store host/blog--flowlog-key host/blog--flow-log)
(list)))}) ;; record the effect (durably); no follow-up activities (P0)
;; rebuild the in-memory flow log from the durable store (call on boot, like host/blog-load-edges!).
(define host/blog-load-flowlog!
(fn ()
(let ((v (persist/backend-kv-get host/blog-store host/blog--flowlog-key)))
(when (and v (= (type-of v) "list")) (set! host/blog--flow-log v)))))
;; P2: rebuild the activity log (the event source) from the durable store on boot.
(define host/blog-load-activitylog!
(fn ()
(let ((v (persist/backend-kv-get host/blog-store host/blog--activitylog-key)))
(when (and v (= (type-of v) "list")) (set! host/blog--activity-log v)))))
(define host/blog--publish-engine
(behavior/make-engine {:triggers host/blog--triggers :runner host/flow--exec-runner
:transport host/blog--transport :driver host/blog--driver
:ctx-of host/blog--publish-ctx}))
;; RA-live: suspended durable instances awaiting resume (the async boundary). Durable, string-keyed.
(define host/blog--pending-log (list))
(define host/blog--pendinglog-key "pendinglog")
(define host/blog--record-pending!
(fn (a s)
(let ((rec {"id" (get (get s :resume) :id) "slug" (or (get a :slug) "")
"verb" (get a :verb) "category" (or (get a :category) "")}))
(begin
(set! host/blog--pending-log (concat host/blog--pending-log (list rec)))
(persist/backend-kv-put host/blog-store host/blog--pendinglog-key host/blog--pending-log)))))
(define host/blog--drop-pending!
(fn (id)
(begin
(set! host/blog--pending-log (filter (fn (p) (not (= (get p "id") id))) host/blog--pending-log))
(persist/backend-kv-put host/blog-store host/blog--pendinglog-key host/blog--pending-log))))
(define host/blog-load-pendinglog!
(fn ()
(let ((v (persist/backend-kv-get host/blog-store host/blog--pendinglog-key)))
(when (and v (= (type-of v) "list")) (set! host/blog--pending-log v)))))
;; P2/TA-live: process an activity through the seam locally (fire behaviors + record suspensions).
;; Shared by emit! (our own state changes) and receive! (a peer's, arriving via /inbox).
(define host/blog--process-local!
(fn (a)
(let ((tr (behavior/process host/blog--publish-engine a)))
(begin (for-each (fn (s) (host/blog--record-pending! a s)) (get tr :suspended)) tr))))
;; ── TA-live: the durable OUTBOX (fed-sx reliability) ──────────────────
;; Emitted activities are QUEUED per-peer (durable) and delivered BEST-EFFORT. A peer being DOWN
;; does NOT fail the local emit — delivery is GUARDED, and a failed item stays queued for retry (on
;; the next emit + on boot). This is the ActivityPub/fed-sx model, vs the fragile direct POST.
(define host/blog--outbox (list)) ;; pending {peer, wire} deliveries
(define host/blog--outbox-key "outbox")
(define host/blog-load-outbox!
(fn () (let ((v (persist/backend-kv-get host/blog-store host/blog--outbox-key)))
(when (and v (= (type-of v) "list")) (set! host/blog--outbox v)))))
(define host/blog--outbox-persist! (fn () (persist/backend-kv-put host/blog-store host/blog--outbox-key host/blog--outbox)))
(define host/blog--enqueue-outbox!
(fn (a)
(let ((targets (host/flow--uniq-concat (host/blog--delivery-bases)
(if (and (get a :to) (not (= (get a :to) ""))) (list (get a :to)) (list)))))
(begin
(for-each (fn (base) (set! host/blog--outbox
(concat host/blog--outbox (list {"peer" base "wire" (host/ta--serialize a)}))))
targets)
(host/blog--outbox-persist!)))))
;; guarded, SIGNED delivery: POST the wire; a connection failure returns false (item kept), never raises.
(define host/blog--try-deliver
(fn (peer wire) (guard (e (true false)) (begin (host/blog--fed-post peer wire) true))))
;; deliver every pending item; KEEP the ones that failed (peer down) for the next retry.
(define host/blog--flush-outbox!
(fn ()
(begin
(set! host/blog--outbox
(filter (fn (item) (not (host/blog--try-deliver (get item "peer") (get item "wire")))) host/blog--outbox))
(host/blog--outbox-persist!))))
;; EMIT our own state change: process locally (ALWAYS succeeds), QUEUE to the outbox, best-effort flush.
(define host/blog--emit!
(fn (a)
(if (nil? a) nil
(let ((tr (host/blog--process-local! a)))
(begin (host/blog--enqueue-outbox! a) (host/blog--flush-outbox!) tr)))))
;; RECEIVE a peer's activity: process locally only — do NOT re-federate (avoids federation loops).
(define host/blog--receive! (fn (a) (if (nil? a) nil (host/blog--process-local! a))))
;; a slug's content CHANGE → the right verb: draft→published = Create (first publish); published→
;; published = Update (a subsequent edit). Draft↔draft emits nothing (unobservable). Fire-once on the
;; create transition; an identical re-edit dedups (same verb:cid id).
(define host/blog--emit-content-change!
(fn (slug prev-status new-status)
(cond
((and (not (= prev-status "published")) (= new-status "published"))
(host/blog--emit! (host/blog--content-activity slug "create")))
((and (= prev-status "published") (= new-status "published"))
(host/blog--emit! (host/blog--content-activity slug "update")))
(else nil))))
;; back-compat alias: the publish transition (create). Kept for the write-path call sites + tests.
(define host/blog--maybe-publish!
(fn (slug prev-status new-status) (host/blog--emit-content-change! slug prev-status new-status)))
;; a relation change → an Add/Remove activity (edge referenced, no CID shift).
(define host/blog--emit-relation!
(fn (verb src kind dst) (host/blog--emit! (host/blog--relation-activity verb src kind dst))))
;; CROSS-DOMAIN: allocate a post to a calendar on the events peer (directed :to → federates to events).
(define host/blog--allocate! (fn (post calendar) (host/blog--emit! (host/blog--allocate-activity post calendar))))
;; ── 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))))))
;; unfiltered outgoing edges — includes CROSS-DOMAIN targets (a post/order on another peer, which
;; isn't a local slug so host/blog-out would drop it). Used for federated links (allocated, sold).
(define host/blog--out-raw
(fn (slug kind)
(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))))
;; the COMPOSITION fields an object has — the fields its (transitive) types declare with
;; :type "Composition" (each edited by its own block editor). Default ["body"] if a type
;; declares none, so every object still has one root composition. This is layer 2: "types
;; declare which fields are compositions" (the schema for the object's structure).
(define host/blog--composition-fields
(fn (slug)
(let ((cf (reduce (fn (acc f) (if (= (get f :type) "Composition") (concat acc (list (str (get f :name)))) acc))
(list) (host/blog--fields-for-post slug))))
(if (empty? cf) (list "body") cf))))
;; the SCALAR (non-composition) fields — the generic edit form's inputs (compositions get a
;; block editor instead of a text input).
(define host/blog--scalar-fields
(fn (slug) (filter (fn (f) (not (= (get f :type) "Composition"))) (host/blog--fields-for-post slug))))
;; ── type-block GRAMMAR (layer 2b): a Composition field declares which block kinds it may
;; contain. {:name "body" :type "Composition" :blocks (…card types…) :allow ("cond" "each")}.
;; :blocks absent -> every card subtype (back-compat); :allow absent -> both control blocks. --
(define host/blog--field-decl
(fn (slug field)
(let loop ((fs (host/blog--fields-for-post slug)))
(cond ((empty? fs) nil)
((= (str (get (first fs) :name)) field) (first fs))
(else (loop (rest fs)))))))
;; the card types a field permits (its :blocks, else all subtypes of "card").
(define host/blog--allowed-blocks
(fn (slug field)
(let ((d (host/blog--field-decl slug field)))
(if (and d (get d :blocks)) (get d :blocks) (host/blog--subtype-closure (list "card") :in)))))
;; whether a control block ("cond"/"each") is permitted in a field (its :allow, else both).
(define host/blog--allows-control?
(fn (slug field kind)
(let ((d (host/blog--field-decl slug field)))
(if (and d (get d :allow)) (contains? (get d :allow) kind) true))))
;; whether a specific card type may be added to a field (grammar check for the add handler).
(define host/blog--block-allowed?
(fn (slug field ctype) (contains? (host/blog--allowed-blocks slug field) ctype)))
;; a short editor label for a card type: strip the "card-" prefix.
(define host/blog--card-label
(fn (ct) (if (starts-with? ct "card-") (substr ct 5) ct)))
;; grammar violations of a field's current composition (empty = valid): card nodes whose type
;; isn't permitted, control blocks that aren't allowed. Used on save/import.
(define host/blog--comp-violations
(fn (slug field)
(reduce
(fn (acc node)
(let ((k (host/blog--node-kind node)))
(cond
((= k "card")
(let ((ct (host/blog--primary-card-type (host/blog--resolve-ref (str (first (rest node))) {"container" slug}))))
(if (host/blog--block-allowed? slug field ct) acc
(concat acc (list (str "block ‘" ct "’ is not allowed in :" field))))))
((or (= k "cond") (= k "each"))
(if (host/blog--allows-control? slug field k) acc
(concat acc (list (str "‘" k "’ blocks are not allowed in :" field)))))
(else acc))))
(list) (host/blog--comp-nodes slug field))))
;; ── Part B: RELATIONS are governed by the type too — related / is-a / subtype-of / tagged are
;; part of the object's composition (external — NOT in the CID), and the type declares which
;; relation kinds its instances may use (:type-relations). Absent -> all kinds (back-compat). --
(define host/blog--all-rel-kinds (fn () (map (fn (s) (get s :kind)) host/blog-rel-kinds)))
(define host/blog--type-relations (fn (type) (get (host/blog-get type) :type-relations)))
(define host/blog--set-type-relations!
(fn (type kinds)
(let ((r (host/blog-get type))) (when r (host/blog--write! type (merge r {:type-relations kinds}))))))
;; the relation kinds a post may use = the union its types declare (:type-relations); if no
;; type declares any, every registered kind (so metamodel types keep full freedom by default).
(define host/blog--allowed-relations
(fn (slug)
(let ((declared (reduce (fn (acc t) (let ((r (host/blog--type-relations t)))
(if r (host/blog--uniq (concat acc r)) acc)))
(list) (host/blog-types-of slug))))
(if (empty? declared) (host/blog--all-rel-kinds) declared))))
(define host/blog--relation-allowed? (fn (slug kind) (contains? (host/blog--allowed-relations slug) kind)))
;; ── Part C: the TYPE DEFINITION is itself editable — a type's :fields (each with, for a
;; Composition field, its block grammar) are displayed + edited on the type's own edit page.
;; is this post a TYPE? (declares fields, or is subtype-of "type" transitively). --
(define host/blog--is-type?
(fn (slug)
(or (> (len (host/blog-fields-of slug)) 0)
(contains? (host/blog--subtype-closure (host/blog-out slug "subtype-of") :out) "type"))))
;; set a Composition field's grammar (:blocks + :allow) on a type, preserving its other fields.
(define host/blog--set-field-grammar!
(fn (slug fname blocks allow)
(host/blog--set-fields! slug
(map (fn (f) (if (= (str (get f :name)) fname) (merge f {:blocks blocks :allow allow}) f))
(host/blog-fields-of slug)))))
;; a labelled checkbox (the attr must be OMITTED when unchecked — an empty :checked still
;; checks the box).
(define host/blog--checkbox
(fn (name label checked)
(if checked
(quasiquote (label :style "margin-right:0.9em;white-space:nowrap"
(input :type "checkbox" :name (unquote name) :checked "checked") " " (unquote label)))
(quasiquote (label :style "margin-right:0.9em;white-space:nowrap"
(input :type "checkbox" :name (unquote name)) " " (unquote label))))))
;; 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) (host/blog--comp-of slug "body")))
(define host/blog--set-body! (fn (slug body) (host/blog--set-comp! slug "body" body)))
;; The resolver for the composition `each` graph-query source (compose.sx asks the context
;; for "query"). `(query REL TYPE)` -> the objects related to TYPE by REL, as full records
;; so the per-item template can field them. Today the supported relation is is-a (TYPE's
;; 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)))))))
;; the first child element of `node` with tag `tag` (a list head), or nil. (For a figure's
;; inner img / figcaption during decompose.)
(define host/blog--find-child
(fn (node tag)
(let loop ((xs (if (= (type-of node) "list") (rest node) (list))))
(cond
((empty? xs) nil)
((and (= (type-of (first xs)) "list") (= (str (first (first xs))) tag)) (first xs))
(else (loop (rest xs)))))))
;; 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")
((or (= tag "img") (= tag "figure")) "card-image") ;; figure = image + figcaption
((or (= tag "iframe") (= tag "embed") (= tag "video")) "card-embed")
((= 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")
;; a bare <img> (src/alt on the block) OR a <figure> (img child + a figcaption caption).
(let ((img (or (host/blog--find-child block "img") block))
(cap (host/blog--find-child block "figcaption")))
{"src" (host/blog--elem-attr img "src") "alt" (host/blog--elem-attr img "alt")
"caption" (if (nil? cap) "" (host/blog--elem-text cap))}))
((= ctype "card-embed") {"url" (host/blog--elem-attr block "src") "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.)
;; a composition FIELD's value on an object — inline, part of the CID. A type declares which
;; of its fields are compositions (host/blog--composition-fields); an object may carry several
;; (:body, :aside, …), each edited by its own block editor. Compositions live in a STRING-KEYED
;; sub-dict :comps (string keys round-trip through persist cleanly, unlike a mix of keyword and
;; string top-level keys). The default "body" field falls back to a legacy top-level :body.
(define host/blog--comps (fn (rec) (or (get rec :comps) {})))
(define host/blog--comp-of
(fn (slug field)
(let ((r (host/blog-get slug)))
(let ((c (get (host/blog--comps r) field)))
(if (nil? c) (if (= field "body") (get r :body) nil) c)))))
(define host/blog--set-comp!
(fn (slug field v)
(let ((r (host/blog-get slug)))
(when r (host/blog--write! slug (assoc r :comps (assoc (host/blog--comps r) field v)))))))
(define host/blog--comp-nodes
(fn (slug field)
(let ((c (host/blog--comp-of slug field)))
(if (and (= (type-of c) "list") (= (str (first c)) "seq")) (rest c) (list)))))
(define host/blog--set-comp-nodes!
(fn (slug field nodes) (host/blog--set-comp! slug field (cons (quote seq) nodes))))
;; back-compat: the default "body" field.
(define host/blog-body-nodes (fn (slug) (host/blog--comp-nodes slug "body")))
(define host/blog--set-body-nodes! (fn (slug nodes) (host/blog--set-comp-nodes! slug "body" nodes)))
;; the value at index k of a list (any element type).
(define host/blog--nth
(fn (xs k) (let loop ((i 0) (ys xs))
(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 field node) (host/blog--set-comp-nodes! slug field (concat (host/blog--comp-nodes slug field) (list node)))))
;; the kind of a body node, for the editor: "card" | "cond" | "each" | "other".
(define host/blog--node-kind
(fn (node)
(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 a composition `field`: (ref <field-relative>). Returns the card slug.
(define host/blog-block-add!
(fn (slug field ctype fields)
(let ((cslug (host/blog--new-card! slug field ctype fields)))
(begin (host/blog--append-node! slug field (list (quote ref) (host/blog--slug->ref slug cslug))) cslug))))
;; add a CONDITIONAL (or) block: (alt (when <pred> (ref A)) (else (ref B))) — A/B relative refs.
(define host/blog-block-add-cond!
(fn (slug field ckey)
(let ((a (host/blog--slug->ref slug (host/blog--new-card! slug field "card-text" {"text" "shown when the condition holds"})))
(b (host/blog--slug->ref slug (host/blog--new-card! slug field "card-text" {"text" "shown otherwise"}))))
(host/blog--append-node! slug field
(list (quote alt)
(list (quote when) (host/blog--cond->pred ckey) (list (quote ref) a))
(list (quote else) (list (quote ref) b)))))))
;; add a REPEATER (each) block: (each (query is-a TYPE) (ref <template>)) — template relative.
(define host/blog-block-add-each!
(fn (slug field type)
(let ((t (host/blog--slug->ref slug (host/blog--new-card! slug field "card-text" {"text" "rendered once per item"}))))
(host/blog--append-node! slug field
(list (quote each)
(list (quote query) (string->symbol "is-a") (string->symbol type))
(list (quote ref) t))))))
;; move / remove a block in `field` by its INDEX (blocks aren't all single refs).
(define host/blog-block-move-idx!
(fn (slug field i dir)
(let ((nodes (host/blog--comp-nodes slug field)))
(let ((j (if (= dir "up") (- i 1) (+ i 1))))
(when (and (>= i 0) (< i (len nodes)) (>= j 0) (< j (len nodes)))
(host/blog--set-comp-nodes! slug field
(map-indexed (fn (k n) (cond ((= k i) (host/blog--nth nodes j))
((= k j) (host/blog--nth nodes i))
(else n))) nodes)))))))
(define host/blog-block-remove-idx!
(fn (slug field i)
(let ((nodes (host/blog--comp-nodes slug field)))
(when (and (>= i 0) (< i (len nodes)))
(begin
;; refs are field-relative; contains edges are keyed by SLUG — resolve before dropping.
(for-each (fn (r) (host/blog-unrelate! slug (host/blog--resolve-ref r {"container" slug}) "contains"))
(host/blog--node-refs (host/blog--nth nodes i)))
(host/blog--set-comp-nodes! slug field (host/blog--remove-at nodes i)))))))
;; change a conditional block's `when` condition (its then/else branches are kept).
(define host/blog-block-set-cond!
(fn (slug field i ckey)
(let ((nodes (host/blog--comp-nodes slug field)))
(when (and (>= i 0) (< i (len nodes)) (= (host/blog--node-kind (host/blog--nth nodes i)) "cond"))
(let ((node (host/blog--nth nodes i)))
(let ((wb (first (rest node))) (eb (first (rest (rest node)))))
(host/blog--set-comp-nodes! slug field
(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)))))))))
;; A REAL imported blog post (from rose-ash.com) decomposed into the :body composition, so the
;; import survives store wipes — reseeded on boot like the demos. host/blog-import-post!
;; decomposes its HTML-derived sx_content into typed card objects (card-image / card-text /
;; card-embed) + a `contains` body. Idempotent (re-import overwrites the same __bN cards).
(define host/blog-seed-nt-live-encore!
(fn ()
(host/blog-import-post!
{"slug" "nt-live-encore"
"title" "NT Live Encore?"
"status" "published"
"custom_excerpt" "Missed an NT Live performance at Rose Ash Village Hall? We can book an encore."
"feature_image" "https://rose-ash.com/content/images/2026/07/61iN2uEt2ML._AC_SL1024_.jpg"
"tags" (list "NT Live" "Films")
"html" "<img src=\"https://rose-ash.com/content/images/2026/07/61iN2uEt2ML._AC_SL1024_.jpg\" alt=\"NT Live Encore?\"><p>Did you miss an <strong>NTLIVE</strong> performance at <strong>Rose Ash Village Hall</strong>? Or maybe you enjoyed it so much you want another chance to see it? We can book an encore with the National Theatre. Ticket price will be &#xA3;10. If you are interested, take a look at the available days for each play below and please email <strong>village@rose-ash.com</strong> (or simply reply to this if you are reading it as an email) and let us know which plays you&apos;d like to see when. We can&apos;t promise to make the date you request - but we will do our best! If none of these times suit - then let us know and we&apos;ll try harder! (you may have to stick the DVD in the slot yourself...)<br><br>Don&apos;t forget to subscribe to <strong>rose-ash.com</strong> for emailed news of all things Rose Ash!<br></p><figure class=\"kg-card kg-image-card kg-card-hascaption\"><img src=\"https://rose-ash.com/content/images/2026/07/LISTING.jpg\" class=\"kg-image\" alt=\"NT Live Encore?\" loading=\"lazy\" width=\"1240\" height=\"874\" srcset=\"https://rose-ash.com/content/images/size/w600/2026/07/LISTING.jpg 600w, https://rose-ash.com/content/images/size/w1000/2026/07/LISTING.jpg 1000w, https://rose-ash.com/content/images/2026/07/LISTING.jpg 1240w\" sizes=\"(min-width: 720px) 720px\"><figcaption><span style=\"white-space: pre-wrap;\">Bryan Cranston (</span><i><em class=\"italic\" style=\"white-space: pre-wrap;\">Breaking Bad</em></i><span style=\"white-space: pre-wrap;\">) and Marianne Jean-Baptiste (</span><i><em class=\"italic\" style=\"white-space: pre-wrap;\">Hard Truths</em></i><span style=\"white-space: pre-wrap;\">) feature in a five-star, triumphantly acclaimed new production of Arthur Miller&#x2019;s classic play, from visionary director Ivo Van Hove (</span><i><em class=\"italic\" style=\"white-space: pre-wrap;\">A View from the Bridge</em></i><span style=\"white-space: pre-wrap;\">).</span></figcaption></figure><p><strong>ALL MY SONS</strong> encore possibilities: Sunday 5th July PM</p><figure class=\"kg-card kg-image-card kg-card-hascaption\"><img src=\"https://rose-ash.com/content/images/2026/07/in.jpg\" class=\"kg-image\" alt=\"NT Live Encore?\" loading=\"lazy\" width=\"1240\" height=\"874\" srcset=\"https://rose-ash.com/content/images/size/w600/2026/07/in.jpg 600w, https://rose-ash.com/content/images/size/w1000/2026/07/in.jpg 1000w, https://rose-ash.com/content/images/2026/07/in.jpg 1240w\" sizes=\"(min-width: 720px) 720px\"><figcaption><span style=\"white-space: pre-wrap;\">Pegeen Flaherty&#x2019;s life is turned upside down when a young man walks into her pub claiming that he&#x2019;s killed his father. Instead of being shunned, the killer becomes a local hero and begins to win hearts,that is until a second man unexpectedly arrives on the scene&#x2026;</span></figcaption></figure><p><strong>PLAYBOY</strong> encore possibilities: Sunday 5th July PM, Sunday 26th July PM, Sunday August 2nd PM</p><figure class=\"kg-card kg-image-card kg-card-hascaption\"><img src=\"https://rose-ash.com/content/images/2026/07/in-1.jpg\" class=\"kg-image\" alt=\"NT Live Encore?\" loading=\"lazy\" width=\"1240\" height=\"874\" srcset=\"https://rose-ash.com/content/images/size/w600/2026/07/in-1.jpg 600w, https://rose-ash.com/content/images/size/w1000/2026/07/in-1.jpg 1000w, https://rose-ash.com/content/images/2026/07/in-1.jpg 1240w\" sizes=\"(min-width: 720px) 720px\"><figcaption><span style=\"white-space: pre-wrap;\">Marquise de Merteuil is a master in the art of survival. Alongside the magnetic Vicomte de Valmont, they turn seduction into strategy and weaponise desire. But when their alliance collapses into rivalry, the battle between them threatens to destroy everyone in their path.</span></figcaption></figure><p><strong>LIASONS</strong> encore possibilities: Sunday 5th July PM, Sunday 26th July PM, Sunday August 2nd PM</p>
<!--kg-card-begin: html-->
<iframe width=\"560\" height=\"560\" src=\"https://www.youtube.com/embed/aLaRT0yAstE?si=LpAEAWc9dNCgv7-X\" title=\"YouTube video player\" frameborder=\"0\" allow=\"accelerometer; autoplay; clipboard-write; encrypted-media; gyroscope; picture-in-picture; web-share\" referrerpolicy=\"strict-origin-when-cross-origin\" allowfullscreen></iframe>
<!--kg-card-end: html-->
<!--kg-card-begin: html-->
<iframe width=\"560\" height=\"560\" src=\"https://www.youtube.com/embed/tdlgR2FDbRI?si=mR3QXCeo_1NeB7RK\" title=\"YouTube video player\" frameborder=\"0\" allow=\"accelerometer; autoplay; clipboard-write; encrypted-media; gyroscope; picture-in-picture; web-share\" referrerpolicy=\"strict-origin-when-cross-origin\" allowfullscreen></iframe>
<!--kg-card-end: html-->
<!--kg-card-begin: html-->
<iframe width=\"560\" height=\"560\" src=\"https://www.youtube.com/embed/wq5l5VV51sU?si=003YiYkMeeqLPVwt\" title=\"YouTube video player\" frameborder=\"0\" allow=\"accelerometer; autoplay; clipboard-write; encrypted-media; gyroscope; picture-in-picture; web-share\" referrerpolicy=\"strict-origin-when-cross-origin\" allowfullscreen></iframe>
<!--kg-card-end: html-->"})))
;; a card with a FIXED slug (idempotent — seed!/set-field-values! overwrite), for demos that
;; set a composition directly. Returns the field-relative ref to store in the composition.
(define host/blog--seed-card!
(fn (container field name ctype fields)
(let ((cslug (host/blog--card-slug container field name)))
(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")
(str field "__" name)))))
;; a LIVE demo of layer 2 — a Landing TYPE with TWO composition fields (:body + :aside), each
;; with its own grammar, and an instance populated in both. Idempotent (fixed slugs; overwrites).
(define host/blog-seed-landing-demo!
(fn ()
(begin
(host/blog-seed! "landing" "Landing"
"(article (h1 \"Landing\") (p \"A page TYPE with two composition fields — a main :body and an :aside — each with its own block grammar. Its instances render both.\"))"
"published")
(host/blog-relate! "landing" "type" "subtype-of")
(host/blog--set-fields! "landing"
(list {:name "body" :type "Composition"
:blocks (list "card-heading" "card-text" "card-image") :allow (list "cond" "each")}
{:name "aside" :type "Composition"
:blocks (list "card-text" "card-callout") :allow (list)}))
(host/blog--set-type-relations! "landing" (list "related" "is-a" "tagged"))
(host/blog-put! "landing-demo" "Landing Demo" "(article)" "published")
(host/blog-relate! "landing-demo" "landing" "is-a")
(host/blog--set-comp! "landing-demo" "body"
(list (quote seq)
(list (quote ref) (host/blog--seed-card! "landing-demo" "body" "b0" "card-heading" {"level" "2" "text" "Welcome to the Landing Demo"}))
(list (quote ref) (host/blog--seed-card! "landing-demo" "body" "b1" "card-text" {"text" "This object has a MAIN :body composition and a separate :aside — two composition fields on one object, each edited by its own block editor and each with its own grammar."}))))
(host/blog--set-comp! "landing-demo" "aside"
(list (quote seq)
(list (quote ref) (host/blog--seed-card! "landing-demo" "aside" "a0" "card-callout" {"style" "info" "text" "This is the ASIDE composition — a second, independent field on the same object."}))
(list (quote ref) (host/blog--seed-card! "landing-demo" "aside" "a1" "card-text" {"text" "Editing the aside is CID-neutral to the body: they are separate composition fields on the record."})))))))
;; 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"}
;; :body is a COMPOSITION field (layer 2) whose GRAMMAR (layer 2b) the type
;; declares: :blocks = the card kinds an article body may contain, :allow = the
;; control blocks permitted. The editor palette + save/import validation read this.
{:name "body" :type "Composition"
:blocks (list "card-heading" "card-text" "card-image" "card-quote" "card-embed" "card-code" "card-callout")
:allow (list "cond" "each")}))
;; 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\"))")
;; article's allowed RELATIONS (Part B): an article instance may be related, typed, and
;; tagged — but NOT subtyped (subtype-of is for types). The relation editors + relate
;; handler read this; the metamodel types declare none, so they keep every kind.
(host/blog--set-type-relations! "article" (list "related" "is-a" "tagged"))
;; P1: the "article" type DECLARES its behavior — on-publish (a create of an article) runs the
;; "publish" DAG. The runner is derived from the DAG's caps ({effect,branch} → exec-runner). This
;; replaces the hardcoded trigger; host/blog--load-behaviors! gathers it into the registry at boot.
(host/blog--set-type-behavior! "article"
(list {"verb" "create" "type" "article" "dag" "publish"}))
;; ── 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\" :style \"margin:1em 0\" (iframe :src (field \"url\") :width \"560\" :height \"315\" :frameborder \"0\" :allowfullscreen \"\" :style \"max-width:100%\"))")
(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)
(let ((allowed (host/blog--allowed-relations slug)))
(cons (quote div)
;; only the relation kinds the post's TYPE permits (Part B). false: the initial edit
;; page renders empty pickers (the load trigger fills each), keeping this render cheap.
(map (fn (spec) (host/blog--relation-editor slug (get spec :kind) false))
(filter (fn (spec) (contains? allowed (get spec :kind))) 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.
;; every block-editor form carries a hidden "field" (which composition field it edits) and
;; targets #comp-<field>, so an object with several composition fields gets several editors
;; that don't collide. host/blog--fld makes the hidden input; host/blog--tgt the target id.
(define host/blog--fld (fn (field) (quasiquote (input :type "hidden" :name "field" :value (unquote field)))))
(define host/blog--tgt (fn (field) (str "#comp-" field)))
(define host/blog--block-btn
(fn (slug field idx action dir label)
(let ((url (str "/" slug "/blocks/" idx "/" action)))
(quasiquote
;; :sx-post -> a text/sx round-trip; the handler returns the re-rendered field editor
;; and sx-swap="outerHTML" replaces #comp-<field>.
(form :method "post" :action (unquote url) :style "display:inline;margin:0 0.1em"
:sx-post (unquote url) :sx-target (unquote (host/blog--tgt field)) :sx-swap "outerHTML"
(unquote (host/blog--fld field))
(unquote (if (= dir "") "" (quasiquote (input :type "hidden" :name "dir" :value (unquote dir)))))
(button :type "submit" (unquote label)))))))
(define host/blog--block-ctrls
(fn (slug field idx)
(quasiquote (span :style "white-space:nowrap"
(unquote (host/blog--block-btn slug field idx "move" "up" "↑"))
(unquote (host/blog--block-btn slug field idx "move" "down" "↓"))
(unquote (host/blog--block-btn slug field idx "remove" "" "remove"))))))
;; a ✎ edit-fields link + preview for a card REF — refs are field-relative, resolved to the
;; card's own /<cslug>/edit page (external object; editing it is CID-neutral to the container).
(define host/blog--ref-chip
(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 field editor).
(define host/blog--cond-form
(fn (slug field idx cur)
(let ((url (str "/" slug "/blocks/" idx "/cond"))
(opt (fn (v l cur) (if (= v cur)
(quasiquote (option :value (unquote v) :selected "selected" (unquote l)))
(quasiquote (option :value (unquote v) (unquote l)))))))
(quasiquote
(form :method "post" :action (unquote url) :style "display:inline"
:sx-post (unquote url) :sx-target (unquote (host/blog--tgt field)) :sx-swap "outerHTML"
(unquote (host/blog--fld field))
(select :name "cond"
(unquote (opt "auth" "logged in" cur))
(unquote (opt "device:mobile" "on mobile" cur))
(unquote (opt "device:desktop" "on desktop" cur))
(unquote (opt "locale:fr" "locale = fr" cur)))
(button :type "submit" "set"))))))
;; a block row rendered by KIND — card / conditional (or) / repeater (each) / inline.
(define host/blog--block-row
(fn (slug field idx node)
(let ((kind (host/blog--node-kind node))
(rs "display:flex;gap:0.5em;align-items:center;border:1px solid #ddd;padding:0.4em;margin:0.2em 0"))
(cond
((= kind "cond")
(quasiquote (li :style (unquote rs)
(b :style "min-width:5em" "if")
(span :style "flex:1"
(unquote (host/blog--cond-form slug field idx (host/blog--pred->ckey (host/blog--node-pred node))))
" → " (unquote (host/blog--branch-display slug (first (rest node))))
" · else → " (unquote (host/blog--branch-display slug (first (rest (rest node))))))
(unquote (host/blog--block-ctrls slug field idx)))))
((= kind "each")
(quasiquote (li :style (unquote rs)
(b :style "min-width:5em" "for each")
(span :style "flex:1"
(code (unquote (host/blog--node-each-type node)))
" → " (unquote (host/blog--node-display slug (host/blog--nth node (- (len node) 1)))))
(unquote (host/blog--block-ctrls slug field idx)))))
(else (quasiquote (li :style (unquote rs)
(b :style "min-width:5em" (unquote kind))
(span :style "flex:1;color:#555;overflow:hidden" (unquote (host/blog--node-display slug node)))
(unquote (host/blog--block-ctrls slug field idx)))))))))
;; ONE composition field's block editor (id #comp-<field>). host/blog--block-editors renders
;; one per field the object's type declares (layer 2).
(define host/blog--block-editor
(fn (slug field)
(let ((nodes (host/blog--comp-nodes slug field))
(allowed (host/blog--allowed-blocks slug field)))
(let ((rows (map-indexed (fn (i n) (host/blog--block-row slug field i n)) nodes))
;; the CARD PALETTE is the field's grammar (:blocks) — one <option> per allowed
;; card type, spliced as DIRECT <select> children (a wrapper breaks a boosted swap).
(card-opts (map (fn (ct) (quasiquote (option :value (unquote ct) (unquote (host/blog--card-label ct))))) allowed))
;; control-block add-forms only appear if the grammar permits them (:allow).
(add-cond
(if (host/blog--allows-control? slug field "cond")
(quasiquote (form :method "post" :action (unquote (str "/" slug "/blocks/add-cond"))
:sx-post (unquote (str "/" slug "/blocks/add-cond")) :sx-target (unquote (host/blog--tgt field)) :sx-swap "outerHTML"
:style "margin-top:0.3em"
(unquote (host/blog--fld field))
(select :name "cond"
(option :value "auth" "logged in") (option :value "device:mobile" "on mobile")
(option :value "device:desktop" "on desktop") (option :value "locale:fr" "locale = fr"))
" " (button :type "submit" "+ conditional (or)")))
""))
(add-each
(if (host/blog--allows-control? slug field "each")
(quasiquote (form :method "post" :action (unquote (str "/" slug "/blocks/add-each"))
:sx-post (unquote (str "/" slug "/blocks/add-each")) :sx-target (unquote (host/blog--tgt field)) :sx-swap "outerHTML"
:style "margin-top:0.3em"
(unquote (host/blog--fld field))
(input :name "type" :placeholder "type name (e.g. compose-item)" :style "width:40%")
" " (button :type "submit" "+ repeater (each)")))
"")))
(quasiquote
(div :id (unquote (str "comp-" field)) :style "margin-top:1.5em;border-top:1px solid #ccc;padding-top:1em"
(h3 :style "font-size:1em;margin:0 0 0.3em" (unquote (str ":" field " (composition)")))
(unquote (if (> (len nodes) 0) (cons (quote ul) rows) (quote (p :style "color:#999" "No blocks yet."))))
(form :method "post" :action (unquote (str "/" slug "/blocks/add"))
:sx-post (unquote (str "/" slug "/blocks/add")) :sx-target (unquote (host/blog--tgt field)) :sx-swap "outerHTML"
(unquote (host/blog--fld field))
(unquote (cons (quote select) (append (quasiquote (:name "ctype")) card-opts)))
" " (input :name "text" :placeholder "text…" :style "width:40%")
" " (button :type "submit" "+ card"))
(unquote add-cond)
(unquote add-each)))))))
;; the edit page's composition section (#block-editor): one block editor per composition
;; field the type declares (layer 2 — types define the object's structure).
(define host/blog--block-editors
(fn (slug)
(quasiquote
(div :id "block-editor"
(unquote (cons (quote div)
(map (fn (f) (host/blog--block-editor slug f)) (host/blog--composition-fields slug))))))))
;; ── Part C: the TYPE-DEFINITION editor (shown when editing a TYPE post). "It's just more
;; composition" — a type's :fields are displayed, and each Composition field's grammar (which
;; card kinds + control blocks it permits) is edited with a checklist. The type governs what
;; its instances' compositions can contain; here you edit that governance. --
(define host/blog--own-field
(fn (slug fname)
(let loop ((fs (host/blog-fields-of slug)))
(cond ((empty? fs) nil) ((= (str (get (first fs) :name)) fname) (first fs)) (else (loop (rest fs)))))))
;; the grammar edit form for ONE Composition field (id #grammar-<field>): a checkbox per card
;; type (checked = permitted) + conditional/repeater toggles, POSTing to /<slug>/grammar.
(define host/blog--grammar-form
(fn (slug fdecl)
(let ((fname (str (get fdecl :name)))
(cur (or (get fdecl :blocks) (host/blog--subtype-closure (list "card") :in)))
(ctrl (or (get fdecl :allow) (list "cond" "each")))
(all-cards (host/blog--subtype-closure (list "card") :in))
(url (str "/" slug "/grammar")))
(let ((tgt (str "#grammar-" fname))
(card-checks (map (fn (ct) (host/blog--checkbox (str "blk-" ct) (host/blog--card-label ct) (contains? cur ct))) all-cards)))
(cons (quote form)
(append
(quasiquote (:method "post" :action (unquote url) :sx-post (unquote url)
:sx-target (unquote tgt) :sx-swap "outerHTML"
:id (unquote (str "grammar-" fname))
:style "margin:0.3em 0;padding:0.5em;border:1px dashed #bbb"
(input :type "hidden" :name "field" :value (unquote fname))
(div :style "font-weight:bold;font-size:0.9em;margin-bottom:0.3em"
(unquote (str ":" fname " may contain these blocks —")))))
(append card-checks
(quasiquote ((br)
(unquote (host/blog--checkbox "allow-cond" "conditional (or)" (contains? ctrl "cond")))
(unquote (host/blog--checkbox "allow-each" "repeater (each)" (contains? ctrl "each")))
(br) (button :type "submit" :style "margin-top:0.4em" "save grammar"))))))))))
;; the RELATION checklist for a type (id #type-relations): which relation kinds its instances
;; may be linked by (Part B — relations are type-governed composition too).
(define host/blog--relations-form
(fn (slug)
(let ((cur (or (host/blog--type-relations slug) (host/blog--all-rel-kinds)))
(all (host/blog--all-rel-kinds))
(url (str "/" slug "/relations")))
(cons (quote form)
(append
(quasiquote (:method "post" :action (unquote url) :sx-post (unquote url)
:sx-target "#type-relations" :sx-swap "outerHTML"
:id "type-relations" :style "margin:0.5em 0;padding:0.5em;border:1px dashed #bbb"
(div :style "font-weight:bold;font-size:0.9em;margin-bottom:0.3em"
"instances may be linked by these relations —")))
(append
(map (fn (k) (host/blog--checkbox (str "rel-" k) k (contains? cur k))) all)
(quasiquote ((br) (button :type "submit" :style "margin-top:0.4em" "save relations")))))))))
;; the whole type-definition editor: the field/grammar rows + the relation checklist. "It's
;; just more composition" — the inline block grammar AND the external relations, in one place.
(define host/blog--type-def-editor
(fn (slug)
(let ((fields (host/blog-fields-of slug)))
(let ((rows (map (fn (f)
(if (= (get f :type) "Composition")
(host/blog--grammar-form slug f)
(quasiquote (div :style "padding:0.15em 0;color:#555"
(b (unquote (str (get f :name)))) (unquote (str " : " (get f :type)))))))
fields)))
(cons (quote div)
(append
(quasiquote (:id "type-def" :style "margin-top:1.5em;border-top:2px solid #999;padding-top:1em"
(h3 :style "font-size:1em;margin:0 0 0.4em" "Type definition — what this type's instances may contain")))
(append rows (list (host/blog--relations-form slug)))))))))
;; the READ-ONLY type definition, shown on a type's PUBLIC page so anyone can read what the
;; type is: its fields, each Composition field's block grammar, and the relations its instances
;; may use. (The edit page's host/blog--type-def-editor is the writable form of the same data.)
;; P1: render a type's declared BEHAVIOR bindings + the DERIVED runner for each (visible, not
;; hand-set — the sync/durable classification falls out of the DAG's required capabilities).
(define host/blog--behavior-lines
(fn (slug)
(let ((bs (host/blog--type-behavior slug)))
(if (empty? bs) ""
(cons (quote div)
(cons (quote (:style "margin:0.4em 0 0"))
(cons (quote (b "Behavior: "))
(map (fn (bd)
(let ((dag (host/blog--dag-of (get bd "dag"))))
(let ((runner (host/flow--select-runner host/blog--runner-fleet dag))
(caps (host/flow--required-caps dag)))
(quasiquote (span :style "display:block;font-size:0.9em;color:#555"
(unquote (str "on " (get bd "verb") " → " (get bd "dag") " DAG · needs {"
(join ", " caps) "} · runner: "
(if (nil? runner) "NONE (capability unmet)"
(if (contains? (get runner :capabilities) "suspend")
"durable (RA)" "synchronous (exec-fold)")))))))))
bs))))))))
(define host/blog--type-def-view
(fn (slug)
(let ((fields (host/blog-fields-of slug))
(rels (or (host/blog--type-relations slug) (host/blog--all-rel-kinds))))
(let ((rows
(map (fn (f)
(if (= (get f :type) "Composition")
(let ((blocks (or (get f :blocks) (host/blog--subtype-closure (list "card") :in)))
(allow (or (get f :allow) (list "cond" "each"))))
(quasiquote (li
(b (unquote (str (get f :name)))) " — composition; may contain "
(unquote (join ", " (map host/blog--card-label blocks)))
(unquote (if (empty? allow) "" (str "; control blocks: " (join ", " allow)))))))
(quasiquote (li (b (unquote (str (get f :name)))) (unquote (str " : " (get f :type)))))))
fields)))
(quasiquote
(aside :style "margin-top:2em;border:1px solid #ccc;background:#fafafa;padding:0.8em 1em;border-radius:4px"
(h3 :style "margin:0 0 0.4em;font-size:1em" "Type definition")
(unquote (if (> (len fields) 0)
(cons (quote ul) (append (quasiquote (:style "margin:0.3em 0")) rows))
(quote (p :style "color:#999;margin:0" "No declared fields."))))
(p :style "margin:0.4em 0 0" (b "Instances may be linked by: ") (unquote (join ", " rels)))
(unquote (host/blog--behavior-lines slug))))))))
;; the first n elements of a list.
(define host/blog--take
(fn (xs n) (let loop ((ys xs) (k n) (acc (list)))
(if (or (empty? ys) (<= k 0)) acc (loop (rest ys) (- k 1) (concat acc (list (first ys))))))))
;; a type's POPULATION — its instances (posts is-a this type) + subtypes — shown on the type's
;; public page next to its definition (schema + extension). Durable reads: call in a handler.
(define host/blog--type-population
(fn (slug)
(let ((instances (host/blog-in slug "is-a"))
(subtypes (host/blog-in slug "subtype-of")))
(let ((inst-links (map (fn (s) (quasiquote (li (a :href (unquote (str "/" s "/")) (unquote s)))))
(host/blog--take instances 24))))
(quasiquote
(aside :style "margin-top:1em;border:1px solid #ccc;background:#fafafa;padding:0.8em 1em;border-radius:4px"
(h3 :style "margin:0 0 0.4em;font-size:1em"
(unquote (str "Population — " (len instances) " instance" (if (= (len instances) 1) "" "s"))))
(unquote (if (> (len subtypes) 0)
(quasiquote (p :style "margin:0.2em 0" (b "Subtypes: ") (unquote (join ", " subtypes))))
""))
(unquote (if (> (len instances) 0)
(cons (quote ul) (append (quasiquote (:style "margin:0.3em 0")) inst-links))
(quote (p :style "color:#999;margin:0" "No instances yet."))))
(unquote (if (> (len instances) 24) (quote (p :style "color:#999;margin:0" "… (showing first 24)")) ""))))))))
;; ── 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")))
;; child spans nest under the request's root span (from otel/instrument-route),
;; so the waterfall breaks the render down: get → body-fold → relations → …
(let ((r (otel/with-span "blog.get" {} (fn () (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: render EACH composition field the type declares
;; (default just :body) via the render-fold, in field order, against a
;; context (auth/device/locale + the container). Else the legacy sx_content.
(body-html
(otel/with-span "blog.render-body" {}
(fn ()
(let ((ctx (host/blog--comp-ctx principal req slug)))
(let ((rendered (reduce (fn (acc f) (str acc (host/comp-render (host/blog--comp-of slug f) ctx)))
"" (host/blog--composition-fields slug))))
(if (= rendered "") (host/blog-render r) rendered))))))
;; all relation blocks (Related, Tags, Types, Tagged-with-this …)
;; come from iterating the registry — one section, registry-driven.
(relations (otel/with-span "blog.relations" {}
(fn () (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 (otel/with-span "blog.typed-block" {} (fn () (host/blog--typed-block slug))))
;; a TYPE post shows its definition (fields + grammar + relations) publicly —
;; read-only; the edit page has the writable form.
(type-def-view (if (host/blog--is-type? slug) (host/blog--type-def-view slug) ""))
(type-population (if (host/blog--is-type? slug) (host/blog--type-population slug) ""))
(auth-foot (otel/with-span "blog.auth-footer" {} (fn () (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 type-def-view)
(unquote type-population)
(unquote relations)
(unquote (host/blog--allocate-form slug))
(unquote (host/blog--showing-extras slug))
(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"))
;; content may arrive as raw "html" (converted to an SX tree by the pure-SX
;; converter) OR as "sx_content" (SX source). Either way -> one tree.
(tree (if (get gp "html")
(host/html->sx (get gp "html"))
(parse-safe (or (get gp "sx_content") "")))))
(begin
(host/blog-put! slug title
(if (get gp "html") (serialize tree) (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 (html- or sx-derived) content tree into card
;; objects + a `contains` body, so the post renders via the composition fold.
(host/blog--decompose! slug tree)
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)))
(let ((prev (host/blog-get slug)))
(begin
(host/blog-put! slug title (or sx-content "") status)
;; P0.3: a draft→published transition fires the publish flow through the seam.
(host/blog--maybe-publish! slug (if prev (get prev :status) nil) 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--relation-allowed? slug kind)
(host/blog-exists? other)
(host/blog--valid-object? kind other))
(begin
(host/blog-relate! slug other kind)
(host/blog--emit-relation! "add" slug other kind))) ;; P2: Add activity
;; 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))
(begin
(host/blog-unrelate! slug other kind)
(host/blog--emit-relation! "remove" slug other kind))) ;; P2: Remove activity
;; 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).
;; every block op names its composition field (a hidden "field" input; default "body"), so
;; the response re-renders THAT field's editor (#comp-<field>).
(define host/blog--block-field (fn (req) (or (host/field req "field") "body")))
(define host/blog--block-resp
(fn (req slug field)
(if (host/blog--editor-swap-req? req)
(dream-html (render-page (host/blog--block-editor slug field)))
(dream-redirect (str "/" slug "/edit")))))
(define host/blog--block-idx (fn (req) (parse-int (or (dream-param req "idx") "0") 0)))
(define host/blog-block-add-submit
(fn (req)
(let ((slug (dream-param req "slug")) (field (host/blog--block-field req))
(ctype (or (host/field req "ctype") "card-text"))
(text (or (host/field req "text") "")))
(begin
;; the ctype must be PERMITTED by the field's grammar (:blocks the type declares —
;; default: any card subtype). This is where the type governs the composition.
(when (and (host/blog-exists? slug) (host/blog--block-allowed? slug field ctype))
(host/blog-block-add! slug field ctype
(if (= ctype "card-heading") {"level" "2" "text" text} {"text" text})))
(host/blog--block-resp req slug field)))))
(define host/blog-block-add-cond-submit
(fn (req)
(let ((slug (dream-param req "slug")) (field (host/blog--block-field req)) (ckey (or (host/field req "cond") "auth")))
(begin (when (host/blog-exists? slug) (host/blog-block-add-cond! slug field ckey))
(host/blog--block-resp req slug field)))))
(define host/blog-block-add-each-submit
(fn (req)
(let ((slug (dream-param req "slug")) (field (host/blog--block-field req)) (type (host/blog-slugify (or (host/field req "type") ""))))
(begin (when (and (host/blog-exists? slug) (not (= type ""))) (host/blog-block-add-each! slug field type))
(host/blog--block-resp req slug field)))))
(define host/blog-block-remove-submit
(fn (req)
(let ((slug (dream-param req "slug")) (field (host/blog--block-field req)))
(begin (when (host/blog-exists? slug) (host/blog-block-remove-idx! slug field (host/blog--block-idx req)))
(host/blog--block-resp req slug field)))))
(define host/blog-block-move-submit
(fn (req)
(let ((slug (dream-param req "slug")) (field (host/blog--block-field req)) (dir (or (host/field req "dir") "up")))
(begin (when (host/blog-exists? slug) (host/blog-block-move-idx! slug field (host/blog--block-idx req) dir))
(host/blog--block-resp req slug field)))))
(define host/blog-block-cond-submit
(fn (req)
(let ((slug (dream-param req "slug")) (field (host/blog--block-field req)) (ckey (or (host/field req "cond") "auth")))
(begin (when (host/blog-exists? slug) (host/blog-block-set-cond! slug field (host/blog--block-idx req) ckey))
(host/blog--block-resp req slug field)))))
;; POST /<type>/grammar — set a Composition field's block grammar from the checklist. Only on a
;; TYPE post (it defines what its instances' compositions may contain).
(define host/blog-grammar-submit
(fn (req)
(let ((slug (dream-param req "slug")) (fname (or (host/field req "field") "body")))
(begin
(when (and (host/blog-exists? slug) (host/blog--is-type? slug))
(let ((all-cards (host/blog--subtype-closure (list "card") :in)))
(host/blog--set-field-grammar! slug fname
(filter (fn (ct) (not (nil? (host/field req (str "blk-" ct))))) all-cards)
(filter (fn (c) (not (nil? (host/field req (str "allow-" c))))) (list "cond" "each")))))
(if (host/blog--editor-swap-req? req)
(dream-html (render-page (host/blog--grammar-form slug (host/blog--own-field slug fname))))
(dream-redirect (str "/" slug "/edit")))))))
;; POST /<type>/relations — set which relation kinds the type's instances may use (Part B).
(define host/blog-relations-submit
(fn (req)
(let ((slug (dream-param req "slug")))
(begin
(when (and (host/blog-exists? slug) (host/blog--is-type? slug))
(host/blog--set-type-relations! slug
(filter (fn (k) (not (nil? (host/field req (str "rel-" k))))) (host/blog--all-rel-kinds))))
(if (host/blog--editor-swap-req? req)
(dream-html (render-page (host/blog--relations-form slug)))
(dream-redirect (str "/" slug "/edit")))))))
;; 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-editors slug))
;; if this post is a TYPE, its definition (fields + grammar) is editable here.
(type-def (if (host/blog--is-type? slug) (host/blog--type-def-editor slug) ""))
(tag-toggle (host/blog--is-tag-toggle slug))
(post-fields (host/blog--scalar-fields 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 type-def)
(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--scalar-fields 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 FIRST — the publish activity reads :category from
;; them, so field-writes must land before the transition fires (else it branches on
;; the stale category on an edit that both sets a category and publishes).
(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))
;; P0.3: a draft→published transition fires the publish flow through the seam.
(host/blog--maybe-publish! slug (get r :status) status)
(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"))))))))))))))
;; ── RA-live: resume a suspended durable KERNEL instance (the async boundary) ──────────
;; The kernel held the flow suspended across requests; resuming re-drives it to completion, records
;; the effects, and clears it from the pending log. Driven here by a link (a timer/queue would in prod).
(define host/blog--resume-pending!
(fn (id)
(let ((r (host/ra--kernel-resume host/blog--kernel-base id)))
(begin
(when (= (get r :status) "done")
(begin
(for-each (fn (eff)
(set! host/blog--flow-log
(concat host/blog--flow-log (list {"verb" (get eff :verb) "args" (get eff :args)}))))
(or (get r :effects) (list)))
(persist/backend-kv-put host/blog-store host/blog--flowlog-key host/blog--flow-log)
(host/blog--drop-pending! id)))
r))))
;; ── /fed-tick — the background federation worker (hit periodically by serve.sh's detached loop) ──
;; Re-follows our target (idempotent — recovers if it was down at boot) and flushes the durable
;; outbox (delivers any backlog to followers who are now up). This is the delivery TIMER.
(define host/blog-fed-tick
(fn (req)
(begin
(when (not (= host/blog--follow-target "")) (host/blog--follow! host/blog--follow-target))
(host/blog--flush-outbox!)
(host/ok {:outbox (len host/blog--outbox) :followers (len host/blog--followers)}))))
;; ── /flows — the behavior surface: what fired + what's SUSPENDED (RA-live). ?resume=<id> resumes. ─
(define host/blog-flows
(fn (req)
(let ((rid (dream-query-param req "resume")))
(begin
(when (and rid (not (= rid ""))) (host/blog--resume-pending! rid))
(when (dream-query-param req "flush") (host/blog--flush-outbox!))
(host/blog--resp req 200
(host/blog--page req "Flows"
(quasiquote
(div (h1 "Flows")
(p "Effect-as-data from behavior workflows — the seam: activity → DAG → runner → effects.")
(p :style "font-size:0.9em;color:#555"
(unquote (str "Federation outbox: " (len host/blog--outbox) " pending delivery(ies) ")) " "
(a :href "/flows?flush=1" "flush"))
(h3 :style "font-size:1em;margin:1em 0 0.3em" "Suspended (durable, on the kernel)")
(unquote
(if (= (len host/blog--pending-log) 0)
(quote (p :style "color:#999;margin:0" (em "None suspended.")))
(cons (quote ul)
(map (fn (p)
(quasiquote (li (unquote (str "instance " (get p "id") " — " (get p "slug")
" (" (get p "category") ") ")) " "
(a :href (unquote (str "/flows?resume=" (get p "id"))) "resume"))))
host/blog--pending-log))))
(h3 :style "font-size:1em;margin:1em 0 0.3em" "Effects")
(unquote
(if (= (len host/blog--flow-log) 0)
(quote (p :style "color:#999;margin:0" (em "No effects yet.")))
(cons (quote ul)
(map (fn (e)
(quasiquote (li (strong (unquote (get e "verb"))) " "
(unquote (if (> (len (get e "args")) 0) (str (first (get e "args"))) "")))))
host/blog--flow-log))))))))))))
;; the scheduled events on a calendar, each with its linked post + a Buy-ticket form (→ shop).
(define host/blog--events-list
(fn (calendar)
(let ((events (host/blog-out calendar "scheduled")))
(if (= (len events) 0) (quote (p :style "color:#999" (em "No events scheduled.")))
(cons (quote ul)
(map (fn (ev)
(let ((features (host/blog--out-raw ev "features")) (sold (host/blog--out-raw ev "sold")))
(quasiquote (li :style "margin:0.3em 0"
(b (unquote (str ev)))
(unquote (if (> (len features) 0) (str " · features: " (first features)) ""))
(unquote (str " · tickets sold: " (str (len sold)) " "))
(form :method "post" :action (unquote (str "/buy?event=" ev)) :style "display:inline"
(button :type "submit" "🎟 Buy ticket"))))))
events))))))
;; events: schedule an event on the main calendar, optionally featuring a (blog-allocated) post.
(define host/blog-new-event
(fn (req)
(let ((title (host/field req "title")) (date (or (host/field req "date") "")) (post (or (host/field req "post") "")))
(begin
(when (and title (not (= title "")))
(let ((slug (host/blog-slugify title)))
(begin
(host/blog-put! slug title (str "(article (h1 \"" title "\") (p \"" date "\"))") "published")
(host/blog-relate! slug "event" "is-a")
(host/blog-relate! "main" slug "scheduled")
(when (not (= post "")) (host/blog-relate! slug post "features")))))
(dream-redirect "/calendars")))))
;; events: buy a ticket for an event — a cross-domain order on the shop, then link event--sold-->order.
(define host/blog-buy
(fn (req)
(let ((event (or (dream-query-param req "event") (host/field req "event") "")))
(begin
(when (and (not (= event "")) (not (= host/blog--shop-base "")))
(let ((body (host/blog--http-order event)))
(when (starts-with? body "order:")
(host/blog-relate! event (substr body 6 (- (len body) 6)) "sold"))))
(dream-redirect "/calendars")))))
;; shop: create an order for an event (an order post is-a order, related to the event) → "order:<id>".
(define host/blog-order
(fn (req)
(let ((event (or (dream-query-param req "event") "unknown")))
(let ((oid (str "order-" event "-" (str (len (host/blog-slugs))))))
(begin
(host/blog-put! oid (str "Order: " event) (str "(article (h1 \"Order\") (p \"" event "\"))") "published")
(host/blog-relate! oid "order" "is-a")
(host/blog-relate! oid event "for")
(dream-response 200 {:content-type "text/plain; charset=utf-8"} (str "order:" oid)))))))
;; ── the CINEMA model (events domain): Cinema → Screen → Calendar, Film, TicketType, Showing, Offering ──
;; Seed the type-posts + Rose Ash Cinema with two screens (each with a default capacity + a calendar)
;; + a set of ticket types. Idempotent (seed!/relate! are sets).
(define host/blog-seed-cinema!
(fn ()
(begin
(for-each (fn (t) (host/blog-seed! t t (str "(article (h1 \"" t "\"))") "published"))
(list "cinema" "screen" "calendar" "film" "ticket-type" "showing" "offering"))
(host/blog-seed! "rose-ash-cinema" "Rose Ash Cinema" "(article (h1 \"Rose Ash Cinema\"))" "published")
(host/blog-relate! "rose-ash-cinema" "cinema" "is-a")
(for-each (fn (n)
(let ((scr (str "screen-" n)) (cal (str "cal-screen-" n)))
(begin
(host/blog-seed! scr (str "Screen " n) (str "(article (h1 \"Screen " n "\"))") "published")
(host/blog-relate! scr "screen" "is-a")
(host/blog-relate! "rose-ash-cinema" scr "has-screen")
(host/blog--set-field-values! scr {"capacity" "100"})
(host/blog-seed! cal (str "Screen " n " Calendar") "(article (h1 \"Calendar\"))" "published")
(host/blog-relate! cal "calendar" "is-a")
(host/blog-relate! scr cal "has-calendar"))))
(list "1" "2"))
(for-each (fn (tt) (begin (host/blog-seed! tt tt (str "(article (h1 \"" tt "\"))") "published")
(host/blog-relate! tt "ticket-type" "is-a")))
(list "adult" "u18" "concession" "standing")))))
;; the showings scheduled on a calendar (calendar --scheduled--> showing).
(define host/blog--calendar-view
(fn (cal)
(let ((showings (host/blog--out-raw cal "scheduled")))
(quasiquote (div :style "margin:0.2em 0 0.2em 1em;font-size:0.9em"
(i (unquote (str cal))) ": "
(unquote (if (= (len showings) 0) (quote (span :style "color:#999" "no showings"))
(cons (quote span) (map (fn (s) (quasiquote (span (a :href (unquote (str "/" s "/")) (unquote (str s))) " "))) showings)))))))))
;; the cinema's screens (with capacity) + each screen's calendar + its showings.
(define host/blog--screens-view
(fn (cinema)
(cons (quote div)
(map (fn (scr)
(let ((cap (get (host/blog-field-values-of scr) "capacity")) (cals (host/blog--out-raw scr "has-calendar")))
(quasiquote (div :style "margin:0.4em 0;padding:0.4em 0.6em;border:1px solid #ddd;border-radius:4px"
(b (unquote (str scr))) (unquote (str " · capacity " (or cap "?")))
(unquote (cons (quote div) (map host/blog--calendar-view cals)))))))
(host/blog--out-raw cinema "has-screen")))))
;; the films + their default ticket types.
(define host/blog--films-view
(fn ()
(let ((films (host/blog-in "film" "is-a")))
(if (= (len films) 0) (quote (p :style "color:#999" (em "No films yet.")))
(cons (quote ul)
(map (fn (f) (quasiquote (li (b (unquote (str f)))
(unquote (str " · ticket types: " (join ", " (host/blog--out-raw f "has-ticket-type")))))))
films))))))
;; add a film (+ its default ticket types: adult, u18).
(define host/blog-new-film
(fn (req)
(let ((title (host/field req "title")))
(begin
(when (and title (not (= title "")))
(let ((slug (host/blog-slugify title)))
(begin
(host/blog-seed! slug title (str "(article (h1 \"" title "\"))") "published")
(host/blog-relate! slug "film" "is-a")
(for-each (fn (tt) (host/blog-relate! slug tt "has-ticket-type")) (list "adult" "u18")))))
(dream-redirect "/cinema")))))
;; book a showing: a Film onto a Calendar at a time; snapshot the film's ticket types as Offerings.
(define host/blog-new-showing
(fn (req)
(let ((film (host/field req "film")) (calendar (host/field req "calendar"))
(time (or (host/field req "time") "")) (cap (or (host/field req "capacity") "")))
(begin
(when (and film (not (= film "")) calendar (not (= calendar "")))
(let ((slug (host/blog-slugify (str film "-" calendar "-" time))))
(begin
(host/blog-seed! slug (str film " showing") (str "(article (h1 \"Showing: " film "\") (p \"" time "\"))") "published")
(host/blog-relate! slug "showing" "is-a")
(host/blog-relate! slug film "of-film")
(host/blog-relate! calendar slug "scheduled")
(host/blog-relate! slug calendar "on-calendar")
(host/blog--set-field-values! slug {"time" time "capacity" cap})
(for-each (fn (tt)
(let ((off (str slug "--" tt)))
(begin
(host/blog-seed! off (str tt " @ " slug) "(article (h1 \"Offering\"))" "published")
(host/blog-relate! off "offering" "is-a")
(host/blog-relate! slug off "offers")
(host/blog-relate! off tt "of-type")
(host/blog--set-field-values! off {"price" "10"}))))
(host/blog--out-raw film "has-ticket-type")))))
(dream-redirect "/cinema")))))
;; ── /cinema — the events domain admin: screens/calendars/showings, add a film, book a showing ──
(define host/blog-cinema
(fn (req)
(host/blog--resp req 200
(host/blog--page req "Rose Ash Cinema"
(quasiquote
(div (h1 "🎬 Rose Ash Cinema")
(h3 :style "margin:0.8em 0 0.2em" "Screens & calendars")
(unquote (host/blog--screens-view "rose-ash-cinema"))
(h3 :style "margin:0.8em 0 0.2em" "Films")
(unquote (host/blog--films-view))
(form :method "post" :action "/new-film" :style "margin:0.4em 0"
(input :name "title" :placeholder "Film title") " " (button :type "submit" "Add film"))
(h3 :style "margin:0.8em 0 0.2em" "Book a showing")
(form :method "post" :action "/new-showing"
:style "padding:0.5em;border:1px dashed #bbb;background:#fafafa;font-size:0.9em"
(input :name "film" :placeholder "film slug" :style "width:9em") " "
(input :name "calendar" :placeholder "cal-screen-1" :style "width:9em") " "
(input :name "time" :placeholder "Fri 8pm" :style "width:7em") " "
(input :name "capacity" :placeholder "cap (opt)" :style "width:6em") " "
(button :type "submit" "Book showing"))))))))
;; a showing's capacity: its own override, else its calendar's screen's default.
(define host/blog--showing-capacity
(fn (slug)
(let ((override (get (host/blog-field-values-of slug) "capacity")))
(if (and override (not (= override ""))) (parse-int override 0)
(let ((cals (host/blog--out-raw slug "on-calendar")))
(if (= (len cals) 0) 0
(let ((screens (host/blog-in (first cals) "has-calendar")))
(if (= (len screens) 0) 0
(parse-int (or (get (host/blog-field-values-of (first screens)) "capacity") "0") 0)))))))))
;; the TICKETS section shown on a showing's page: capacity/sold + a Buy form per Offering.
;; the admin editor for a showing's offerings — edit price/cap, remove, and add (incl. brand-new
;; ticket types like special-offer). Collapsed in a <details> so it doesn't clutter the buy view.
(define host/blog--offering-editor
(fn (slug)
(quasiquote
(details :style "margin-top:0.8em;font-size:0.9em"
(summary :style "cursor:pointer;color:#a58" "⚙ Manage offerings")
(unquote
(cons (quote div)
(map (fn (off)
(let ((tt (host/blog--out-raw off "of-type"))
(price (get (host/blog-field-values-of off) "price"))
(ocap (get (host/blog-field-values-of off) "cap")))
(quasiquote (div :style "margin:0.3em 0;padding:0.3em 0;border-bottom:1px solid #eee"
(b (unquote (if (> (len tt) 0) (first tt) off))) " "
(form :method "post" :action (unquote (str "/offering-update?offering=" off)) :style "display:inline"
"£" (input :name "price" :value (unquote (or price "")) :style "width:4em")
" cap " (input :name "cap" :value (unquote (or ocap "")) :placeholder "∞" :style "width:4em")
" " (button :type "submit" "Save"))
" "
(form :method "post" :action (unquote (str "/offering-remove?offering=" off)) :style "display:inline"
(button :type "submit" "Remove"))))))
(host/blog--out-raw slug "offers"))))
(form :method "post" :action (unquote (str "/offering-add?showing=" slug))
:style "margin-top:0.4em;padding:0.4em;background:#f2f2f2;border-radius:3px"
(b "Add: ") (input :name "tickettype" :placeholder "ticket type (e.g. special-offer)" :style "width:12em")
" £" (input :name "price" :placeholder "price" :style "width:4em")
" cap " (input :name "cap" :placeholder "∞" :style "width:4em")
" " (button :type "submit" "Add offering"))))))
;; is an offering still available? — its own cap if set, else limited only by the showing capacity.
(define host/blog--offering-available?
(fn (off)
(let ((cap (get (host/blog-field-values-of off) "cap")))
(if (or (not cap) (= cap "")) true
(< (len (host/blog--out-raw off "sold")) (parse-int cap 0))))))
(define host/blog--showing-extras
(fn (slug)
(if (not (contains? (host/blog--out-raw slug "is-a") "showing")) ""
(let ((cap (host/blog--showing-capacity slug)) (sold (len (host/blog--out-raw slug "sold"))))
(quasiquote
(div :style "margin:1.5em 0;padding:0.8em 1em;border:2px solid #b9a;border-radius:6px;background:#fbf7fb"
(h3 :style "margin:0 0 0.2em" "🎟 Tickets")
(p :style "font-size:0.9em;color:#555"
(unquote (str "Capacity " (str cap) " · sold " (str sold) (if (>= sold cap) " · SOLD OUT" ""))))
(unquote
(cons (quote div)
(map (fn (off)
(let ((tt (host/blog--out-raw off "of-type"))
(price (get (host/blog-field-values-of off) "price"))
(ocap (get (host/blog-field-values-of off) "cap"))
(osold (len (host/blog--out-raw off "sold"))))
(quasiquote (div :style "margin:0.35em 0"
(b (unquote (if (> (len tt) 0) (first tt) off))) (unquote (str " — £" (or price "?")))
(unquote (if (and ocap (not (= ocap ""))) (str " (" (str osold) "/" ocap " sold)") ""))
" "
(unquote (if (or (>= sold cap) (not (host/blog--offering-available? off)))
(quote (span :style "color:#999" "sold out"))
(quasiquote (form :method "post"
:action (unquote (str "/buy-ticket?showing=" slug "&offering=" off)) :style "display:inline"
(input :name "email" :placeholder "your email" :style "width:12em") " "
(button :type "submit" "Buy")))))))))
(host/blog--out-raw slug "offers"))))
(unquote (host/blog--offering-editor slug))))))))
;; events: buy a ticket for a showing/offering — CAPACITY-CHECKED, then a cross-domain order on shop.
(define host/blog-buy-ticket
(fn (req)
(let ((showing (dream-query-param req "showing")) (offering (dream-query-param req "offering"))
(email (or (host/field req "email") "")))
(begin
(when (and showing offering (not (= email ""))
(< (len (host/blog--out-raw showing "sold")) (host/blog--showing-capacity showing))
(host/blog--offering-available? offering)
(not (= host/blog--shop-base "")))
(let ((body (get (http-request "POST"
(str host/blog--shop-base "/ticket?showing=" showing "&offering=" offering "&email=" email)
{} "") "body")))
(when (starts-with? body "ticket:")
(let ((tid (substr body 7 (- (len body) 7))))
(begin
(host/blog-relate! showing tid "sold")
(host/blog-relate! offering tid "sold")))))) ;; per-offering tally too
(dream-redirect (str "/" showing "/"))))))
;; the showing an offering belongs to (showing --offers--> offering).
(define host/blog--offering-showing
(fn (off) (let ((ss (host/blog-in off "offers"))) (if (> (len ss) 0) (first ss) "cinema"))))
;; edit an offering's price + cap.
(define host/blog-offering-update
(fn (req)
(let ((off (dream-query-param req "offering"))
(price (or (host/field req "price") "")) (cap (or (host/field req "cap") "")))
(begin
(when off (host/blog--set-field-values! off {"price" price "cap" cap}))
(dream-redirect (str "/" (host/blog--offering-showing off) "/"))))))
;; remove an offering from a showing (unlink; tickets already sold keep their record).
(define host/blog-offering-remove
(fn (req)
(let ((off (dream-query-param req "offering")))
(let ((showing (host/blog--offering-showing off)))
(begin
(when off (host/blog-unrelate! showing off "offers"))
(dream-redirect (str "/" showing "/")))))))
;; add an offering to a showing — creating the ticket type first if it's new (e.g. special-offer).
(define host/blog-offering-add
(fn (req)
(let ((showing (dream-query-param req "showing"))
(tt (host/blog-slugify (or (host/field req "tickettype") "")))
(price (or (host/field req "price") "0")) (cap (or (host/field req "cap") "")))
(begin
(when (and showing (not (= tt "")))
(begin
(when (not (host/blog-exists? tt))
(begin (host/blog-seed! tt tt (str "(article (h1 \"" tt "\"))") "published")
(host/blog-relate! tt "ticket-type" "is-a")))
(let ((off (str showing "--" tt)))
(begin
(host/blog-seed! off (str tt " @ " showing) "(article (h1 \"Offering\"))" "published")
(host/blog-relate! off "offering" "is-a")
(host/blog-relate! showing off "offers")
(host/blog-relate! off tt "of-type")
(host/blog--set-field-values! off {"price" price "cap" cap})))))
(dream-redirect (str "/" showing "/"))))))
;; shop: issue a ticket (is-a ticket, for showing, bought-as offering, owned-by person) → "ticket:<id>".
(define host/blog-ticket
(fn (req)
(let ((showing (or (dream-query-param req "showing") "")) (offering (or (dream-query-param req "offering") ""))
(email (or (dream-query-param req "email") "")))
(let ((tid (str "ticket-" showing "-" (str (len (host/blog-slugs))))))
(begin
(host/blog-put! tid (str "Ticket: " showing) (str "(article (h1 \"Ticket\") (p \"" showing " · " offering "\"))") "published")
(host/blog-relate! tid "ticket" "is-a")
(host/blog-relate! tid showing "for")
(host/blog-relate! tid offering "bought-as")
(host/blog-relate! tid email "owned-by")
(host/blog--set-field-values! tid {"email" email})
(when (not (= host/blog--identity-base ""))
(http-request "POST" (str host/blog--identity-base "/person?email=" email) {} ""))
(dream-response 200 {:content-type "text/plain; charset=utf-8"} (str "ticket:" tid)))))))
;; identity: find-or-create a Person keyed by a contact-id (email), login-optional → "person:<id>".
(define host/blog-person
(fn (req)
(let ((email (or (dream-query-param req "email") "")))
(let ((pid (str "person-" (host/blog-slugify email))))
(begin
(when (not (host/blog-exists? pid))
(begin
(host/blog-put! pid email (str "(article (h1 \"" email "\"))") "published")
(host/blog-relate! pid "person" "is-a")
(host/blog--set-field-values! pid {"email" email})))
(dream-response 200 {:content-type "text/plain; charset=utf-8"} (str "person:" pid)))))))
;; ── /people — the identity domain view: Persons, email-keyed, login-optional ──
(define host/blog-people
(fn (req)
(host/blog--resp req 200
(host/blog--page req "People"
(quasiquote
(div (h1 "👤 People")
(p "Accounts keyed by contact-id (email) — created at checkout, login optional.")
(unquote
(let ((people (host/blog-in "person" "is-a")))
(if (= (len people) 0) (quote (p :style "color:#999" (em "No people yet.")))
(cons (quote ul)
(map (fn (p) (let ((email (get (host/blog-field-values-of p) "email")))
(quasiquote (li (b (unquote (str p))) (unquote (str " — " (or email "")))))))
people)))))))))))
;; ── /orders — the shop domain view: ticket orders placed for events (federated from events) ──
(define host/blog-orders
(fn (req)
(host/blog--resp req 200
(host/blog--page req "Orders"
(quasiquote
(div (h1 "🛒 Orders (shop)")
(p "Ticket orders placed for events.")
(unquote
(let ((orders (host/blog-in "order" "is-a")))
(if (= (len orders) 0) (quote (p :style "color:#999" (em "No orders yet.")))
(cons (quote ul)
(map (fn (o)
(let ((ev (host/blog--out-raw o "for")))
(quasiquote (li (b (unquote (str o)))
(unquote (if (> (len ev) 0) (str " — for event: " (first ev)) ""))))))
orders)))))))))))
;; ── /calendars — the events domain view: allocated posts + scheduled events + a create form ──
(define host/blog-calendars
(fn (req)
(host/blog--resp req 200
(host/blog--page req "Calendars"
(quasiquote
(div (h1 "📅 Calendars (events domain)")
(p "Posts allocated in from blog, events scheduled on each calendar, and ticket sales.")
(h3 :style "margin:1em 0 0.2em" "main")
(h4 :style "margin:0.6em 0 0.2em;font-size:0.95em" "Allocated posts")
(unquote
(let ((posts (host/blog--out-raw "main" "allocated")))
(if (= (len posts) 0) (quote (p :style "color:#999" (em "Nothing allocated yet.")))
(cons (quote ul) (map (fn (p) (quasiquote (li (unquote (str p))))) posts)))))
(h4 :style "margin:0.6em 0 0.2em;font-size:0.95em" "Scheduled events")
(unquote (host/blog--events-list "main"))
(h4 :style "margin:0.8em 0 0.2em;font-size:0.95em" "Schedule an event")
(form :method "post" :action "/new-event"
:style "padding:0.6em;border:1px dashed #bbb;background:#fafafa;font-size:0.9em"
(input :name "title" :placeholder "Event title" :style "width:12em") " "
(input :name "date" :placeholder "date" :style "width:7em") " "
(input :name "post" :placeholder "features post (slug)" :style "width:11em") " "
(button :type "submit" "Create event"))))))))
;; ── /activities — P2: the EVENT SOURCE ───────────────────────────────
;; Every observable state change emitted as a canonical activity (Create/Update on content,
;; Add/Remove on relations). This is what federates (TA pushes it to peers) and what triggers
;; behaviors. Public read; durable (survives restart).
(define host/blog-activities
(fn (req)
(host/blog--resp req 200
(host/blog--page req "Activities"
(quasiquote
(div (h1 "Activities")
(p "The event source — every observable state change (content Create/Update, relation Add/Remove).")
(unquote
(if (= (len host/blog--activity-log) 0)
(quote (p (em "No activities yet.")))
(cons (quote ul)
(map (fn (a)
(quasiquote (li (strong (unquote (get a "verb"))) " "
(unquote (str (get a "type") " ")) (code (unquote (str (get a "object"))))
(unquote (str " — " (get a "delta"))))))
host/blog--activity-log))))))))))
;; ── TA-live: the federation INBOX ────────────────────────────────────
;; A peer POSTs a serialized activity here (fed-sx over HTTP); we deserialize it and run it through
;; OUR engine — so a REMOTE instance's state change fires THIS instance's behaviors (and logs as a
;; received event, and can suspend on our kernel). Public for the demo; prod verifies the peer's
;; signature before accepting. This is the receive side of TA — "everything works over fed-sx", live.
;; (host/blog--receive! is defined with emit! above — process-local only, no re-federation.)
(define host/blog-inbox
(fn (req)
(let ((body (dream-body req)))
(if (not (host/blog--fed-verify? req body))
(host/error 403 "bad federation signature") ;; reject unsigned/forged POSTs
(let ((w (parse-safe body)))
(if (= (get w "verb") "follow")
;; a FOLLOW: register the sender as a follower (deliver our activities to its inbox).
(begin (host/blog--add-follower! (get w "actor") (get w "base")) (host/ok {:followed (get w "actor")}))
;; a regular activity: process it (fires our behaviors on the peer's event).
(let ((a (host/ta--wire->activity w)))
(begin (host/blog--receive! a) (host/ok {:received (or (get a :id) "")})))))))))
;; ── 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-post "/inbox" host/blog-inbox)
(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 "/flows" host/blog-flows)
(dream-get "/fed-tick" host/blog-fed-tick)
(dream-get "/calendars" host/blog-calendars)
(dream-get "/cinema" host/blog-cinema)
(dream-get "/orders" host/blog-orders)
(dream-get "/people" host/blog-people)
(dream-post "/new-film" host/blog-new-film)
(dream-post "/new-showing" host/blog-new-showing)
(dream-post "/buy-ticket" host/blog-buy-ticket)
(dream-post "/offering-add" host/blog-offering-add)
(dream-post "/offering-update" host/blog-offering-update)
(dream-post "/offering-remove" host/blog-offering-remove)
(dream-post "/ticket" host/blog-ticket)
(dream-post "/person" host/blog-person)
(dream-post "/new-event" host/blog-new-event)
(dream-post "/buy" host/blog-buy)
(dream-post "/order" host/blog-order)
(dream-get "/activities" host/blog-activities)
(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)))
;; POST /<slug>/allocate?calendar=<id> — allocate a post to a calendar on the events peer. Emits a
;; directed "allocate" activity that federates to events, whose calendar type reacts (P1 behavior).
(define host/blog-allocate
(fn (req)
(let ((post (dream-param req "slug"))
(calendar (or (host/field req "calendar") (dream-query-param req "calendar") "main")))
(begin
(when (not (= host/blog--events-base "")) (host/blog--allocate! post calendar))
(dream-redirect (str "/" post "/"))))))
(define host/blog-write-routes
(fn (resolve)
(list
(dream-post "/new" (host/blog--protect-html resolve host/blog-form-submit))
(dream-post "/:slug/allocate" (host/blog--protect-html resolve host/blog-allocate))
(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/grammar" (host/blog--protect-html resolve host/blog-grammar-submit))
(dream-post "/:slug/relations" (host/blog--protect-html resolve host/blog-relations-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))))
Reference in New Issue View Git Blame Copy Permalink