giles
9effa71dde
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 52s
Define a relation through the UI (metamodel editor surface 1, completing it): POST /meta/new-relation creates a relation-post (is-a relation, :rel metadata) and registers it via a runtime concat onto host/blog-rel-kinds — safe because the serving handler has the IO resolver installed. /meta gains a '+ Relation' form (name, label, symmetric). Verified: define 'Blocks' (symmetric) -> Relations(5), its editor renders on edit pages, kind-spec + symmetric correct; auth-guarded. SESSION-SCOPED: the relation-post + edges persist durably, but the rel-kinds registry entry is lost on restart because load-rel-kinds! must stay UNROLLED — it runs at BOOT where it is JIT-compiled but the IO resolver is NOT yet installed, so a dynamic loader (map/reduce over instances-of 'relation' with a durable read per item) silently returns [] (verified: dynamic -> /meta Relations(0)). The serving-JIT HO-callback-perform fix only engages with the resolver = serve time. Flagged to sx-vm-extensions (NOTE-render-diff-for- vm-ext.md); they ACKed + are tracking the boot-resolver fix. Reverted the dynamic loader, kept the unroll with a comment explaining why. VERIFICATION NOTE: the full blog suite could not complete — the box is under extreme contention from sibling loops (load 14, multiple full conformance + erlang/vm-ext rebuilds) and the Datalog-heavy 140-test suite times out even at a 1800s cap. Verified instead two ways: (1) live-path HTTP (real route + auth + editor render, ephemeral SX_SERVING_JIT=1), (2) a focused in-process eval of the create-relation core (exists/is-a/kind-spec/symmetric/ registry-len = true,true,true,true,5). Prior full run was 140/140; changes since are purely additive (handler + form + route + 3 tests). Re-run the blog suite when the box is quiet. Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
1516 lines
81 KiB
Plaintext
1516 lines
81 KiB
Plaintext
;; lib/host/blog.sx — Blog domain on the host, on the EDITOR's content model.
|
||
;; The SX post editor (blog/sx/editor.sx) emits `sx_content`: SX element markup
|
||
;; (e.g. "(article (h1 \"T\") (p \"body\" (strong \"x\")))"), NOT content-on-sx
|
||
;; CtDoc blocks. So a post here is a record {slug,title,sx_content,status} stored
|
||
;; in the durable persist KV, and a post page is `render-to-html (parse sx_content)`
|
||
;; — server-side, static, no client runtime needed to view a published post.
|
||
;;
|
||
;; GET / HTML index of posts (public)
|
||
;; GET /<slug>/ rendered post (public) -> HTML / 404
|
||
;; GET /posts SX list (public) -> {:ok true :data ({:slug …} …)}
|
||
;; GET /new HTML create form (public chrome)
|
||
;; POST /new form ingest from the editor (guarded)
|
||
;; POST /<slug>/edit form ingest, edit an existing post (guarded)
|
||
;; Reads anonymous; writes behind the auth+ACL pipeline ("edit" on "blog"). The
|
||
;; JSON CRUD /posts (POST/PUT/DELETE) was deleted in the SX-native pivot — the wire
|
||
;; is SX/SXTP (host/ok emits text/sx), writes go through the form ingest.
|
||
;; Depends on spec/render + web/adapter-html (render-to-html), lib/persist/*
|
||
;; (durable KV), lib/dream/* (+ form), lib/host/{handler,middleware}.sx.
|
||
|
||
;; ── store (durable persist KV, injectable) ──────────────────────────
|
||
(define host/blog-store (persist/open))
|
||
(define host/blog-use-store! (fn (b) (set! host/blog-store b)))
|
||
(define host/blog--key (fn (slug) (str "blog:" slug)))
|
||
|
||
;; ── content-addressing: a universal CID over the canonical form ─────
|
||
;; Every object (content/type/relation/constraint post) carries a stable :cid =
|
||
;; hash of its CONTENT. The runtime has no hash primitive, so the canon serializer
|
||
;; and a tail-recursive double-hash are built here. Canon SORTS keys, so the CID is
|
||
;; identical across processes regardless of dict insertion / hash-seed order. The
|
||
;; :slug (a mutable name) and any prior :cid are excluded — the CID hashes content
|
||
;; only. git-shaped: slug = mutable name -> CID = immutable content identity.
|
||
(define host/blog--canon
|
||
(fn (v)
|
||
(let ((t (type-of v)))
|
||
(cond
|
||
((= t "dict")
|
||
(str "{" (join "|"
|
||
(map (fn (k) (str k "=" (host/blog--canon (get v k))))
|
||
(filter (fn (k) (and (not (= k "slug")) (not (= k "cid"))))
|
||
(sort (keys v))))) "}"))
|
||
((= t "list") (str "[" (join "|" (map host/blog--canon v)) "]"))
|
||
((= t "nil") "~")
|
||
(else (str v))))))
|
||
(define host/blog--hash-go
|
||
(fn (s i n h1 h2)
|
||
(if (>= i n)
|
||
(str h1 "-" h2)
|
||
(let ((c (char-code (substr s i 1))))
|
||
(host/blog--hash-go s (+ i 1) n
|
||
(mod (+ (* h1 131) c) 1000000007)
|
||
(mod (+ (* h2 137) c) 998244353))))))
|
||
(define host/blog--cid-of
|
||
(fn (rec) (let ((s (host/blog--canon rec))) (str "z" (host/blog--hash-go s 0 (len s) 7 11)))))
|
||
;; the single choke point for every record write: stamps the content CID, then puts.
|
||
(define host/blog--write!
|
||
(fn (slug rec)
|
||
(persist/backend-kv-put host/blog-store (host/blog--key slug)
|
||
(merge rec {:cid (host/blog--cid-of rec)}))))
|
||
|
||
;; slug from a title: lowercase, words joined by '-'. (Punctuation kept simple.)
|
||
(define host/blog-slugify
|
||
(fn (title)
|
||
(join "-" (filter (fn (w) (not (= w ""))) (split (lower title) " ")))))
|
||
|
||
;; ── records ─────────────────────────────────────────────────────────
|
||
(define host/blog-get
|
||
(fn (slug) (persist/backend-kv-get host/blog-store (host/blog--key slug))))
|
||
(define host/blog-exists?
|
||
(fn (slug) (persist/backend-kv-has? host/blog-store (host/blog--key slug))))
|
||
;; A write preserves any extra slots already on the record (:rel for relation-posts,
|
||
;; :schema for refinement types) — merging over the previous record — so editing a
|
||
;; post's title/content/status doesn't nuke the metadata that lives alongside it.
|
||
(define host/blog-put!
|
||
(fn (slug title sx-content status)
|
||
(let ((prev (host/blog-get slug)))
|
||
(host/blog--write! slug
|
||
(merge (if prev prev {})
|
||
{:slug slug :title title :sx-content sx-content :status status})))))
|
||
(define host/blog-delete!
|
||
(fn (slug) (persist/backend-kv-delete host/blog-store (host/blog--key slug))))
|
||
(define host/blog-seed!
|
||
(fn (slug title sx-content status)
|
||
(when (not (host/blog-exists? slug)) (host/blog-put! slug title sx-content status))))
|
||
|
||
;; all blog slugs (kv keys are "blog:<slug>")
|
||
(define host/blog-slugs
|
||
(fn ()
|
||
(reduce
|
||
(fn (acc k)
|
||
(if (starts-with? k "blog:") (append acc (list (substr k 5))) acc))
|
||
(list)
|
||
(persist/backend-kv-keys host/blog-store))))
|
||
(define host/blog-list
|
||
(fn ()
|
||
(map
|
||
(fn (slug)
|
||
(let ((r (host/blog-get slug)))
|
||
{:slug slug :title (get r :title) :status (get r :status)}))
|
||
(host/blog-slugs))))
|
||
|
||
;; a post's content CID — its global, location-independent identity (nil if unknown).
|
||
(define host/blog-cid (fn (slug) (get (host/blog-get slug) :cid)))
|
||
;; reverse lookup: a slug whose record has this CID (nil if none). Scan; not for renders.
|
||
(define host/blog-by-cid
|
||
(fn (cid)
|
||
(reduce
|
||
(fn (acc slug) (if acc acc (if (= (host/blog-cid slug) cid) slug acc)))
|
||
nil (host/blog-slugs))))
|
||
|
||
;; ── render ──────────────────────────────────────────────────────────
|
||
;; A post's sx_content is SX element markup -> HTML via render-page (which supplies
|
||
;; the server env so components resolve + keyword attrs are kept).
|
||
;;
|
||
;; Rendered PER BLOCK and guarded: the editor wraps content in a (<> ...) fragment
|
||
;; of blocks, some of which the host can't render (the legacy editor emits bare
|
||
;; ~kg-md cards while the components are ~kg_cards/kg-md — drift we don't paper over
|
||
;; with aliases). Rendering each block under its own guard means the real prose
|
||
;; (p/h1/ul/...) shows and only the unsupported block degrades to a placeholder —
|
||
;; and a bad block never crashes the handler (-> 502).
|
||
(define host/blog--render-node
|
||
(fn (node)
|
||
(guard (e (true "<div class=\"blk-unsupported\"><em>(unsupported block)</em></div>"))
|
||
(render-page node))))
|
||
(define host/blog-render
|
||
(fn (record)
|
||
(let ((sx (get record :sx-content)))
|
||
(if (and sx (not (= sx "")))
|
||
(let ((tree (parse-safe sx)))
|
||
(cond
|
||
((nil? tree) "<p><em>(unparseable content)</em></p>")
|
||
((and (= (type-of tree) "list") (> (len tree) 0)
|
||
(= (str (first tree)) "<>"))
|
||
(join "" (map host/blog--render-node (rest tree))))
|
||
(else (host/blog--render-node tree))))
|
||
(str "<p>(empty post)</p>")))))
|
||
;; ── related posts (blog × relations) ────────────────────────────────
|
||
;; Every link between posts is a typed edge in the relations graph (lib/relations):
|
||
;; node = "blog:<slug>", kind = a relation kind. "related" is symmetric; directed
|
||
;; kinds (is-a, tagged) carry meaning by direction. The registry below is the one
|
||
;; place that knows each kind's direction, label, and candidate set — relate, the
|
||
;; picker, and rendering all read from it (see plans/typed-posts-and-relations.md).
|
||
;; "Typing is just relating to a type": classification is an is-a/tagged edge to a
|
||
;; type-post, and types ARE posts (same blog:<slug> namespace).
|
||
(define host/blog--node (fn (slug) (string->symbol (str "blog:" slug))))
|
||
|
||
;; Relations are POSTS (plans/relations-as-posts.md). Each relation-post is-a
|
||
;; `relation` and owns its metadata in a :rel slot {:symmetric :label
|
||
;; :inverse-label}. To keep RENDER paths perform-free — a durable read inside the
|
||
;; http-listen render VM raises VmSuspended — the relation specs are loaded into an
|
||
;; in-memory cache at boot, exactly like edges (host/blog-load-edges!). kind-spec /
|
||
;; rel-kinds / kind-symmetric? then read the cache (pure); the relation-posts stay
|
||
;; the durable source of truth. host/blog-load-rel-kinds! re-reads them.
|
||
(define host/blog--rel-cache (dict))
|
||
;; cache one relation-post's :rel metadata (+ :kind), keyed by slug.
|
||
(define host/blog--cache-rel!
|
||
(fn (kind)
|
||
(let ((m (get (host/blog-get kind) :rel)))
|
||
(when m (dict-set! host/blog--rel-cache kind (merge {:kind kind} m))))))
|
||
;; host/blog-rel-kinds is a VALUE (the list of relation specs), populated at boot by
|
||
;; load-rel-kinds! — like slice 1's static registry, which mapped fine on the live
|
||
;; serving JIT. (Computing it as a function that map/for-each-es a function-produced
|
||
;; list silently lost 3 of 4 relations on the live JIT — see plans/relations-as-posts.md
|
||
;; / plans/jit-bytecode-correctness.md. Both the cache loads and the list build are
|
||
;; therefore UNROLLED — no iteration over the relation list.) Metadata still lives on
|
||
;; the relation-posts; add a relation = a seed-rel! + a line in each unrolled list.
|
||
(define host/blog-rel-kinds (list))
|
||
;; UNROLLED, and it must STAY unrolled: load-rel-kinds! runs at BOOT, where it is
|
||
;; JIT-compiled but the http-listen IO resolver is NOT yet installed (that happens when
|
||
;; serving starts). The serving-JIT HO-callback-perform fix (81177d0e) only engages WITH
|
||
;; the resolver, so a dynamic loader (map/for-each/reduce over instances-of "relation"
|
||
;; with a durable read per item) silently returns [] at boot — verified 2026-06-30:
|
||
;; dynamic loader -> /meta Relations(0). So the cache loads + the list are UNROLLED (no
|
||
;; HO over a function-produced list). A new relation is a seed-rel! + a line here; or
|
||
;; appended at RUNTIME (where the resolver IS installed) — see host/blog-meta-new-relation.
|
||
(define host/blog-load-rel-kinds!
|
||
(fn ()
|
||
(begin
|
||
(host/blog--cache-rel! "related")
|
||
(host/blog--cache-rel! "is-a")
|
||
(host/blog--cache-rel! "subtype-of")
|
||
(host/blog--cache-rel! "tagged")
|
||
(set! host/blog-rel-kinds
|
||
(list (get host/blog--rel-cache "related") (get host/blog--rel-cache "is-a")
|
||
(get host/blog--rel-cache "subtype-of") (get host/blog--rel-cache "tagged"))))))
|
||
;; spec = the cached :rel metadata + :kind; nil for a non-relation (relate validates).
|
||
(define host/blog--kind-spec (fn (kind) (get host/blog--rel-cache kind)))
|
||
(define host/blog--kind-symmetric?
|
||
(fn (kind) (let ((s (host/blog--kind-spec kind))) (and s (get s :symmetric)))))
|
||
|
||
;; ── edges (parameterised by kind, DURABLE) ──────────────────────────
|
||
;; lib/relations holds the graph in memory (a Datalog cache that re-saturates per
|
||
;; query); it does NOT survive a restart. So the host owns the durable source of
|
||
;; truth: every physical edge is also a KV row "edge:<src>|<kind>|<dst>" in the
|
||
;; blog store, replayed into the in-memory graph on boot (host/blog-load-edges!).
|
||
;; '|' is a safe delimiter — slugs are [a-z0-9-], kinds are registry names.
|
||
(define host/blog--edge-key (fn (src kind dst) (str "edge:" src "|" kind "|" dst)))
|
||
|
||
(define host/blog--add-edge!
|
||
(fn (src dst kind)
|
||
(begin
|
||
(relations/relate (host/blog--node src) (host/blog--node dst) (string->symbol 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)
|
||
(begin
|
||
(relations/unrelate (host/blog--node src) (host/blog--node dst) (string->symbol 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)))))
|
||
|
||
;; rebuild the in-memory graph from the durable edge store — called on boot, after
|
||
;; the store is pointed at the durable backend. Each "edge:<src>|<kind>|<dst>" key
|
||
;; is re-applied directly (both directions of a symmetric kind are stored, so no
|
||
;; symmetry re-derivation is needed here).
|
||
(define host/blog-load-edges!
|
||
(fn ()
|
||
(for-each
|
||
(fn (key)
|
||
(let ((body (substr key 5))) ;; drop "edge:"
|
||
(let ((p1 (index-of body "|")))
|
||
(when (>= p1 0)
|
||
(let ((src (substr body 0 p1))
|
||
(tail (substr body (+ p1 1))))
|
||
(let ((p2 (index-of tail "|")))
|
||
(when (>= p2 0)
|
||
(let ((ek (substr tail 0 p2)))
|
||
;; conj/disj are structural (type-algebra operands) — KV-only,
|
||
;; never replayed into the Datalog graph (it re-saturates per query).
|
||
(when (not (or (= ek "conj") (= ek "disj")))
|
||
(relations/relate
|
||
(host/blog--node src)
|
||
(host/blog--node (substr tail (+ p2 1)))
|
||
(string->symbol ek)))))))))))
|
||
(filter (fn (k) (starts-with? k "edge:"))
|
||
(persist/backend-kv-keys host/blog-store)))))
|
||
|
||
;; nodes -> existing blog slugs: strip "blog:", drop non-blog and deleted targets.
|
||
;; Existence is one kv-keys read (host/blog-slugs), NOT a perform per candidate —
|
||
;; keeping IO out of the inner filter (and out of the page-render quasiquote).
|
||
(define host/blog--edge-slugs
|
||
(fn (nodes)
|
||
(let ((existing (host/blog-slugs)))
|
||
(filter (fn (s) (contains? existing s))
|
||
(map (fn (n) (substr (symbol->string n) 5))
|
||
(filter (fn (n) (starts-with? (symbol->string n) "blog:")) nodes))))))
|
||
|
||
;; DIRECT edges come from the durable edge store, NOT lib/relations: each relations
|
||
;; query re-runs the (CEK-interpreted) ruleset — ~seconds even on a tiny graph —
|
||
;; whereas the edge:<src>|<kind>|<dst> KV rows are a cheap string scan. lib/relations
|
||
;; is reserved for TRANSITIVE queries (descendants/ancestors). The two are always
|
||
;; in sync: host/blog-relate! writes both, and a plain blog edge has no derived
|
||
;; effective edges, so KV == relations/children for direct lookups.
|
||
(define host/blog--parse-edge-key
|
||
(fn (k)
|
||
(if (starts-with? k "edge:")
|
||
(let ((body (substr k 5)))
|
||
(let ((p1 (index-of body "|")))
|
||
(if (< p1 0) nil
|
||
(let ((rest (substr body (+ p1 1))))
|
||
(let ((p2 (index-of rest "|")))
|
||
(if (< p2 0) nil
|
||
{:src (substr body 0 p1)
|
||
:kind (substr rest 0 p2)
|
||
:dst (substr rest (+ p2 1))}))))))
|
||
nil)))
|
||
(define host/blog--all-edges
|
||
(fn ()
|
||
(filter (fn (e) (not (nil? e)))
|
||
(map host/blog--parse-edge-key (persist/backend-kv-keys host/blog-store)))))
|
||
|
||
;; outgoing targets / incoming sources of `slug` under `kind`, as existing slugs.
|
||
(define host/blog-out
|
||
(fn (slug kind)
|
||
(let ((existing (host/blog-slugs)))
|
||
(filter (fn (s) (contains? existing s))
|
||
(reduce (fn (acc e)
|
||
(if (and (= (get e :src) slug) (= (get e :kind) kind))
|
||
(concat acc (list (get e :dst))) acc))
|
||
(list) (host/blog--all-edges))))))
|
||
(define host/blog-in
|
||
(fn (slug kind)
|
||
(let ((existing (host/blog-slugs)))
|
||
(filter (fn (s) (contains? existing s))
|
||
(reduce (fn (acc e)
|
||
(if (and (= (get e :dst) slug) (= (get e :kind) kind))
|
||
(concat acc (list (get e :src))) acc))
|
||
(list) (host/blog--all-edges))))))
|
||
|
||
;; back-compat: "related posts" is just the symmetric "related" kind.
|
||
(define host/blog-related (fn (slug) (host/blog-out slug "related")))
|
||
|
||
;; ── typing: is-a + subtype-of with subsumption ──────────────────────
|
||
;; Typing is just relating to a type, and types ARE posts. A post DECLARES its
|
||
;; types with is-a edges; types form a hierarchy with subtype-of edges. is-a
|
||
;; (instance-of) is NOT transitive on its own, but subsumption is: an instance of
|
||
;; a subtype is an instance of the supertype. So a post's full type set is its
|
||
;; declared types PLUS every subtype-of-ancestor of each (relations/descendants
|
||
;; follows subtype-of transitively). Keeps the Datalog ruleset minimal — the
|
||
;; closure is composed host-side.
|
||
(define host/blog--uniq
|
||
(fn (xs) (reduce (fn (acc x) (if (contains? acc x) acc (concat acc (list x)))) (list) xs)))
|
||
|
||
(define host/blog-types-of
|
||
(fn (slug)
|
||
(host/blog--uniq
|
||
(reduce
|
||
(fn (acc t)
|
||
(concat (concat acc (list t))
|
||
(host/blog--edge-slugs
|
||
(relations/descendants (host/blog--node t) (string->symbol "subtype-of")))))
|
||
(list)
|
||
(host/blog-out slug "is-a")))))
|
||
|
||
;; 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. Computed in O(#subtypes) relation
|
||
;; queries, NOT one type-resolution per post — the efficient way to enumerate a
|
||
;; type's members (e.g. "all tags") for the picker.
|
||
(define host/blog-instances-of
|
||
(fn (type)
|
||
(let ((subtypes
|
||
(concat (list type)
|
||
(host/blog--edge-slugs
|
||
(relations/ancestors (host/blog--node type) (string->symbol "subtype-of"))))))
|
||
(host/blog--uniq
|
||
(reduce (fn (acc t) (concat acc (host/blog-in t "is-a"))) (list) subtypes)))))
|
||
|
||
;; 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, the same set instances-of
|
||
;; computes internally as `subtypes`). Used by the metamodel overview + editor.
|
||
(define host/blog-type-defs
|
||
(fn ()
|
||
(host/blog--uniq
|
||
(concat (list "type")
|
||
(host/blog--edge-slugs
|
||
(relations/ancestors (host/blog--node "type") (string->symbol "subtype-of")))))))
|
||
|
||
;; ── Slice 4: type ALGEBRA — intersection (∧) and union (∨) types ─────
|
||
;; An algebraic type is a post with operand edges: a `conj` edge per intersection
|
||
;; member, a `disj` edge per union member. Its EXTENT is its operands' extents combined
|
||
;; by set intersection / union, recursively — so types compose into an algebra in the
|
||
;; same graph (meta-circular: an algebraic type is just another post). Binary today
|
||
;; (nth 0/1, no fold over operands — robust on the serving JIT); n-ary is a follow-up.
|
||
;; is-a-expr? generalises is-a? to type expressions.
|
||
(define host/blog--set-intersect
|
||
(fn (xs ys) (filter (fn (x) (contains? ys x)) xs)))
|
||
;; operand edges live in the KV ONLY (read back via host/blog-out), NOT in lib/relations:
|
||
;; conj/disj are structural, and feeding extra kinds into the Datalog graph blows up its
|
||
;; per-query re-saturation. host/blog-load-edges! skips them on replay for the same reason.
|
||
(define host/blog--add-edge-kv!
|
||
(fn (src dst kind)
|
||
(persist/backend-kv-put host/blog-store (host/blog--edge-key src kind dst) 1)))
|
||
(define host/blog-make-and!
|
||
(fn (t a b)
|
||
(begin
|
||
(host/blog-seed! t t
|
||
(str "(article (h1 \"" t "\") (p \"An intersection type (" a " ∧ " b ") — its instances are exactly those that are instances of BOTH.\"))")
|
||
"published")
|
||
(host/blog--add-edge-kv! t a "conj")
|
||
(host/blog--add-edge-kv! t b "conj"))))
|
||
(define host/blog-make-or!
|
||
(fn (t a b)
|
||
(begin
|
||
(host/blog-seed! t t
|
||
(str "(article (h1 \"" t "\") (p \"A union type (" a " ∨ " b ") — its instances are those that are instances of EITHER.\"))")
|
||
"published")
|
||
(host/blog--add-edge-kv! t a "disj")
|
||
(host/blog--add-edge-kv! t b "disj"))))
|
||
;; the EXTENT of a type expression: operands' extents combined by set ops (recursive).
|
||
;; A plain type (no operands) falls through to its instances.
|
||
(define host/blog-instances-of-expr
|
||
(fn (t)
|
||
(let ((conj (host/blog-out t "conj"))
|
||
(disj (host/blog-out t "disj")))
|
||
(cond
|
||
((>= (len conj) 2)
|
||
(host/blog--set-intersect (host/blog-instances-of-expr (nth conj 0))
|
||
(host/blog-instances-of-expr (nth conj 1))))
|
||
((>= (len disj) 2)
|
||
(host/blog--uniq (concat (host/blog-instances-of-expr (nth disj 0))
|
||
(host/blog-instances-of-expr (nth disj 1)))))
|
||
(else (host/blog-instances-of t))))))
|
||
;; is `slug` a member of the type expression `t`? Generalises is-a? to the algebra.
|
||
(define host/blog-is-a-expr?
|
||
(fn (slug t) (contains? (host/blog-instances-of-expr t) slug)))
|
||
|
||
;; ── tags (a tag is a post that is-a tag) ────────────────────────────
|
||
(define host/blog-is-tag? (fn (slug) (host/blog-is-a? slug "tag")))
|
||
(define host/blog-tags (fn (slug) (host/blog-out slug "tagged"))) ;; a post's tags
|
||
(define host/blog-tagged-with (fn (tag) (host/blog-in tag "tagged"))) ;; posts with a tag
|
||
|
||
;; ── gradual validation: refinement types (schemas ON the type-post) ──
|
||
;; A type-post may carry a SCHEMA in a :schema slot: a list of rules
|
||
;; {:block <tag> :msg <why>}, each requiring the content to contain (anywhere) an
|
||
;; element of that tag — i.e. a refinement type {x : T | x has these blocks}. A post
|
||
;; is checked against the schema of every type it is-a; a type with no schema imposes
|
||
;; nothing (gradual). Schemas are declarative data (not opaque predicates), so they
|
||
;; yield a specific, human error AND live on the type-post (Slice 5) — make a new
|
||
;; refinement type by giving its post a :schema (host/blog--set-schema!).
|
||
;; schema-of reads the type-post; only the SAVE path calls it (a write request, where
|
||
;; a durable read is fine — never in a render, which would VmSuspend).
|
||
(define host/blog-schema-of (fn (type-slug) (get (host/blog-get type-slug) :schema)))
|
||
;; attach/replace a type-post's :schema (idempotent; preserves the rest of the record).
|
||
;; Used at boot to install schemas on type-posts — incl. migrating ones seeded before
|
||
;; schemas lived on the post (a single read+write, not a loop, so boot-JIT-safe).
|
||
(define host/blog--set-schema!
|
||
(fn (slug schema)
|
||
(let ((r (host/blog-get slug)))
|
||
(when r
|
||
(host/blog--write! slug (merge r {:schema schema}))))))
|
||
|
||
;; ── Slice 8: typed scalar FIELDS on a type (the keystone for the UI) ─
|
||
;; A type declares :fields — a list of {:name :type [:widget] [:required]} specs. A
|
||
;; field holds a typed VALUE on an instance (vs a relation, which is an edge to a post).
|
||
;; value-type names map to a default input widget; fields drive BOTH the generic edit
|
||
;; form (one input per field) AND the render template. Direct fields for now; inheritance
|
||
;; through subtype-of is a follow-up. See plans/relations-as-posts.md ("Types define the UI").
|
||
(define host/blog-value-types
|
||
{"String" {:widget "text"}
|
||
"Text" {:widget "textarea"}
|
||
"URL" {:widget "url"}
|
||
"Int" {:widget "number"}
|
||
"Date" {:widget "date"}
|
||
"Bool" {:widget "checkbox"}})
|
||
;; the input widget for a field: its explicit :widget, else its value-type's default,
|
||
;; else "text" (an unknown value-type degrades to a plain text input).
|
||
(define host/blog--widget-for
|
||
(fn (field)
|
||
(or (get field :widget)
|
||
(let ((vt (get host/blog-value-types (get field :type))))
|
||
(if vt (get vt :widget) "text")))))
|
||
;; a type-post's declared fields (empty list if none).
|
||
(define host/blog-fields-of
|
||
(fn (type-slug) (or (get (host/blog-get type-slug) :fields) (list))))
|
||
;; attach/replace a type-post's :fields (idempotent; preserves the rest of the record).
|
||
(define host/blog--set-fields!
|
||
(fn (slug fields)
|
||
(let ((r (host/blog-get slug)))
|
||
(when r
|
||
(host/blog--write! slug (merge r {:fields fields}))))))
|
||
;; "name:Type, name:Type" — a one-line summary of a field list (for /meta). "—" if none.
|
||
(define host/blog--fields-summary
|
||
(fn (fields)
|
||
(if (and fields (> (len fields) 0))
|
||
(join ", " (map (fn (f) (str (get f :name) ":" (get f :type))) fields))
|
||
"—")))
|
||
|
||
;; ── Slice 8b: field VALUES on an instance + the generic, type-driven form ──
|
||
;; An instance carries :field-values = {field-name -> value}. The fields applicable to
|
||
;; a post are the union of the fields declared by every type it is-a (deduped by name) —
|
||
;; so the SAME form is generated from the type definitions, no per-type code. This IS
|
||
;; "the editor maps onto the types": host/blog--field-inputs turns a type's fields into
|
||
;; the edit inputs; host/blog-edit-submit reads them back. Display-via-template is next.
|
||
(define host/blog-field-values-of
|
||
(fn (slug) (or (get (host/blog-get slug) :field-values) {})))
|
||
(define host/blog--set-field-values!
|
||
(fn (slug vals)
|
||
(let ((r (host/blog-get slug)))
|
||
(when r (host/blog--write! slug (merge r {:field-values vals}))))))
|
||
;; the fields applicable to a post = union over its (transitive) types' fields, deduped
|
||
;; by name. One durable graph read (types-of) up front — call in a handler let, not a render.
|
||
(define host/blog--fields-for-post
|
||
(fn (slug)
|
||
(reduce
|
||
(fn (acc t)
|
||
(reduce
|
||
(fn (a f)
|
||
(if (contains? (map (fn (g) (get g :name)) a) (get f :name))
|
||
a
|
||
(concat a (list f))))
|
||
acc
|
||
(host/blog-fields-of t)))
|
||
(list)
|
||
(host/blog-types-of slug))))
|
||
;; render one labelled input per field, pre-filled from `values`. Widget per value-type
|
||
;; (textarea for Text, else a typed <input>). Pure — takes pre-fetched fields + values.
|
||
(define host/blog--field-inputs
|
||
(fn (fields values)
|
||
(map (fn (f)
|
||
(let ((nm (get f :name)) (w (host/blog--widget-for f)))
|
||
(let ((val (or (get values nm) "")))
|
||
(quasiquote
|
||
(p (label :style "display:block;font-size:0.85em;opacity:0.7"
|
||
(unquote (str nm " (" (get f :type) ")")))
|
||
(unquote
|
||
(if (= w "textarea")
|
||
(quasiquote (textarea :name (unquote (str "field-" nm)) :rows "3"
|
||
:style "width:100%" (unquote val)))
|
||
(quasiquote (input :type (unquote w) :name (unquote (str "field-" nm))
|
||
:value (unquote val) :style "width:100%")))))))))
|
||
fields)))
|
||
|
||
;; ── Slice 8c: render TEMPLATE per type (fields drive the page, not just the form) ──
|
||
;; A type may declare a :template — a parameterised SX tree (stored as source) where
|
||
;; (field "name") placeholders resolve to the instance's field-values at render. So ONE
|
||
;; field definition drives BOTH the edit form (above) AND the rendered page. The template
|
||
;; is DATA (editable, meta-circular); a type with no template renders nothing extra. See
|
||
;; plans/relations-as-posts.md ("Types define the UI").
|
||
(define host/blog-template-of
|
||
(fn (type-slug) (get (host/blog-get type-slug) :template)))
|
||
(define host/blog--set-template!
|
||
(fn (slug template)
|
||
(let ((r (host/blog-get slug)))
|
||
(when r (host/blog--write! slug (merge r {:template template}))))))
|
||
;; 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"))))
|
||
|
||
;; Seed the root type-posts: "type" (the root) and "tag" (a kind of type). Types
|
||
;; ARE posts, so these are real posts that document themselves; tag subtype-of
|
||
;; type means anything that is-a tag is, transitively, a type. Idempotent — safe
|
||
;; to call on every boot (host/blog-seed! no-ops if present, edges are sets).
|
||
(define host/blog-seed-types!
|
||
(fn ()
|
||
(begin
|
||
;; relations are posts too — `relation` is their root; each relation-post
|
||
;; is-a relation and owns its symmetry + labels (plans/relations-as-posts.md).
|
||
(host/blog-seed! "relation" "Relation"
|
||
"(article (h1 \"Relation\") (p \"The root of relations. A relation is a typed edge between posts; each relation-post declares its symmetry and labels, and a type anchors its object end (which gives the picker its candidates).\"))"
|
||
"published")
|
||
(host/blog--seed-rel! "related" "related" true "Related posts" nil)
|
||
(host/blog--seed-rel! "is-a" "is a" false "Types" "Instances")
|
||
(host/blog--seed-rel! "subtype-of" "subtype of" false "Subtype of" "Subtypes")
|
||
(host/blog--seed-rel! "tagged" "tagged" false "Tags" "Tagged with this")
|
||
(host/blog-seed! "type" "Type"
|
||
"(article (h1 \"Type\") (p \"The root type. Types are posts — so this is a post that documents the idea of a type. A post declares its types with is-a edges; types form a hierarchy with subtype-of edges.\"))"
|
||
"published")
|
||
(host/blog-seed! "tag" "Tag"
|
||
"(article (h1 \"Tag\") (p \"A tag is a kind of type (tag subtype-of type), so anything that is-a tag is also a type. A post is tagged with a tag; a tag post documents the tag and lists what is tagged with it.\"))"
|
||
"published")
|
||
(host/blog-relate! "tag" "type" "subtype-of")
|
||
;; "article" — a type WITH a schema (requires a heading). Posts that is-a
|
||
;; article are validated against it on save (gradual typing in action).
|
||
(host/blog-seed! "article" "Article"
|
||
"(article (h1 \"Article\") (p \"A kind of post that must have a heading. A post that is-a article is checked against this type's schema on save — gradual typing: declaring the type adds the requirement, and the next edit must satisfy it.\"))"
|
||
"published")
|
||
(host/blog-relate! "article" "type" "subtype-of")
|
||
;; article's schema lives ON the article post now (Slice 5) — install/migrate it.
|
||
(host/blog--set-schema! "article" (list {:block "h1" :msg "an article needs a heading (h1)"}))
|
||
;; article's typed FIELDS (Slice 8) — these drive the generic edit form + the render
|
||
;; template: a subtitle (plain text) and an optional hero image URL.
|
||
(host/blog--set-fields! "article"
|
||
(list {:name "subtitle" :type "String"}
|
||
{:name "hero" :type "URL"}))
|
||
;; article's render TEMPLATE (Slice 8c) — the subtitle field shown as a standfirst
|
||
;; above the body. (field "subtitle") resolves to the instance's value at render.
|
||
(host/blog--set-template! "article"
|
||
"(p :style \"font-style:italic;color:#555;margin:0 0 1em;font-size:1.1em\" (field \"subtitle\"))")
|
||
;; relation DECLARATIONS (see plans/relations-as-posts.md). A type-post declares
|
||
;; which relation it anchors at its OBJECT end ("you may point at me with R"); the
|
||
;; picker's candidate set is the down-closure of a relation's anchors through the
|
||
;; type graph, so the candidates for a relation are exactly the posts that inherit
|
||
;; its declaration. `type` anchors is-a + subtype-of (you point at a type), `tag`
|
||
;; anchors tagged (you point at a tag). `related` has no anchor → every post.
|
||
(host/blog-relate! "type" "is-a" "declares")
|
||
(host/blog-relate! "type" "subtype-of" "declares")
|
||
(host/blog-relate! "tag" "tagged" "declares"))))
|
||
|
||
;; ── relate picker (filterable, paginated candidate list) ────────────
|
||
;; Candidates to relate `slug` to: every post except itself and ones already
|
||
;; related, narrowed by `q` (case-insensitive substring of title or slug),
|
||
;; title-sorted. One page is `host/blog--picker-limit` rows from `offset`.
|
||
(define host/blog--picker-limit 20)
|
||
;; Down-closure: every post reachable from `roots` by walking INVERSE is-a ∪
|
||
;; subtype-of edges (i.e. instances and subtypes, transitively), roots included.
|
||
;; This is "everything that is, transitively, an instance-or-subtype of a root".
|
||
;; BFS over direct edges (host/blog-in); `seen` makes it cycle-safe and terminating.
|
||
(define host/blog--reach-down
|
||
(fn (roots)
|
||
(let loop ((frontier roots) (seen (list)))
|
||
(if (empty? frontier)
|
||
seen
|
||
(let ((t (first frontier)))
|
||
(if (contains? seen t)
|
||
(loop (rest frontier) seen)
|
||
(loop
|
||
(concat (rest frontier)
|
||
(concat (host/blog-in t "is-a") (host/blog-in t "subtype-of")))
|
||
(concat seen (list t)))))))))
|
||
|
||
;; The candidate POOL for relating under `kind` is DECLARATION-driven (see
|
||
;; plans/relations-as-posts.md): the down-closure of the posts that DECLARE `kind`
|
||
;; at their object end. So is-a/subtype-of (anchored by `type`) offer the whole type
|
||
;; closure — roots AND instances — and `tagged` (anchored by `tag`) offers the tags.
|
||
;; A relation with no declaration (e.g. `related`) offers every post.
|
||
(define host/blog--candidate-pool
|
||
(fn (kind)
|
||
(let ((anchors (host/blog-in kind "declares")))
|
||
(if (empty? anchors)
|
||
(host/blog-slugs)
|
||
(host/blog--reach-down anchors)))))
|
||
|
||
;; Slice 3 — typed relations: a post is a valid OBJECT (target end) of `kind` iff it's
|
||
;; in the relation's declared candidate set (the down-closure of kind's declares-anchors
|
||
;; — the target-type constraint). The SAME set the picker offers, so the picker and
|
||
;; the relate endpoint agree by construction. A relation with no anchor (`related`)
|
||
;; accepts any existing post. This is what turns "candidate set" into an enforced
|
||
;; relation schema: is-a's object must be a type, tagged's must be a tag, etc.
|
||
(define host/blog--valid-object?
|
||
(fn (kind other)
|
||
(contains? (host/blog--candidate-pool kind) other)))
|
||
|
||
(define host/blog--title (fn (s) (get (host/blog-get s) :title))) ;; one durable read
|
||
|
||
;; One PAGE of candidates (records {:slug :title}) for relating `slug` under `kind`.
|
||
;; Slice 2.5 — title reads are O(page), not O(pool): the available candidate SLUGS are
|
||
;; computed + slug-sorted with NO per-candidate read; then titles are fetched only for
|
||
;; the rows actually returned. On the unfiltered path (q="" — the initial picker load
|
||
;; AND every editor server-fill) that's ~`limit` reads instead of one-per-post, which
|
||
;; was the durable-read churn under http-listen. A filter (q≠"") still resolves titles
|
||
;; across the pool, since it matches on the title — but that's the interactive path.
|
||
(define host/blog--relate-candidates
|
||
(fn (slug q kind offset limit)
|
||
(let ((pool (host/blog--candidate-pool kind))
|
||
(already (host/blog-out slug kind))
|
||
(ql (lower (or q ""))))
|
||
(let ((avail (sort (filter (fn (s) (and (not (= s slug)) (not (contains? already s)))) pool))))
|
||
(if (= ql "")
|
||
;; no filter: page by slug, then read titles for just the page
|
||
(map (fn (s) {:slug s :title (host/blog--title s)})
|
||
(take (drop avail offset) limit))
|
||
;; filter: resolve titles, match on title|slug, then page
|
||
(let ((recs (map (fn (s) {:slug s :title (host/blog--title s)}) avail)))
|
||
(take
|
||
(drop
|
||
(filter (fn (r) (or (contains? (lower (get r :title)) ql)
|
||
(contains? (get r :slug) ql)))
|
||
recs)
|
||
offset)
|
||
limit)))))))
|
||
|
||
;; One candidate row: a tiny form whose button adds the relation under `kind`.
|
||
(define host/blog--picker-item
|
||
(fn (slug p kind)
|
||
(quasiquote
|
||
(li :id (unquote (str "cand-" kind "-" (get p :slug)))
|
||
:style "border-bottom:1px solid #eee"
|
||
;; AJAX relate: sx-post the relation, then sx-swap="outerHTML" re-renders the
|
||
;; WHOLE relation editor for this kind (its sx-target #rel-editor-KIND) — the
|
||
;; just-related post moves into the current-relations list and out of the
|
||
;; candidate pool, and the fresh picker re-loads its candidates. (A bare
|
||
;; delete of this row added the relation server-side but never showed it in
|
||
;; the current list; re-rendering the editor keeps BOTH lists in sync.)
|
||
;; method+action stay for the no-JS fallback (plain POST -> 303 -> reload).
|
||
(form :method "post" :style "margin:0"
|
||
:action (unquote (str "/" slug "/relate"))
|
||
:sx-post (unquote (str "/" slug "/relate"))
|
||
:sx-target (unquote (str "#rel-editor-" kind))
|
||
:sx-swap "outerHTML"
|
||
(input :type "hidden" :name "other" :value (unquote (get p :slug)))
|
||
(input :type "hidden" :name "kind" :value (unquote kind))
|
||
(button :type "submit"
|
||
:style "width:100%;text-align:left;background:none;border:none;padding:0.5em;cursor:pointer"
|
||
(unquote (get p :title))))))))
|
||
|
||
;; The infinite-scroll "load more" sentinel: an <li> that, when scrolled into view
|
||
;; (sx-trigger "revealed"), GETs the NEXT page and replaces ITSELF (sx-swap
|
||
;; outerHTML, default self-target) with those rows + the next sentinel. This is the
|
||
;; SX-htmx engine doing the paging — no client JS. q is %-encoded back into the URL
|
||
;; so the filter is preserved across pages.
|
||
(define host/blog--picker-more
|
||
(fn (slug kind q next)
|
||
(quasiquote
|
||
(li :class "rp-more"
|
||
:style "list-style:none;padding:0.5em;text-align:center;opacity:0.6"
|
||
:sx-get (unquote (str "/" slug "/relate-options?kind=" kind
|
||
"&q=" (dr/url-encode q) "&offset=" next))
|
||
:sx-trigger "revealed"
|
||
:sx-swap "outerHTML"
|
||
;; a dropped/offline page-fetch retries with exponential backoff (1s→30s)
|
||
;; until it succeeds, so a flaky connection self-heals as you scroll.
|
||
:sx-retry "exponential:1000:30000"
|
||
"Loading more…"))))
|
||
|
||
;; GET /<slug>/relate-options?kind=&q=&offset= — one page of candidate rows for a
|
||
;; kind as an HTML fragment, swapped into the picker by the SX-htmx engine. A full
|
||
;; page is followed by a "load more" sentinel (above); the last page is not. Public
|
||
;; read; the relate action stays guarded.
|
||
(define host/blog-relate-options
|
||
(fn (req)
|
||
(let ((slug (dream-param req "slug"))
|
||
(kind (or (dream-query-param req "kind") "related"))
|
||
;; dream's query parser does not %-decode values (its form parser does),
|
||
;; so a filter like "Item 13" arrives as "Item%2013" — decode it.
|
||
(q (dr/url-decode (or (dream-query-param req "q") "")))
|
||
(offset (host/query-int req "offset" 0)))
|
||
(let ((page (host/blog--relate-candidates slug q kind offset host/blog--picker-limit)))
|
||
(let ((rows (join "" (map (fn (p) (render-page (host/blog--picker-item slug p kind))) page)))
|
||
(more (if (= (len page) host/blog--picker-limit)
|
||
(render-page (host/blog--picker-more slug kind q (+ offset host/blog--picker-limit)))
|
||
"")))
|
||
(dream-html (str rows more)))))))
|
||
|
||
|
||
;; ── page shell ──────────────────────────────────────────────────────
|
||
;; A page is an SX element tree, rendered via render-page (5.1). The handler
|
||
;; builds the tree (running any dynamic logic in the full evaluator, e.g. a posts
|
||
;; loop) and render-page renders the static result — no embedded HTML strings,
|
||
;; only the doctype prefix render-to-html doesn't emit. `body` is an SX node.
|
||
;; SPA shell. The blog is a single-page app: the page boots the WASM OCaml kernel
|
||
;; (the SAME evaluator as the server) + the SX-htmx engine (web/engine.sx), and
|
||
;; `sx-boost="#content"` turns every in-page link/form into a fragment swap into
|
||
;; #content — no full reloads, history handled. A boosted request carries the
|
||
;; SX-Request:true header; we then return ONLY the inner content (so the engine
|
||
;; swaps it straight into #content). A direct / no-JS request gets the full shell,
|
||
;; so the blog degrades gracefully to plain server-rendered pages.
|
||
(define host/blog--spa-req? (fn (req) (= (dream-header req "sx-request") "true")))
|
||
|
||
;; An AJAX editor swap (the picker's relate / the editor's remove) vs. a plain
|
||
;; boosted form. The engine sends an SX-Target header for an sx-post form
|
||
;; (sx-target=#rel-editor-…), but NOT for a plain boosted form (the is-a-tag
|
||
;; toggle). So this tells "return the re-rendered editor fragment" apart from
|
||
;; "redirect + re-render #content" (the toggle / no-JS path).
|
||
(define host/blog--editor-swap-req?
|
||
(fn (req)
|
||
(and (host/blog--spa-req? req)
|
||
(let ((t (dream-header req "sx-target"))) (and t (not (= t "")))))))
|
||
|
||
(define host/blog--page
|
||
(fn (req title body)
|
||
(if (host/blog--spa-req? req)
|
||
;; SPA fragment: SX WIRE FORMAT (text/sx), not HTML. The WASM kernel parses
|
||
;; + renders it client-side into #content (the engine's handle-sx-response).
|
||
;; No server-side HTML render on the boosted path.
|
||
(serialize body)
|
||
;; full SPA shell: WASM kernel + platform + boosted #content (server HTML
|
||
;; for first load / no-JS / SEO)
|
||
(str "<!doctype html>"
|
||
(render-page
|
||
(quasiquote
|
||
(html
|
||
(head (meta :charset "utf-8") (title (unquote title))
|
||
;; content-addressed module manifest: {file -> hash}. The client's
|
||
;; loadBytecodeFile reads this and fetches each web-stack module
|
||
;; immutably from /sx/h/{hash} (localStorage-cached, never stale)
|
||
;; instead of /static/wasm/sx/*.sxbc with max-age.
|
||
(script :type "application/json" :data-sx-manifest "1"
|
||
(raw! (unquote (host/static-manifest-json))))
|
||
(script :src "/static/wasm/sx_browser.bc.wasm.js")
|
||
(script :src "/static/wasm/sx-platform.js")
|
||
;; Visible failure state for the SX engine's .sx-error class (added
|
||
;; on a failed/offline fetch, cleared on the next success). Without
|
||
;; it a stuck retry is invisible — the picker just sits "Loading…".
|
||
(style (raw! (unquote (str
|
||
".rp-more.sx-error{color:#b00}"
|
||
".rp-more.sx-error::after{content:\" — offline, retrying…\"}"
|
||
".relate-picker.sx-error .rp-results::before{"
|
||
"content:\"Connection problem — retrying…\";display:block;"
|
||
"padding:.5em;color:#b00;font-size:.9em}")))))
|
||
(body
|
||
;; sx-boost must be on a DESCENDANT of <body> (process-boosted
|
||
;; queries [sx-boost] WITHIN the body, so it can't sit on body
|
||
;; itself). The wrapper boosts every link/form inside, targeting
|
||
;; #content; #content is the swap target.
|
||
(div :sx-boost "#content"
|
||
;; persistent top nav OUTSIDE #content, so it survives every
|
||
;; content swap; the Home link is boosted (SPA nav to /).
|
||
(nav :style "padding:0.75em 0;border-bottom:1px solid #ccc;margin-bottom:1em"
|
||
(a :href "/" :style "font-weight:bold;text-decoration:none" "Home"))
|
||
(div :id "content" (unquote body)))))))))))
|
||
|
||
;; Wrap a host/blog--page result in a response with the matching content-type:
|
||
;; text/sx for a boosted (SPA) request (the WASM kernel renders it), text/html
|
||
;; for a full-page request. Replaces the old dream-html/-status wrappers so the
|
||
;; boosted path ships SX instead of server-rendered HTML.
|
||
(define host/blog--resp
|
||
(fn (req status str)
|
||
(dream-response status
|
||
{:content-type
|
||
(if (host/blog--spa-req? req) "text/sx; charset=utf-8" "text/html; charset=utf-8")}
|
||
str)))
|
||
|
||
;; ── registry-driven relation rendering (post page) ──────────────────
|
||
;; One labelled block of links from records ({:slug :title}), or "" when empty.
|
||
;; Records are pre-fetched, so the tree is built from in-memory data only.
|
||
(define host/blog--edges-block
|
||
(fn (records label)
|
||
(if (> (len records) 0)
|
||
(let ((items (map (fn (p)
|
||
(quasiquote
|
||
(li (a :href (unquote (str "/" (get p :slug) "/"))
|
||
(unquote (get p :title))))))
|
||
records)))
|
||
(quasiquote
|
||
(div :style "margin-top:2em"
|
||
(h3 (unquote label))
|
||
(unquote (cons (quote ul) items)))))
|
||
"")))
|
||
|
||
;; nodes -> {:slug :title} records, existence-filtered against a shared key set.
|
||
(define host/blog--recs
|
||
(fn (existing nodes)
|
||
(map (fn (s) {:slug s :title (get (host/blog-get s) :title)})
|
||
(filter (fn (s) (contains? existing s))
|
||
(map (fn (n) (substr (symbol->string n) 5))
|
||
(filter (fn (n) (starts-with? (symbol->string n) "blog:")) nodes))))))
|
||
|
||
;; The relation blocks shown on a POST page — a CURATED, fixed set: Related (out),
|
||
;; Tags (out), Tagged-with-this (in). PERFORMANCE: read the KV key list ONCE and
|
||
;; derive both the post set and the edges from it in memory, instead of letting
|
||
;; each host/blog-out/in re-scan the store. Every durable read is a perform routed
|
||
;; through cek_run_with_io (costly deep in the call stack), so the post page must
|
||
;; minimise them — this does ONE kv-keys plus a host/blog-get per linked post.
|
||
(define host/blog--post-relation-specs
|
||
(list {:kind "related" :dir "out" :label "Related posts"}
|
||
{:kind "tagged" :dir "out" :label "Tags"}
|
||
{:kind "tagged" :dir "in" :label "Tagged with this"}))
|
||
;; in-memory: the slug list (out: dst, in: src) for `slug` under `kind` from
|
||
;; pre-parsed edges — no perform.
|
||
(define host/blog--edges-for
|
||
(fn (edges slug kind dir)
|
||
(reduce
|
||
(fn (acc e)
|
||
(if (= (get e :kind) kind)
|
||
(if (= dir "out")
|
||
(if (= (get e :src) slug) (concat acc (list (get e :dst))) acc)
|
||
(if (= (get e :dst) slug) (concat acc (list (get e :src))) acc))
|
||
acc))
|
||
(list) edges)))
|
||
;; slug list -> {:slug :title} records (existence-filtered), one host/blog-get each.
|
||
(define host/blog--recs-slugs
|
||
(fn (existing slugs)
|
||
(map (fn (s) {:slug s :title (get (host/blog-get s) :title)})
|
||
(filter (fn (s) (contains? existing s)) slugs))))
|
||
(define host/blog--relation-blocks
|
||
(fn (slug)
|
||
(let ((keys (persist/backend-kv-keys host/blog-store))) ;; ONE durable read
|
||
(let ((existing (reduce (fn (acc k)
|
||
(if (starts-with? k "blog:")
|
||
(concat acc (list (substr k 5))) acc))
|
||
(list) keys))
|
||
(edges (filter (fn (e) (not (nil? e)))
|
||
(map host/blog--parse-edge-key keys))))
|
||
(let ((blocks
|
||
(reduce
|
||
(fn (acc spec)
|
||
(let ((b (host/blog--edges-block
|
||
(host/blog--recs-slugs existing
|
||
(host/blog--edges-for edges slug (get spec :kind) (get spec :dir)))
|
||
(get spec :label))))
|
||
(if (= b "") acc (concat acc (list b)))))
|
||
(list)
|
||
host/blog--post-relation-specs)))
|
||
(if (> (len blocks) 0) (cons (quote div) blocks) ""))))))
|
||
|
||
;; the relation section for the post page: the blocks, or — when empty and the
|
||
;; viewer is logged in — a subtle "add some" hint; nothing for anonymous viewers.
|
||
(define host/blog--relations-or-hint
|
||
(fn (slug logged-in)
|
||
(let ((blocks (host/blog--relation-blocks slug)))
|
||
(cond
|
||
((not (= blocks "")) blocks)
|
||
(logged-in
|
||
(quasiquote
|
||
(p :style "margin-top:2em;font-size:0.9em;opacity:0.7"
|
||
"No relations yet — "
|
||
(a :href (unquote (str "/" slug "/edit")) "add some") ".")))
|
||
(else "")))))
|
||
|
||
;; Kind-aware relation editor for the edit page: current links (each with a
|
||
;; kind-scoped remove), plus a filterable picker (a declarative SX-htmx form, one
|
||
;; per kind). The picker's candidates come from the kind's registry :candidates
|
||
;; ("all" / tags / types).
|
||
(define host/blog--relation-editor
|
||
(fn (slug kind with-cands)
|
||
;; current edges read up front (a perform) — NOT inside the quasiquote, where
|
||
;; a perform would raise VmSuspended under http-listen.
|
||
(let ((spec (host/blog--kind-spec kind))
|
||
(current (host/blog-out slug kind))
|
||
;; results <ul>. When `with-cands` (the relate/unrelate fragment), the first
|
||
;; page of candidates is server-rendered in, so the re-rendered picker is
|
||
;; never briefly empty (the load trigger then re-fetches the same page and
|
||
;; morphs it in, invisibly). On the INITIAL edit page it renders EMPTY and the
|
||
;; load trigger fills it — server-rendering candidates for EVERY kind's picker
|
||
;; would do a durable read per candidate × every editor, blowing the
|
||
;; http-listen render budget (VmSuspended). Built by cons so candidate
|
||
;; li-trees splice in as children (component args would evaluate them).
|
||
(results-ul
|
||
(let ((rows (if with-cands
|
||
(let ((cands (host/blog--relate-candidates slug "" kind 0 host/blog--picker-limit)))
|
||
(append
|
||
(map (fn (p) (host/blog--picker-item slug p kind)) cands)
|
||
(if (= (len cands) host/blog--picker-limit)
|
||
(list (host/blog--picker-more slug kind "" host/blog--picker-limit))
|
||
(list))))
|
||
(list))))
|
||
(cons (quote ul)
|
||
(append
|
||
(quasiquote (:id (unquote (str "rp-" kind "-results"))
|
||
:class "rp-results"
|
||
:style "list-style:none;padding:0;margin:0.5em 0;border:1px solid #ddd"))
|
||
rows)))))
|
||
(quasiquote
|
||
;; #rel-editor-KIND wraps the WHOLE editor (current list + picker) so relate
|
||
;; and unrelate can re-render it with one outerHTML swap — keeping the two
|
||
;; lists in sync. The fresh picker re-loads its candidates (an explicit
|
||
;; outerHTML swap installs a NEW form the engine binds, unlike the old
|
||
;; redirect that morphed the stale picker and left it empty).
|
||
(div :id (unquote (str "rel-editor-" kind))
|
||
:style "margin-top:2em;border-top:1px solid #ccc;padding-top:1em"
|
||
(h3 (unquote (get spec :label)))
|
||
(unquote
|
||
(if (> (len current) 0)
|
||
(cons (quote ul)
|
||
(map (fn (s)
|
||
(quasiquote
|
||
;; remove: sx-post the unrelate, then sx-swap="outerHTML"
|
||
;; re-renders this kind's editor (its sx-target
|
||
;; #rel-editor-KIND) — the row leaves the current list and
|
||
;; the post returns to the candidate pool, both in sync,
|
||
;; with the picker NOT cleared. method+action stay for no-JS.
|
||
(li (a :href (unquote (str "/" s "/")) (unquote s)) " "
|
||
(form :method "post" :style "display:inline"
|
||
:action (unquote (str "/" slug "/unrelate"))
|
||
:sx-post (unquote (str "/" slug "/unrelate"))
|
||
:sx-target (unquote (str "#rel-editor-" kind))
|
||
:sx-swap "outerHTML"
|
||
(input :type "hidden" :name "other" :value (unquote s))
|
||
(input :type "hidden" :name "kind" :value (unquote kind))
|
||
(button :type "submit" "remove")))))
|
||
current))
|
||
(quote (p :style "opacity:0.7" "None yet."))))
|
||
;; The picker, rendered INLINE (not via the ~relate-picker component) so the
|
||
;; first page of candidates is server-rendered into the results <ul> — the
|
||
;; re-rendered editor shows them immediately, no empty flash. Same declarative
|
||
;; SX-htmx form: GET relate-options, innerHTML-swap the results on a debounced
|
||
;; "input" and on "load"; sx-retry self-heals a dropped fetch.
|
||
(form
|
||
:class "relate-picker"
|
||
:data-slug (unquote slug)
|
||
:data-kind (unquote kind)
|
||
:sx-get (unquote (str "/" slug "/relate-options"))
|
||
:sx-trigger "input delay:200ms, load"
|
||
:sx-target (unquote (str "#rp-" kind "-results"))
|
||
:sx-swap "innerHTML"
|
||
:sx-retry "exponential:1000:30000"
|
||
:style "margin:0"
|
||
(input :type "hidden" :name "kind" :value (unquote kind))
|
||
(input :type "text" :name "q" :class "rp-filter" :placeholder "filter…"
|
||
:autocomplete "off" :style "width:100%;padding:0.4em;box-sizing:border-box")
|
||
(unquote results-ul)))))))
|
||
|
||
;; "Is this post a tag?" toggle — marking a post a tag is just an is-a edge to the
|
||
;; "tag" type-post, so it reuses the relate/unrelate routes (no new endpoint).
|
||
(define host/blog--is-tag-toggle
|
||
(fn (slug)
|
||
(if (host/blog-is-tag? slug)
|
||
(quasiquote
|
||
(p (span "This post is a tag ✓ ")
|
||
(form :method "post" :style "display:inline"
|
||
:action (unquote (str "/" slug "/unrelate"))
|
||
(input :type "hidden" :name "other" :value "tag")
|
||
(input :type "hidden" :name "kind" :value "is-a")
|
||
(button :type "submit" "remove tag status"))))
|
||
(quasiquote
|
||
(form :method "post" :action (unquote (str "/" slug "/relate"))
|
||
(input :type "hidden" :name "other" :value "tag")
|
||
(input :type "hidden" :name "kind" :value "is-a")
|
||
(button :type "submit" "Make this a tag"))))))
|
||
|
||
;; One editor per registry kind, wrapped in a div — the edit page's relation
|
||
;; section, generated by ITERATING the registry (add a kind -> it gets an editor).
|
||
(define host/blog--relation-editors
|
||
(fn (slug)
|
||
(cons (quote div)
|
||
;; false: the initial edit page renders empty pickers (the load trigger fills
|
||
;; each), keeping this render cheap. The relate/unrelate FRAGMENT passes true.
|
||
(map (fn (spec) (host/blog--relation-editor slug (get spec :kind) false))
|
||
host/blog-rel-kinds))))
|
||
|
||
;; ── read handlers ───────────────────────────────────────────────────
|
||
;; Post body is rendered per-block (a guarded HTML string) then injected raw.
|
||
(define host/blog-post
|
||
(fn (req)
|
||
(let ((slug (dream-param req "slug")))
|
||
(let ((r (host/blog-get slug)))
|
||
(if r
|
||
;; Compute everything that does durable reads — body, related block, AND
|
||
;; the auth footer (a durable session read now) — in let bindings BEFORE
|
||
;; the quasiquote. IO must run in the handler body, never while the page
|
||
;; tree is built (a perform there raises VmSuspended under http-listen).
|
||
(let ((principal (host/current-principal req)))
|
||
(let ((body-html (host/blog-render r))
|
||
;; all relation blocks (Related, Tags, Types, Tagged-with-this …)
|
||
;; come from iterating the registry — one section, registry-driven.
|
||
(relations (host/blog--relations-or-hint slug (not (nil? principal))))
|
||
;; the typed render-template block (Slice 8c) — field values shown via
|
||
;; the post's types' templates. A durable read, so pre-fetch it here.
|
||
(typed-block (host/blog--typed-block slug))
|
||
(auth-foot (host/auth-footer req)))
|
||
(host/blog--resp req 200
|
||
(host/blog--page req (get r :title)
|
||
(quasiquote
|
||
(div
|
||
(unquote typed-block)
|
||
(article (raw! (unquote body-html)))
|
||
(unquote relations)
|
||
(p :style "margin-top:2em;font-size:0.9em;opacity:0.8"
|
||
(a :href (unquote (str "/" slug "/source")) "view source")
|
||
" · "
|
||
(a :href (unquote (str "/" slug "/edit")) "edit")
|
||
" · "
|
||
(a :href "/" "all posts")
|
||
" · "
|
||
(unquote auth-foot))))))))
|
||
(host/blog--resp req 404
|
||
(host/blog--page req "Not found"
|
||
(quasiquote
|
||
(div (h1 "404")
|
||
(p (unquote (str "No published post: " slug))))))))))))
|
||
|
||
(define host/blog-home
|
||
(fn (req)
|
||
(let ((posts (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"))))
|
||
|
||
;; GET /<slug>/source — the raw sx_content as text/plain. Posts ARE SX source, so
|
||
;; this just hands back the stored markup (public; a published post's source is
|
||
;; not secret). 404 if the post is absent.
|
||
(define host/blog-source
|
||
(fn (req)
|
||
(let ((slug (dream-param req "slug")))
|
||
(let ((r (host/blog-get slug)))
|
||
(if r
|
||
(dream-response 200 {:content-type "text/plain; charset=utf-8"}
|
||
(or (get r :sx-content) ""))
|
||
(host/blog--resp req 404
|
||
(host/blog--page req "Not found"
|
||
(quasiquote (div (h1 "404") (p (unquote (str "No post: " slug))))))))))))
|
||
|
||
;; ── create page (GET /new) — clean minimal form as an SX tree ───────
|
||
;; No legacy JS editor, no external assets, no shims. The rich WYSIWYG is a
|
||
;; future native SX-island editor (Phase 5.2+). Posts to /new.
|
||
(define host/blog-new-form
|
||
(fn (req)
|
||
(host/blog--resp req 200
|
||
(host/blog--page req "New post"
|
||
(quasiquote
|
||
(div
|
||
(h1 "New post")
|
||
(form :method "post" :action "/new"
|
||
(p (input :name "title" :placeholder "Title"
|
||
:style "font-size:1.4em;width:100%"))
|
||
(p (textarea :name "sx_content" :rows "12"
|
||
:style "width:100%;font-family:monospace"
|
||
:placeholder "(p \"Your post as SX markup\")"))
|
||
(p (select :name "status"
|
||
(option :value "draft" "Draft")
|
||
(option :value "published" "Published"))
|
||
" "
|
||
(button :type "submit" "Publish")))
|
||
(p (a :href "/" "all posts"))))))))
|
||
|
||
;; ── write-time validation ───────────────────────────────────────────
|
||
;; sx_content must be storable as renderable SX: empty is allowed (an empty post),
|
||
;; otherwise it must parse. parse-safe returns nil on malformed input (the kernel
|
||
;; parser raises a native Parse_error an SX guard can't catch), so this rejects a
|
||
;; bad body at write time instead of letting it 500 on read. Mirrors the read-path
|
||
;; guard in host/blog-render — bad content never enters the durable store.
|
||
(define host/blog-content-ok?
|
||
(fn (sx)
|
||
(or (nil? sx) (= sx "") (not (nil? (parse-safe sx))))))
|
||
|
||
;; ── write handlers ──────────────────────────────────────────────────
|
||
;; POST /new — form-urlencoded ingest (the editor's submit shape: title,
|
||
;; sx_content, status, custom_excerpt, csrf_token). Slug derived from the title.
|
||
;; Redirects to the new post on success; rejects a missing title or unparseable
|
||
;; body with a 400 HTML page (this path serves a browser form).
|
||
(define host/blog-form-submit
|
||
(fn (req)
|
||
(let ((title (host/field req "title"))
|
||
(sx-content (host/field req "sx_content"))
|
||
(status (or (host/field req "status") "published")))
|
||
(cond
|
||
((or (nil? title) (= title ""))
|
||
(host/blog--resp req 400
|
||
(host/blog--page req "Error"
|
||
(quasiquote (div (h1 "Error") (p "Title is required.")
|
||
(p (a :href "/new" "Back")))))))
|
||
((not (host/blog-content-ok? sx-content))
|
||
(host/blog--resp req 400
|
||
(host/blog--page req "Error"
|
||
(quasiquote (div (h1 "Error") (p "Post body is not valid SX markup.")
|
||
(p (a :href "/new" "Back")))))))
|
||
(else
|
||
(let ((slug (host/blog-slugify title)))
|
||
(begin
|
||
(host/blog-put! slug title (or sx-content "") status)
|
||
(dream-redirect (str "/" slug "/")))))))))
|
||
|
||
;; The JSON CRUD /posts (create/update/delete) was DELETED in the greenfield
|
||
;; SX-native pivot (plans/relations-as-posts.md, "SX all the way out") — it was a
|
||
;; pure old-contract REST mirror. Create + edit go through the HTML editor forms
|
||
;; (POST /new, POST /:slug/edit); programmatic writes will speak SXTP. FOLLOW-UP:
|
||
;; there is no browser delete route yet (delete was JSON-only and had no UI) — add
|
||
;; POST /:slug/delete + cascade edge cleanup (drop every edge touching the slug,
|
||
;; both directions, all kinds) when the metamodel UI needs it.
|
||
|
||
;; POST /<slug>/relate — relate this post to another (form `other` = slug, `kind` =
|
||
;; relation kind, default "related"). Validated: kind must be a known kind and the
|
||
;; other post must exist and differ; otherwise a no-op. Redirects back to the edit
|
||
;; page. Guarded like the other browser write routes.
|
||
(define host/blog-relate-submit
|
||
(fn (req)
|
||
(let ((slug (dream-param req "slug"))
|
||
(other (host/field req "other"))
|
||
(kind (or (host/field req "kind") "related")))
|
||
(if (nil? (host/blog-get slug))
|
||
(host/blog--resp req 404
|
||
(host/blog--page req "Not found"
|
||
(quasiquote (div (h1 "404") (p (unquote (str "No post: " slug)))))))
|
||
(begin
|
||
;; …and `other` must satisfy the relation's TARGET-TYPE CONSTRAINT
|
||
;; (host/blog--valid-object?): you can only declare `slug is-a <a type>`,
|
||
;; tag with `<a tag>`, etc. The picker never offers an invalid target, so
|
||
;; this enforces the same schema against crafted/API requests; an invalid
|
||
;; relate is a silent no-op (consistent with the other guards here).
|
||
(when (and other (not (= other "")) (not (= other slug))
|
||
(host/blog--kind-spec kind) (host/blog-exists? other)
|
||
(host/blog--valid-object? kind other))
|
||
(host/blog-relate! slug other kind))
|
||
;; AJAX (the picker's sx-post, carries SX-Target): return the re-rendered
|
||
;; editor for this kind so its sx-swap="outerHTML" replaces #rel-editor-KIND
|
||
;; — the just-related post shows in the current list and the picker refreshes
|
||
;; its candidates. text/html so the client's DOMParser swap path renders the
|
||
;; already-expanded fragment. Plain boosted form / no-JS still redirects.
|
||
(if (host/blog--editor-swap-req? req)
|
||
(dream-html (render-page (host/blog--relation-editor slug kind true)))
|
||
(dream-redirect (str "/" slug "/edit"))))))))
|
||
|
||
;; POST /<slug>/unrelate — remove the relation to `other` under `kind` (default
|
||
;; "related"). Idempotent.
|
||
(define host/blog-unrelate-submit
|
||
(fn (req)
|
||
(let ((slug (dream-param req "slug"))
|
||
(other (host/field req "other"))
|
||
(kind (or (host/field req "kind") "related")))
|
||
(begin
|
||
(when (and other (not (= other "")) (host/blog--kind-spec kind))
|
||
(host/blog-unrelate! slug other kind))
|
||
;; AJAX remove (the editor's sx-post, carries SX-Target): return the
|
||
;; re-rendered editor for this kind so its sx-swap="outerHTML" replaces
|
||
;; #rel-editor-KIND — the row leaves the current list, the post returns to the
|
||
;; (re-loaded) candidate pool, and the picker is NOT cleared. A plain boosted
|
||
;; form (the tag toggle) or a no-JS POST still redirects + re-renders #content.
|
||
(if (host/blog--editor-swap-req? req)
|
||
(dream-html (render-page (host/blog--relation-editor slug kind true)))
|
||
(dream-redirect (str "/" slug "/edit")))))))
|
||
|
||
;; 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))
|
||
(tag-toggle (host/blog--is-tag-toggle slug))
|
||
(post-fields (host/blog--fields-for-post slug))
|
||
(field-values (host/blog-field-values-of slug))
|
||
(mk-opt
|
||
(fn (val label)
|
||
(if (= val status)
|
||
(quasiquote (option :value (unquote val) :selected "selected" (unquote label)))
|
||
(quasiquote (option :value (unquote val) (unquote label)))))))
|
||
(host/blog--resp req 200
|
||
(host/blog--page req (str "Edit: " (get r :title))
|
||
(quasiquote
|
||
(div
|
||
(h1 (unquote (str "Edit: " (get r :title))))
|
||
(form :method "post" :action (unquote (str "/" slug "/edit"))
|
||
(p (input :name "title" :value (unquote (get r :title))
|
||
:style "font-size:1.4em;width:100%"))
|
||
(p (textarea :name "sx_content" :rows "16"
|
||
:style "width:100%;font-family:monospace"
|
||
(unquote (or (get r :sx-content) ""))))
|
||
(unquote (if (> (len post-fields) 0)
|
||
(cons (quote div)
|
||
(cons (quote (h3 :style "font-size:1em;margin:1em 0 0.3em" "Fields"))
|
||
(host/blog--field-inputs post-fields field-values)))
|
||
""))
|
||
(p (select :name "status"
|
||
(unquote (mk-opt "draft" "Draft"))
|
||
(unquote (mk-opt "published" "Published")))
|
||
" "
|
||
(button :type "submit" "Save")))
|
||
(div :style "margin-top:2em;border-top:1px solid #ccc;padding-top:1em"
|
||
(unquote tag-toggle))
|
||
(unquote relation-editors)
|
||
(p :style "margin-top:1.5em"
|
||
(a :href (unquote (str "/" slug "/")) "view post")
|
||
" · "
|
||
(a :href (unquote (str "/" slug "/source")) "view source")))))))))))))
|
||
|
||
;; POST /<slug>/edit — save the edited source. Same write-time validation as the
|
||
;; create paths (unparseable body -> 400, post left intact). Slug is preserved.
|
||
(define host/blog-edit-submit
|
||
(fn (req)
|
||
(let ((slug (dream-param req "slug")) (r (host/blog-get (dream-param req "slug"))))
|
||
(if (nil? r)
|
||
(host/blog--resp req 404
|
||
(host/blog--page req "Not found"
|
||
(quasiquote (div (h1 "404") (p (unquote (str "No post: " slug)))))))
|
||
(let ((title (or (host/field req "title") (get r :title)))
|
||
(sx-content (or (host/field req "sx_content") ""))
|
||
(status (or (host/field req "status") (get r :status)))
|
||
(post-fields (host/blog--fields-for-post slug)))
|
||
;; collect issues up front (perform): unparseable markup, then each
|
||
;; schema requirement the post's types impose. Empty = save.
|
||
(let ((issues (if (host/blog-content-ok? sx-content)
|
||
(host/blog-type-issues slug sx-content)
|
||
(list "Post body is not valid SX markup."))))
|
||
(if (= (len issues) 0)
|
||
(begin
|
||
(host/blog-put! slug title sx-content status)
|
||
;; store the typed field values from the generic, type-driven form (Slice 8b)
|
||
(host/blog--set-field-values! slug
|
||
(reduce (fn (acc f)
|
||
(assoc acc (get f :name)
|
||
(or (host/field req (str "field-" (get f :name))) "")))
|
||
{} post-fields))
|
||
(dream-redirect (str "/" slug "/")))
|
||
(let ((issue-items (map (fn (i) (quasiquote (li (unquote i)))) issues)))
|
||
(host/blog--resp req 400
|
||
(host/blog--page req "Cannot save"
|
||
(quasiquote
|
||
(div (h1 "Cannot save")
|
||
(p "This post can't be saved yet:")
|
||
(unquote (cons (quote ul) issue-items))
|
||
(p (a :href (unquote (str "/" slug "/edit")) "Back"))))))))))))))
|
||
|
||
;; ── routes ──────────────────────────────────────────────────────────
|
||
;; Public reads + the create form. /, /posts, /new BEFORE /:slug (catch-all).
|
||
;; MUST be mounted LAST in the app so domain routes (/feed, /health) win.
|
||
(define host/blog-routes
|
||
(list
|
||
(dream-get "/" host/blog-home)
|
||
(dream-get "/posts" host/blog-index)
|
||
(dream-get "/new" host/blog-new-form)
|
||
(dream-get "/tags" host/blog-tags-index)
|
||
(dream-get "/meta" host/blog-meta-index)
|
||
(dream-get "/:slug/source" host/blog-source)
|
||
(dream-get "/:slug/relate-options" host/blog-relate-options)
|
||
(dream-get "/:slug" host/blog-post)))
|
||
|
||
;; Guarded writes: HTML editor form ingest behind auth+ACL. (The JSON CRUD that
|
||
;; used a bearer-based host/blog--protect was deleted in the SX-native pivot.)
|
||
;; Browser gate: identical ACL, but an unauthenticated request REDIRECTS
|
||
;; to the login page (host/require-login) rather than returning a raw JSON 401 —
|
||
;; the form/edit pages are HTML, so a logged-out click should land on /login and
|
||
;; return here afterwards.
|
||
(define host/blog--protect-html
|
||
(fn (resolve h)
|
||
(host/pipeline
|
||
(list
|
||
host/wrap-errors
|
||
(host/require-login resolve)
|
||
(host/require-permission "edit" (fn (req) "blog")))
|
||
h)))
|
||
(define host/blog-write-routes
|
||
(fn (resolve)
|
||
(list
|
||
(dream-post "/new" (host/blog--protect-html resolve host/blog-form-submit))
|
||
(dream-get "/:slug/edit" (host/blog--protect-html resolve host/blog-edit-form))
|
||
(dream-post "/:slug/edit" (host/blog--protect-html resolve host/blog-edit-submit))
|
||
(dream-post "/:slug/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)))))
|
||
|
||
;; 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))))
|