From c6627f4954279475da7ee11a880c8d978d8dce82 Mon Sep 17 00:00:00 2001 From: giles Date: Mon, 29 Jun 2026 22:49:59 +0000 Subject: [PATCH] =?UTF-8?q?host:=20relations-as-posts=20slice=202=20?= =?UTF-8?q?=E2=80=94=20relation=20metadata=20lives=20on=20relation-posts?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit is-a/subtype-of/tagged/related are now POSTS (each is-a a new `relation` root), owning their metadata in a :rel slot {:symmetric :label :inverse-label}. The static host/blog-rel-kinds registry is gone: kind-spec/rel-kinds/kind-symmetric? read the relation-posts (via an in-memory cache), and the relation list derives from host/blog-in "relation" "is-a". Perform-budget fixes (a durable read inside the http-listen render VM raises VmSuspended; too many per request 500s the page): - relation metadata is loaded into a cache at boot (host/blog-load-rel-kinds!, like load-edges!), so kind-spec is pure on render paths; - the initial edit page renders its pickers EMPTY (the load trigger fills each) — only the relate/unrelate FRAGMENT server-renders candidates (with-cands flag). Previously every edit page render did candidate-get × 4 pickers and 500'd. host conformance 287/287 (+4 slice-2: kind-spec reads :rel, kind-symmetric? off the post, unknown kind has no spec, rel-kinds derived from the graph). run-picker-check 3/3 (edit page boots, relate/unrelate flow works, no client errors). Co-Authored-By: Claude Opus 4.8 --- lib/host/blog.sx | 108 ++++++++++++++++++++++++------------ lib/host/serve.sh | 5 ++ lib/host/tests/blog.sx | 27 ++++++++- plans/relations-as-posts.md | 21 +++++-- 4 files changed, 116 insertions(+), 45 deletions(-) diff --git a/lib/host/blog.sx b/lib/host/blog.sx index 944d1ced..7d6a9607 100644 --- a/lib/host/blog.sx +++ b/lib/host/blog.sx @@ -94,20 +94,25 @@ ;; type-post, and types ARE posts (same blog: 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)) +(define host/blog-load-rel-kinds! + (fn () + (for-each + (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-in "relation" "is-a")))) ;; relations are flat: direct is-a is enough +;; 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-rel-kinds - (list - {:kind "related" :label "Related posts" :symmetric true :candidates "all"} - {:kind "is-a" :label "Types" :symmetric false :candidates "types" - :inverse-label "Instances"} - {:kind "subtype-of" :label "Subtype of" :symmetric false :candidates "types" - :inverse-label "Subtypes"} - {:kind "tagged" :label "Tags" :symmetric false :candidates "tags" - :inverse-label "Tagged with this"})) - -;; registry lookup; nil for an unknown kind (relate validates against this) -(define host/blog--kind-spec - (fn (kind) - (reduce (fn (acc k) (if (= (get k :kind) kind) k acc)) nil host/blog-rel-kinds))) + (fn () (map (fn (k) (get host/blog--rel-cache k)) (keys host/blog--rel-cache)))) (define host/blog--kind-symmetric? (fn (kind) (let ((s (host/blog--kind-spec kind))) (and s (get s :symmetric))))) @@ -303,6 +308,19 @@ (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)) + (persist/backend-kv-put host/blog-store (host/blog--key 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 @@ -310,6 +328,15 @@ (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") @@ -620,30 +647,35 @@ ;; per kind). The picker's candidates come from the kind's registry :candidates ;; ("all" / tags / types). (define host/blog--relation-editor - (fn (slug kind) + (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)) - ;; the results
    , server-rendered with the first page of candidates so a - ;; re-rendered editor's picker is never briefly empty (the load trigger then - ;; re-fetches the same page and morphs it in, invisibly). Built by cons so - ;; the candidate li-trees splice in as children (the same pattern the current - ;; list uses) — they can't be passed through a component arg (those evaluate). + ;; results
      . 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 ((cands (take (host/blog--relate-candidates slug "" kind) - host/blog--picker-limit))) - (let ((rows (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))))) - (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)))))) + (let ((rows (if with-cands + (let ((cands (take (host/blog--relate-candidates slug "" kind) + 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 @@ -717,8 +749,10 @@ (define host/blog--relation-editors (fn (slug) (cons (quote div) - (map (fn (spec) (host/blog--relation-editor slug (get spec :kind))) - host/blog-rel-kinds)))) + ;; 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. @@ -932,7 +966,7 @@ (begin (for-each (fn (o) (host/blog-unrelate! slug o kind)) (host/blog-out slug kind)) (for-each (fn (o) (host/blog-unrelate! o slug kind)) (host/blog-in slug kind))))) - host/blog-rel-kinds))) + (host/blog-rel-kinds)))) (define host/blog-delete-handler (fn (req) @@ -967,7 +1001,7 @@ ;; 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))) + (dream-html (render-page (host/blog--relation-editor slug kind true))) (dream-redirect (str "/" slug "/edit")))))))) ;; POST //unrelate — remove the relation to `other` under `kind` (default @@ -986,7 +1020,7 @@ ;; (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))) + (dream-html (render-page (host/blog--relation-editor slug kind true))) (dream-redirect (str "/" slug "/edit"))))))) ;; GET //edit — edit form pre-filled with the post's current title, raw diff --git a/lib/host/serve.sh b/lib/host/serve.sh index 97abe7a6..7a3633b0 100755 --- a/lib/host/serve.sh +++ b/lib/host/serve.sh @@ -151,6 +151,11 @@ EPOCH=1 echo "(epoch $EPOCH)" echo "(eval \"(host/blog-seed-types!)\")" EPOCH=$((EPOCH+1)) + # Load relation metadata (symmetry/labels) from the relation-posts into the + # in-memory cache, so render paths read it without a (VmSuspending) durable read. + echo "(epoch $EPOCH)" + echo "(eval \"(host/blog-load-rel-kinds!)\")" + EPOCH=$((EPOCH+1)) # Index the web-stack .sxbc by content hash so /sx/h/{hash} can serve them # immutably and the shell can emit the data-sx-manifest (content-addressed # client module cache). Done once at boot. diff --git a/lib/host/tests/blog.sx b/lib/host/tests/blog.sx index 452d3f11..8c01af5e 100644 --- a/lib/host/tests/blog.sx +++ b/lib/host/tests/blog.sx @@ -213,6 +213,11 @@ ;; -- relate posts (blog × relations) -- ;; my-first-post and another-one both exist in the write-test store at this point. +;; Relations are posts now (their symmetry/labels live on relation-posts), so seed +;; them up front exactly as boot does (serve.sh) before exercising relate, and load +;; the relation metadata into the in-memory cache the same way. +(host/blog-seed-types!) +(host/blog-load-rel-kinds!) (host-bl-test "relate no auth -> redirect to login" (dream-status (host-bl-wapp (host-bl-send "POST" "/my-first-post/relate" nil "application/x-www-form-urlencoded" "other=another-one"))) 303) @@ -276,7 +281,7 @@ ;; "load" and on debounced "input". The SX engine re-binds these triggers on ;; swapped content, so it works on a full load AND a boosted SPA nav. (host-bl-test "picker form is declaratively wired to relate-options (load + debounced input)" - (let ((html (render-page (host/blog--relation-editor "alpha-post" "related")))) + (let ((html (render-page (host/blog--relation-editor "alpha-post" "related" true)))) (list (contains? html "/alpha-post/relate-options") (contains? html "input delay:200ms, load") (contains? html "rp-related-results"))) @@ -285,7 +290,7 @@ ;;
        , so a re-rendered editor is never briefly empty (no flash). The candidate row ;; for an existing post appears inside the results ul. (host-bl-test "editor server-renders the first page of candidates into the picker" - (let ((html (render-page (host/blog--relation-editor "alpha-post" "related")))) + (let ((html (render-page (host/blog--relation-editor "alpha-post" "related" true)))) (list (contains? html "id=\"cand-related-") ;; a candidate row is present (contains? html "Beta Post"))) ;; an unrelated post is offered (list true true)) @@ -313,7 +318,7 @@ (host/blog-relate! "alpha-post" "beta-post" "related") ;; the editor wraps current list + picker in #rel-editor-KIND; remove re-renders it (host-bl-test "relation-editor wires remove to re-render the kind's editor" - (let ((html (render-page (host/blog--relation-editor "alpha-post" "related")))) + (let ((html (render-page (host/blog--relation-editor "alpha-post" "related" true)))) (list (contains? html "id=\"rel-editor-related\"") ;; the swap target (contains? html "sx-post=\"/alpha-post/unrelate\"") ;; AJAX, not plain post (contains? html "sx-target=\"#rel-editor-related\"") @@ -481,6 +486,22 @@ (contains? (dream-resp-body (host-bl-app (host-bl-req "/ppost/relate-options?kind=is-a"))) "Article") true) +;; -- relations are posts: symmetry + labels read off the relation-posts (slice 2) -- +(host-bl-test "kind-spec reads :rel metadata off the relation-post" + (let ((s (host/blog--kind-spec "is-a"))) + (list (get s :kind) (get s :label) (get s :symmetric) (get s :inverse-label))) + (list "is-a" "Types" false "Instances")) +(host-bl-test "kind-symmetric? reads symmetry off the post (related yes, is-a no)" + (list (host/blog--kind-symmetric? "related") (host/blog--kind-symmetric? "is-a")) + (list true false)) +(host-bl-test "an unknown kind has no spec, so relate still validates it away" + (host/blog--kind-spec "bogus-kind") nil) +(host-bl-test "rel-kinds is DERIVED from the graph (every post that is-a relation)" + (let ((kinds (map (fn (s) (get s :kind)) (host/blog-rel-kinds)))) + (list (contains? kinds "related") (contains? kinds "is-a") + (contains? kinds "subtype-of") (contains? kinds "tagged"))) + (list true true true true)) + ;; -- Phase 3: tags as posts -- (ocaml is-a tag, from the seed-types test above) (host-bl-test "is-tag?: a post that is-a tag is a tag; others are not" (list (host/blog-is-tag? "ocaml") (host/blog-is-tag? "ppost")) diff --git a/plans/relations-as-posts.md b/plans/relations-as-posts.md index b8f59f57..72e819f5 100644 --- a/plans/relations-as-posts.md +++ b/plans/relations-as-posts.md @@ -40,11 +40,22 @@ the relation's object-end declaration from the anchor**, which includes the root `host/blog--candidate-pool` to be declaration-driven. `:candidates` becomes vestigial. - Wrinkle fixed: the type roots now appear as `is-a` candidates. -### Slice 2 — relations as first-class posts -- Seed `is-a`/`subtype-of`/`tagged`/`related` as posts that own their metadata - (`:symmetric`, `:label`, `:inverse-label`, **cardinality**, **end roles**). The registry - `host/blog-rel-kinds` melts into reads off these posts. A relation can declare its - *subject*-end anchor too (who may be the source), not just object. +### Slice 2 — relations as first-class posts — DONE +- `relation` root + `is-a`/`subtype-of`/`tagged`/`related` seeded as posts (each is-a + relation) owning their metadata in a `:rel` slot (`:symmetric :label :inverse-label`). + `host/blog-rel-kinds` / `kind-spec` / `kind-symmetric?` now read it; the static registry + is gone. `host/blog--rel-slugs` = `host/blog-in "relation" "is-a"` (cheap, flat). +- **Perform budget under http-listen (the hard lesson):** a durable read inside the + render VM raises `VmSuspended`, and too many per request 500s the page. Two fixes: + (1) relation metadata is loaded into an in-memory cache at boot (`host/blog-load-rel-kinds!`, + like `load-edges!`) so `kind-spec` is pure; (2) the initial edit page renders its pickers + EMPTY (the load trigger fills each) — only the relate/unrelate FRAGMENT server-renders + candidates (`with-cands` flag), so one page render doesn't do `candidate-get × every + picker`. Benign single-perform suspend/resume still logs `VmSuspended` but returns 200. +- **Follow-up (Slice 2.5):** `relate-candidates` does a `host/blog-get` per pool member + (O(posts) for `related`). A boot-time **title cache** (updated on put!/delete!) would make + the picker O(1)-perform and cut the suspend/resume churn. Subject-end declarations + a + proper relation-subtype closure (when relations get subtyped) also belong here. ### Slice 3 — typed relations (target-type constraints) - A declaration carries a **target-type constraint**: the *other* end must be (an instance