host: Part B — relations are type-governed composition too

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
/<type>/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 <noreply@anthropic.com>

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 /<type>/relations — set which relation kinds the type's instances may use (Part B).
+(define host/blog-relations-submit
+  (fn (req)
+    (let ((slug (dream-param req "slug")))
+      (begin
+        (when (and (host/blog-exists? slug) (host/blog--is-type? slug))
+          (host/blog--set-type-relations! slug
+            (filter (fn (k) (not (nil? (host/field req (str "rel-" k))))) (host/blog--all-rel-kinds))))
+        (if (host/blog--editor-swap-req? req)
+          (dream-html (render-page (host/blog--relations-form slug)))
+          (dream-redirect (str "/" slug "/edit")))))))
 
 ;; GET /<slug>/edit — edit form pre-filled with the post's current title, raw
 ;; sx_content (in a textarea — render-to-html escapes the text child, so the
@@ -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))

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 /<type>/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)"