From 7838e45aea16455410201bdd8641f99d9f7c6613 Mon Sep 17 00:00:00 2001 From: giles Date: Wed, 1 Jul 2026 14:22:41 +0000 Subject: [PATCH] =?UTF-8?q?host:=20Part=20B=20=E2=80=94=20relations=20are?= =?UTF-8?q?=20type-governed=20composition=20too?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit related / is-a / subtype-of / tagged are part of an object's composition (external — NOT in the CID), and the TYPE declares which relation kinds its instances may use (:type-relations; absent -> all kinds, so metamodel types keep full freedom). host/blog--{all-rel-kinds, type-relations, set-type-relations!, allowed-relations, relation-allowed?}. The relation editors filter to the permitted kinds; relate-submit ENFORCES it. article declares (related is-a tagged) — an article instance can't be subtyped. The type-def editor (Part C) gains a relation CHECKLIST + POST //relations, so the type's inline block-grammar AND external relations are edited in one place: "it's just more composition." blog 189/189 (+ Part B tests: allowed-relations excludes subtype-of for article, editors filter, relate rejects a forbidden kind, checklist renders, POST /relations sets it). Full conformance deferred — the sibling OTel loop is contending on the shared warm-conf dir; Part B touches only blog.sx, so the other 7 suites are unaffected. Verifying live instead. Co-Authored-By: Claude Opus 4.8 --- lib/host/blog.sx | 70 ++++++++++++++++++++++++++++++++++++------ lib/host/tests/blog.sx | 34 ++++++++++++++++++++ 2 files changed, 95 insertions(+), 9 deletions(-) diff --git a/lib/host/blog.sx b/lib/host/blog.sx index 1875e544..82848e8b 100644 --- a/lib/host/blog.sx +++ b/lib/host/blog.sx @@ -536,6 +536,23 @@ (concat acc (list (str "‘" k "’ blocks are not allowed in :" field))))) (else acc)))) (list) (host/blog--comp-nodes slug field)))) +;; ── Part B: RELATIONS are governed by the type too — related / is-a / subtype-of / tagged are +;; part of the object's composition (external — NOT in the CID), and the type declares which +;; relation kinds its instances may use (:type-relations). Absent -> all kinds (back-compat). -- +(define host/blog--all-rel-kinds (fn () (map (fn (s) (get s :kind)) host/blog-rel-kinds))) +(define host/blog--type-relations (fn (type) (get (host/blog-get type) :type-relations))) +(define host/blog--set-type-relations! + (fn (type kinds) + (let ((r (host/blog-get type))) (when r (host/blog--write! type (merge r {:type-relations kinds})))))) +;; the relation kinds a post may use = the union its types declare (:type-relations); if no +;; type declares any, every registered kind (so metamodel types keep full freedom by default). +(define host/blog--allowed-relations + (fn (slug) + (let ((declared (reduce (fn (acc t) (let ((r (host/blog--type-relations t))) + (if r (host/blog--uniq (concat acc r)) acc))) + (list) (host/blog-types-of slug)))) + (if (empty? declared) (host/blog--all-rel-kinds) declared)))) +(define host/blog--relation-allowed? (fn (slug kind) (contains? (host/blog--allowed-relations slug) kind))) ;; ── Part C: the TYPE DEFINITION is itself editable — a type's :fields (each with, for a ;; Composition field, its block grammar) are displayed + edited on the type's own edit page. ;; is this post a TYPE? (declares fields, or is subtype-of "type" transitively). -- @@ -1232,6 +1249,10 @@ ;; above the body. (field "subtitle") resolves to the instance's value at render. (host/blog--set-template! "article" "(p :style \"font-style:italic;color:#555;margin:0 0 1em;font-size:1.1em\" (field \"subtitle\"))") + ;; article's allowed RELATIONS (Part B): an article instance may be related, typed, and + ;; tagged — but NOT subtyped (subtype-of is for types). The relation editors + relate + ;; handler read this; the metamodel types declare none, so they keep every kind. + (host/blog--set-type-relations! "article" (list "related" "is-a" "tagged")) ;; ── cards-as-types: the blog content block vocabulary (kg-cards / content-on-sx ;; block kinds) as metamodel types. "card" is the root; each card kind is a subtype ;; with its own fields. These define the editor's card palette + the radar migrator's @@ -1678,11 +1699,12 @@ ;; 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)))) + (let ((allowed (host/blog--allowed-relations slug))) + (cons (quote div) + ;; only the relation kinds the post's TYPE permits (Part B). false: the initial edit + ;; page renders empty pickers (the load trigger fills each), keeping this render cheap. + (map (fn (spec) (host/blog--relation-editor slug (get spec :kind) false)) + (filter (fn (spec) (contains? allowed (get spec :kind))) host/blog-rel-kinds)))))) ;; ── block editor: edit the post :body composition (insert/reorder/remove blocks) ───── ;; A row per block (type + preview + up/down/remove + a link to edit the card's fields) and @@ -1847,8 +1869,25 @@ (unquote (host/blog--checkbox "allow-cond" "conditional (or)" (contains? ctrl "cond"))) (unquote (host/blog--checkbox "allow-each" "repeater (each)" (contains? ctrl "each"))) (br) (button :type "submit" :style "margin-top:0.4em" "save grammar")))))))))) -;; the whole type-definition editor: a row per field (scalar shown as name:type; Composition -;; shown with its grammar form). +;; the RELATION checklist for a type (id #type-relations): which relation kinds its instances +;; may be linked by (Part B — relations are type-governed composition too). +(define host/blog--relations-form + (fn (slug) + (let ((cur (or (host/blog--type-relations slug) (host/blog--all-rel-kinds))) + (all (host/blog--all-rel-kinds)) + (url (str "/" slug "/relations"))) + (cons (quote form) + (append + (quasiquote (:method "post" :action (unquote url) :sx-post (unquote url) + :sx-target "#type-relations" :sx-swap "outerHTML" + :id "type-relations" :style "margin:0.5em 0;padding:0.5em;border:1px dashed #bbb" + (div :style "font-weight:bold;font-size:0.9em;margin-bottom:0.3em" + "instances may be linked by these relations —"))) + (append + (map (fn (k) (host/blog--checkbox (str "rel-" k) k (contains? cur k))) all) + (quasiquote ((br) (button :type "submit" :style "margin-top:0.4em" "save relations"))))))))) +;; the whole type-definition editor: the field/grammar rows + the relation checklist. "It's +;; just more composition" — the inline block grammar AND the external relations, in one place. (define host/blog--type-def-editor (fn (slug) (let ((fields (host/blog-fields-of slug))) @@ -1862,7 +1901,7 @@ (append (quasiquote (:id "type-def" :style "margin-top:1.5em;border-top:2px solid #999;padding-top:1em" (h3 :style "font-size:1em;margin:0 0 0.4em" "Type definition — what this type's instances may contain"))) - rows)))))) + (append rows (list (host/blog--relations-form slug))))))))) ;; ── read handlers ─────────────────────────────────────────────────── ;; Post body is rendered per-block (a guarded HTML string) then injected raw. @@ -2219,7 +2258,8 @@ ;; 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--kind-spec kind) (host/blog--relation-allowed? slug 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 @@ -2312,6 +2352,17 @@ (if (host/blog--editor-swap-req? req) (dream-html (render-page (host/blog--grammar-form slug (host/blog--own-field slug fname)))) (dream-redirect (str "/" slug "/edit"))))))) +;; POST //relations — set which relation kinds the type's instances may use (Part B). +(define host/blog-relations-submit + (fn (req) + (let ((slug (dream-param req "slug"))) + (begin + (when (and (host/blog-exists? slug) (host/blog--is-type? slug)) + (host/blog--set-type-relations! slug + (filter (fn (k) (not (nil? (host/field req (str "rel-" k))))) (host/blog--all-rel-kinds)))) + (if (host/blog--editor-swap-req? req) + (dream-html (render-page (host/blog--relations-form slug))) + (dream-redirect (str "/" slug "/edit"))))))) ;; GET //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 @@ -2450,6 +2501,7 @@ (dream-post "/:slug/blocks/:idx/move" (host/blog--protect-html resolve host/blog-block-move-submit)) (dream-post "/:slug/blocks/:idx/cond" (host/blog--protect-html resolve host/blog-block-cond-submit)) (dream-post "/:slug/grammar" (host/blog--protect-html resolve host/blog-grammar-submit)) + (dream-post "/:slug/relations" (host/blog--protect-html resolve host/blog-relations-submit)) (dream-post "/:slug/relate" (host/blog--protect-html resolve host/blog-relate-submit)) (dream-post "/:slug/unrelate" (host/blog--protect-html resolve host/blog-unrelate-submit)) (dream-post "/meta/new-type" (host/blog--protect-html resolve host/blog-meta-new-type)) diff --git a/lib/host/tests/blog.sx b/lib/host/tests/blog.sx index f9ce95d6..86f76ecc 100644 --- a/lib/host/tests/blog.sx +++ b/lib/host/tests/blog.sx @@ -1006,6 +1006,40 @@ (list (contains? (dream-resp-body (host-bl-wapp (host-bl-send "GET" "/article/edit" "Bearer good" "" ""))) "Type definition") (contains? (dream-resp-body (host-bl-wapp (host-bl-send "GET" "/my-first-post/edit" "Bearer good" "" ""))) "Type definition")) (list true false)) +;; -- Part B: RELATIONS are type-governed composition — the type declares which relation kinds +;; its instances may use; the editors + relate handler honour it; editable on the type page. -- +(host-bl-test "allowed-relations reads the type's :type-relations (article excludes subtype-of)" + (begin + (host/blog-put! "artinst" "AI" "(article (h1 \"x\"))" "published") + (host/blog-relate! "artinst" "article" "is-a") + (let ((allowed (host/blog--allowed-relations "artinst"))) + (list (contains? allowed "related") (contains? allowed "is-a") (contains? allowed "tagged") + (contains? allowed "subtype-of")))) + (list true true true false)) +(host-bl-test "the relation editors show only the type's permitted kinds" + (let ((html (render-page (host/blog--relation-editors "artinst")))) + (list (contains? html "rel-editor-related") (contains? html "rel-editor-tagged") + (contains? html "rel-editor-subtype-of"))) + (list true true false)) +(host-bl-test "relate-submit rejects a relation kind the type forbids" + (begin + (host/blog-seed! "sometype" "ST" "(p)" "published") (host/blog-relate! "sometype" "type" "subtype-of") + (host-bl-wapp (host-bl-send "POST" "/artinst/relate" "Bearer good" + "application/x-www-form-urlencoded" "kind=subtype-of&other=sometype")) + (contains? (host/blog-out "artinst" "subtype-of") "sometype")) + false) +(host-bl-test "the type-def editor includes the relation checklist" + (let ((html (render-page (host/blog--type-def-editor "article")))) + (list (contains? html "may be linked by") (contains? html "rel-related") (contains? html "rel-tagged"))) + (list true true true)) +(host-bl-test "POST //relations sets the allowed relations from the checklist" + (begin + (host/blog-seed! "rtype" "RT" "(p)" "published") (host/blog-relate! "rtype" "type" "subtype-of") + (host-bl-wapp (host-bl-send "POST" "/rtype/relations" "Bearer good" + "application/x-www-form-urlencoded" "rel-related=on&rel-tagged=on")) + (let ((r (host/blog--type-relations "rtype"))) + (list (contains? r "related") (contains? r "tagged") (contains? r "is-a")))) + (list true true false)) ;; the editor renders a HAND-AUTHORED composition (text/row/alt-with-text) WITHOUT falling ;; through to "(unknown block)" — every node kind gets a labelled row (the compose-demo case). (host-bl-test "the block editor renders text/layout/inline-alt nodes (no unknown block)"