host P1: types DECLARE behavior, runner DERIVED (LIVE-VERIFIED)
Generalizes the hardcoded publish trigger into declared, capability-routed behavior.
- Types carry :behavior — flat string-keyed bindings {"verb" "type" "dag"} on the type-post
(persist-safe, like :type-relations). The "article" type declares on-create → the "publish" DAG.
- host/blog--load-behaviors! gathers ALL posts' declarations into a registry at boot (serve.sh); the
trigger match (host/blog--triggers :match = host/blog--match-behaviors) consults it. Hardcoded
create+article trigger removed.
- Runner DERIVED (DEBT #2 fixed): match resolves :dag via host/blog--dag-registry and picks the
runner via host/flow--select-runner over host/blog--runner-fleet ([exec-runner]; RA joins at
RA-live). Each binding carries its :runner; behavior/-run-binding now uses the binding's runner
(else the engine default) — so the capability model drives the LIVE engine.
- The type-def view shows each behavior + its derived runner (host/blog--behavior-lines).
LIVE PROOF: /article shows 'on create → publish DAG · needs {effect, branch} · runner: synchronous
(exec-fold)'; publishing on blog.rose-ash.com fired /flows validate+notify via the DECLARED path.
blog 213/213 (+3 P1), full host conformance 610/610. FINDING: load-behaviors! scans all posts, not
is-type?-filtered (article failed is-type? on the durable store though it passed in-memory).
Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
This commit is contained in:
@@ -41,13 +41,16 @@
|
||||
(define behavior/-empty-trace
|
||||
{:emitted (list) :ran (list) :effects (list) :suspended (list) :failed (list) :seen (list)})
|
||||
|
||||
;; run one trigger binding: execute its DAG with the FULL env, then branch on :status.
|
||||
;; run one trigger binding: execute its DAG with the FULL env, then branch on :status. The runner
|
||||
;; is the binding's DERIVED runner (get binding :runner) if the registry resolved one (capability
|
||||
;; selection — P1), else the engine's default :runner.
|
||||
(define behavior/-run-binding
|
||||
(fn (engine activity binding depth acc)
|
||||
(let ((env {:activity activity :actor (get activity :actor)
|
||||
:ctx (behavior/-ctx-of engine activity) :effects (behavior/-effects engine)
|
||||
:binding binding}))
|
||||
(let ((result ((get (behavior/-runner engine) :run) (get binding :dag) env)))
|
||||
(let ((runner (or (get binding :runner) (behavior/-runner engine))))
|
||||
(let ((result ((get runner :run) (get binding :dag) env)))
|
||||
(let ((acc1 (assoc acc :ran (concat (get acc :ran) (list result))))
|
||||
(status (or (get result :status) "done")))
|
||||
(cond
|
||||
@@ -62,7 +65,7 @@
|
||||
(fn (a eff)
|
||||
(behavior/-dispatch-effect engine eff depth
|
||||
(assoc a :effects (concat (get a :effects) (list eff)))))
|
||||
acc1 (or (get result :effects) (list))))))))))
|
||||
acc1 (or (get result :effects) (list)))))))))))
|
||||
|
||||
;; dispatch one effect via the driver; recurse on any NEW activities it emits (the loop closes).
|
||||
(define behavior/-dispatch-effect
|
||||
|
||||
@@ -161,6 +161,43 @@
|
||||
(define host/blog--publish-ctx
|
||||
(fn (activity) {"category" (get activity :category) "slug" (get activity :slug)}))
|
||||
|
||||
;; ── P1: types DECLARE behavior; the runner is DERIVED from the DAG's capabilities ──────
|
||||
;; A type-post carries :behavior = a list of flat string-keyed bindings {"verb" "type" "dag"} (like
|
||||
;; :type-relations). At boot they're gathered into a registry the trigger match consults. :dag NAMES
|
||||
;; a registered behavior DAG; the runner is chosen by host/flow--select-runner over the fleet — an
|
||||
;; {effect,branch} composition → exec-runner; a {suspend} DAG → RA once RA-live adds it to the fleet.
|
||||
(define host/blog--dag-registry {"publish" host/blog--publish-dag}) ;; name -> behavior DAG
|
||||
(define host/blog--dag-of (fn (name) (get host/blog--dag-registry name)))
|
||||
;; the runner fleet, cheapest-first. exec-runner only until RA-live stands up a persistent kernel.
|
||||
(define host/blog--runner-fleet (list host/flow--exec-runner))
|
||||
;; per-type behavior declaration, stored on the type-post (string-keyed → persist-safe).
|
||||
(define host/blog--type-behavior (fn (type) (or (get (host/blog-get type) :behavior) (list))))
|
||||
(define host/blog--set-type-behavior!
|
||||
(fn (type bindings)
|
||||
(let ((r (host/blog-get type))) (when r (host/blog--write! type (merge r {:behavior bindings}))))))
|
||||
;; the behavior REGISTRY: every declared binding, gathered at boot (like load-edges!). Scans ALL
|
||||
;; posts for a :behavior declaration — robust to is-type? state differences across the durable store
|
||||
;; (a post without :behavior contributes nothing).
|
||||
(define host/blog--behaviors (list))
|
||||
(define host/blog--load-behaviors!
|
||||
(fn ()
|
||||
(set! host/blog--behaviors
|
||||
(reduce (fn (acc t) (concat acc (host/blog--type-behavior t)))
|
||||
(list) (host/blog-slugs)))))
|
||||
;; match an activity against the registry → resolved bindings {:dag :runner}, runner DERIVED by caps.
|
||||
;; (A binding whose DAG needs a capability no fleet runner has is SKIPPED — a soft bind failure.)
|
||||
(define host/blog--match-behaviors
|
||||
(fn (activity)
|
||||
(reduce
|
||||
(fn (acc b)
|
||||
(if (and (= (get b "verb") (get activity :verb))
|
||||
(= (get b "type") (get activity :object-type)))
|
||||
(let ((dag (host/blog--dag-of (get b "dag"))))
|
||||
(let ((runner (host/flow--select-runner host/blog--runner-fleet dag)))
|
||||
(if (nil? runner) acc (concat acc (list {:dag dag :runner runner})))))
|
||||
acc))
|
||||
(list) host/blog--behaviors)))
|
||||
|
||||
;; ── P0.3: the seam WIRED on the live host ──────────────────────────────
|
||||
;; The publish ENGINE = the execute-fold runner (flows.sx) + a local-SX on-publish trigger registry
|
||||
;; + an in-process transport (the activity log = the event source) + the host driver (records each
|
||||
@@ -173,10 +210,11 @@
|
||||
(define host/blog--transport
|
||||
{:emit (fn (a) (set! host/blog--activity-log (concat host/blog--activity-log (list a))))
|
||||
:deliver (fn () (list))}) ;; nothing inbound yet — P0 is synchronous
|
||||
;; P1: the trigger match consults the behavior REGISTRY (built from types' declarations), and each
|
||||
;; matched binding carries its DERIVED runner (capability selection). Was a hardcoded create+article.
|
||||
(define host/blog--triggers
|
||||
{:register! (fn (spec dag hint) nil)
|
||||
:match (fn (a) (if (and (= (get a :verb) "create") (= (get a :object-type) "article"))
|
||||
(list {:dag host/blog--publish-dag}) (list)))})
|
||||
:match host/blog--match-behaviors})
|
||||
;; P0.3b: the flow log is DURABLE — string-keyed records (dodge the keyword/persist top-level split),
|
||||
;; persisted to the blog store under one key, so /flows survives a restart. Boot-loaded via
|
||||
;; host/blog-load-flowlog!. (Whole-list rewrite per effect — fine at P0 volume; cap/rotate later.)
|
||||
@@ -1401,6 +1439,11 @@
|
||||
;; tagged — but NOT subtyped (subtype-of is for types). The relation editors + relate
|
||||
;; handler read this; the metamodel types declare none, so they keep every kind.
|
||||
(host/blog--set-type-relations! "article" (list "related" "is-a" "tagged"))
|
||||
;; P1: the "article" type DECLARES its behavior — on-publish (a create of an article) runs the
|
||||
;; "publish" DAG. The runner is derived from the DAG's caps ({effect,branch} → exec-runner). This
|
||||
;; replaces the hardcoded trigger; host/blog--load-behaviors! gathers it into the registry at boot.
|
||||
(host/blog--set-type-behavior! "article"
|
||||
(list {"verb" "create" "type" "article" "dag" "publish"}))
|
||||
;; ── cards-as-types: the blog content block vocabulary (kg-cards / content-on-sx
|
||||
;; block kinds) as metamodel types. "card" is the root; each card kind is a subtype
|
||||
;; with its own fields. These define the editor's card palette + the radar migrator's
|
||||
@@ -2053,6 +2096,26 @@
|
||||
;; the READ-ONLY type definition, shown on a type's PUBLIC page so anyone can read what the
|
||||
;; type is: its fields, each Composition field's block grammar, and the relations its instances
|
||||
;; may use. (The edit page's host/blog--type-def-editor is the writable form of the same data.)
|
||||
;; P1: render a type's declared BEHAVIOR bindings + the DERIVED runner for each (visible, not
|
||||
;; hand-set — the sync/durable classification falls out of the DAG's required capabilities).
|
||||
(define host/blog--behavior-lines
|
||||
(fn (slug)
|
||||
(let ((bs (host/blog--type-behavior slug)))
|
||||
(if (empty? bs) ""
|
||||
(cons (quote div)
|
||||
(cons (quote (:style "margin:0.4em 0 0"))
|
||||
(cons (quote (b "Behavior: "))
|
||||
(map (fn (bd)
|
||||
(let ((dag (host/blog--dag-of (get bd "dag"))))
|
||||
(let ((runner (host/flow--select-runner host/blog--runner-fleet dag))
|
||||
(caps (host/flow--required-caps dag)))
|
||||
(quasiquote (span :style "display:block;font-size:0.9em;color:#555"
|
||||
(unquote (str "on " (get bd "verb") " → " (get bd "dag") " DAG · needs {"
|
||||
(join ", " caps) "} · runner: "
|
||||
(if (nil? runner) "NONE (capability unmet)"
|
||||
(if (contains? (get runner :capabilities) "suspend")
|
||||
"durable (RA)" "synchronous (exec-fold)")))))))))
|
||||
bs))))))))
|
||||
(define host/blog--type-def-view
|
||||
(fn (slug)
|
||||
(let ((fields (host/blog-fields-of slug))
|
||||
@@ -2074,7 +2137,8 @@
|
||||
(unquote (if (> (len fields) 0)
|
||||
(cons (quote ul) (append (quasiquote (:style "margin:0.3em 0")) rows))
|
||||
(quote (p :style "color:#999;margin:0" "No declared fields."))))
|
||||
(p :style "margin:0.4em 0 0" (b "Instances may be linked by: ") (unquote (join ", " rels)))))))))
|
||||
(p :style "margin:0.4em 0 0" (b "Instances may be linked by: ") (unquote (join ", " rels)))
|
||||
(unquote (host/blog--behavior-lines slug))))))))
|
||||
;; the first n elements of a list.
|
||||
(define host/blog--take
|
||||
(fn (xs n) (let loop ((ys xs) (k n) (acc (list)))
|
||||
|
||||
@@ -185,6 +185,11 @@ EPOCH=1
|
||||
echo "(epoch $EPOCH)"
|
||||
echo "(eval \"(host/blog-seed-types!)\")"
|
||||
EPOCH=$((EPOCH+1))
|
||||
# P1: gather the types' declared :behavior bindings into the registry the trigger match
|
||||
# consults (so publishing an article fires its declared on-publish DAG, runner derived).
|
||||
echo "(epoch $EPOCH)"
|
||||
echo "(eval \"(host/blog--load-behaviors!)\")"
|
||||
EPOCH=$((EPOCH+1))
|
||||
# Seed a live demo of the composition fold (plans/composition-objects.md): /compose-demo
|
||||
# is one composition object rendered by host/comp-render — renders differently by context.
|
||||
echo "(epoch $EPOCH)"
|
||||
|
||||
@@ -175,6 +175,17 @@
|
||||
;; the relation metadata into the in-memory cache the same way.
|
||||
(host/blog-seed-types!)
|
||||
(host/blog-load-rel-kinds!)
|
||||
(host/blog--load-behaviors!) ;; P1: gather types' declared behaviors into the registry (as boot does)
|
||||
(host-bl-test "P1: load-behaviors! gathers the article type's declared on-publish binding"
|
||||
(list (>= (len host/blog--behaviors) 1)
|
||||
(contains? (map (fn (b) (get b "dag")) host/blog--behaviors) "publish"))
|
||||
(list true true))
|
||||
(host-bl-test "P1: match-behaviors resolves a create/article activity → a binding with a DERIVED runner"
|
||||
(let ((ms (host/blog--match-behaviors {:verb "create" :object-type "article"})))
|
||||
(list (len ms) (get (get (first ms) :runner) :capabilities)))
|
||||
(list 1 (list "effect" "branch" "each")))
|
||||
(host-bl-test "P1: a non-article activity matches nothing"
|
||||
(len (host/blog--match-behaviors {:verb "create" :object-type "note"})) 0)
|
||||
(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)
|
||||
|
||||
Reference in New Issue
Block a user