feat: make Host attach and detach authoritative
This commit is contained in:
parent
86dd00cf6d
commit
96df9e2858
4
Makefile
4
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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
178
etaf-host.el
Normal file
178
etaf-host.el
Normal 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
|
||||
@ -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.")
|
||||
|
||||
@ -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
|
||||
|
||||
175
etaf-runtime.el
175
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)
|
||||
|
||||
1
etaf.el
1
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)
|
||||
|
||||
182
tests/etaf-host-tests.el
Normal file
182
tests/etaf-host-tests.el
Normal 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
|
||||
@ -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)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user