feat: make Host attach and detach authoritative

This commit is contained in:
Kinneyzhang 2026-09-01 01:07:39 +08:00
parent 86dd00cf6d
commit 96df9e2858
10 changed files with 538 additions and 67 deletions

View File

@ -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

View File

@ -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

View File

@ -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 pathstep

178
etaf-host.el Normal file
View File

@ -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

View File

@ -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.")

View File

@ -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

View File

@ -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)

View File

@ -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)

182
tests/etaf-host-tests.el Normal file
View File

@ -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

View File

@ -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)