From 96df9e2858c0a7547d77d7d244163ffef1f5d5ff Mon Sep 17 00:00:00 2001 From: Kinneyzhang Date: Tue, 1 Sep 2026 01:07:39 +0800 Subject: [PATCH] feat: make Host attach and detach authoritative --- Makefile | 4 +- docs/architecture.en.md | 8 + docs/architecture.zh.md | 7 + etaf-host.el | 178 +++++++++++++++++ etaf-reactive.el | 2 +- etaf-render-port.el | 47 ++++- etaf-runtime.el | 175 +++++++++++------ etaf.el | 1 + tests/etaf-host-tests.el | 182 ++++++++++++++++++ .../etaf-m0a-condition-consumers.sexp | 1 + 10 files changed, 538 insertions(+), 67 deletions(-) create mode 100644 etaf-host.el create mode 100644 tests/etaf-host-tests.el diff --git a/Makefile b/Makefile index 6d57bbd..fd5dff6 100644 --- a/Makefile +++ b/Makefile @@ -1,8 +1,8 @@ EMACS ?= emacs LOAD_PATH = -L . -L examples -L scripts -L ../ebox -L ../tp -L ../ecss -SOURCES = etaf-view.el etaf-compiler.el etaf-component.el etaf-reactive.el etaf-observer.el etaf-context.el etaf-theme-tp.el etaf-resource.el etaf-data.el etaf-generation.el etaf-render-port.el etaf-renderer.el etaf-runtime.el etaf-behavior.el etaf-actions.el etaf-events.el etaf-performance.el etaf.el scripts/emacs-gui-verifier.el +SOURCES = etaf-view.el etaf-compiler.el etaf-component.el etaf-reactive.el etaf-observer.el etaf-context.el etaf-theme-tp.el etaf-resource.el etaf-data.el etaf-generation.el etaf-host.el etaf-render-port.el etaf-renderer.el etaf-runtime.el etaf-behavior.el etaf-actions.el etaf-events.el etaf-performance.el etaf.el scripts/emacs-gui-verifier.el EXAMPLES = examples/etaf-counter-example.el examples/etaf-data-example.el examples/etaf-resource-example.el -TESTS = tests/etaf-tests.el tests/etaf-compiler-tests.el tests/etaf-component-frontends-tests.el tests/etaf-resource-tests.el tests/etaf-data-tests.el tests/etaf-theme-tp-tests.el tests/etaf-examples-tests.el tests/etaf-observer-tests.el tests/etaf-performance-tests.el tests/etaf-gui-verifier-tests.el tests/etaf-m0a-current-characterization-tests.el tests/etaf-interaction-contract-tests.el tests/etaf-m0b-component-manifest-tests.el tests/etaf-render-port-tests.el tests/etaf-generation-tests.el +TESTS = tests/etaf-tests.el tests/etaf-compiler-tests.el tests/etaf-component-frontends-tests.el tests/etaf-resource-tests.el tests/etaf-data-tests.el tests/etaf-theme-tp-tests.el tests/etaf-examples-tests.el tests/etaf-observer-tests.el tests/etaf-performance-tests.el tests/etaf-gui-verifier-tests.el tests/etaf-m0a-current-characterization-tests.el tests/etaf-interaction-contract-tests.el tests/etaf-m0b-component-manifest-tests.el tests/etaf-render-port-tests.el tests/etaf-generation-tests.el tests/etaf-host-tests.el .PHONY: test compile load checkdoc docs-check check clean diff --git a/docs/architecture.en.md b/docs/architecture.en.md index 579d23e..0ff3152 100644 --- a/docs/architecture.en.md +++ b/docs/architecture.en.md @@ -466,6 +466,14 @@ without creating an Ebox commit or TP revision. Mirror projection and obsolete route cleanup after CAS are postcommit work and cannot reverse the committed token if they fail. +Each mounted Runtime also owns a distinct Host authority containing `state / +opaque token / version`. The initial v2 framework stage enters only a +provisional state and registers a fixed-slot TP final marker; the Host becomes +attached only when buffer final accept succeeds. Public lookup, events, and +source routes validate both attached state and token. Detach invalidates the +token at one O(1) boundary before removing registries, routes, Component scopes, +or Behaviors, so cleanup volume or failure cannot revive the old Host. + Each Runtime flush records a candidate-aware effect tuple containing the generation id, effect-to-source edges and source versions, plus an immutable semantic-node stamp for candidate input/context/output facts. A repeated tuple diff --git a/docs/architecture.zh.md b/docs/architecture.zh.md index 3067d62..bafa665 100644 --- a/docs/architecture.zh.md +++ b/docs/architecture.zh.md @@ -454,6 +454,13 @@ stage 中暂存一次 CAS，失败时由同一个 inverse journal 恢复；没 revision。CAS 后的 mirror 与旧 route 清理属于 postcommit，失败不能反向恢复已提交 token。 +每个 mounted Runtime 还拥有独立的 Host authority：`state / opaque token / +version`。initial v2 framework stage 只进入 provisional state，并向 TP 注册固定 +slot final marker；只有 buffer final accept 成功时 Host 才成为 attached。公开 +lookup、event 和 source route 同时校验 attached state 与 token。detach 先在 O(1) +边界让 token 失效，再清理 registry、routes、Component scopes 和 Behaviors；因此 +cleanup 数量或错误不能让旧 Host 重新获得 authority。 + 每次 Runtime flush 都记录 candidate-aware effect tuple：其中包含 generation id、 effect→source 边和 source version，以及 candidate input/context/output facts 的 immutable semantic-node stamp。重复 tuple 会报告有序的 effect/edge path；step diff --git a/etaf-host.el b/etaf-host.el new file mode 100644 index 0000000..bb47f5f --- /dev/null +++ b/etaf-host.el @@ -0,0 +1,178 @@ +;;; etaf-host.el --- ETAF Host attach/detach authority -*- lexical-binding: t; -*- + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;;; Commentary: + +;; Owns one mounted Runtime's fixed Host authority token and state machine. +;; Initial v2 attachment registers a bounded TP final marker so attached +;; authority and buffer publication share one final-accept boundary. Detach +;; invalidates authority in O(1) before any unbounded retirement work. + +;;; Code: + +(require 'cl-lib) +(require 'tp-transaction) +(require 'tp-reactive) + +(define-error 'etaf-host-authority-error "Invalid ETAF Host authority state") + +(defconst etaf-host--state-slot 0) +(defconst etaf-host--token-slot 1) +(defconst etaf-host--version-slot 2) + +(cl-defstruct + (etaf-host-authority + (:constructor etaf-host-authority--create)) + "Fixed identity and mutable authority slots for one Runtime Host." + host-id + mount-epoch + buffer + slots) + +(defun etaf-host-authority-create (host-id mount-epoch buffer) + "Return detached authority for HOST-ID, MOUNT-EPOCH, and BUFFER." + (unless (and host-id (integerp mount-epoch) (> mount-epoch 0) + (bufferp buffer)) + (signal 'etaf-host-authority-error + (list :invalid-host host-id mount-epoch buffer))) + (etaf-host-authority--create + :host-id host-id + :mount-epoch mount-epoch + :buffer buffer + :slots (vector 'detached + (list 'etaf-host-token mount-epoch (make-symbol "token")) + 0))) + +(defun etaf-host-authority-state (authority) + "Return AUTHORITY's current Host state." + (aref (etaf-host-authority-slots authority) etaf-host--state-slot)) + +(defun etaf-host-authority-token (authority) + "Return AUTHORITY's current opaque token, or nil after detach." + (aref (etaf-host-authority-slots authority) etaf-host--token-slot)) + +(defun etaf-host-authority-version (authority) + "Return AUTHORITY's monotonic registration version." + (aref (etaf-host-authority-slots authority) etaf-host--version-slot)) + +(defun etaf-host-authority-attached-p (authority) + "Return non-nil when AUTHORITY is publicly attached." + (and (etaf-host-authority-p authority) + (eq (etaf-host-authority-state authority) 'attached) + (etaf-host-authority-token authority))) + +(defun etaf-host-authority-accepts-token-p (authority token) + "Return non-nil when attached AUTHORITY accepts opaque TOKEN." + (and (etaf-host-authority-attached-p authority) + (eq token (etaf-host-authority-token authority)))) + +(defun etaf-host-authority-begin-attach (authority) + "Move detached AUTHORITY into its private attaching state." + (unless (eq (etaf-host-authority-state authority) 'detached) + (signal 'etaf-host-authority-error + (list :begin-attach (etaf-host-authority-state authority)))) + (aset (etaf-host-authority-slots authority) + etaf-host--state-slot 'attaching) + authority) + +(defun etaf-host--slot-write (authority index value) + "Return one prebuilt TP marker write for AUTHORITY slot INDEX and VALUE." + (tp-final-marker-slot-write-create + :target (etaf-host-authority-slots authority) + :index index + :value value)) + +(defun etaf-host-authority-stage-attach (authority &optional legacy-p) + "Stage AUTHORITY attachment and register its final marker. +When LEGACY-P is non-nil, publish attached state directly after the legacy Ebox +initial operation and rely on manual framework rollback." + (unless (eq (etaf-host-authority-state authority) 'attaching) + (signal 'etaf-host-authority-error + (list :stage-attach (etaf-host-authority-state authority)))) + (let* ((slots (etaf-host-authority-slots authority)) + (token (etaf-host-authority-token authority)) + (version (etaf-host-authority-version authority))) + (aset slots etaf-host--state-slot 'provisionally-attached) + (if legacy-p + (let ((inhibit-quit t)) + (aset slots etaf-host--state-slot 'attached) + (aset slots etaf-host--version-slot (1+ version))) + (tp-transaction-register-final-marker + :owner-key + (list 'etaf-host + (etaf-host-authority-host-id authority) + (etaf-host-authority-mount-epoch authority)) + :expected-token + (tp-final-marker-expectation-create + :target slots :index etaf-host--token-slot :value token) + :expected-version + (tp-final-marker-expectation-create + :target slots :index etaf-host--version-slot :value version) + :next-values + (vector + (etaf-host--slot-write authority etaf-host--state-slot 'attached) + (etaf-host--slot-write authority etaf-host--version-slot (1+ version))) + :inverse-values + (vector + (etaf-host--slot-write + authority etaf-host--state-slot 'provisionally-attached) + (etaf-host--slot-write authority etaf-host--version-slot version)) + :slot-write-count 2 + :operation-key 'tp-vector-slots/v1)) + authority)) + +(defun etaf-host-authority-rollback-attach (authority) + "Restore failed attaching AUTHORITY to detached, idempotently." + (pcase (etaf-host-authority-state authority) + ((or 'attaching 'provisionally-attached 'attached) + (aset (etaf-host-authority-slots authority) + etaf-host--state-slot 'detached)) + ((or 'detached 'terminal) nil) + (state + (signal 'etaf-host-authority-error (list :rollback-attach state)))) + authority) + +(defun etaf-host-authority-finish-attach (authority) + "Validate and return final-accept attached AUTHORITY." + (unless (etaf-host-authority-attached-p authority) + (signal 'etaf-host-authority-error + (list :finish-attach (etaf-host-authority-state authority)))) + authority) + +(defun etaf-host-authority-begin-detach (authority) + "Move attached AUTHORITY into pre-boundary detaching state." + (unless (etaf-host-authority-attached-p authority) + (signal 'etaf-host-authority-error + (list :begin-detach (etaf-host-authority-state authority)))) + (aset (etaf-host-authority-slots authority) + etaf-host--state-slot 'detaching) + authority) + +(defun etaf-host-authority-invalidate (authority) + "Invalidate AUTHORITY token in O(1) and enter detached retirement." + (unless (memq (etaf-host-authority-state authority) + '(detaching attaching provisionally-attached detached)) + (signal 'etaf-host-authority-error + (list :invalidate (etaf-host-authority-state authority)))) + (let* ((slots (etaf-host-authority-slots authority)) + (version (etaf-host-authority-version authority)) + (inhibit-quit t)) + (aset slots etaf-host--state-slot 'detached-retiring) + (aset slots etaf-host--token-slot nil) + (aset slots etaf-host--version-slot (1+ version))) + authority) + +(defun etaf-host-authority-finish-detach (authority) + "Move detached-retiring AUTHORITY to terminal." + (unless (memq (etaf-host-authority-state authority) + '(detached-retiring terminal)) + (signal 'etaf-host-authority-error + (list :finish-detach (etaf-host-authority-state authority)))) + (aset (etaf-host-authority-slots authority) + etaf-host--state-slot 'terminal) + authority) + +(provide 'etaf-host) + +;;; etaf-host.el ends here diff --git a/etaf-reactive.el b/etaf-reactive.el index d758b44..f25ffab 100644 --- a/etaf-reactive.el +++ b/etaf-reactive.el @@ -71,7 +71,7 @@ (cl-defstruct (etaf-runtime-route (:constructor etaf-runtime-route-create)) "Opaque Runtime route stored by reactive sources." - runtime-id mount-epoch scheduler) + runtime-id mount-epoch authority-token scheduler) (defvar etaf--active-effect nil "The effect currently collecting dependencies.") diff --git a/etaf-render-port.el b/etaf-render-port.el index 282fa75..b607d61 100644 --- a/etaf-render-port.el +++ b/etaf-render-port.el @@ -33,7 +33,8 @@ '(initial-paired-stage-rollback update-paired-stage-rollback combined-participant-ordering - same-object-legacy-report) + same-object-legacy-report + initial-observation-replay) "Capabilities required from an Ebox framework SPI v2 provider.") (defconst etaf-render-port--required-tp-protocol @@ -119,7 +120,8 @@ ebox-framework-spi-operation-function ebox-framework-spi-operation-argument-schema ebox-framework-spi-operation-result-schema - ebox-framework-spi-operation-paired-stage-rollback-p)) + ebox-framework-spi-operation-paired-stage-rollback-p + ebox-framework-spi-initial-observation-reports)) (unless (fboundp function) (etaf-render-port--bootstrap-error 'missing-provider-accessor function)))) @@ -258,13 +260,15 @@ t) (defun etaf-render-port--v1-initial - (buffer input framework-stage framework-rollback) + (buffer input framework-stage framework-rollback &optional observer) "Publish INPUT initially to BUFFER through legacy Ebox. FRAMEWORK-STAGE runs after publication; FRAMEWORK-ROLLBACK performs contained -manual framework cleanup if staging fails." +manual framework cleanup if staging fails. OBSERVER, when non-nil, is passed +through Ebox's legacy initial option." (etaf-render-port--validate-framework-pair framework-stage framework-rollback) - (let ((result (ebox-render-to-buffer buffer input)) + (let ((result (ebox-render-to-buffer + buffer input (and observer (list :observer observer)))) stage-entered) (condition-case primary (progn @@ -273,6 +277,9 @@ manual framework cleanup if staging fails." result) ((error quit) (when stage-entered + (when (and observer (buffer-live-p (get-buffer buffer)) + (ebox-surface-buffer-mounted-p (get-buffer buffer))) + (ebox-buffer-set-observer buffer nil)) (let ((inhibit-quit t) (quit-flag nil)) (condition-case nil (funcall framework-rollback nil) @@ -351,12 +358,24 @@ FRAMEWORK-STAGE and FRAMEWORK-ROLLBACK retain their existing Ebox meanings." etaf-render-port--selected-port) (defun etaf-render-port-initial - (buffer input framework-stage framework-rollback) + (buffer input framework-stage framework-rollback &optional observer) "Run selected initial operation for BUFFER and canonical INPUT. -FRAMEWORK-STAGE and FRAMEWORK-ROLLBACK are one required callback pair." - (funcall (etaf-render-port-initial-function - etaf-render-port--selected-port) - buffer input framework-stage framework-rollback)) +FRAMEWORK-STAGE and FRAMEWORK-ROLLBACK are one required callback pair. +OBSERVER, when non-nil, is installed while initial v2 publication remains +provisional so TP and Ebox acceptance reports are preserved." + (if (eq (etaf-render-port-route etaf-render-port--selected-port) 'v1) + (funcall (etaf-render-port-initial-function + etaf-render-port--selected-port) + buffer input framework-stage framework-rollback observer) + (let ((report + (funcall + (etaf-render-port-initial-function etaf-render-port--selected-port) + buffer input framework-stage framework-rollback))) + (when observer + (dolist (provider-report + (ebox-framework-spi-initial-observation-reports report)) + (funcall observer buffer provider-report))) + report))) (defun etaf-render-port-update (buffer input framework-stage framework-rollback) @@ -366,6 +385,14 @@ FRAMEWORK-STAGE and FRAMEWORK-ROLLBACK are one required callback pair." etaf-render-port--selected-port) buffer input framework-stage framework-rollback)) +(defun etaf-render-port-unmount (buffer) + "Release the retained Ebox surface owned by mounted BUFFER." + (ebox-unmount-buffer buffer)) + +(defun etaf-render-port-mounted-p (buffer) + "Return non-nil when BUFFER owns a live retained Ebox surface." + (ebox-surface-buffer-mounted-p buffer)) + (provide 'etaf-render-port) ;;; etaf-render-port.el ends here diff --git a/etaf-runtime.el b/etaf-runtime.el index c12108a..47e91e5 100644 --- a/etaf-runtime.el +++ b/etaf-runtime.el @@ -16,6 +16,7 @@ (require 'etaf-component) (require 'etaf-reactive) (require 'etaf-generation) +(require 'etaf-host) (require 'etaf-render-port) (require 'etaf-renderer) (require 'etaf-context) @@ -282,6 +283,7 @@ the sequential `etaf--pvec-put' contract." instances resource-registry mount-epoch + host-authority next-resource-id next-effect-id next-semantic-id @@ -1023,7 +1025,14 @@ Component owner to absorb them." (defun etaf--runtime-kill-buffer () "Unmount the ETAF Runtime owned by the current buffer before it dies." (when-let* ((runtime (gethash (current-buffer) etaf--runtime-table))) - (etaf-runtime-unmount runtime))) + (condition-case condition + (etaf-runtime-call-operation + runtime 'unmount "buffer kill" + (lambda () (etaf--runtime-unmount-now runtime 'buffer-kill))) + ((error quit) + (etaf--runtime-record-observer-diagnostic + runtime (list :kind 'buffer-kill-retirement + :condition condition)))))) (defun etaf--runtime-enqueue-effect (runtime effect-id) "Append EFFECT-ID once to RUNTIME's stable FIFO work queue." @@ -1233,7 +1242,10 @@ effect-to-source edges. It is intentionally immutable and suitable as an (when-let* ((runtime (gethash (etaf-runtime-route-mount-epoch route) etaf--runtime-route-registry))) - (when (etaf-runtime-mounted-p runtime) + (when (and (etaf-runtime-mounted-p runtime) + (etaf-host-authority-accepts-token-p + (etaf-runtime-host-authority runtime) + (etaf-runtime-route-authority-token route))) (dolist (effect-id (etaf--generation-source-effects (etaf-runtime-current-generation runtime) source)) @@ -1387,8 +1399,13 @@ error or quit." (defun etaf-runtime-for-buffer (buffer-or-name) "Return the live Runtime mounted in BUFFER-OR-NAME, or nil." - (let ((buffer (get-buffer buffer-or-name))) - (and buffer (gethash buffer etaf--runtime-table)))) + (let* ((buffer (get-buffer buffer-or-name)) + (runtime (and buffer (gethash buffer etaf--runtime-table)))) + (and runtime + (etaf-runtime-mounted-p runtime) + (etaf-host-authority-attached-p + (etaf-runtime-host-authority runtime)) + runtime))) (defun etaf-runtime-require-mounted (&optional runtime) "Return mounted RUNTIME or the Runtime in the current buffer. @@ -1399,7 +1416,9 @@ when the requested boundary is no longer mounted." (and (buffer-live-p (current-buffer)) (gethash (current-buffer) etaf--runtime-table))))) (unless (and (etaf-runtime-p runtime) - (etaf-runtime-mounted-p runtime)) + (etaf-runtime-mounted-p runtime) + (etaf-host-authority-attached-p + (etaf-runtime-host-authority runtime))) (signal 'etaf-runtime-error (list "ETAF runtime is not mounted"))) runtime)) @@ -5908,11 +5927,23 @@ RENDERED-IDENTITIES names the Component render participants." (etaf--runtime-participant-publish participant)) (lambda (_report) (etaf--runtime-participant-rollback participant)))) - (ebox-render-to-buffer - (etaf-runtime-buffer runtime) next-root - (when (etaf-runtime-observer runtime) - (list :observer #'etaf--runtime-forward-ebox-report))) - (etaf--runtime-participant-publish participant))) + (let* ((host-authority (etaf-runtime-host-authority runtime)) + (legacy-p + (eq (etaf-render-port-route + (etaf-render-port-selected)) + 'v1))) + (etaf-render-port-initial + (etaf-runtime-buffer runtime) next-root + (lambda (_report) + (etaf--runtime-participant-publish participant) + (etaf-host-authority-stage-attach + host-authority legacy-p)) + (lambda (_report) + (etaf-host-authority-rollback-attach host-authority) + (etaf--runtime-participant-rollback participant)) + (and (etaf-runtime-observer runtime) + #'etaf--runtime-forward-ebox-report)) + (etaf-host-authority-finish-attach host-authority)))) ((error quit) (when semantic-candidate (etaf-semantic-candidate-rollback semantic-candidate) @@ -6007,13 +6038,18 @@ backend anchor proof failed; ordinary root turns keep their artifact reuse." (when old (etaf-runtime-unmount old)) (let* ((scope (etaf-effect-scope :detached t :name buffer)) + (mount-epoch (cl-incf etaf--mount-epoch-counter)) + (host-authority + (etaf-host-authority-create + (list 'etaf-runtime mount-epoch) mount-epoch buffer)) (runtime (etaf--runtime-create :buffer buffer :root-view view :scope scope :instances (make-hash-table :test #'equal) :resource-registry (make-hash-table :test #'equal) - :mount-epoch (cl-incf etaf--mount-epoch-counter) + :mount-epoch mount-epoch + :host-authority host-authority :next-resource-id 0 :next-effect-id 0 :next-semantic-id 1 @@ -6034,12 +6070,15 @@ backend anchor proof failed; ordinary root turns keep their artifact reuse." :behavior-resource-keys (make-hash-table :test #'equal) :observer observer :root-dirty-p t))) + (etaf-host-authority-begin-attach host-authority) (puthash buffer runtime etaf--runtime-table) (with-current-buffer buffer (add-hook 'kill-buffer-hook #'etaf--runtime-kill-buffer nil t)) (let ((route (etaf-runtime-route-create :runtime-id (etaf-runtime-mount-epoch runtime) :mount-epoch (etaf-runtime-mount-epoch runtime) + :authority-token + (etaf-host-authority-token host-authority) :scheduler 'etaf--runtime-route-scheduler))) (setf (etaf-runtime-route-token runtime) route) (puthash (etaf-runtime-mount-epoch runtime) runtime @@ -6062,14 +6101,19 @@ backend anchor proof failed; ordinary root turns keep their artifact reuse." (etaf-events-enable-input buffer)) buffer) ((error quit) - (when (buffer-live-p buffer) - (with-current-buffer buffer - (remove-hook 'kill-buffer-hook - #'etaf--runtime-kill-buffer t))) - (remhash buffer etaf--runtime-table) - (remhash (etaf-runtime-mount-epoch runtime) - etaf--runtime-route-registry) - (etaf-scope-stop scope) + ;; Postaccept lifecycle errors leave an attached Runtime queryable. + ;; Preaccept failures have no Host authority and discard registration. + (unless (etaf-host-authority-attached-p host-authority) + (setf (etaf-runtime-mounted-p runtime) nil) + (etaf-host-authority-rollback-attach host-authority) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (remove-hook 'kill-buffer-hook + #'etaf--runtime-kill-buffer t))) + (remhash buffer etaf--runtime-table) + (remhash (etaf-runtime-mount-epoch runtime) + etaf--runtime-route-registry) + (etaf-scope-stop scope)) (signal (car err) (cdr err)))) buffer))) @@ -6112,41 +6156,64 @@ before the first Ebox publication." #'etaf--runtime-mount-now buffer-or-name view (plist-get options :observer)))) -(defun etaf--runtime-unmount-now (runtime) - "Unmount RUNTIME and dispose its Component scopes now." - (let ((runtime (etaf-runtime-require-mounted runtime))) - (when (buffer-live-p (etaf-runtime-buffer runtime)) - (with-current-buffer (etaf-runtime-buffer runtime) - (remove-hook 'kill-buffer-hook #'etaf--runtime-kill-buffer t))) - (setf (etaf-runtime-mounted-p runtime) nil) - (when (fboundp 'etaf-events-disable-input) - (etaf-events-disable-input (etaf-runtime-buffer runtime))) - (remhash (etaf-runtime-buffer runtime) etaf--runtime-table) - (remhash (etaf-runtime-mount-epoch runtime) etaf--runtime-route-registry) - (maphash - (lambda (source _) - (remhash (etaf-runtime-route-token runtime) - (etaf--source-subscribers source))) - (etaf-runtime-route-sources runtime)) - (clrhash (etaf-runtime-route-sources runtime)) - (let (instances) - (maphash (lambda (_identity instance) (push instance instances)) - (etaf-runtime-instances runtime)) - (dolist (instance (sort instances - (lambda (left right) - (> (length (etaf--component-instance-identity left)) - (length (etaf--component-instance-identity right)))))) - (etaf--runtime-dispose-instance instance t))) - (etaf-scope-stop (etaf-runtime-scope runtime)) - (maphash - (lambda (identity state) - (when-let* ((cleanup (cdr state))) - (etaf--runtime-run-contained-cleanup - runtime 'behavior-unmount identity cleanup))) - (etaf-runtime-behaviors runtime)) - (clrhash (etaf-runtime-instances runtime)) - (clrhash (etaf-runtime-resource-registry runtime)) - runtime)) +(defun etaf--runtime-unmount-now (runtime &optional cause) + "Unmount RUNTIME idempotently and retire its Component scopes. +CAUSE is `buffer-kill' for the contained dead-buffer path, or nil for explicit +unmount. Host authority is invalidated before any unbounded cleanup." + (unless (etaf-runtime-p runtime) + (signal 'wrong-type-argument (list 'etaf-runtime-p runtime))) + (ignore cause) + (if (not (etaf-runtime-mounted-p runtime)) + runtime + (let ((authority (etaf-runtime-host-authority runtime))) + (when (etaf-host-authority-attached-p authority) + (etaf-host-authority-begin-detach authority)) + (unless (eq (etaf-host-authority-state authority) 'terminal) + (etaf-host-authority-invalidate authority)) + (setf (etaf-runtime-mounted-p runtime) nil) + (unwind-protect + (progn + (when (buffer-live-p (etaf-runtime-buffer runtime)) + (with-current-buffer (etaf-runtime-buffer runtime) + (remove-hook 'kill-buffer-hook #'etaf--runtime-kill-buffer t))) + (when (fboundp 'etaf-events-disable-input) + (etaf-events-disable-input (etaf-runtime-buffer runtime))) + (unless (eq cause 'buffer-kill) + (when (etaf-render-port-mounted-p + (etaf-runtime-buffer runtime)) + (etaf-render-port-unmount (etaf-runtime-buffer runtime)))) + (remhash (etaf-runtime-buffer runtime) etaf--runtime-table) + (remhash (etaf-runtime-mount-epoch runtime) + etaf--runtime-route-registry) + (maphash + (lambda (source _) + (remhash (etaf-runtime-route-token runtime) + (etaf--source-subscribers source))) + (etaf-runtime-route-sources runtime)) + (clrhash (etaf-runtime-route-sources runtime)) + (let (instances) + (maphash (lambda (_identity instance) (push instance instances)) + (etaf-runtime-instances runtime)) + (dolist + (instance + (sort instances + (lambda (left right) + (> (length + (etaf--component-instance-identity left)) + (length + (etaf--component-instance-identity right)))))) + (etaf--runtime-dispose-instance instance t))) + (etaf-scope-stop (etaf-runtime-scope runtime)) + (maphash + (lambda (identity state) + (when-let* ((cleanup (cdr state))) + (etaf--runtime-run-contained-cleanup + runtime 'behavior-unmount identity cleanup))) + (etaf-runtime-behaviors runtime)) + (clrhash (etaf-runtime-instances runtime)) + (clrhash (etaf-runtime-resource-registry runtime)) + runtime) + (etaf-host-authority-finish-detach authority))))) ;;;###autoload (defun etaf-runtime-unmount (&optional runtime) diff --git a/etaf.el b/etaf.el index 6202cfb..d34218f 100644 --- a/etaf.el +++ b/etaf.el @@ -36,6 +36,7 @@ (require 'etaf-resource) (require 'etaf-data) (require 'etaf-generation) +(require 'etaf-host) (require 'etaf-render-port) (require 'etaf-renderer) (etaf--prefer-local-files) diff --git a/tests/etaf-host-tests.el b/tests/etaf-host-tests.el new file mode 100644 index 0000000..1a85d1f --- /dev/null +++ b/tests/etaf-host-tests.el @@ -0,0 +1,182 @@ +;;; etaf-host-tests.el --- M3a Host authority gates -*- lexical-binding: t; -*- + +;; SPDX-License-Identifier: GPL-3.0-or-later + +(require 'cl-lib) +(require 'ert) +(require 'etaf) +(require 'tp-transaction) + +(defvar etaf-host-test-unmount-error-p nil) + +(etaf-define-component etaf-host-test-component (&key source fail-unmount) + "Render SOURCE and optionally fail the public unmounted hook." + :setup + (progn + (etaf-on-unmounted + (lambda () + (when (or fail-unmount etaf-host-test-unmount-error-p) + (error "injected Host retirement failure")))) + nil) + :view + (text :ref 'host-value (expr (format "host=%s" (etaf-value source))))) + +(ert-deftest etaf-host-initial-marker-attaches-on-final-accept-only () + "Initial v2 mount uses one marker; ordinary update uses zero markers." + (let ((buffer-name " *etaf-host-marker-test*") + (source (etaf-ref 0)) + lookup-during-stage + (original-stage (symbol-function 'etaf-host-authority-stage-attach))) + (unwind-protect + (progn + (cl-letf (((symbol-function 'etaf-host-authority-stage-attach) + (lambda (authority &optional legacy-p) + (setq lookup-during-stage + (etaf-runtime-for-buffer buffer-name)) + (funcall original-stage authority legacy-p)))) + (etaf-mount + buffer-name + (etaf--view-call 'etaf-host-test-component + (list :source source) nil))) + (should-not lookup-during-stage) + (let* ((runtime (etaf-runtime-for-buffer buffer-name)) + (authority (etaf-runtime-host-authority runtime))) + (should (etaf-host-authority-attached-p authority)) + (should (= (etaf-host-authority-version authority) 1)) + (should (= (tp-committed-success-outcome-marker-count + tp--last-transaction-outcome) + 1)) + (setf (etaf-value source) 1) + (should (= (tp-committed-success-outcome-marker-count + tp--last-transaction-outcome) + 0)))) + (when-let* ((runtime (etaf-runtime-for-buffer buffer-name))) + (etaf-unmount runtime)) + (when-let* ((buffer (get-buffer buffer-name))) + (kill-buffer buffer))))) + +(ert-deftest etaf-host-initial-faults-restore-detached-authority () + "Precommit and final-accept faults restore Host and Ebox initial state." + (dolist (phase '(precommit final-accept)) + (let ((buffer-name + (format " *etaf-host-%s-fault-test*" phase)) + captured-authority + (source (etaf-ref 0)) + (original-create (symbol-function 'etaf-host-authority-create)) + (original-precommit + (symbol-function 'tp--run-transaction-precommit-functions)) + (original-accept (symbol-function 'accept-change-group))) + (unwind-protect + (cl-letf + (((symbol-function 'etaf-host-authority-create) + (lambda (&rest arguments) + (setq captured-authority (apply original-create arguments)))) + ((symbol-function 'tp--run-transaction-precommit-functions) + (if (eq phase 'precommit) + (lambda () + (funcall original-precommit) + (error "injected Host precommit failure")) + original-precommit)) + ((symbol-function 'accept-change-group) + (if (eq phase 'final-accept) + (lambda (_group) + (error "injected Host final-accept failure")) + original-accept))) + (should-error + (etaf-mount + buffer-name + (etaf--view-call 'etaf-host-test-component + (list :source source) nil)) + :type 'error) + (should (etaf-host-authority-p captured-authority)) + (should (eq (etaf-host-authority-state captured-authority) + 'detached)) + (should (zerop + (etaf-host-authority-version captured-authority))) + (should-not (etaf-runtime-for-buffer buffer-name)) + (should-not + (ebox-surface-buffer-mounted-p (get-buffer buffer-name)))) + (when-let* ((runtime (etaf-runtime-for-buffer buffer-name))) + (etaf-unmount runtime)) + (when-let* ((buffer (get-buffer buffer-name))) + (kill-buffer buffer)))))) + +(ert-deftest etaf-host-unmount-invalidates-before-component-cleanup () + "Explicit unmount invalidates Host token before any Component hook runs." + (let ((buffer-name " *etaf-host-unmount-boundary-test*") + (source (etaf-ref 0)) + checked) + (unwind-protect + (progn + (etaf-mount + buffer-name + (etaf--view-call 'etaf-host-test-component + (list :source source) nil)) + (let* ((runtime (etaf-runtime-for-buffer buffer-name)) + (authority (etaf-runtime-host-authority runtime)) + (original + (symbol-function 'etaf--runtime-dispose-instance))) + (cl-letf (((symbol-function 'etaf--runtime-dispose-instance) + (lambda (&rest arguments) + (should-not (etaf-host-authority-token authority)) + (should (eq (etaf-host-authority-state authority) + 'detached-retiring)) + (setq checked t) + (apply original arguments)))) + (etaf-unmount runtime)) + (should checked) + (should (eq (etaf-host-authority-state authority) 'terminal)) + (should-not (etaf-runtime-for-buffer buffer-name)) + (should (eq (etaf--runtime-unmount-now runtime) runtime)) + (should-error (etaf-unmount runtime) :type 'etaf-runtime-error))) + (when-let* ((buffer (get-buffer buffer-name))) + (kill-buffer buffer))))) + +(ert-deftest etaf-host-kill-contains-user-cleanup-failure () + "Buffer kill never rethrows user cleanup after Host authority invalidation." + (let ((buffer-name " *etaf-host-kill-contained-test*") + (source (etaf-ref 0)) + runtime authority) + (setq etaf-host-test-unmount-error-p nil) + (unwind-protect + (progn + (etaf-mount + buffer-name + (etaf--view-call 'etaf-host-test-component + (list :source source :fail-unmount t) nil)) + (setq runtime (etaf-runtime-for-buffer buffer-name) + authority (etaf-runtime-host-authority runtime)) + (kill-buffer (get-buffer buffer-name)) + (should (eq (etaf-host-authority-state authority) 'terminal)) + (should-not (etaf-runtime-mounted-p runtime)) + (should-not (gethash (etaf-runtime-mount-epoch runtime) + etaf--runtime-route-registry))) + (when-let* ((buffer (get-buffer buffer-name))) + (kill-buffer buffer))))) + +(ert-deftest etaf-host-detach-makes-route-token-stale () + "A detached Host route cannot schedule later source changes." + (let ((buffer-name " *etaf-host-stale-route-test*") + (source (etaf-ref 0)) + runtime route) + (unwind-protect + (progn + (etaf-mount + buffer-name + (etaf--view-call 'etaf-host-test-component + (list :source source) nil)) + (setq runtime (etaf-runtime-for-buffer buffer-name) + route (etaf-runtime-route-token runtime)) + (etaf-unmount runtime) + (should-not + (etaf-host-authority-accepts-token-p + (etaf-runtime-host-authority runtime) + (etaf-runtime-route-authority-token route))) + (setf (etaf-value source) 1) + (should-not (etaf-runtime-pending-p runtime))) + (when-let* ((buffer (get-buffer buffer-name))) + (kill-buffer buffer))))) + +(provide 'etaf-host-tests) + +;;; etaf-host-tests.el ends here diff --git a/tests/fixtures/etaf-m0a-condition-consumers.sexp b/tests/fixtures/etaf-m0a-condition-consumers.sexp index 3d1eda5..0510762 100644 --- a/tests/fixtures/etaf-m0a-condition-consumers.sexp +++ b/tests/fixtures/etaf-m0a-condition-consumers.sexp @@ -15,6 +15,7 @@ (:file "etaf-resource.el" :form condition-case :conditions (error) :owner etaf-resource :policy generic-containment) (:file "etaf-resource.el" :form condition-case :conditions (error) :owner etaf-resource :policy generic-containment) (:file "etaf-runtime.el" :form condition-case :conditions (error) :owner etaf-runtime :policy generic-containment) + (:file "etaf-runtime.el" :form condition-case :conditions (error quit) :owner etaf-runtime :policy generic-containment) (:file "etaf-runtime.el" :form condition-case :conditions (error) :owner etaf-runtime :policy generic-containment) (:file "etaf-runtime.el" :form condition-case :conditions (quit) :owner etaf-runtime :policy generic-containment) (:file "etaf-runtime.el" :form condition-case :conditions (error quit) :owner etaf-runtime :policy generic-containment)