chore: freeze verified etaf baseline before C1b
This commit is contained in:
Kinneyzhang
parent
b82f09aa79
commit
01b1deb178
2
Makefile
2
Makefile
@ -2,7 +2,7 @@ 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-scheduler.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-retirement.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 scripts/benchmark-scheduler-context.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/etaf-host-tests.el tests/etaf-retirement-tests.el tests/etaf-scheduler-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 tests/etaf-retirement-tests.el tests/etaf-scheduler-tests.el tests/etaf-g1-cross-layer-tests.el
|
||||
|
||||
.PHONY: test compile load checkdoc docs-check scheduler-benchmark check clean
|
||||
|
||||
|
||||
@ -114,6 +114,14 @@ There is no separate `etaf-data` install: Data is a core ETAF capability. There
|
||||
|
||||
ECSS 0.1.0 and TP 1.0.1 are independent packages and may be installed in either order. Install both before Ebox 2.0.1, then install ETAF 0.1.1. ETAF declares TP directly because Host final-accept authority uses the TP transaction contract; rendering still consumes only the Ebox 2.0 public contract.
|
||||
|
||||
ETAF selects the Ebox framework SPI v2 port by default. For an immediate
|
||||
process-wide rollback to the complete legacy render/Host port, set
|
||||
`etaf-render-port-selection-policy` to `v1` before loading ETAF. The selection
|
||||
is immutable for that Emacs process; restart Emacs to change it. This rollback
|
||||
does not create a second generation owner: semantic CAS, projected compatibility
|
||||
stores, retirement, and scheduler authority stay unified, preserving the same
|
||||
generation, token, and store-version outcomes on both render ports.
|
||||
|
||||
During development, load the sibling Ebox checkout before ETAF:
|
||||
|
||||
```elisp
|
||||
|
||||
@ -108,6 +108,13 @@ operation 的 flat 阶段。`etaf-performance-records` 返回 operation/stage
|
||||
|
||||
ECSS 0.1.0 与 TP 1.0.1 是互相独立的包，安装顺序任意；两者都安装后再安装 Ebox 2.0.1，最后安装 ETAF 0.1.1。ETAF 会直接声明 TP 依赖，因为 Host final-accept authority 使用 TP transaction contract；渲染仍只使用 Ebox 2.0 的公共契约。
|
||||
|
||||
ETAF 默认选择 Ebox framework SPI v2 port。若要立即按进程完整回退旧
|
||||
render/Host port，必须在加载 ETAF 前把
|
||||
`etaf-render-port-selection-policy` 设为 `v1`。该选择在当前 Emacs 进程中不可
|
||||
变；切换时需要重启 Emacs。这个回退不会创建第二个 generation owner：semantic
|
||||
CAS、单向投影的兼容 stores、retirement 和 scheduler authority 仍保持统一，因此
|
||||
两个 render port 的 generation、token 与 store-version outcome 完全一致。
|
||||
|
||||
开发时先把同级 Ebox 检出目录加入 `load-path`：
|
||||
|
||||
```elisp
|
||||
|
||||
@ -458,6 +458,15 @@ back into it. The migration-only `legacy`, `project`, and `shadow` routes prove
|
||||
projection equivalence and rollback safety without introducing a second
|
||||
committed truth.
|
||||
|
||||
At process bootstrap, `etaf-render-port-selection-policy` selects exactly one
|
||||
immutable Ebox port. Its default `v2` value uses the compatible framework SPI;
|
||||
`v1`, when set before ETAF is loaded, bypasses provider probing and selects the
|
||||
complete legacy render/Host port. The rollback changes only that inter-package
|
||||
publication route. Generation/store CAS, compatibility projection, retirement,
|
||||
and scheduler authority remain single-owner so the old and new render ports
|
||||
produce identical generation, token, and store-version outcomes. A mounted or
|
||||
in-flight Runtime is never switched between ports.
|
||||
|
||||
Each semantic candidate captures the expected generation, semantic token, and
|
||||
instance/resource/artifact/route store versions. The render path stages one CAS
|
||||
inside the Ebox framework callback and restores it through the same inverse
|
||||
|
||||
@ -447,6 +447,13 @@ generation；Runtime 中同名 hash table 只是由 generation 单向重建的
|
||||
`legacy`/`project`/`shadow` 路由只用于证明投影等价与安全回退，不增加第二份
|
||||
committed truth。
|
||||
|
||||
进程 bootstrap 时，`etaf-render-port-selection-policy` 只选择一个不可变的 Ebox
|
||||
port。默认值 `v2` 使用兼容的 framework SPI；若在 ETAF 加载前设为 `v1`，则跳过
|
||||
provider 探测并选择完整的旧 render/Host port。这个回退只改变跨包 publication
|
||||
route；generation/store CAS、兼容投影、retirement 与 scheduler authority 始终只有
|
||||
一个 owner，因此新旧 render port 会产生完全一致的 generation、token 与
|
||||
store-version outcome。mounted 或 in-flight Runtime 绝不会在两个 port 之间切换。
|
||||
|
||||
每个 semantic candidate 同时捕获 expected generation、semantic token，以及
|
||||
instance/resource/artifact/route store versions。render 路径在 Ebox framework
|
||||
stage 中暂存一次 CAS，失败时由同一个 inverse journal 恢复；没有可见 Ebox
|
||||
|
||||
1345
etaf-data.el
1345
etaf-data.el
File diff suppressed because it is too large
Load Diff
@ -284,15 +284,23 @@ of the run."
|
||||
(puthash effect t (etaf--source-subscribers source)))
|
||||
(setf (etaf-effect-deps effect) old-deps)))))))))
|
||||
|
||||
(defun etaf--dispatch-source (source)
|
||||
"Notify every current subscriber of SOURCE once."
|
||||
(defun etaf--dispatch-source (source &optional context-filter)
|
||||
"Notify current subscribers of SOURCE once.
|
||||
|
||||
When CONTEXT-FILTER is non-nil, it is called with each subscriber's scheduler
|
||||
context and only subscribers for which it returns non-nil are included. The
|
||||
filter is an internal reconciliation hook: the ordinary source publication
|
||||
path leaves it nil, while a retry can target only contexts that did not finish
|
||||
an earlier projection epoch."
|
||||
(etaf-scheduler-call-with-projection
|
||||
(lambda ()
|
||||
(let ((groups (make-hash-table :test #'eq)))
|
||||
(maphash
|
||||
(lambda (subscriber _)
|
||||
(let ((context (etaf--subscriber-scheduler-context subscriber)))
|
||||
(cond
|
||||
(when (or (null context-filter)
|
||||
(funcall context-filter context))
|
||||
(cond
|
||||
((etaf-runtime-route-p subscriber)
|
||||
(if (etaf-runtime-route-live-p subscriber)
|
||||
(puthash context
|
||||
@ -300,8 +308,9 @@ of the run."
|
||||
(etaf-scheduler-record-stale-route-drop context)))
|
||||
((and (etaf-effect-p subscriber)
|
||||
(etaf-effect-active-p subscriber))
|
||||
(puthash context
|
||||
(puthash context
|
||||
(cons subscriber (gethash context groups)) groups)))))
|
||||
)
|
||||
(etaf--source-subscribers source))
|
||||
(let (contexts)
|
||||
(maphash (lambda (context _) (push context contexts)) groups)
|
||||
|
||||
@ -5,7 +5,7 @@
|
||||
;;; Commentary:
|
||||
|
||||
;; This file is ETAF's only Ebox framework-SPI bootstrap owner. It probes the
|
||||
;; additive Ebox v2 provider once, selects one immutable port, and exposes that
|
||||
;; Ebox v2 provider once, selects one immutable port, and exposes that
|
||||
;; selection to downstream ETAF code without repeated `featurep' or `fboundp'
|
||||
;; protocol guesses. A completely absent v2 provider receives a complete v1
|
||||
;; fallback; a present but broken or incompatible provider fails closed.
|
||||
@ -22,6 +22,17 @@
|
||||
"Incompatible Ebox framework SPI provider"
|
||||
'etaf-spi-bootstrap-error)
|
||||
|
||||
(defcustom etaf-render-port-selection-policy 'v2
|
||||
"ETAF render authority selected during process bootstrap.
|
||||
`v2' selects the compatible Ebox SPI v2 port. `v1' is the complete legacy
|
||||
render/Host rollback switch and bypasses provider probing. Generation stores,
|
||||
retirement, and scheduler keep their unified authority so v1 and v2 preserve
|
||||
the same generation/token/store-version outcomes. Set this before loading
|
||||
ETAF; the selected port is process-wide and immutable."
|
||||
:type '(choice (const :tag "ETAF v2 authorities" v2)
|
||||
(const :tag "Complete ETAF v1 route" v1))
|
||||
:group 'etaf)
|
||||
|
||||
(defconst etaf-render-port--required-spi-version 2
|
||||
"Ebox framework SPI version consumed by this ETAF build.")
|
||||
|
||||
@ -526,8 +537,8 @@ FRAMEWORK-STAGE and FRAMEWORK-ROLLBACK retain their existing Ebox meanings."
|
||||
(get-buffer buffer) (plist-get report :surface-revision))
|
||||
report))
|
||||
|
||||
(defun etaf-render-port--v1-fallback ()
|
||||
"Return the complete immutable fallback port for an absent Ebox v2 SPI."
|
||||
(defun etaf-render-port--v1-fallback (&optional bootstrap-outcome)
|
||||
"Return the complete immutable v1 port tagged with BOOTSTRAP-OUTCOME."
|
||||
(etaf-render-port--create
|
||||
:route 'v1
|
||||
:spi-version 1
|
||||
@ -539,7 +550,7 @@ FRAMEWORK-STAGE and FRAMEWORK-ROLLBACK retain their existing Ebox meanings."
|
||||
:initial-function 'etaf-render-port--v1-initial
|
||||
:update-function 'etaf-render-port--v1-update
|
||||
:revision-function 'etaf-render-port--v1-revision
|
||||
:bootstrap-outcome 'v2-absent-v1-selected))
|
||||
:bootstrap-outcome (or bootstrap-outcome 'v2-absent-v1-selected)))
|
||||
|
||||
(defun etaf-render-port--v2-port (snapshot)
|
||||
"Return an immutable selected v2 port from compatible SNAPSHOT."
|
||||
@ -563,25 +574,32 @@ FRAMEWORK-STAGE and FRAMEWORK-ROLLBACK retain their existing Ebox meanings."
|
||||
|
||||
(defun etaf-render-port--bootstrap ()
|
||||
"Probe Ebox exactly once and return one immutable selected render port."
|
||||
(let ((feature-present-p (featurep 'ebox-framework-spi-v2))
|
||||
(predicate-present-p (fboundp 'ebox-framework-spi-capabilities)))
|
||||
(cond
|
||||
((and (not feature-present-p) (not predicate-present-p))
|
||||
(etaf-render-port--v1-fallback))
|
||||
((not feature-present-p)
|
||||
(etaf-render-port--bootstrap-error 'predicate-without-v2-feature))
|
||||
((not predicate-present-p)
|
||||
(etaf-render-port--bootstrap-error 'v2-feature-without-predicate))
|
||||
(t
|
||||
(condition-case condition
|
||||
(etaf-render-port--v2-port
|
||||
(etaf-render-port--provider-snapshot
|
||||
(ebox-framework-spi-capabilities)))
|
||||
((etaf-spi-incompatible-error etaf-spi-bootstrap-error)
|
||||
(signal (car condition) (cdr condition)))
|
||||
((error quit)
|
||||
(etaf-render-port--bootstrap-error
|
||||
'provider-predicate-failure condition)))))))
|
||||
(pcase etaf-render-port-selection-policy
|
||||
('v1
|
||||
(etaf-render-port--v1-fallback 'v1-kill-switch-selected))
|
||||
('v2
|
||||
(let ((feature-present-p (featurep 'ebox-framework-spi-v2))
|
||||
(predicate-present-p (fboundp 'ebox-framework-spi-capabilities)))
|
||||
(cond
|
||||
((and (not feature-present-p) (not predicate-present-p))
|
||||
(etaf-render-port--v1-fallback))
|
||||
((not feature-present-p)
|
||||
(etaf-render-port--bootstrap-error 'predicate-without-v2-feature))
|
||||
((not predicate-present-p)
|
||||
(etaf-render-port--bootstrap-error 'v2-feature-without-predicate))
|
||||
(t
|
||||
(condition-case condition
|
||||
(etaf-render-port--v2-port
|
||||
(etaf-render-port--provider-snapshot
|
||||
(ebox-framework-spi-capabilities)))
|
||||
((etaf-spi-incompatible-error etaf-spi-bootstrap-error)
|
||||
(signal (car condition) (cdr condition)))
|
||||
((error quit)
|
||||
(etaf-render-port--bootstrap-error
|
||||
'provider-predicate-failure condition)))))))
|
||||
(_
|
||||
(etaf-render-port--bootstrap-error
|
||||
'invalid-render-port-selection etaf-render-port-selection-policy))))
|
||||
|
||||
(defconst etaf-render-port--selected-port
|
||||
(etaf-render-port--bootstrap)
|
||||
|
||||
@ -24,6 +24,12 @@
|
||||
:diagnostic-journal-id)
|
||||
"Canonical ordered keys in a v1 postcommit condition payload.")
|
||||
|
||||
(defconst etaf-retirement--projection-payload-keys
|
||||
'(:kind :committed-p :external-commit-certainty :reconciliation-token
|
||||
:projection-token :result :operation-id :outcome-id :generation-id
|
||||
:revision :diagnostic-journal-id)
|
||||
"Canonical ordered keys in a v1 data projection condition payload.")
|
||||
|
||||
(cl-defstruct
|
||||
(etaf-retirement-entry
|
||||
(:constructor etaf-retirement-entry--create))
|
||||
@ -237,47 +243,95 @@ without rerunning the failed operation or changing committed authority."
|
||||
(etaf-retirement-journal-diagnostics journal))
|
||||
condition)
|
||||
|
||||
(defun etaf-retirement-condition-trailer (journal &optional kind)
|
||||
"Return the canonical committed trailer for JOURNAL and optional KIND."
|
||||
(list
|
||||
:etaf-condition-trailer/v1
|
||||
(list :kind (or kind 'postcommit)
|
||||
:committed-p t
|
||||
:operation-id (etaf-retirement-journal-operation-id journal)
|
||||
:outcome-id (etaf-retirement-journal-outcome-id journal)
|
||||
:generation-id (etaf-retirement-journal-generation-id journal)
|
||||
:revision (etaf-retirement-journal-revision journal)
|
||||
:diagnostic-journal-id (etaf-retirement-journal-id journal))))
|
||||
(cl-defun etaf-retirement-condition-trailer
|
||||
(journal &optional kind &rest options)
|
||||
"Return the canonical v1 trailer for JOURNAL and KIND.
|
||||
|
||||
The legacy POSTCOMMIT form is unchanged. KIND `projection' additionally
|
||||
requires the certainty and both reconciliation/projection tokens, which are
|
||||
encoded in the same versioned sentinel wire format."
|
||||
;; Accept both the historical positional KIND and a keyword-style KIND.
|
||||
(when (keywordp kind)
|
||||
(setq options (cons kind options)
|
||||
kind (plist-get options :kind)))
|
||||
(let ((external-commit-certainty
|
||||
(plist-get options :external-commit-certainty))
|
||||
(reconciliation-token (plist-get options :reconciliation-token))
|
||||
(projection-token (plist-get options :projection-token))
|
||||
(result (plist-get options :result)))
|
||||
(if (eq (or kind 'postcommit) 'projection)
|
||||
(list :etaf-condition-trailer/v1
|
||||
(list :kind 'projection
|
||||
:committed-p t
|
||||
:external-commit-certainty external-commit-certainty
|
||||
:reconciliation-token reconciliation-token
|
||||
:projection-token projection-token
|
||||
:result result
|
||||
:operation-id (etaf-retirement-journal-operation-id journal)
|
||||
:outcome-id (etaf-retirement-journal-outcome-id journal)
|
||||
:generation-id (etaf-retirement-journal-generation-id journal)
|
||||
:revision (etaf-retirement-journal-revision journal)
|
||||
:diagnostic-journal-id (etaf-retirement-journal-id journal)))
|
||||
(list :etaf-condition-trailer/v1
|
||||
(list :kind (or kind 'postcommit)
|
||||
:committed-p t
|
||||
:operation-id (etaf-retirement-journal-operation-id journal)
|
||||
:outcome-id (etaf-retirement-journal-outcome-id journal)
|
||||
:generation-id (etaf-retirement-journal-generation-id journal)
|
||||
:revision (etaf-retirement-journal-revision journal)
|
||||
:diagnostic-journal-id (etaf-retirement-journal-id journal))))))
|
||||
|
||||
(defun etaf-retirement--condition-trailer-payload (condition)
|
||||
"Return the final validated-looking trailer payload in CONDITION, or nil.
|
||||
Validation of kind-specific fields is performed by the public readers."
|
||||
(when (and (consp condition) (symbolp (car condition))
|
||||
(proper-list-p (cdr condition)) (cdr condition))
|
||||
(let ((trailer (car (last (cdr condition)))))
|
||||
(when (and (proper-list-p trailer)
|
||||
(= (length trailer) 2)
|
||||
(eq (car trailer) :etaf-condition-trailer/v1)
|
||||
(proper-list-p (cadr trailer)))
|
||||
(cadr trailer)))))
|
||||
|
||||
(defun etaf-retirement--valid-payload-p (payload keys kind)
|
||||
"Return non-nil when PAYLOAD exactly matches KEYS and has KIND metadata."
|
||||
(and (= (length payload) (* 2 (length keys)))
|
||||
(equal (cl-loop for (key _value) on payload by #'cddr collect key)
|
||||
keys)
|
||||
(eq (plist-get payload :kind) kind)
|
||||
(eq (plist-get payload :committed-p) t)
|
||||
(integerp (plist-get payload :operation-id))
|
||||
(>= (plist-get payload :operation-id) 0)
|
||||
(plist-get payload :outcome-id)
|
||||
(integerp (plist-get payload :generation-id))
|
||||
(>= (plist-get payload :generation-id) 0)
|
||||
(integerp (plist-get payload :revision))
|
||||
(>= (plist-get payload :revision) 0)
|
||||
(integerp (plist-get payload :diagnostic-journal-id))
|
||||
(> (plist-get payload :diagnostic-journal-id) 0)))
|
||||
|
||||
(defun etaf-condition-postcommit-info (condition)
|
||||
"Return validated postcommit payload from CONDITION, or nil."
|
||||
(when (and (consp condition) (symbolp (car condition))
|
||||
(proper-list-p (cdr condition)) (cdr condition))
|
||||
(let* ((trailer (car (last (cdr condition))))
|
||||
(payload
|
||||
(and (proper-list-p trailer)
|
||||
(= (length trailer) 2)
|
||||
(eq (car trailer) :etaf-condition-trailer/v1)
|
||||
(cadr trailer))))
|
||||
(when (and (proper-list-p payload)
|
||||
(= (length payload)
|
||||
(* 2 (length etaf-retirement--condition-payload-keys)))
|
||||
(equal
|
||||
(cl-loop for (key _value) on payload by #'cddr
|
||||
collect key)
|
||||
etaf-retirement--condition-payload-keys)
|
||||
(eq (plist-get payload :committed-p) t)
|
||||
(eq (plist-get payload :kind) 'postcommit)
|
||||
(integerp (plist-get payload :operation-id))
|
||||
(>= (plist-get payload :operation-id) 0)
|
||||
(plist-get payload :outcome-id)
|
||||
(integerp (plist-get payload :generation-id))
|
||||
(>= (plist-get payload :generation-id) 0)
|
||||
(integerp (plist-get payload :revision))
|
||||
(>= (plist-get payload :revision) 0)
|
||||
(integerp (plist-get payload :diagnostic-journal-id))
|
||||
(> (plist-get payload :diagnostic-journal-id) 0))
|
||||
(copy-tree payload)))))
|
||||
(let ((payload (etaf-retirement--condition-trailer-payload condition)))
|
||||
(when (and payload
|
||||
(etaf-retirement--valid-payload-p
|
||||
payload etaf-retirement--condition-payload-keys 'postcommit))
|
||||
(copy-tree payload))))
|
||||
|
||||
(defun etaf-data-condition-projection-info (condition)
|
||||
"Return validated v1 Data projection payload from CONDITION, or nil.
|
||||
|
||||
The reader only recognizes the final datum, preserving arbitrary business
|
||||
data and earlier lookalike sentinels."
|
||||
(let ((payload (etaf-retirement--condition-trailer-payload condition)))
|
||||
(when (and payload
|
||||
(etaf-retirement--valid-payload-p
|
||||
payload etaf-retirement--projection-payload-keys 'projection)
|
||||
(memq (plist-get payload :external-commit-certainty)
|
||||
'(committed external-unknown rolled-back))
|
||||
(plist-get payload :reconciliation-token)
|
||||
(plist-get payload :projection-token))
|
||||
(copy-tree payload))))
|
||||
|
||||
(defun etaf-retirement-resignal (condition journal)
|
||||
"Re-signal original CONDITION with JOURNAL's committed trailer appended."
|
||||
|
||||
@ -6475,7 +6475,12 @@ unmount. Host authority is invalidated before any unbounded cleanup."
|
||||
(etaf-host-authority-invalidate authority))
|
||||
(when-let* ((route (etaf-runtime-route-token runtime)))
|
||||
(setf (etaf-runtime-route-active-p route) nil))
|
||||
(setf (etaf-runtime-mounted-p runtime) nil)
|
||||
;; Invalidation is the one-way boundary for every queued/in-flight
|
||||
;; delivery. Clear pending work at that same boundary so a Runtime
|
||||
;; retained by a buffer-kill hook cannot advertise an impossible tail
|
||||
;; after its route and buffer are dead.
|
||||
(setf (etaf-runtime-mounted-p runtime) nil
|
||||
(etaf-runtime-pending-p runtime) nil)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(when (buffer-live-p (etaf-runtime-buffer runtime))
|
||||
|
||||
@ -63,17 +63,22 @@
|
||||
|
||||
(ert-deftest etaf-data-loading-state-is-visible-to-source-boundary ()
|
||||
"Publish loading before invoking the source load capability."
|
||||
(let (controller seen)
|
||||
(let (controller seen candidate-kinds)
|
||||
(let ((source (etaf-data-source
|
||||
:load (lambda (_query _page _page-size)
|
||||
(push (etaf-value (etaf-data-status controller))
|
||||
seen)
|
||||
(push (etaf-data--projection-candidate-kind
|
||||
(etaf-data--controller-projection-candidate
|
||||
controller))
|
||||
candidate-kinds)
|
||||
(list :items '(a b) :total 2)))))
|
||||
(setq controller (etaf-data-controller source))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-data-load controller)
|
||||
(should (equal '(loading) seen))
|
||||
(should (equal '(loading) candidate-kinds))
|
||||
(should (eq 'success (etaf-value
|
||||
(etaf-data-status controller)))))
|
||||
(etaf-data-stop controller)))))
|
||||
@ -185,6 +190,444 @@
|
||||
(car (etaf-value (etaf-data-error controller))))))
|
||||
(etaf-data-stop controller))))
|
||||
|
||||
(ert-deftest etaf-data-m4a-malformed-load-publishes-atomic-error ()
|
||||
"A malformed source result leaves old data intact and exits loading."
|
||||
(let* ((source (etaf-data-source
|
||||
:load (lambda (&rest _args) '(:total 99))))
|
||||
(controller
|
||||
(etaf-data-controller
|
||||
source
|
||||
:initial-result '(:items (old) :total 1 :page 2 :page-size 7)))
|
||||
captured)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(condition-case condition
|
||||
(etaf-data-load controller)
|
||||
(error (setq captured condition)))
|
||||
(should captured)
|
||||
(should (eq 'error (car captured)))
|
||||
(should (eq 'error (etaf-value (etaf-data-status controller))))
|
||||
(should (equal captured
|
||||
(etaf-value (etaf-data-error controller))))
|
||||
(should (equal '(old) (etaf-value (etaf-data-items controller))))
|
||||
(should (= 1 (etaf-value (etaf-data-total controller))))
|
||||
(should (= 2 (etaf-value (etaf-data-page controller))))
|
||||
(should (= 7 (etaf-value (etaf-data-page-size controller)))))
|
||||
(etaf-data-stop controller))))
|
||||
|
||||
(ert-deftest etaf-data-m4a-committed-load-error-has-read-only-retry ()
|
||||
"A committed mutation reports a trailer and retry never mutates twice."
|
||||
(let* ((load-count 0)
|
||||
(mutate-count 0)
|
||||
(source
|
||||
(etaf-data-source
|
||||
:load (lambda (&rest _args)
|
||||
(cl-incf load-count)
|
||||
(if (= load-count 1)
|
||||
(error "reconciliation read failed")
|
||||
'(:items (new) :total 1)))
|
||||
:mutate-v2 (lambda (&rest _args)
|
||||
(cl-incf mutate-count)
|
||||
'(:certainty committed :result committed-result))))
|
||||
(controller
|
||||
(etaf-data-controller
|
||||
source :initial-result '(:items (old) :total 1)))
|
||||
captured)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(condition-case condition
|
||||
(etaf-data-mutate controller 'update 'payload)
|
||||
(error (setq captured condition)))
|
||||
(should captured)
|
||||
(should (eq 'error (car captured)))
|
||||
(should (equal '(error "reconciliation read failed")
|
||||
(butlast captured)))
|
||||
(should (equal 'committed-result
|
||||
(plist-get (etaf-data-condition-projection-info
|
||||
captured)
|
||||
:result)))
|
||||
(should (= 1 mutate-count))
|
||||
(should (= 1 load-count))
|
||||
(should (eq 'committed
|
||||
(plist-get (etaf-data-mutation-outcome controller)
|
||||
:certainty)))
|
||||
(should (eq 'projection-pending
|
||||
(etaf-data-reconciliation-state controller)))
|
||||
(should (eq 'error (etaf-value (etaf-data-status controller))))
|
||||
(should (equal '(old) (etaf-value (etaf-data-items controller))))
|
||||
(should (equal '(:items (new) :total 1)
|
||||
(etaf-data-retry-reconciliation controller)))
|
||||
(should (= 1 mutate-count))
|
||||
(should (= 2 load-count))
|
||||
(should (eq 'success (etaf-value (etaf-data-status controller))))
|
||||
(should (equal '(new) (etaf-value (etaf-data-items controller))))
|
||||
(should (eq 'projected
|
||||
(etaf-data-reconciliation-state controller))))
|
||||
(etaf-data-stop controller))))
|
||||
|
||||
(ert-deftest etaf-data-m4a-external-unknown-is-not-replayed ()
|
||||
"A v1 mutation signal is conservatively unknown and never auto-retried."
|
||||
(let* ((mutate-count 0)
|
||||
(load-count 0)
|
||||
(source
|
||||
(etaf-data-source
|
||||
:load (lambda (&rest _args)
|
||||
(cl-incf load-count)
|
||||
'(:items (old) :total 1))
|
||||
:mutate (lambda (&rest _args)
|
||||
(cl-incf mutate-count)
|
||||
(error "write uncertainty"))))
|
||||
(controller
|
||||
(etaf-data-controller source :initial-result '(:items (old) :total 1)))
|
||||
captured)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(condition-case condition
|
||||
(etaf-data-mutate controller 'update 'payload)
|
||||
(error (setq captured condition)))
|
||||
(should captured)
|
||||
(should (equal '(error "write uncertainty") captured))
|
||||
(should (= 1 mutate-count))
|
||||
(should (= 0 load-count))
|
||||
(should (eq 'external-unknown
|
||||
(plist-get (etaf-data-mutation-outcome controller)
|
||||
:certainty)))
|
||||
(should (eq 'external-unknown
|
||||
(etaf-data-reconciliation-state controller)))
|
||||
(should-not (etaf-data-retry-reconciliation controller))
|
||||
(should-not (etaf-data-retry-render controller)))
|
||||
(etaf-data-stop controller))))
|
||||
|
||||
(ert-deftest etaf-data-m4a-uncertain-mutation-projection-fault-keeps-cause ()
|
||||
"A mutation projection fault preserves the primary cause and adds a trailer."
|
||||
(let* ((source
|
||||
(etaf-data-source
|
||||
:load (lambda (&rest _args) '(:items (old) :total 1))
|
||||
:mutate (lambda (&rest _args) (error "write uncertainty"))))
|
||||
(controller
|
||||
(etaf-data-controller source :initial-result '(:items (old) :total 1)))
|
||||
(stop-status-watch
|
||||
(etaf-watch
|
||||
(etaf-data-status controller)
|
||||
(lambda (new _old)
|
||||
(when (eq new 'error)
|
||||
(error "status projection failed")))))
|
||||
captured)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(condition-case condition
|
||||
(etaf-data-mutate controller 'update 'payload)
|
||||
(error (setq captured condition)))
|
||||
(should (equal '(error "write uncertainty") (butlast captured)))
|
||||
(let ((projection-info (etaf-data-condition-projection-info captured))
|
||||
(token (etaf-data-reconciliation-token controller)))
|
||||
(should projection-info)
|
||||
(should (eq 'external-unknown
|
||||
(plist-get projection-info
|
||||
:external-commit-certainty)))
|
||||
(should (equal token (plist-get projection-info
|
||||
:reconciliation-token)))
|
||||
(should (equal '(error "status projection failed")
|
||||
(plist-get token :projection-condition)))))
|
||||
(funcall stop-status-watch)
|
||||
(etaf-data-stop controller))))
|
||||
|
||||
(ert-deftest etaf-data-m4a-mutation-loading-is-a-candidate ()
|
||||
"The mutation boundary exposes loading through the shared candidate path."
|
||||
(let (controller seen kinds)
|
||||
(let ((source
|
||||
(etaf-data-source
|
||||
:load (lambda (&rest _args) '(:items (old) :total 1))
|
||||
:mutate (lambda (&rest _args)
|
||||
(push (etaf-value (etaf-data-status controller)) seen)
|
||||
(push (etaf-data--projection-candidate-kind
|
||||
(etaf-data--controller-projection-candidate
|
||||
controller))
|
||||
kinds)
|
||||
'mutation-result))))
|
||||
(setq controller
|
||||
(etaf-data-controller source
|
||||
:initial-result '(:items (old) :total 1))))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(should (equal 'mutation-result
|
||||
(etaf-data-mutate controller 'update 'payload)))
|
||||
(should (equal '(loading) seen))
|
||||
(should (equal '(loading) kinds)))
|
||||
(etaf-data-stop controller))))
|
||||
|
||||
(ert-deftest etaf-data-m4a-loading-projection-fault-exits-terminally ()
|
||||
"A loading dispatch fault publishes error and prevents the mutation call."
|
||||
(let* ((mutate-count 0)
|
||||
(source
|
||||
(etaf-data-source
|
||||
:load (lambda (&rest _args) '(:items (old) :total 1))
|
||||
:mutate (lambda (&rest _args)
|
||||
(cl-incf mutate-count)
|
||||
'mutation-result)))
|
||||
(controller
|
||||
(etaf-data-controller source :initial-result '(:items (old) :total 1)))
|
||||
(stop-status-watch
|
||||
(etaf-watch
|
||||
(etaf-data-status controller)
|
||||
(lambda (new _old)
|
||||
(when (eq new 'loading)
|
||||
(error "loading projection failed")))))
|
||||
captured)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(condition-case condition
|
||||
(etaf-data-mutate controller 'update 'payload)
|
||||
(error (setq captured condition)))
|
||||
(should (equal '(error "loading projection failed") captured))
|
||||
(should (= 0 mutate-count))
|
||||
(should (eq 'error (etaf-value (etaf-data-status controller))))
|
||||
(should (equal captured (etaf-value (etaf-data-error controller)))))
|
||||
(funcall stop-status-watch)
|
||||
(etaf-data-stop controller))))
|
||||
|
||||
(ert-deftest etaf-data-m4a-committed-candidate-is-one-shot ()
|
||||
"A committed projection candidate cannot be submitted or rolled back twice."
|
||||
(let* ((source (etaf-data-source
|
||||
:load (lambda (&rest _args)
|
||||
'(:items (new) :total 2))))
|
||||
(controller
|
||||
(etaf-data-controller source :initial-result '(:items (old) :total 1)))
|
||||
candidate)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-data-load controller)
|
||||
(setq candidate (etaf-data--controller-projection-candidate controller))
|
||||
(let ((items-version (etaf-ref-version (etaf-data-items controller)))
|
||||
(total-version (etaf-ref-version (etaf-data-total controller))))
|
||||
(should (eq 'committed
|
||||
(etaf-data--projection-candidate-state candidate)))
|
||||
(should-error
|
||||
(etaf-data--commit-projection controller candidate)
|
||||
:type 'etaf-data-projection-conflict)
|
||||
(should (eq 'committed
|
||||
(etaf-data--projection-candidate-state candidate)))
|
||||
(should (equal '(new) (etaf-value (etaf-data-items controller))))
|
||||
(should (= 2 (etaf-value (etaf-data-total controller))))
|
||||
(should (= items-version
|
||||
(etaf-ref-version (etaf-data-items controller))))
|
||||
(should (= total-version
|
||||
(etaf-ref-version (etaf-data-total controller))))))
|
||||
(etaf-data-stop controller))))
|
||||
|
||||
(ert-deftest etaf-data-m4a-v2-malformed-outcome-is-unknown ()
|
||||
"Malformed v2 metadata publishes an error without starting a read."
|
||||
(let* ((load-count 0)
|
||||
(source
|
||||
(etaf-data-source
|
||||
:load (lambda (&rest _args)
|
||||
(cl-incf load-count)
|
||||
'(:items (old) :total 1))
|
||||
:mutate-v2 (lambda (&rest _args) '(:certainty committed :error bad))))
|
||||
(controller
|
||||
(etaf-data-controller source :initial-result '(:items (old) :total 1)))
|
||||
captured)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(condition-case condition
|
||||
(etaf-data-mutate controller 'update 'payload)
|
||||
(error (setq captured condition)))
|
||||
(should captured)
|
||||
(should (eq 'external-unknown
|
||||
(plist-get (etaf-data-mutation-outcome controller)
|
||||
:certainty)))
|
||||
(should (eq 'external-unknown
|
||||
(etaf-data-reconciliation-state controller)))
|
||||
(should (= 0 load-count))
|
||||
(should (eq 'error (etaf-value (etaf-data-status controller))))
|
||||
(should-not (etaf-data-retry-reconciliation controller)))
|
||||
(etaf-data-stop controller))))
|
||||
|
||||
(ert-deftest etaf-data-m4a-v2-outcome-validates-result-and-rollback-error ()
|
||||
"Reject contradictory results and incomplete rolled-back outcomes."
|
||||
(dolist (outcome
|
||||
'((:certainty committed :result left :mutation-result right)
|
||||
(:certainty committed)
|
||||
(:certainty rolled-back)))
|
||||
(let* ((load-count 0)
|
||||
(source
|
||||
(etaf-data-source
|
||||
:load (lambda (&rest _args)
|
||||
(cl-incf load-count)
|
||||
'(:items (old) :total 1))
|
||||
:mutate-v2 (lambda (&rest _args) outcome)))
|
||||
(controller
|
||||
(etaf-data-controller source :initial-result '(:items (old)
|
||||
:total 1)))
|
||||
captured)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(condition-case condition
|
||||
(etaf-data-mutate controller 'update 'payload)
|
||||
(error (setq captured condition)))
|
||||
(should captured)
|
||||
(should (eq 'external-unknown
|
||||
(plist-get (etaf-data-mutation-outcome controller)
|
||||
:certainty)))
|
||||
(should (eq 'external-unknown
|
||||
(etaf-data-reconciliation-state controller)))
|
||||
(should (zerop load-count)))
|
||||
(etaf-data-stop controller)))))
|
||||
|
||||
(ert-deftest etaf-data-m4a-field-apply-fault-restores-written-fields ()
|
||||
"A field fault before dispatch restores every field written by the candidate."
|
||||
(let* ((source (etaf-data-source
|
||||
:load (lambda (&rest _args)
|
||||
'(:items (new) :total 2))))
|
||||
(controller
|
||||
(etaf-data-controller source :initial-result '(:items (old) :total 1)))
|
||||
(old-apply etaf-data--projection-field-apply-function)
|
||||
(old-items-version (etaf-ref-version (etaf-data-items controller)))
|
||||
(old-total-version (etaf-ref-version (etaf-data-total controller)))
|
||||
captured)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setq etaf-data--projection-field-apply-function
|
||||
(lambda (entry)
|
||||
(let ((ref (plist-get entry :ref)))
|
||||
(setf (etaf-ref-value ref) (plist-get entry :new-value)
|
||||
(etaf-ref-version ref)
|
||||
(1+ (plist-get entry :old-version))))
|
||||
(error "field installation failed")))
|
||||
(condition-case condition
|
||||
(etaf-data-load controller)
|
||||
(error (setq captured condition)))
|
||||
(should captured)
|
||||
(should (equal '(old) (etaf-value (etaf-data-items controller))))
|
||||
(should (= 1 (etaf-value (etaf-data-total controller))))
|
||||
(should (= old-items-version
|
||||
(etaf-ref-version (etaf-data-items controller))))
|
||||
(should (= old-total-version
|
||||
(etaf-ref-version (etaf-data-total controller)))))
|
||||
(setq etaf-data--projection-field-apply-function old-apply)
|
||||
(etaf-data-stop controller))))
|
||||
|
||||
(ert-deftest etaf-data-m4a-field-apply-runs-once-per-entry ()
|
||||
"Install each changed field exactly once after version validation."
|
||||
(let* ((source (etaf-data-source
|
||||
:load (lambda (&rest _args)
|
||||
(list :items '(new) :total 2))))
|
||||
(controller
|
||||
(etaf-data-controller source
|
||||
:initial-result '(:items (old) :total 1)))
|
||||
(old-apply etaf-data--projection-field-apply-function)
|
||||
(apply-count 0))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setq etaf-data--projection-field-apply-function
|
||||
(lambda (entry)
|
||||
(cl-incf apply-count)
|
||||
(etaf-data--projection-default-apply-field entry)))
|
||||
(etaf-data-load controller)
|
||||
(let* ((candidate (etaf-data-projection-candidate controller))
|
||||
(entries (etaf-data--projection-candidate-entries candidate)))
|
||||
(should (= apply-count (length entries)))
|
||||
(should (equal '(new) (etaf-value (etaf-data-items controller))))
|
||||
(should (= 2 (etaf-value (etaf-data-total controller))))))
|
||||
(setq etaf-data--projection-field-apply-function old-apply)
|
||||
(etaf-data-stop controller))))
|
||||
|
||||
(ert-deftest etaf-data-m4a-item-key-fault-exits-loading ()
|
||||
"A materialization fault publishes error instead of leaving loading set."
|
||||
(let* ((source (etaf-data-source
|
||||
:load (lambda (&rest _args)
|
||||
(list :items '((:id new)) :total 2))))
|
||||
(controller
|
||||
(etaf-data-controller
|
||||
source
|
||||
:initial-result '(:items ((:id old)) :total 1)
|
||||
:item-key
|
||||
(lambda (item)
|
||||
(if (eq (plist-get item :id) 'new)
|
||||
(error "item key failed")
|
||||
(plist-get item :id)))))
|
||||
captured)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(condition-case condition
|
||||
(etaf-data-load controller)
|
||||
(error (setq captured condition)))
|
||||
(should (equal '(error "item key failed") captured))
|
||||
(should (eq 'error (etaf-value (etaf-data-status controller))))
|
||||
(should (equal captured
|
||||
(etaf-value (etaf-data-error controller))))
|
||||
(should (equal '((:id old))
|
||||
(etaf-value (etaf-data-items controller))))
|
||||
(should (= 1 (etaf-value (etaf-data-total controller))))
|
||||
(should (eq 'load-error
|
||||
(etaf-data--projection-candidate-kind
|
||||
(etaf-data--controller-projection-candidate
|
||||
controller)))))
|
||||
(etaf-data-stop controller))))
|
||||
|
||||
(ert-deftest etaf-data-m4a-source-error-projection-fault-exits-loading ()
|
||||
"A source error plus error projection fault still leaves terminal error state."
|
||||
(let* ((source (etaf-data-source
|
||||
:load (lambda (&rest _args)
|
||||
(error "source boom"))))
|
||||
(controller
|
||||
(etaf-data-controller source
|
||||
:initial-result '(:items (old) :total 1)))
|
||||
(old-apply etaf-data--projection-field-apply-function)
|
||||
captured)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setq etaf-data--projection-field-apply-function
|
||||
(lambda (entry)
|
||||
(let ((ref (plist-get entry :ref)))
|
||||
(setf (etaf-ref-value ref) (plist-get entry :new-value)
|
||||
(etaf-ref-version ref)
|
||||
(1+ (plist-get entry :old-version))))
|
||||
(error "error projection installation failed")))
|
||||
(condition-case condition
|
||||
(etaf-data-load controller)
|
||||
(error (setq captured condition)))
|
||||
(should (equal '(error "source boom") captured))
|
||||
(should (eq 'error (etaf-value (etaf-data-status controller))))
|
||||
(should (equal captured
|
||||
(etaf-value (etaf-data-error controller))))
|
||||
(should (equal '(old) (etaf-value (etaf-data-items controller))))
|
||||
(should (= 1 (etaf-value (etaf-data-total controller))))
|
||||
(should (eq 'aborted
|
||||
(etaf-data--projection-candidate-state
|
||||
(etaf-data--controller-projection-candidate
|
||||
controller)))))
|
||||
(setq etaf-data--projection-field-apply-function old-apply)
|
||||
(etaf-data-stop controller))))
|
||||
|
||||
(ert-deftest etaf-data-m4a-plain-load-projection-fault-keeps-raw-condition ()
|
||||
"A plain successful load keeps a projection fault in the v1 condition shape."
|
||||
(let* ((source (etaf-data-source
|
||||
:load (lambda (&rest _args)
|
||||
'(:items (new) :total 2))))
|
||||
(controller
|
||||
(etaf-data-controller source :initial-result '(:items (old) :total 1)))
|
||||
(stop-status-watch
|
||||
(etaf-watch
|
||||
(etaf-data-status controller)
|
||||
(lambda (new _old)
|
||||
(when (eq new 'success)
|
||||
(error "success projection failed")))))
|
||||
captured)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(condition-case condition
|
||||
(etaf-data-load controller)
|
||||
(error (setq captured condition)))
|
||||
(should (equal '(error "success projection failed") captured))
|
||||
(should-not (etaf-data-condition-projection-info captured))
|
||||
(should-not (etaf-data-reconciliation-token controller))
|
||||
(should (eq 'success (etaf-value (etaf-data-status controller))))
|
||||
(should (equal '(new) (etaf-value (etaf-data-items controller))))
|
||||
(should (= 2 (etaf-value (etaf-data-total controller)))))
|
||||
(funcall stop-status-watch)
|
||||
(etaf-data-stop controller))))
|
||||
|
||||
(ert-deftest etaf-data-selection-is-reactive-state ()
|
||||
"Select, deselect, and clear identities through the controller API."
|
||||
(let* ((source (etaf-data-memory-source etaf-data-test-records
|
||||
|
||||
872
tests/etaf-g1-cross-layer-tests.el
Normal file
872
tests/etaf-g1-cross-layer-tests.el
Normal file
@ -0,0 +1,872 @@
|
||||
;;; etaf-g1-cross-layer-tests.el --- G1 cross-layer fault gate -*- lexical-binding: t; -*-
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'ert)
|
||||
(require 'etaf)
|
||||
(require 'etaf-render-port)
|
||||
(require 'tp-reactive)
|
||||
(require 'ebox-spi)
|
||||
(require 'ebox-surface)
|
||||
(require 'ebox-native-reflow)
|
||||
|
||||
(define-error 'etaf-g1-retirement-error "G1 retirement test error")
|
||||
|
||||
(defvar etaf-g1--tp-trace nil)
|
||||
(defvar etaf-g1--tp-precommit-condition nil)
|
||||
|
||||
(defun etaf-g1--tp-precommit-probe ()
|
||||
"Record and optionally signal the G1 TP precommit fault."
|
||||
(push 'precommit etaf-g1--tp-trace)
|
||||
(when etaf-g1--tp-precommit-condition
|
||||
(signal (car etaf-g1--tp-precommit-condition)
|
||||
(cdr etaf-g1--tp-precommit-condition))))
|
||||
|
||||
(defconst etaf-g1--workspace-root
|
||||
(expand-file-name "../.."
|
||||
(file-name-directory
|
||||
(or load-file-name buffer-file-name)))
|
||||
"Workspace root used by cross-package evidence checks.")
|
||||
|
||||
(defconst etaf-g1-fault-matrix
|
||||
'((tp-order . etaf-g1-tp-order-precommit-and-rollback-are-atomic)
|
||||
(multi-surface . etaf-g1-tp-multi-surface-final-accept-restores-in-order)
|
||||
(combined-participant . etaf-g1-ebox-etaf-combined-participant-same-report)
|
||||
(spi-branches . etaf-g1-spi-four-branches-and-selected-port-immutability)
|
||||
(generation-host-cas . etaf-g1-generation-cas-and-host-lifecycle-guards)
|
||||
(v1-v2-equivalence . etaf-g1-v1-v2-runtime-equivalence)
|
||||
(runtime-fault-rollback . etaf-g1-runtime-fault-restores-authorities)
|
||||
(postcommit-diagnostics . etaf-g1-postcommit-report-fault-keeps-accepted-state)
|
||||
(host-unmount-kill . etaf-g1-host-unmount-and-kill-inflight-route)
|
||||
(nested-runtime-event . etaf-g1-nested-runtime-event-batches-once)
|
||||
(multi-context . etaf-g1-multi-context-runtimes-isolate)
|
||||
(native-fallback . etaf-g1-native-fallback-keeps-surface)
|
||||
(retirement . etaf-g1-retirement-diagnostics-are-cause-compatible)
|
||||
(load-path-harness . etaf-g1-research-shelf-load-path-harness-contract)
|
||||
(gui-recovery-harness . etaf-g1-research-shelf-gui-recovery-harness-contract))
|
||||
"Auditable G1 fault-gate coverage map.")
|
||||
|
||||
(defconst etaf-g1--required-fault-keys
|
||||
'(tp-order multi-surface combined-participant spi-branches
|
||||
generation-host-cas v1-v2-equivalence runtime-fault-rollback
|
||||
postcommit-diagnostics host-unmount-kill nested-runtime-event multi-context
|
||||
native-fallback retirement load-path-harness gui-recovery-harness)
|
||||
"Required unique behavior keys for the G1 cross-layer gate.")
|
||||
|
||||
(defun etaf-g1--cleanup-buffer (buffer-or-name)
|
||||
"Unmount and kill BUFFER-OR-NAME, signaling any cleanup failure."
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-or-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((buffer (get-buffer buffer-or-name)))
|
||||
(when (ebox-surface-buffer-mounted-p buffer)
|
||||
(ebox-unmount-buffer buffer))
|
||||
(kill-buffer buffer)))
|
||||
|
||||
(defun etaf-g1--view (source)
|
||||
"Return a small reactive View that exposes SOURCE as styled text."
|
||||
(etaf-view
|
||||
(text :ref 'g1-value :color "red"
|
||||
(expr (format "value=%s" (etaf-value source))))))
|
||||
|
||||
(defun etaf-g1--normalized-property-runs (text)
|
||||
"Return TEXT property runs with backend identities normalized by topology."
|
||||
(let ((identity-map (make-hash-table :test #'equal))
|
||||
(next-identity 0)
|
||||
(position 0)
|
||||
runs)
|
||||
(cl-labels
|
||||
((normalize
|
||||
(identity)
|
||||
(when identity
|
||||
(or (gethash identity identity-map)
|
||||
(prog1 next-identity
|
||||
(puthash identity next-identity identity-map)
|
||||
(cl-incf next-identity))))))
|
||||
(while (< position (length text))
|
||||
(let* ((next (or (next-property-change position text)
|
||||
(length text)))
|
||||
(properties (copy-tree (text-properties-at position text))))
|
||||
(dolist (key '(ebox-content ebox-content-owner))
|
||||
(when (plist-member properties key)
|
||||
(setq properties
|
||||
(plist-put properties key
|
||||
(normalize (plist-get properties key))))))
|
||||
(when (plist-member properties 'ebox-content-owners)
|
||||
(setq properties
|
||||
(plist-put
|
||||
properties 'ebox-content-owners
|
||||
(mapcar #'normalize
|
||||
(plist-get properties 'ebox-content-owners)))))
|
||||
(push (list :from position :to next :properties properties) runs)
|
||||
(setq position next))))
|
||||
(nreverse runs)))
|
||||
|
||||
(defun etaf-g1--surface-snapshot (buffer)
|
||||
"Return public, rollback-sensitive rendering evidence for BUFFER."
|
||||
(let* ((text (with-current-buffer buffer
|
||||
(buffer-substring (point-min) (point-max))))
|
||||
(semantic-text (copy-sequence text)))
|
||||
(remove-text-properties
|
||||
0 (length semantic-text)
|
||||
'(ebox-content nil ebox-content-owner nil ebox-content-owners nil)
|
||||
semantic-text)
|
||||
(list :text text
|
||||
:semantic-text semantic-text
|
||||
:property-runs (etaf-g1--normalized-property-runs text)
|
||||
:region-count (length (ebox-region-ids text))
|
||||
:mounted (ebox-surface-buffer-mounted-p buffer)
|
||||
:revision (and (ebox-surface-buffer-mounted-p buffer)
|
||||
(ebox-surface-buffer-revision buffer))
|
||||
:report (and (ebox-surface-buffer-mounted-p buffer)
|
||||
(ebox-buffer-update-report buffer)))))
|
||||
|
||||
(defun etaf-g1--report-contract (report)
|
||||
"Return route-independent committed fields from REPORT."
|
||||
(mapcar (lambda (key) (cons key (plist-get report key)))
|
||||
'(:runtime-published :surface-revision :strategy
|
||||
:render-scope :publication-scope)))
|
||||
|
||||
(defun etaf-g1--surface-contract (buffer)
|
||||
"Return route-independent visible surface evidence for BUFFER."
|
||||
(let ((snapshot (etaf-g1--surface-snapshot buffer)))
|
||||
(list :semantic-text (plist-get snapshot :semantic-text)
|
||||
:property-runs (plist-get snapshot :property-runs)
|
||||
:region-count (plist-get snapshot :region-count)
|
||||
:mounted (plist-get snapshot :mounted)
|
||||
:revision (plist-get snapshot :revision))))
|
||||
|
||||
(defun etaf-g1--runtime-host-contract (runtime)
|
||||
"Return lifecycle and route authority evidence for RUNTIME."
|
||||
(let ((authority (etaf-runtime-host-authority runtime))
|
||||
(route (etaf-runtime-route-token runtime)))
|
||||
(list :host-state (etaf-host-authority-state authority)
|
||||
:host-version (etaf-host-authority-version authority)
|
||||
:mounted (etaf-runtime-mounted-p runtime)
|
||||
:pending (etaf-runtime-pending-p runtime)
|
||||
:route-live (and (etaf-runtime-route-live-p route) t))))
|
||||
|
||||
(defun etaf-g1--runtime-visible-contract (runtime)
|
||||
"Return route-independent visible and authority evidence for RUNTIME."
|
||||
(append
|
||||
(etaf-g1--surface-contract (etaf-runtime-buffer runtime))
|
||||
(list :generation (etaf-runtime-generation runtime)
|
||||
:token (etaf-runtime-generation-token runtime)
|
||||
:store-versions (copy-tree (etaf-runtime-store-versions runtime)))
|
||||
(etaf-g1--runtime-host-contract runtime)))
|
||||
|
||||
(defun etaf-g1--runtime-state (runtime)
|
||||
"Return rollback-sensitive ETAF, Ebox, route, and store state for RUNTIME."
|
||||
(let* ((buffer (etaf-runtime-buffer runtime))
|
||||
(surface (etaf-g1--surface-snapshot buffer))
|
||||
(report (plist-get surface :report)))
|
||||
(list :visible (etaf-g1--runtime-visible-contract runtime)
|
||||
:handlers (etaf-runtime-handler-entries runtime)
|
||||
:host-props (etaf-runtime-host-props-entries runtime)
|
||||
:resource-count
|
||||
(hash-table-count (etaf-runtime-resource-registry runtime))
|
||||
:artifact-count
|
||||
(hash-table-count (etaf-runtime-artifact-registry runtime))
|
||||
:range-artifact-count
|
||||
(hash-table-count (etaf-runtime-range-artifact-registry runtime))
|
||||
:route-source-count
|
||||
(hash-table-count (etaf-runtime-route-sources runtime))
|
||||
:paint-count
|
||||
(hash-table-count (etaf-runtime-theme-paint-slots runtime))
|
||||
:behavior-count
|
||||
(hash-table-count (etaf-runtime-behaviors runtime))
|
||||
:surface-report (and report (etaf-g1--report-contract report)))))
|
||||
|
||||
(ert-deftest etaf-g1-fault-matrix-is-auditable ()
|
||||
(let ((keys (mapcar #'car etaf-g1-fault-matrix))
|
||||
(tests (mapcar #'cdr etaf-g1-fault-matrix)))
|
||||
(should (equal keys etaf-g1--required-fault-keys))
|
||||
(should (= (length keys) (length (delete-dups (copy-sequence keys)))))
|
||||
(should (= (length tests) (length (delete-dups (copy-sequence tests)))))
|
||||
(dolist (test tests)
|
||||
(should (symbolp test))
|
||||
(should (ert-get-test test)))))
|
||||
|
||||
(ert-deftest etaf-g1-tp-order-precommit-and-rollback-are-atomic ()
|
||||
"TP stages in order and reverses partial-stage and precommit faults."
|
||||
(let (etaf-g1--tp-trace)
|
||||
(let ((tp--transaction-participant-precommit-allowed-functions nil)
|
||||
(tp--transaction-precommit-functions nil))
|
||||
(should-error
|
||||
(tp-with-transaction
|
||||
(tp-transaction-participate
|
||||
'tp-first (lambda () (push 'first-stage etaf-g1--tp-trace))
|
||||
(lambda () (push 'first-rollback etaf-g1--tp-trace)))
|
||||
(tp-transaction-participate
|
||||
'tp-second
|
||||
(lambda () (push 'second-stage etaf-g1--tp-trace)
|
||||
(error "G1 injected partial apply"))
|
||||
(lambda () (push 'second-rollback etaf-g1--tp-trace))))))
|
||||
(should
|
||||
(equal (nreverse etaf-g1--tp-trace)
|
||||
'(first-stage second-stage second-rollback first-rollback))))
|
||||
(let ((etaf-g1--tp-trace nil)
|
||||
(etaf-g1--tp-precommit-condition
|
||||
'(error "G1 injected precommit failure"))
|
||||
(tp--transaction-precommit-functions
|
||||
'(etaf-g1--tp-precommit-probe))
|
||||
(tp--transaction-precommit-allowed-functions
|
||||
'(etaf-g1--tp-precommit-probe)))
|
||||
(should-error
|
||||
(tp-with-transaction
|
||||
(tp-transaction-participate
|
||||
'tp-first (lambda () (push 'first-stage etaf-g1--tp-trace))
|
||||
(lambda () (push 'first-rollback etaf-g1--tp-trace)))
|
||||
(tp-transaction-participate
|
||||
'tp-second (lambda () (push 'second-stage etaf-g1--tp-trace))
|
||||
(lambda () (push 'second-rollback etaf-g1--tp-trace)))))
|
||||
(should
|
||||
(equal (nreverse etaf-g1--tp-trace)
|
||||
'(first-stage second-stage precommit
|
||||
second-rollback first-rollback)))))
|
||||
|
||||
(ert-deftest etaf-g1-tp-multi-surface-final-accept-restores-in-order ()
|
||||
"One TP publication updates two surfaces atomically and restores both."
|
||||
(let* ((source (tp-signal-create 0))
|
||||
(left-buffer (generate-new-buffer " *etaf-g1-tp-left*"))
|
||||
(right-buffer (generate-new-buffer " *etaf-g1-tp-right*"))
|
||||
(left nil) (right nil))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setq left
|
||||
(tp-surface-mount
|
||||
left-buffer
|
||||
(lambda (context)
|
||||
(tp-object-ensure context nil 'root 'text)
|
||||
(tp-surface-plan-create
|
||||
:key 'root :kind 'text
|
||||
:text (format "L%s" (tp-signal-read source))
|
||||
:capability 'content))))
|
||||
(setq right
|
||||
(tp-surface-mount
|
||||
right-buffer
|
||||
(lambda (context)
|
||||
(tp-object-ensure context nil 'root 'text)
|
||||
(tp-surface-plan-create
|
||||
:key 'root :kind 'text
|
||||
:text (format "R%s" (tp-signal-read source))
|
||||
:capability 'content))))
|
||||
(let ((left-before (with-current-buffer left-buffer (buffer-string)))
|
||||
(right-before (with-current-buffer right-buffer (buffer-string)))
|
||||
(left-revision (tp-surface-revision left))
|
||||
(right-revision (tp-surface-revision right))
|
||||
condition)
|
||||
(cl-letf (((symbol-function 'accept-change-group)
|
||||
(lambda (&rest _)
|
||||
(error "G1 injected final-accept failure"))))
|
||||
(setq condition
|
||||
(condition-case error-data
|
||||
(progn (tp-signal-set source 1) nil)
|
||||
((error quit) error-data))))
|
||||
(should condition)
|
||||
(should (tp-publication-failure-outcome-p
|
||||
tp--last-transaction-outcome))
|
||||
(should (= 2
|
||||
(length
|
||||
(tp-publication-failure-outcome-target-results
|
||||
tp--last-transaction-outcome))))
|
||||
(should (equal-including-properties
|
||||
left-before (with-current-buffer left-buffer (buffer-string))))
|
||||
(should (equal-including-properties
|
||||
right-before (with-current-buffer right-buffer (buffer-string))))
|
||||
(should (= left-revision (tp-surface-revision left)))
|
||||
(should (= right-revision (tp-surface-revision right)))
|
||||
(should (= 0 (tp-signal-peek source)))
|
||||
(should (null (tp--transaction-condition-trailer
|
||||
condition :rollback-failures)))))
|
||||
(when (tp-surface-live-p left) (tp-surface-unmount left))
|
||||
(when (tp-surface-live-p right) (tp-surface-unmount right))
|
||||
(when (buffer-live-p left-buffer) (kill-buffer left-buffer))
|
||||
(when (buffer-live-p right-buffer) (kill-buffer right-buffer))
|
||||
(when (tp-signal-live-p source) (tp-signal-dispose source)))))
|
||||
|
||||
(ert-deftest etaf-g1-ebox-etaf-combined-participant-same-report ()
|
||||
"Ebox SPI callbacks share reports while TP outcomes remain observational."
|
||||
(let ((buffer (generate-new-buffer " *etaf-g1-combined*"))
|
||||
(input (ebox-build '(box "g1")))
|
||||
seen)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(let ((report
|
||||
(ebox-framework-spi-initial
|
||||
buffer input
|
||||
(lambda (value) (setq seen value))
|
||||
(lambda (_value) nil))))
|
||||
(should (eq report seen))
|
||||
(should (eq (plist-get report :framework-participant-state)
|
||||
'completed))
|
||||
(should (equal (mapcar (lambda (x) (plist-get x :provider))
|
||||
(ebox-framework-spi-initial-observation-reports
|
||||
report))
|
||||
'(tp ebox)))
|
||||
(should (tp-committed-success-outcome-p
|
||||
tp--last-transaction-outcome))
|
||||
(let ((first (tp--committed-success-outcome-snapshot
|
||||
tp--last-transaction-outcome))
|
||||
(second (tp--committed-success-outcome-snapshot
|
||||
tp--last-transaction-outcome)))
|
||||
(should (equal first second))
|
||||
(should-not (eq first second))
|
||||
(let ((counts (plist-get first :operation-counts)))
|
||||
(should (consp counts))
|
||||
(setcar counts :g1-mutated-counts)
|
||||
(should-not (equal first second))
|
||||
(should
|
||||
(equal second
|
||||
(tp--committed-success-outcome-snapshot
|
||||
tp--last-transaction-outcome)))))
|
||||
(let (update-seen update-return)
|
||||
(setq update-return
|
||||
(ebox-framework-spi-update
|
||||
buffer input (lambda (value) (setq update-seen value)) #'ignore))
|
||||
(should (eq update-seen update-return))
|
||||
(should (tp-committed-success-outcome-p
|
||||
tp--last-transaction-outcome)))))
|
||||
(when (buffer-live-p buffer)
|
||||
(when (ebox-surface-buffer-mounted-p buffer)
|
||||
(ebox-unmount-buffer buffer))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-g1-runtime-fault-restores-authorities ()
|
||||
"A semantic participant fault restores observable cross-layer authority."
|
||||
(let* ((buffer-name (generate-new-buffer-name " *etaf-g1-runtime-fault*"))
|
||||
(source (etaf-ref 0))
|
||||
(events nil)
|
||||
(failure-seen nil))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount buffer-name (etaf-g1--view source))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(before (etaf-g1--runtime-state runtime))
|
||||
(old-publish (symbol-function 'etaf--runtime-participant-publish))
|
||||
(old-rollback (symbol-function 'etaf--runtime-participant-rollback))
|
||||
(condition nil))
|
||||
(cl-letf
|
||||
(((symbol-function 'etaf--runtime-participant-publish)
|
||||
(lambda (participant)
|
||||
(push 'semantic-publish events)
|
||||
(prog1 (funcall old-publish participant)
|
||||
(unless failure-seen
|
||||
(setq failure-seen t)
|
||||
(error "G1 injected semantic participant failure")))))
|
||||
((symbol-function 'etaf--runtime-participant-rollback)
|
||||
(lambda (participant)
|
||||
(push 'semantic-rollback events)
|
||||
(funcall old-rollback participant))))
|
||||
(setq condition
|
||||
(condition-case error-data
|
||||
(progn (setf (etaf-value source) 1) nil)
|
||||
((error quit) error-data))))
|
||||
(should condition)
|
||||
(should (equal (nreverse events)
|
||||
'(semantic-publish semantic-rollback)))
|
||||
(should
|
||||
(equal-including-properties
|
||||
before (etaf-g1--runtime-state runtime)))
|
||||
(should (etaf-host-authority-attached-p
|
||||
(etaf-runtime-host-authority runtime)))
|
||||
(should (etaf-runtime-generation-mirrors-consistent-p runtime))
|
||||
(should (tp-publication-failure-outcome-p
|
||||
tp--last-transaction-outcome))
|
||||
(should (null (tp--transaction-condition-trailer
|
||||
condition :rollback-failures)))
|
||||
;; A retry is a fresh publication, not a partial continuation of
|
||||
;; the failed candidate.
|
||||
(etaf-runtime-flush runtime)
|
||||
(should (equal "value=1"
|
||||
(with-current-buffer buffer-name (buffer-string))))))
|
||||
(etaf-g1--cleanup-buffer buffer-name))))
|
||||
|
||||
(ert-deftest etaf-g1-postcommit-report-fault-keeps-accepted-state ()
|
||||
"A report-finalization fault is diagnostic only after commit."
|
||||
(let* ((buffer-name (generate-new-buffer-name " *etaf-g1-postcommit*"))
|
||||
(source (etaf-ref 0)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(cl-letf (((symbol-function 'ebox-surface--participant-complete)
|
||||
(lambda (&rest _)
|
||||
(error "G1 injected report finalization fault"))))
|
||||
(etaf-mount buffer-name (etaf-g1--view source)))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(report (ebox-buffer-update-report buffer-name))
|
||||
(diagnostics
|
||||
(plist-get report :framework-participant-diagnostics)))
|
||||
(should (etaf-host-authority-attached-p
|
||||
(etaf-runtime-host-authority runtime)))
|
||||
(should (etaf-runtime-mounted-p runtime))
|
||||
(should (= 1 (etaf-runtime-generation runtime)))
|
||||
(should (= 1 (etaf-runtime-generation-token runtime)))
|
||||
(should (equal "value=0"
|
||||
(with-current-buffer buffer-name (buffer-string))))
|
||||
(should (cl-some
|
||||
(lambda (entry)
|
||||
(eq (plist-get entry :phase)
|
||||
'framework-report-finalization))
|
||||
diagnostics))))
|
||||
(etaf-g1--cleanup-buffer buffer-name))))
|
||||
|
||||
(ert-deftest etaf-g1-host-unmount-and-kill-inflight-route ()
|
||||
"Detach invalidates routes before cleanup and never revives dead buffers."
|
||||
(let* ((source (etaf-ref 0))
|
||||
(explicit-name (generate-new-buffer-name " *etaf-g1-explicit*"))
|
||||
(killed-name (generate-new-buffer-name " *etaf-g1-killed*")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount explicit-name (etaf-g1--view source))
|
||||
(let* ((runtime (etaf-runtime-for-buffer explicit-name))
|
||||
(route (etaf-runtime-route-token runtime))
|
||||
(authority (etaf-runtime-host-authority runtime)))
|
||||
(etaf-unmount runtime)
|
||||
(should (eq (etaf-host-authority-state authority) 'terminal))
|
||||
(should-not (etaf-runtime-route-live-p route))
|
||||
(should-not (etaf-runtime-for-buffer explicit-name)))
|
||||
(etaf-mount killed-name (etaf-g1--view source))
|
||||
(let* ((runtime (etaf-runtime-for-buffer killed-name))
|
||||
(route (etaf-runtime-route-token runtime))
|
||||
(authority (etaf-runtime-host-authority runtime)))
|
||||
;; Hold a logical event open so the source write is in-flight;
|
||||
;; killing the buffer must invalidate the route and drop it.
|
||||
(etaf-runtime-event-begin runtime)
|
||||
(setf (etaf-value source) 1)
|
||||
(kill-buffer (get-buffer killed-name))
|
||||
(etaf-runtime-event-end runtime)
|
||||
(should-not (etaf-runtime-mounted-p runtime))
|
||||
(should (eq (etaf-host-authority-state authority) 'terminal))
|
||||
(should-not (etaf-runtime-route-live-p route))
|
||||
(should-not (etaf-runtime-pending-p runtime))
|
||||
(should-not (gethash route (etaf-ref-subscribers source)))
|
||||
(setf (etaf-value source) 2)
|
||||
(should-not (etaf-runtime-pending-p runtime))))
|
||||
(etaf-g1--cleanup-buffer explicit-name)
|
||||
(etaf-g1--cleanup-buffer killed-name))))
|
||||
|
||||
(ert-deftest etaf-g1-multi-context-runtimes-isolate ()
|
||||
"Sibling render roots share a source but isolate scheduler contexts."
|
||||
(let* ((source (etaf-ref 0))
|
||||
(left-context (etaf-scheduler-context-create :name 'g1-left))
|
||||
(right-context (etaf-scheduler-context-create :name 'g1-right))
|
||||
(left-name (generate-new-buffer-name " *etaf-g1-left*"))
|
||||
(right-name (generate-new-buffer-name " *etaf-g1-right*")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount left-name (etaf-view (column (text "L")
|
||||
(text (expr (format "%s" (etaf-value source))))))
|
||||
(list :scheduler-context left-context))
|
||||
(etaf-mount right-name (etaf-view (column (text "R")
|
||||
(box (text (expr (format "%s" (etaf-value source)))))))
|
||||
(list :scheduler-context right-context))
|
||||
(let ((left (etaf-runtime-for-buffer left-name))
|
||||
(right (etaf-runtime-for-buffer right-name)))
|
||||
(setf (etaf-value source) 1)
|
||||
(should (= 2 (etaf-runtime-generation left)))
|
||||
(should (= 2 (etaf-runtime-generation right)))
|
||||
(should (equal "L1"
|
||||
(replace-regexp-in-string
|
||||
"\n" ""
|
||||
(with-current-buffer left-name (buffer-string)))))
|
||||
(should (equal "R1"
|
||||
(replace-regexp-in-string
|
||||
"\n" ""
|
||||
(with-current-buffer right-name (buffer-string)))))
|
||||
(should (etaf-scheduler-context-idle-p left-context))
|
||||
(should (etaf-scheduler-context-idle-p right-context))
|
||||
(etaf-unmount left)
|
||||
(setf (etaf-value source) 2)
|
||||
(should (= 3 (etaf-runtime-generation right)))
|
||||
(should (equal "R2"
|
||||
(replace-regexp-in-string
|
||||
"\n" ""
|
||||
(with-current-buffer right-name (buffer-string)))))
|
||||
(should-not (etaf-runtime-pending-p left))))
|
||||
(etaf-g1--cleanup-buffer left-name)
|
||||
(etaf-g1--cleanup-buffer right-name))))
|
||||
|
||||
(ert-deftest etaf-g1-nested-runtime-event-batches-once ()
|
||||
"A nested Runtime event boundary publishes only its final source value."
|
||||
(let* ((source (etaf-ref 0))
|
||||
(buffer-name (generate-new-buffer-name " *etaf-g1-nested-event*")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount buffer-name (etaf-g1--view source))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(before (etaf-runtime-generation runtime)))
|
||||
(etaf-runtime-event-begin runtime)
|
||||
(etaf-runtime-event-begin runtime)
|
||||
(setf (etaf-value source) 1)
|
||||
(should (= before (etaf-runtime-generation runtime)))
|
||||
(should (etaf-runtime-pending-p runtime))
|
||||
(etaf-runtime-event-end runtime)
|
||||
(should (= before (etaf-runtime-generation runtime)))
|
||||
(setf (etaf-value source) 2)
|
||||
(etaf-runtime-event-end runtime)
|
||||
(should (= (1+ before) (etaf-runtime-generation runtime)))
|
||||
(should-not (etaf-runtime-pending-p runtime))
|
||||
(should
|
||||
(equal "value=2"
|
||||
(with-current-buffer buffer-name (buffer-string))))))
|
||||
(etaf-g1--cleanup-buffer buffer-name))))
|
||||
|
||||
(ert-deftest etaf-g1-native-fallback-keeps-surface ()
|
||||
"A forced native execution failure truthfully commits ordinary fallback."
|
||||
(let ((buffer (generate-new-buffer " *etaf-g1-native-fallback*"))
|
||||
(initial (ebox-build '(column (box :key a "A")
|
||||
(box :key b "B"))))
|
||||
(updated (ebox-build '(column (box :key a "A")
|
||||
(box :key b "B2")
|
||||
(box :key c "C"))))
|
||||
(native-attempts 0))
|
||||
(unwind-protect
|
||||
(let ((ebox-viewport-width 240)
|
||||
(ebox-viewport-height 8)
|
||||
(ebox-runtime-idle-prewarm nil)
|
||||
(ebox-runtime-idle-reflow-cache-prewarm nil))
|
||||
;; Establish an ordinary surface, then explicitly make the
|
||||
;; structural update eligible for native bootstrap.
|
||||
(cl-letf (((symbol-function 'ebox-native-reflow-layout-ready-p)
|
||||
(lambda () nil)))
|
||||
(ebox-render-to-buffer buffer initial))
|
||||
(let ((before (with-current-buffer buffer (buffer-string))))
|
||||
(cl-letf (((symbol-function 'ebox-native-reflow-layout-ready-p)
|
||||
(lambda () t))
|
||||
((symbol-function 'ebox-style-cascade-active-p)
|
||||
(lambda () nil))
|
||||
((symbol-function 'ebox-native-reflow-create-session)
|
||||
(lambda (&rest _)
|
||||
(ebox-native-reflow--make-session
|
||||
:handle 'g1-native-session
|
||||
:generation 0
|
||||
:layout-fragment-cache
|
||||
(make-hash-table :test #'equal)
|
||||
:layout-fragment-revision 0)))
|
||||
((symbol-function 'ebox-native-reflow-release-session)
|
||||
(lambda (session)
|
||||
(setf (ebox-native-reflow-session-released-p session) t)))
|
||||
((symbol-function 'ebox-native-reflow-execute-session-sync)
|
||||
(lambda (&rest _)
|
||||
(cl-incf native-attempts)
|
||||
(error "G1 forced native failure"))))
|
||||
(let ((report (ebox-commit buffer updated)))
|
||||
(should (= native-attempts 1))
|
||||
(should (equal "AB2C"
|
||||
(replace-regexp-in-string
|
||||
"[[:space:]]" ""
|
||||
(with-current-buffer buffer (buffer-string)))))
|
||||
(should (not (equal before (with-current-buffer buffer
|
||||
(buffer-string)))))
|
||||
(should (eq (plist-get report :strategy) 'ordinary-fallback))
|
||||
(should (eq (plist-get report :native-attempt) 'failed))
|
||||
(should (equal (plist-get report :native-fallback-reason)
|
||||
"G1 forced native failure"))
|
||||
(should (eq (plist-get report :render-scope) 'surface))
|
||||
(should-not (plist-get report :projection-kind))
|
||||
(should-not (plist-get report :native-frame-kind))
|
||||
(should (ebox-surface-buffer-mounted-p buffer))))))
|
||||
(when (buffer-live-p buffer)
|
||||
(when (ebox-surface-buffer-mounted-p buffer)
|
||||
(ebox-unmount-buffer buffer))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-g1-retirement-diagnostics-are-cause-compatible ()
|
||||
"Retirement errors retain the business condition and committed metadata."
|
||||
(let* ((journal
|
||||
(etaf-retirement-journal-create
|
||||
:operation-id 17 :outcome-id 18 :generation-id 19 :revision 20))
|
||||
captured)
|
||||
(condition-case condition
|
||||
(etaf-retirement-resignal
|
||||
'(etaf-g1-retirement-error "business" (:cause injected)) journal)
|
||||
(etaf-g1-retirement-error (setq captured condition)))
|
||||
(should captured)
|
||||
(should (equal (butlast (cdr captured))
|
||||
'("business" (:cause injected))))
|
||||
(should (equal (etaf-condition-postcommit-info captured)
|
||||
(list :kind 'postcommit :committed-p t :operation-id 17
|
||||
:outcome-id 18 :generation-id 19 :revision 20
|
||||
:diagnostic-journal-id
|
||||
(etaf-retirement-journal-id journal))))))
|
||||
|
||||
(ert-deftest etaf-g1-research-shelf-load-path-harness-contract ()
|
||||
"The Research Shelf execution harness names every required artifact."
|
||||
(dolist (file '("etaf-playground/examples/research-shelf.el"
|
||||
"etaf-playground/scripts/benchmark-research-shelf.el"
|
||||
"etaf-playground/scripts/playground-gui-scenarios.el"
|
||||
"etaf-playground/scripts/run-gui-verification.sh"))
|
||||
(should (file-exists-p (expand-file-name file etaf-g1--workspace-root)))))
|
||||
|
||||
(ert-deftest etaf-g1-research-shelf-gui-recovery-harness-contract ()
|
||||
"The GUI harness exposes the actions required by external GUI execution."
|
||||
(let* ((adapter (expand-file-name
|
||||
"etaf-playground/scripts/playground-gui-scenarios.el"
|
||||
etaf-g1--workspace-root))
|
||||
(evidence (expand-file-name
|
||||
"etaf-playground/scripts/research-shelf-m0a-evidence.el"
|
||||
etaf-g1--workspace-root))
|
||||
(adapter-source (with-temp-buffer
|
||||
(insert-file-contents adapter)
|
||||
(buffer-string)))
|
||||
(evidence-source (with-temp-buffer
|
||||
(insert-file-contents evidence)
|
||||
(buffer-string)))
|
||||
(engine-source (with-temp-buffer
|
||||
(insert-file-contents
|
||||
(expand-file-name
|
||||
"etaf/scripts/emacs-gui-verifier.el"
|
||||
etaf-g1--workspace-root))
|
||||
(buffer-string))))
|
||||
(dolist (token '("research-shelf" "screenshot"))
|
||||
(should (string-match-p (regexp-quote token) adapter-source)))
|
||||
(should (string-match-p "after-redisplay" engine-source))
|
||||
(dolist (token '("load-error" "buffer-killed" "unmounted"))
|
||||
(should (string-match-p (regexp-quote token) evidence-source)))))
|
||||
|
||||
(ert-deftest etaf-g1-spi-four-branches-and-selected-port-immutability ()
|
||||
"Absent, valid, malformed and incompatible SPI providers fail distinctly."
|
||||
(let ((selected (etaf-render-port-selected))
|
||||
(original-featurep (symbol-function 'featurep))
|
||||
(provider (ebox-framework-spi-capabilities)))
|
||||
(cl-letf (((symbol-function 'featurep)
|
||||
(lambda (feature)
|
||||
(and (not (eq feature 'ebox-framework-spi-v2))
|
||||
(funcall original-featurep feature))))
|
||||
((symbol-function 'ebox-framework-spi-capabilities) nil))
|
||||
(should (eq (etaf-render-port-route (etaf-render-port--bootstrap)) 'v1)))
|
||||
(should (eq (etaf-render-port-route (etaf-render-port--bootstrap)) 'v2))
|
||||
(cl-letf (((symbol-function 'ebox-framework-spi-capabilities)
|
||||
(lambda () (error "G1 malformed provider"))))
|
||||
(should-error (etaf-render-port--bootstrap)
|
||||
:type 'etaf-spi-bootstrap-error))
|
||||
(cl-letf (((symbol-function 'ebox-framework-spi-capabilities)
|
||||
(lambda () provider))
|
||||
((symbol-function 'ebox-framework-spi-provider-spi-version)
|
||||
(lambda (_provider) 99)))
|
||||
(should-error (etaf-render-port--bootstrap)
|
||||
:type 'etaf-spi-incompatible-error))
|
||||
(should (eq selected (etaf-render-port-selected)))
|
||||
(should-error (eval `(setf (etaf-render-port--route ',selected) 'v1)))))
|
||||
|
||||
(ert-deftest etaf-g1-generation-cas-and-host-lifecycle-guards ()
|
||||
"Generation authority rejects stale tokens and host authority is revocable."
|
||||
(let* ((authority (etaf-generation-authority-create))
|
||||
(generation (etaf--generation-create :generation-id 1))
|
||||
(token (etaf-generation-authority-token authority))
|
||||
(versions (etaf-generation-authority-store-versions authority)))
|
||||
(should (= token 0))
|
||||
(should (etaf-generation-authority-compare-and-swap
|
||||
authority nil token versions generation 1 versions))
|
||||
(should-error
|
||||
(etaf-generation-authority-compare-and-swap
|
||||
authority generation token versions
|
||||
(etaf--generation-create :generation-id 2) 2 versions)
|
||||
:type 'etaf-generation-error))
|
||||
(let ((buffer (generate-new-buffer " *g1-host*")))
|
||||
(unwind-protect
|
||||
(let ((host (etaf-host-authority-create 'g1-host 1 buffer)))
|
||||
(etaf-host-authority-begin-attach host)
|
||||
;; Legacy attach is the explicit non-transactional compatibility
|
||||
;; path; v2 uses the same state transition behind a TP marker.
|
||||
(etaf-host-authority-stage-attach host t)
|
||||
(let ((token (etaf-host-authority-token host)))
|
||||
(should (etaf-host-authority-accepts-token-p host token))
|
||||
(etaf-host-authority-begin-detach host)
|
||||
(etaf-host-authority-invalidate host)
|
||||
(should-not (etaf-host-authority-accepts-token-p host token))))
|
||||
(kill-buffer buffer))))
|
||||
|
||||
(defun etaf-g1--run-selected-render-port-route ()
|
||||
"Run one lifecycle through the process-selected port and return evidence."
|
||||
(let* ((source (etaf-ref 0))
|
||||
(buffer-name (generate-new-buffer-name " *etaf-g1-route*"))
|
||||
(original-publish
|
||||
(symbol-function 'etaf--runtime-participant-publish))
|
||||
runtime initial updated rolled-back lifecycle result injected)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount buffer-name (etaf-g1--view source))
|
||||
(setq runtime (etaf-runtime-for-buffer buffer-name)
|
||||
initial (etaf-g1--runtime-visible-contract runtime))
|
||||
(push (etaf-g1--runtime-host-contract runtime) lifecycle)
|
||||
(let ((initial-marker-count
|
||||
(tp-committed-success-outcome-marker-count
|
||||
tp--last-transaction-outcome)))
|
||||
(setf (etaf-value source) 1)
|
||||
(setq updated (etaf-g1--runtime-visible-contract runtime))
|
||||
(push (etaf-g1--runtime-host-contract runtime) lifecycle)
|
||||
(let ((update-report
|
||||
(ebox-buffer-update-report
|
||||
(etaf-runtime-buffer runtime)))
|
||||
(update-marker-count
|
||||
(tp-committed-success-outcome-marker-count
|
||||
tp--last-transaction-outcome)))
|
||||
(cl-letf
|
||||
(((symbol-function 'etaf--runtime-participant-publish)
|
||||
(lambda (participant)
|
||||
(prog1 (funcall original-publish participant)
|
||||
(unless injected
|
||||
(setq injected t)
|
||||
(error "G1 failed Runtime update"))))))
|
||||
(should-error (setf (etaf-value source) 2) :type 'error))
|
||||
(should injected)
|
||||
(setq rolled-back
|
||||
(etaf-g1--runtime-visible-contract runtime))
|
||||
(should (equal-including-properties updated rolled-back))
|
||||
(push (etaf-g1--runtime-host-contract runtime) lifecycle)
|
||||
(etaf-unmount runtime)
|
||||
(push (etaf-g1--runtime-host-contract runtime) lifecycle)
|
||||
(setq result
|
||||
(list
|
||||
:initial initial
|
||||
:updated updated
|
||||
:rolled-back rolled-back
|
||||
:update-report
|
||||
(etaf-g1--report-contract update-report)
|
||||
:initial-marker-count initial-marker-count
|
||||
:update-marker-count update-marker-count
|
||||
:lifecycle (nreverse lifecycle))))))
|
||||
(etaf-g1--cleanup-buffer buffer-name))
|
||||
result))
|
||||
|
||||
(defun etaf-g1--selected-route-evidence ()
|
||||
"Return lifecycle and dispatcher evidence for the actual selected port."
|
||||
(let* ((selected (etaf-render-port-selected))
|
||||
(initial-function (etaf-render-port-initial-function selected))
|
||||
(update-function (etaf-render-port-update-function selected))
|
||||
(original-initial (symbol-function initial-function))
|
||||
(original-update (symbol-function update-function))
|
||||
(initial-calls 0)
|
||||
(update-calls 0)
|
||||
lifecycle-evidence)
|
||||
(cl-letf (((symbol-function initial-function)
|
||||
(lambda (&rest arguments)
|
||||
(setq initial-calls (1+ initial-calls))
|
||||
(apply original-initial arguments)))
|
||||
((symbol-function update-function)
|
||||
(lambda (&rest arguments)
|
||||
(setq update-calls (1+ update-calls))
|
||||
(apply original-update arguments))))
|
||||
(setq lifecycle-evidence (etaf-g1--run-selected-render-port-route)))
|
||||
(list
|
||||
:selected-route (etaf-render-port-route selected)
|
||||
:bootstrap-outcome (etaf-render-port-bootstrap-outcome selected)
|
||||
:render-port-selection-policy etaf-render-port-selection-policy
|
||||
:generation-mirror-route etaf-generation-mirror-route
|
||||
:semantic-commit-route etaf-semantic-commit-route
|
||||
:v2-feature-present (featurep 'ebox-framework-spi-v2)
|
||||
:v2-predicate-present (fboundp 'ebox-framework-spi-capabilities)
|
||||
:selected-stable (eq selected (etaf-render-port-selected))
|
||||
:initial-dispatch initial-function
|
||||
:update-dispatch update-function
|
||||
:initial-dispatch-count initial-calls
|
||||
:update-dispatch-count update-calls
|
||||
:lifecycle-evidence lifecycle-evidence)))
|
||||
|
||||
(defun etaf-g1--emacs-executable ()
|
||||
"Return the executable running this test process."
|
||||
(or (and invocation-directory
|
||||
(let ((path (expand-file-name invocation-name
|
||||
invocation-directory)))
|
||||
(and (file-executable-p path) path)))
|
||||
(executable-find invocation-name)
|
||||
(error "Cannot resolve current Emacs executable: %S" invocation-name)))
|
||||
|
||||
(defun etaf-g1--probe-route-in-fresh-emacs (route)
|
||||
"Bootstrap ROUTE in a fresh Emacs process and return its route evidence."
|
||||
(let* ((etaf-root (expand-file-name "etaf" etaf-g1--workspace-root))
|
||||
(test-file (expand-file-name "tests/etaf-g1-cross-layer-tests.el"
|
||||
etaf-root))
|
||||
(load-directories
|
||||
(mapcar (lambda (directory)
|
||||
(expand-file-name directory etaf-g1--workspace-root))
|
||||
'("etaf" "etaf/examples" "etaf/scripts"
|
||||
"ebox" "tp" "ecss")))
|
||||
(route-setup
|
||||
(pcase route
|
||||
('v1
|
||||
(list
|
||||
"--eval"
|
||||
"(setq etaf-render-port-selection-policy 'v1)"))
|
||||
('v2
|
||||
(list "--eval" "(setq etaf-render-port-selection-policy 'v2)"))
|
||||
(_ (error "Unknown G1 render route: %S" route))))
|
||||
(arguments
|
||||
(append
|
||||
'("-Q" "--batch")
|
||||
(apply #'append
|
||||
(mapcar (lambda (directory) (list "-L" directory))
|
||||
load-directories))
|
||||
'("--eval" "(setq load-prefer-newer t)")
|
||||
route-setup
|
||||
(list
|
||||
"-l" test-file
|
||||
"--eval"
|
||||
(concat
|
||||
"(princ (concat \"ETAF_G1_ROUTE_EVIDENCE:\" "
|
||||
"(base64-encode-string "
|
||||
"(prin1-to-string (etaf-g1--selected-route-evidence)) t) "
|
||||
"\"\\n\"))"))))
|
||||
status output encoded)
|
||||
(with-temp-buffer
|
||||
(setq status
|
||||
(apply #'call-process (etaf-g1--emacs-executable) nil
|
||||
(list (current-buffer) t) nil arguments)
|
||||
output (buffer-string))
|
||||
(unless (and (integerp status) (zerop status))
|
||||
(ert-fail (format "Fresh %S route probe failed (%S):\n%s"
|
||||
route status output)))
|
||||
(goto-char (point-min))
|
||||
(unless (re-search-forward
|
||||
"^ETAF_G1_ROUTE_EVIDENCE:\\([^[:space:]]+\\)$" nil t)
|
||||
(ert-fail (format "Fresh %S route probe emitted no evidence:\n%s"
|
||||
route output)))
|
||||
(setq encoded (match-string-no-properties 1)))
|
||||
(read (base64-decode-string encoded))))
|
||||
|
||||
(ert-deftest etaf-g1-v1-v2-runtime-equivalence ()
|
||||
"Fresh v1 and v2 bootstraps preserve lifecycle and rollback equivalence."
|
||||
(let* ((v1 (etaf-g1--probe-route-in-fresh-emacs 'v1))
|
||||
(v2 (etaf-g1--probe-route-in-fresh-emacs 'v2))
|
||||
(v1-lifecycle (plist-get v1 :lifecycle-evidence))
|
||||
(v2-lifecycle (plist-get v2 :lifecycle-evidence)))
|
||||
(should (eq (plist-get v1 :selected-route) 'v1))
|
||||
(should (eq (plist-get v2 :selected-route) 'v2))
|
||||
(should (eq (plist-get v1 :bootstrap-outcome)
|
||||
'v1-kill-switch-selected))
|
||||
(should (eq (plist-get v2 :bootstrap-outcome)
|
||||
'valid-v2-selected))
|
||||
(should (plist-get v1 :v2-feature-present))
|
||||
(should (plist-get v1 :v2-predicate-present))
|
||||
(should (plist-get v2 :v2-feature-present))
|
||||
(should (plist-get v2 :v2-predicate-present))
|
||||
(should (eq (plist-get v1 :render-port-selection-policy) 'v1))
|
||||
(should (eq (plist-get v1 :generation-mirror-route) 'project))
|
||||
(should (eq (plist-get v1 :semantic-commit-route) 'cas))
|
||||
(should (eq (plist-get v2 :render-port-selection-policy) 'v2))
|
||||
(should (eq (plist-get v2 :generation-mirror-route) 'project))
|
||||
(should (eq (plist-get v2 :semantic-commit-route) 'cas))
|
||||
(should (plist-get v1 :selected-stable))
|
||||
(should (plist-get v2 :selected-stable))
|
||||
(should (eq (plist-get v1 :initial-dispatch)
|
||||
'etaf-render-port--v1-initial))
|
||||
(should (eq (plist-get v1 :update-dispatch)
|
||||
'etaf-render-port--v1-update))
|
||||
(should (eq (plist-get v2 :initial-dispatch)
|
||||
'ebox-framework-spi-initial))
|
||||
(should (eq (plist-get v2 :update-dispatch)
|
||||
'ebox-framework-spi-update))
|
||||
(dolist (evidence (list v1 v2))
|
||||
(should (= 1 (plist-get evidence :initial-dispatch-count)))
|
||||
(should (= 2 (plist-get evidence :update-dispatch-count))))
|
||||
(dolist (key '(:initial :updated :rolled-back :update-report :lifecycle))
|
||||
(should (equal-including-properties
|
||||
(plist-get v1-lifecycle key) (plist-get v2-lifecycle key))))
|
||||
;; The v2 Host attaches with one generic final marker; legacy v1 performs
|
||||
;; its compatible attach inside the reversible manual stage.
|
||||
(should (= 0 (plist-get v1-lifecycle :initial-marker-count)))
|
||||
(should (= 1 (plist-get v2-lifecycle :initial-marker-count)))
|
||||
(should (= 0 (plist-get v1-lifecycle :update-marker-count)))
|
||||
(should (= 0 (plist-get v2-lifecycle :update-marker-count)))))
|
||||
|
||||
(provide 'etaf-g1-cross-layer-tests)
|
||||
;;; etaf-g1-cross-layer-tests.el ends here
|
||||
@ -12,6 +12,12 @@
|
||||
(file-name-directory (or load-file-name buffer-file-name))))
|
||||
"ETAF package root used by static bootstrap-owner checks.")
|
||||
|
||||
(ert-deftest etaf-render-port-selection-policy-defaults-to-v2 ()
|
||||
"The package's declared bootstrap authority profile defaults to v2."
|
||||
(should
|
||||
(eq (eval (car (get 'etaf-render-port-selection-policy 'standard-value)) t)
|
||||
'v2)))
|
||||
|
||||
(ert-deftest etaf-render-port-selects-valid-v2-immutably ()
|
||||
"A valid provider produces one immutable v2 selected port."
|
||||
(let* ((port (etaf-render-port--bootstrap))
|
||||
@ -57,6 +63,28 @@
|
||||
(should (eq (etaf-render-port-bootstrap-outcome port)
|
||||
'v2-absent-v1-selected))))))
|
||||
|
||||
(ert-deftest etaf-render-port-v1-kill-switch-bypasses-present-provider ()
|
||||
"The explicit v1 profile selects old authority without probing Ebox v2."
|
||||
(let ((etaf-render-port-selection-policy 'v1)
|
||||
(provider-calls 0))
|
||||
(cl-letf (((symbol-function 'ebox-framework-spi-capabilities)
|
||||
(lambda ()
|
||||
(cl-incf provider-calls)
|
||||
(error "kill switch must bypass provider"))))
|
||||
(let ((port (etaf-render-port--bootstrap)))
|
||||
(should (featurep 'ebox-framework-spi-v2))
|
||||
(should (fboundp 'ebox-framework-spi-capabilities))
|
||||
(should (= provider-calls 0))
|
||||
(should (eq (etaf-render-port-route port) 'v1))
|
||||
(should (eq (etaf-render-port-bootstrap-outcome port)
|
||||
'v1-kill-switch-selected))))))
|
||||
|
||||
(ert-deftest etaf-render-port-rejects-invalid-selection-policy ()
|
||||
"A malformed render-port selection policy fails before provider probing."
|
||||
(let ((etaf-render-port-selection-policy 'invalid))
|
||||
(should-error (etaf-render-port--bootstrap)
|
||||
:type 'etaf-spi-bootstrap-error)))
|
||||
|
||||
(ert-deftest etaf-render-port-rejects-half-present-v2 ()
|
||||
"Feature-only and predicate-only providers fail instead of downgrading."
|
||||
(cl-letf (((symbol-function 'ebox-framework-spi-capabilities) nil))
|
||||
@ -511,10 +539,12 @@
|
||||
|
||||
(ert-deftest etaf-render-port-selected-port-is-process-stable ()
|
||||
"Every downstream read returns the one bootstrap-selected port identity."
|
||||
(should (eq (etaf-render-port-selected)
|
||||
(etaf-render-port-selected)))
|
||||
(should (memq (etaf-render-port-route (etaf-render-port-selected))
|
||||
'(v1 v2))))
|
||||
(let* ((selected (etaf-render-port-selected))
|
||||
(route (etaf-render-port-route selected)))
|
||||
(let ((etaf-render-port-selection-policy (if (eq route 'v1) 'v2 'v1)))
|
||||
(should (eq selected (etaf-render-port-selected)))
|
||||
(should (eq route
|
||||
(etaf-render-port-route (etaf-render-port-selected)))))))
|
||||
|
||||
(provide 'etaf-render-port-tests)
|
||||
|
||||
|
||||
@ -156,6 +156,62 @@
|
||||
(should (etaf-condition-postcommit-info decorated))
|
||||
(should (= 3 (length (cdr decorated)))))))
|
||||
|
||||
(ert-deftest etaf-retirement-data-projection-trailer-reader ()
|
||||
"Projection trailers are readable while preserving the condition prefix."
|
||||
(let* ((journal (etaf-retirement-journal-create
|
||||
:operation-id 11 :outcome-id 12 :generation-id 13
|
||||
:revision 14))
|
||||
(trailer (etaf-retirement-condition-trailer
|
||||
journal 'projection
|
||||
:external-commit-certainty 'committed
|
||||
:reconciliation-token 'reconcile-1
|
||||
:projection-token 'projection-1
|
||||
:result 'mutation-result))
|
||||
(condition (append '(etaf-retirement-test-condition "business"
|
||||
(:cause original)) (list trailer)))
|
||||
(info (etaf-data-condition-projection-info condition)))
|
||||
(should info)
|
||||
(should (equal (butlast (cdr condition))
|
||||
'("business" (:cause original))))
|
||||
(should (equal info
|
||||
(list :kind 'projection :committed-p t
|
||||
:external-commit-certainty 'committed
|
||||
:reconciliation-token 'reconcile-1
|
||||
:projection-token 'projection-1
|
||||
:result 'mutation-result
|
||||
:operation-id 11 :outcome-id 12
|
||||
:generation-id 13 :revision 14
|
||||
:diagnostic-journal-id
|
||||
(etaf-retirement-journal-id journal))))
|
||||
(should-not (etaf-condition-postcommit-info condition))
|
||||
;; Unknown versions, malformed payloads, and non-final lookalikes are inert.
|
||||
(should-not
|
||||
(etaf-data-condition-projection-info
|
||||
'(error (:etaf-condition-trailer/v2 (:kind projection)))))
|
||||
(should-not
|
||||
(etaf-data-condition-projection-info
|
||||
'(error (:etaf-condition-trailer/v1
|
||||
(:kind projection :committed-p t
|
||||
:external-commit-certainty committed
|
||||
:reconciliation-token r :projection-token p
|
||||
:operation-id 1 :outcome-id 2 :generation-id 3 :revision 4
|
||||
:diagnostic-journal-id 5 :unexpected x)))))
|
||||
(should
|
||||
(etaf-data-condition-projection-info
|
||||
(list 'error
|
||||
'(:etaf-condition-trailer/v1
|
||||
(:kind projection :committed-p t
|
||||
:external-commit-certainty committed
|
||||
:reconciliation-token r :projection-token p :result result
|
||||
:operation-id 1 :outcome-id 2 :generation-id 3 :revision 4
|
||||
:diagnostic-journal-id 5))
|
||||
'(:etaf-condition-trailer/v1
|
||||
(:kind projection :committed-p t
|
||||
:external-commit-certainty committed
|
||||
:reconciliation-token r :projection-token p :result result
|
||||
:operation-id 1 :outcome-id 2 :generation-id 3 :revision 4
|
||||
:diagnostic-journal-id 6)))))))
|
||||
|
||||
(ert-deftest etaf-retirement-updated-error-is-committed-and-not-rerun ()
|
||||
"Updated hook error carries a trailer while generation and buffer stay new."
|
||||
(let ((buffer-name " *etaf-retirement-update-test*")
|
||||
|
||||
@ -17,6 +17,9 @@
|
||||
(define-error 'etaf-scheduler-test-render-recovery-condition
|
||||
"ETAF scheduler render recovery condition")
|
||||
|
||||
(defvar etaf-scheduler-test-partial-failure-enabled nil)
|
||||
(defvar etaf-scheduler-test-partial-failure-context nil)
|
||||
|
||||
(etaf-define-component etaf-scheduler-test-pair (&key left right)
|
||||
"Render reactive LEFT and RIGHT values."
|
||||
:view
|
||||
@ -45,6 +48,18 @@
|
||||
(signal 'etaf-scheduler-test-projection-condition '("projection")))
|
||||
(etaf-node 'text nil (list (symbol-name status)))))
|
||||
|
||||
(etaf-define-component etaf-scheduler-test-data-partial-failure
|
||||
(&key controller)
|
||||
"Fail the success projection only in one selected scheduler context."
|
||||
:render
|
||||
(let ((status (etaf-value (etaf-data-status controller))))
|
||||
(when (and etaf-scheduler-test-partial-failure-enabled
|
||||
(eq status 'success)
|
||||
(eq (etaf-scheduler-current-context)
|
||||
etaf-scheduler-test-partial-failure-context))
|
||||
(signal 'etaf-scheduler-test-projection-condition '("partial")))
|
||||
(etaf-node 'text nil (list (symbol-name status)))))
|
||||
|
||||
(etaf-define-component etaf-scheduler-test-render-recovery
|
||||
(&key source fail)
|
||||
"Render SOURCE unless FAIL requests a deterministic render error."
|
||||
@ -667,6 +682,79 @@
|
||||
(kill-buffer buffer)))
|
||||
(etaf-data-stop controller))))
|
||||
|
||||
(ert-deftest etaf-scheduler-data-partial-retry-only-failed-context ()
|
||||
"A committed Data projection retries only the context that failed."
|
||||
(let* ((left-buffer " *etaf-scheduler-data-partial-left*")
|
||||
(right-buffer " *etaf-scheduler-data-partial-right*")
|
||||
(left-context (etaf-scheduler-context-create :name 'partial-left))
|
||||
(right-context (etaf-scheduler-context-create :name 'partial-right))
|
||||
(load-count 0)
|
||||
(mutate-count 0)
|
||||
(source
|
||||
(etaf-data-source
|
||||
:load
|
||||
(lambda (_query _page _page-size)
|
||||
(cl-incf load-count)
|
||||
(list :items '(new) :total 2))
|
||||
:mutate-v2
|
||||
(lambda (_operation _payload)
|
||||
(cl-incf mutate-count)
|
||||
'(:certainty committed :result changed))))
|
||||
(controller (etaf-data-controller source
|
||||
:initial-result
|
||||
'(:items (old) :total 1)))
|
||||
(view (etaf--view-call
|
||||
'etaf-scheduler-test-data-partial-failure
|
||||
(list :controller controller) nil))
|
||||
captured)
|
||||
(setq etaf-scheduler-test-partial-failure-enabled nil
|
||||
etaf-scheduler-test-partial-failure-context nil)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount left-buffer view
|
||||
(list :scheduler-context left-context))
|
||||
(etaf-mount right-buffer view
|
||||
(list :scheduler-context right-context))
|
||||
(setq etaf-scheduler-test-partial-failure-context left-context
|
||||
etaf-scheduler-test-partial-failure-enabled t)
|
||||
(let ((left-before (etaf-scheduler-test--metric
|
||||
left-context :runtime-enqueues))
|
||||
(right-before (etaf-scheduler-test--metric
|
||||
right-context :runtime-enqueues)))
|
||||
(condition-case condition
|
||||
(etaf-data-mutate controller 'update 'payload)
|
||||
(etaf-scheduler-test-projection-condition
|
||||
(setq captured condition)))
|
||||
(should captured)
|
||||
(should (= 1 mutate-count))
|
||||
(should (= 1 load-count))
|
||||
(should (equal '(new)
|
||||
(etaf-value (etaf-data-items controller))))
|
||||
(should (eq 'render-pending
|
||||
(etaf-data-reconciliation-state controller)))
|
||||
(let ((right-after (etaf-scheduler-test--metric
|
||||
right-context :runtime-enqueues)))
|
||||
(should (> (- (etaf-scheduler-test--metric
|
||||
left-context :runtime-enqueues)
|
||||
left-before)
|
||||
0))
|
||||
(should (> (- right-after right-before) 0))
|
||||
(setq etaf-scheduler-test-partial-failure-enabled nil)
|
||||
(should (etaf-data-retry-render controller))
|
||||
(should (eq 'projected
|
||||
(etaf-data-reconciliation-state controller)))
|
||||
(should (= right-after
|
||||
(etaf-scheduler-test--metric
|
||||
right-context :runtime-enqueues))))))
|
||||
(setq etaf-scheduler-test-partial-failure-enabled nil
|
||||
etaf-scheduler-test-partial-failure-context nil)
|
||||
(dolist (buffer-name (list left-buffer right-buffer))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))
|
||||
(etaf-data-stop controller))))
|
||||
|
||||
(ert-deftest etaf-scheduler-data-separates-source-and-projection-errors ()
|
||||
"Source failure sets Data error; render failure leaves successful refs."
|
||||
(let* ((buffer-name " *etaf-scheduler-data-projection-error*")
|
||||
|
||||
Loading…
Reference in New Issue
Block a user