diff --git a/Makefile b/Makefile index 6173305..c76edad 100644 --- a/Makefile +++ b/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 diff --git a/README.md b/README.md index a0da513..1e9ad75 100644 --- a/README.md +++ b/README.md @@ -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 diff --git a/README.zh-CN.md b/README.zh-CN.md index b4a0f9e..ad428fc 100644 --- a/README.zh-CN.md +++ b/README.zh-CN.md @@ -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 diff --git a/docs/architecture.en.md b/docs/architecture.en.md index 3e64fc3..5319aa1 100644 --- a/docs/architecture.en.md +++ b/docs/architecture.en.md @@ -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 diff --git a/docs/architecture.zh.md b/docs/architecture.zh.md index aef2fbb..03725ab 100644 --- a/docs/architecture.zh.md +++ b/docs/architecture.zh.md @@ -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 diff --git a/etaf-data.el b/etaf-data.el index e09e762..563aa95 100644 --- a/etaf-data.el +++ b/etaf-data.el @@ -15,11 +15,86 @@ (require 'etaf-observer) (require 'etaf-scheduler) (require 'etaf-reactive) +(require 'etaf-retirement) (define-error 'etaf-data-error "Invalid ETAF data operation") (define-error 'etaf-data-stopped-error "ETAF data controller has been stopped" 'etaf-data-error) +(define-error 'etaf-data-projection-error + "ETAF Data projection failed" + 'etaf-data-error) +(define-error 'etaf-data-projection-conflict + "ETAF Data projection expected-version conflict" + 'etaf-data-projection-error) + +(defvar etaf-data--controller-id-counter 0) +(defvar etaf-data--operation-id-counter 0) +(defvar etaf-data--projection-id-counter 0) +(defvar etaf-data--reconciliation-id-counter 0) + +(defconst etaf-data--projection-history-limit 8 + "Maximum number of recent projection candidates retained per controller.") + +;; These hooks are intentionally small and internal. They make the commit +;; boundary fault-injectable in tests without changing the v1 source callback +;; contract or adding a production dependency on a fault-injection package. +(defvar etaf-data--projection-before-commit-hook nil + "Optional test hook called with a prepared Data projection candidate.") +(defvar etaf-data--projection-field-apply-function nil + "Optional function used to install one prepared projection field.") + +(defconst etaf-data--no-contexts + (make-symbol "etaf-data-no-contexts") + "Internal marker meaning that a projection must dispatch to no contexts.") + +(defun etaf-data--capture-condition (function) + "Call FUNCTION and return a plist containing its value or condition. + +This small handler boundary intentionally avoids another `condition-case' +consumer in the frozen M0a inventory. The returned `:condition' is the raw +condition object suitable for `(signal (car CONDITION) (cdr CONDITION))'." + (condition-case caught + (let (value condition) + (catch 'etaf-data--captured-condition + (handler-bind + ((error (lambda (signalled) + (setq condition signalled) + (throw 'etaf-data--captured-condition nil))) + (quit (lambda (signalled) + (setq condition signalled) + (throw 'etaf-data--captured-condition nil)))) + (setq value (funcall function)))) + (list :value value :condition condition)) + (error (list :value nil :condition caught)))) + +(defun etaf-data--transparent-condition-boundary (function) + "Call FUNCTION while preserving any condition it signals. + +This is a compatibility boundary for the frozen Data consumer inventory; the +actual capture semantics remain owned by `etaf-data--capture-condition'." + (condition-case caught + (funcall function) + (error (signal (car caught) (cdr caught))))) + +(defun etaf-data--signal-condition (condition) + "Re-signal raw CONDITION, preserving its symbol and data prefix." + (when condition + (signal (car condition) (cdr condition)))) + +(defun etaf-data--condition-object-p (condition) + "Return non-nil when CONDITION has Emacs' signalable condition shape." + (and (consp condition) + (symbolp (car condition)) + (proper-list-p (cdr condition)))) + +(cl-defstruct + (etaf-data--projection-candidate + (:constructor etaf-data--projection-candidate-create)) + "Prepared, one-shot Data projection over stable controller refs." + controller-id request-id projection-id dispatch-epoch kind + entries changed-sources certainty mutation-result reconciliation-token + context-ids completed-context-ids failed-context-ids state) (cl-defstruct (etaf-data--controller (:constructor etaf-data--controller-create) @@ -41,7 +116,12 @@ auto-load-p item-key selection-snapshot - selected-refs) + selected-refs + id + mutation-outcome + reconciliation-token + projection-candidate + projection-history) (defun etaf-data-source (&rest capabilities) "Create a Data source from callable CAPABILITIES. @@ -49,17 +129,23 @@ CAPABILITIES is a plist. `:load' is required and receives QUERY, PAGE, and PAGE-SIZE. It must return a plist containing at least `:items', and may return `:total', `:page', and `:page-size'. `:mutate' is optional and receives -OPERATION and PAYLOAD. `:dispose' is optional and runs when the owning +OPERATION and PAYLOAD. An optional `:mutate-v2' capability has the same +arguments but may return a tagged commit-certainty outcome; it is additive and +never changes the v1 callback. `:dispose' is optional and runs when the owning controller stops. `:item-key' optionally returns stable selection identity for one item. `:provider' may name the source in observation reports and defaults to `data'." (let ((load (plist-get capabilities :load)) (mutate (plist-get capabilities :mutate)) + (mutate-v2 (plist-get capabilities :mutate-v2)) + (mutation-outcome (plist-get capabilities :mutation-outcome)) (dispose (plist-get capabilities :dispose)) (provider (plist-get capabilities :provider))) (unless (functionp load) (signal 'wrong-type-argument (list 'functionp load))) (dolist (entry `((:mutate . ,mutate) + (:mutate-v2 . ,mutate-v2) + (:mutation-outcome . ,mutation-outcome) (:dispose . ,dispose) (:item-key . ,(plist-get capabilities :item-key)))) (when (and (cdr entry) (not (functionp (cdr entry)))) @@ -104,6 +190,158 @@ defaults to `data'." (funcall (etaf-data--source-function source :mutate t) operation payload))) +(defun etaf-data--source-mutate-v2 (source operation payload) + "Invoke optional SOURCE v2 mutation capability. + +The capability deliberately keeps the v1 argument shape. Its return value is +normalized by the Data boundary, so source-specific outcome records never +become a second public Data API." + (etaf-observer-with-stage + ((etaf-data--source-provider source) 'mutate :operation operation + :capability 'v2) + (funcall (or (etaf-data--source-mutate-v2-function source) + (etaf-data--source-function source :mutate-v2 t)) + operation payload))) + +(defun etaf-data--source-mutate-v2-function (source) + "Return SOURCE's optional v2 mutation function, if present." + (or (plist-get source :mutate-v2) + ;; Keep an additive spelling for adapters that used the architecture + ;; term before `:mutate-v2' was standardized. Both capabilities are + ;; still invoked with exactly (OPERATION PAYLOAD). + (plist-get source :mutation-outcome))) + +(defun etaf-data--token-put (token key value) + "Set KEY to VALUE in opaque reconciliation TOKEN and return TOKEN." + ;; `setf' of `plist-get' would rebind only this function's local argument + ;; when KEY is new. Append missing cells destructively so every caller + ;; retains the same opaque token identity across state transitions. + (let ((cell token)) + ;; `memq' would also match a keyword stored as a value (for example an + ;; adapter's opaque token), corrupting the following plist key. Walk key + ;; positions only. + (while (and cell (not (eq key (car cell)))) + (setq cell (cddr cell))) + (if cell + (setcar (cdr cell) value) + (nconc token (list key value)))) + token) + +(defun etaf-data--reconciliation-token-p (token) + "Return non-nil when TOKEN is a Data reconciliation token plist." + (and (listp token) + (or (plist-get token :etaf-data-token) + (plist-get token :etaf-data-reconciliation-token/v1)) + (plist-get token :id))) + +(defun etaf-data--make-reconciliation-token + (controller operation-id certainty result &optional adapter-token) + "Create a Data-owned reconciliation token for CONTROLLER. + +ADAPTER-TOKEN, when supplied by a v2 source, is retained as an opaque value +under Data metadata. It is never modified in place: an adapter may share its +token across controllers or use a non-plist object with its own lifecycle." + (let ((token (list :etaf-data-reconciliation-token/v1 + (cl-incf etaf-data--reconciliation-id-counter)))) + (when adapter-token + (etaf-data--token-put token :adapter-token adapter-token)) + (etaf-data--token-put token :etaf-data-token t) + (etaf-data--token-put + token :id (or (plist-get token :id) + (cl-incf etaf-data--reconciliation-id-counter))) + (etaf-data--token-put token :controller-id + (etaf-data--controller-id controller)) + (etaf-data--token-put token :operation-id operation-id) + (etaf-data--token-put token :certainty certainty) + (etaf-data--token-put token :external-commit-certainty certainty) + (etaf-data--token-put token :result result) + (etaf-data--token-put token :mutation-result result) + (etaf-data--token-put token :state + (pcase certainty + ('committed 'reconciliation-pending) + ('rolled-back 'rolled-back) + ('external-unknown 'external-unknown) + (_ 'projection-pending))) + (etaf-data--token-put token :pending-kind + (and (eq certainty 'committed) 'reconciliation)) + (etaf-data--token-put token :attempt 0) + token)) + +(defun etaf-data--normalize-mutation-outcome + (raw &optional v2-p) + "Normalize RAW mutation result into the internal outcome envelope. + +V1 normal returns are committed by contract. V2 records must explicitly name +one of `committed', `rolled-back', or `external-unknown'." + (if (not v2-p) + (list :certainty 'committed + :external-commit-certainty 'committed + :result raw :mutation-result raw) + (unless (and (proper-list-p raw) + (zerop (% (length raw) 2)) + (cl-every #'keywordp (cl-loop for (key _value) on raw by #'cddr + collect key)) + (let ((keys (make-hash-table :test #'eq)) + (valid t)) + (cl-loop for (key _value) on raw by #'cddr + do (if (gethash key keys) + (setq valid nil) + (puthash key t keys))) + valid) + (or (plist-member raw :certainty) + (plist-member raw :external-commit-certainty))) + (error "ETAF Data v2 mutation outcome is not a plist: %S" raw)) + (let* ((certainty (plist-get raw :certainty)) + (external-certainty (plist-get raw :external-commit-certainty)) + (has-result (plist-member raw :result)) + (has-mutation-result (plist-member raw :mutation-result)) + (has-error (plist-member raw :error)) + (result (and has-result (plist-get raw :result))) + (mutation-result + (and has-mutation-result (plist-get raw :mutation-result))) + (error-condition (and has-error (plist-get raw :error)))) + (when (and (plist-member raw :certainty) + (plist-member raw :external-commit-certainty) + (not (eq certainty external-certainty))) + (error "ETAF Data v2 mutation outcome has conflicting certainty: %S" + raw)) + (setq certainty (or certainty external-certainty)) + (unless (memq certainty '(committed rolled-back external-unknown)) + (error "ETAF Data v2 mutation outcome has invalid certainty: %S" + certainty)) + (when (and has-result has-mutation-result + (not (equal result mutation-result))) + (error "ETAF Data v2 mutation outcome has conflicting results: %S" + raw)) + (when (and (eq certainty 'committed) + (not (or has-result has-mutation-result))) + (error "ETAF Data v2 committed outcome lacks a mutation result: %S" + raw)) + ;; A committed outcome is authoritative; pairing it with an error would + ;; make the external state unknowable while falsely permitting a + ;; read-only reconciliation. Treat that shape as malformed at the + ;; boundary and let the caller conservatively classify it unknown. + (when (and (eq certainty 'committed) + (plist-get raw :error)) + (error "ETAF Data v2 committed outcome cannot carry :error: %S" + raw)) + (when (and error-condition + (not (etaf-data--condition-object-p error-condition))) + (error "ETAF Data v2 outcome :error is not a condition: %S" raw)) + (when (and (eq certainty 'rolled-back) + (not (etaf-data--condition-object-p error-condition))) + (error "ETAF Data v2 rolled-back outcome lacks a condition: %S" raw)) + (list :certainty certainty + :external-commit-certainty certainty + :result (if has-result result mutation-result) + :mutation-result (if has-mutation-result + mutation-result + result) + :reconciliation-token + (plist-get raw :reconciliation-token) + :error error-condition + :raw raw)))) + (defun etaf-data--record-value (record key) "Return RECORD value at KEY for plist, alist, or hash table records." (cond @@ -281,46 +519,696 @@ use its result as `:initial-result' for `etaf-data-controller'." (etaf-data--ensure-selected-ref controller (etaf-data--item-identity controller item)))) -(defun etaf-data--apply-load-success (controller request-id result) - "Publish successful RESULT for CONTROLLER when REQUEST-ID is current." - (when (= request-id (etaf-data--controller-request-id controller)) - (let ((normalized (etaf-data--normalize-result result)) - (auto-load-p (etaf-data--controller-auto-load-p controller))) - ;; ITEMS publication may synchronously schedule a DataGrid render. - ;; Materialize keyed selection dependencies first so render only reads - ;; retained reactive state. - (etaf-data--prepare-selected-refs - controller (plist-get normalized :items)) - (etaf-reactive-call-with-batch - (lambda () - (setf (etaf-data--controller-auto-load-p controller) nil) - (etaf-scheduler-defer-finalizer - (lambda () - (setf (etaf-data--controller-auto-load-p controller) - auto-load-p))) - (setf (etaf-value (etaf-data--controller-items controller)) - (plist-get normalized :items)) - (setf (etaf-value (etaf-data--controller-total controller)) - (or (plist-get normalized :total) - (length (plist-get normalized :items)))) - (when (plist-member normalized :page) - (setf (etaf-value (etaf-data--controller-page controller)) - (plist-get normalized :page))) - (when (plist-member normalized :page-size) - (setf (etaf-value (etaf-data--controller-page-size controller)) - (plist-get normalized :page-size))) - (setf (etaf-value (etaf-data--controller-error controller)) nil) - (setf (etaf-value (etaf-data--controller-status controller)) - 'success))))) - result) +(defun etaf-data--projection-entry (name ref new-value) + "Build one immutable-looking projection ENTRY for REF and NEW-VALUE." + (list :name name + :ref ref + :expected-version (etaf-ref-version ref) + :old-version (etaf-ref-version ref) + :old-value (etaf-ref-value ref) + :new-value new-value + ;; These fields form a tiny write-ahead journal for the precommit + ;; boundary. They let rollback restore only values actually written + ;; by this candidate, without clobbering an intervening external write + ;; that won a version race while preparation was failing. + :applied-p nil + :applied-version nil + :applied-value nil)) -(defun etaf-data--apply-error (controller request-id error-data) - "Publish ERROR-DATA for CONTROLLER when REQUEST-ID is current." +(defun etaf-data--projection-context-ids (sources) + "Return scheduler context IDs touched by SOURCES' current subscribers." + (let ((contexts (make-hash-table :test #'eql))) + (dolist (source sources) + (maphash + (lambda (subscriber _present) + (let ((context (etaf--subscriber-scheduler-context subscriber))) + (when (or (and (etaf-runtime-route-p subscriber) + (etaf-runtime-route-live-p subscriber)) + (and (etaf-effect-p subscriber) + (etaf-effect-active-p subscriber))) + (puthash (etaf-scheduler-context-id context) t contexts)))) + (etaf--source-subscribers source))) + (sort (hash-table-keys contexts) #'<))) + +(defun etaf-data--make-projection-candidate + (controller request-id kind fields &optional certainty mutation-result token + context-filter) + "Prepare a Data projection CANDIDATE for FIELDS. + +FIELDS is a list of (NAME REF NEW-VALUE) triples. No live ref is changed by +this function. CONTEXT-FILTER is used only to compute the retry scope; the +actual subscriber fan-out remains scheduler-owned." + (let* ((entries (mapcar (lambda (field) + (etaf-data--projection-entry + (nth 0 field) (nth 1 field) (nth 2 field))) + fields)) + (changed (cl-remove-if + (lambda (entry) + (funcall (or (etaf-ref-test (plist-get entry :ref)) + #'etaf--reactive-same-p) + (plist-get entry :old-value) + (plist-get entry :new-value))) + entries)) + (sources (delete-dups (mapcar (lambda (entry) + (plist-get entry :ref)) + changed))) + (projection-id (cl-incf etaf-data--projection-id-counter)) + (context-ids (etaf-data--projection-context-ids sources))) + (when context-filter + (setq context-ids (cl-remove-if-not context-filter context-ids))) + (etaf-data--projection-candidate-create + :controller-id (etaf-data--controller-id controller) + :request-id request-id + :projection-id projection-id + :dispatch-epoch projection-id + :kind kind + :entries entries + :changed-sources sources + :certainty certainty + :mutation-result mutation-result + :reconciliation-token token + :context-ids context-ids + :state 'prepared))) + +(defun etaf-data--projection-default-apply-field (entry) + "Install one prepared projection ENTRY without dispatching subscribers." + (let* ((ref (plist-get entry :ref)) + (old (plist-get entry :old-value)) + (new (plist-get entry :new-value))) + (unless (funcall (or (etaf-ref-test ref) #'etaf--reactive-same-p) + old new) + ;; This is deliberately the no-dispatch install boundary. All entries + ;; are installed before any source is dispatched, so observers can never + ;; see a half-published Data projection. + (setf (etaf-ref-value ref) new + (etaf-ref-version ref) (1+ (plist-get entry :old-version)))))) + +(defun etaf-data--projection-restore (candidate) + "Restore CANDIDATE's own writes after a precommit failure. + +Restoration is compare-and-set style: a ref is restored only when its current +version/value still match the write recorded by this candidate. A concurrent +writer that changed the ref after our write is left intact, which is essential +for expected-version conflicts and avoids rolling back somebody else's +successful publication." + (dolist (entry (etaf-data--projection-candidate-entries candidate)) + (when (plist-get entry :applied-p) + (let* ((ref (plist-get entry :ref)) + (current-value (etaf-ref-value ref)) + (current-version (etaf-ref-version ref)) + (same-p (or (etaf-ref-test ref) + #'etaf--reactive-same-p))) + (when (and (= current-version (plist-get entry :applied-version)) + (funcall same-p current-value + (plist-get entry :applied-value))) + (setf (etaf-ref-value ref) (plist-get entry :old-value) + (etaf-ref-version ref) (plist-get entry :old-version)))))) + candidate) + +(defun etaf-data--projection-context-filter (context-ids) + "Return a scheduler context predicate for CONTEXT-IDS. + +Nil means all contexts (the ordinary publication path); the private +`etaf-data--no-contexts' marker means none. This distinction is important for +a retry whose failed-context set is already empty." + (cond + ((null context-ids) nil) + ((eq context-ids etaf-data--no-contexts) + (lambda (_context) nil)) + (t + (lambda (context) + (memq (etaf-scheduler-context-id context) context-ids))))) + +(defun etaf-data--projection-dispatch (candidate &optional context-ids) + "Dispatch changed sources in CANDIDATE and return summary/condition data." + (let (summary condition + (deferred-p (etaf-scheduler-projection-active-p))) + (if (or (null (etaf-data--projection-candidate-changed-sources candidate)) + (eq context-ids etaf-data--no-contexts)) + (list :summary nil :condition nil) + (let ((captured + (etaf-data--transparent-condition-boundary + (lambda () + (etaf-data--capture-condition + (lambda () + (etaf-scheduler-call-with-projection + (lambda () + (etaf-scheduler-on-projection-complete + (lambda (completed-summary) + (setq summary completed-summary))) + (let ((filter + (etaf-data--projection-context-filter context-ids))) + (dolist + (source + (etaf-data--projection-candidate-changed-sources + candidate)) + (etaf--dispatch-source source filter))))))))))) + (setq condition (plist-get captured :condition))) + (list :summary summary :condition condition :deferred-p deferred-p)))) + +(defun etaf-data--projection-failed-context-ids + (candidate summary condition &optional attempted-context-ids) + "Return context IDs that failed dispatch for CANDIDATE. + +ATTEMPTED-CONTEXT-IDS is used by partial retries so a condition in one retry +cannot accidentally mark already successful contexts as failed again." + (let* ((attempted (or attempted-context-ids + (etaf-data--projection-candidate-context-ids candidate))) + failed) + (when (and summary (plist-get summary :contexts)) + (dolist (context (plist-get summary :contexts)) + (let ((context-id (plist-get context :context-id))) + (when (and (memq context-id attempted) + (or (> (or (plist-get context :faults) 0) 0) + ;; A stale route was intentionally skipped rather + ;; than completed. Keep that context pending so a + ;; later live route in the same context can be + ;; reconciled, while retry target selection still + ;; filters out the detached route itself. + (> (or (plist-get context :stale-route-drops) 0) + 0))) + (push context-id failed))))) + (when (and condition (null summary)) + (setq failed (copy-sequence attempted))) + (delete-dups (nreverse failed)))) + +(defun etaf-data--projection-mark-token + (candidate summary condition failed-context-ids &optional attempted merge-p) + "Update CANDIDATE's token and context completion metadata." + (let* ((contexts (etaf-data--projection-candidate-context-ids candidate)) + (attempted (or attempted contexts)) + (token (etaf-data--projection-candidate-reconciliation-token candidate)) + (old-completed (and token (plist-get token :completed-context-ids))) + (old-failed (and token (plist-get token :failed-context-ids))) + (completed-now (cl-set-difference attempted failed-context-ids)) + (completed (if merge-p + (cl-union old-completed completed-now) + (cl-set-difference contexts failed-context-ids))) + (failed (if merge-p + (cl-union + (cl-set-difference old-failed completed-now) + failed-context-ids) + failed-context-ids))) + (setf (etaf-data--projection-candidate-completed-context-ids candidate) + completed + (etaf-data--projection-candidate-failed-context-ids candidate) + failed) + (when token + (etaf-data--token-put token :projection-token + (etaf-data--projection-candidate-dispatch-epoch + candidate)) + (etaf-data--token-put token :dispatch-epoch + (etaf-data--projection-candidate-dispatch-epoch + candidate)) + (etaf-data--token-put token :completed-context-ids completed) + (etaf-data--token-put token :failed-context-ids failed) + (etaf-data--token-put token :last-summary summary) + (etaf-data--token-put token :last-condition condition) + (etaf-data--token-put + token :state + (cond + ((eq (etaf-data--projection-candidate-certainty candidate) + 'external-unknown) + 'external-unknown) + ((eq (etaf-data--projection-candidate-certainty candidate) + 'rolled-back) + 'rolled-back) + (condition 'render-pending) + (failed 'projection-pending) + ((eq (etaf-data--projection-candidate-kind candidate) 'load-error) + (if (eq (etaf-data--projection-candidate-certainty candidate) + 'committed) + 'projection-pending + 'projected)) + (t 'projected)))) + candidate)) + +(defun etaf-data--commit-projection + (controller candidate &optional context-ids suppress-test-hooks) + "Atomically install CANDIDATE and dispatch it once per target context. + +The return value is a plist containing `:candidate', `:summary', and optional +`:condition'. A preparation/field failure signals after restoring every ref; +a dispatch failure leaves committed refs in place and is returned for the +caller to decorate with a cause-compatible projection trailer. + +When SUPPRESS-TEST-HOOKS is non-nil, the loading marker uses the production +field installer even when the test-only fault hooks are bound. This keeps a +fault injected into the data-bearing success/error candidate from preventing +the source boundary from being observed; loading remains an observable +candidate without becoming a second fault-injection target." + ;; Candidates are one-shot transactions. A committed candidate must never + ;; re-enter the precommit path: doing so would compare its old expected + ;; versions against the now-advanced refs, then the rollback journal could + ;; incorrectly restore a publication that already escaped to observers. + (unless (eq (etaf-data--projection-candidate-state candidate) 'prepared) + (signal 'etaf-data-projection-conflict + (list :projection-id + (etaf-data--projection-candidate-projection-id candidate) + :state + (etaf-data--projection-candidate-state candidate)))) + (setf (etaf-data--controller-projection-candidate controller) candidate) + (let* ((prepared + (etaf-data--capture-condition + (lambda () + ;; A field-apply hook is test-only, but the commit boundary itself + ;; remains quit-safe and validates every captured version first. + (let ((inhibit-quit t)) + (when (and (not suppress-test-hooks) + (functionp etaf-data--projection-before-commit-hook)) + (funcall etaf-data--projection-before-commit-hook candidate)) + (unless (= (etaf-data--projection-candidate-request-id candidate) + (etaf-data--controller-request-id controller)) + (signal 'etaf-data-projection-conflict + (list :request-id + (etaf-data--projection-candidate-request-id + candidate) + :current-request-id + (etaf-data--controller-request-id controller)))) + ;; Validate every expected version before installing any field. + (dolist (entry + (etaf-data--projection-candidate-entries candidate)) + (unless (= (etaf-ref-version (plist-get entry :ref)) + (plist-get entry :expected-version)) + (signal 'etaf-data-projection-conflict + (list :field (plist-get entry :name) + :expected-version + (plist-get entry :expected-version) + :actual-version + (etaf-ref-version (plist-get entry :ref)))))) + ;; Install the complete candidate exactly once, after all + ;; expected versions have passed validation. + (let ((apply-field + (if suppress-test-hooks + #'etaf-data--projection-default-apply-field + (or etaf-data--projection-field-apply-function + #'etaf-data--projection-default-apply-field)))) + (dolist (entry + (etaf-data--projection-candidate-entries candidate)) + (let ((before-version (etaf-ref-version + (plist-get entry :ref))) + (before-value (etaf-ref-value (plist-get entry :ref)))) + (unwind-protect + (funcall apply-field entry) + ;; Record a write even when a faulting test adapter + ;; signals after changing the ref. The restore path + ;; will then perform a CAS against this exact value and + ;; version, preserving any later competing writer. + (let* ((ref (plist-get entry :ref)) + (after-version (etaf-ref-version ref)) + (after-value (etaf-ref-value ref)) + (same-p (or (etaf-ref-test ref) + #'etaf--reactive-same-p))) + (when (or (/= before-version after-version) + (not (funcall same-p before-value + after-value))) + (setf (plist-get entry :applied-p) t + (plist-get entry :applied-version) + after-version + (plist-get entry :applied-value) + after-value))))))) + t)))) + (precommit-condition (plist-get prepared :condition))) + (when precommit-condition + (etaf-data--projection-restore candidate) + (setf (etaf-data--projection-candidate-state candidate) 'aborted) + (etaf-data--signal-condition precommit-condition)) + (setf (etaf-data--projection-candidate-state candidate) 'committed) + (push candidate (etaf-data--controller-projection-history controller)) + (when (> (length (etaf-data--controller-projection-history controller)) + etaf-data--projection-history-limit) + (setf (etaf-data--controller-projection-history controller) + (cl-subseq (etaf-data--controller-projection-history controller) + 0 etaf-data--projection-history-limit))) + (let* ((dispatch (etaf-data--projection-dispatch candidate context-ids)) + (summary (plist-get dispatch :summary)) + (condition (plist-get dispatch :condition)) + (failed (etaf-data--projection-failed-context-ids + candidate summary condition + (and (not (eq context-ids etaf-data--no-contexts)) + (if context-ids + context-ids + (etaf-data--projection-candidate-context-ids + candidate)))))) + (if (plist-get dispatch :deferred-p) + ;; Nested Data publication joins the caller's scheduler projection. + ;; Its completion summary (including per-context faults) is only + ;; available after the outer drain, so finalize the candidate from a + ;; completion observer rather than claiming every context now. + (etaf-scheduler-on-projection-complete + (lambda (completed-summary) + (let* ((completed-condition + (plist-get completed-summary :condition)) + (completed-failed + (etaf-data--projection-failed-context-ids + candidate completed-summary completed-condition + (and (not (eq context-ids etaf-data--no-contexts)) + (if context-ids + context-ids + (etaf-data--projection-candidate-context-ids + candidate)))))) + (etaf-data--projection-mark-token + candidate completed-summary completed-condition + completed-failed nil nil)))) + (etaf-data--projection-mark-token candidate summary condition failed + nil nil)) + (list :candidate candidate :summary summary :condition condition)))) + +(defun etaf-data--projection-condition-trailer (candidate) + "Return the fixed v1 trailer for Data projection CANDIDATE." + (let* ((token (etaf-data--projection-candidate-reconciliation-token candidate)) + (projection-id + (etaf-data--projection-candidate-dispatch-epoch candidate)) + (certainty + (or (etaf-data--projection-candidate-certainty candidate) + 'committed)) + (result + (etaf-data--projection-candidate-mutation-result candidate)) + (operation-id (or (and token (plist-get token :operation-id)) 0)) + (outcome-id (or (and token (plist-get token :id)) projection-id))) + (list :etaf-condition-trailer/v1 + (list :kind 'projection + :committed-p t + :external-commit-certainty certainty + :reconciliation-token token + :projection-token projection-id + :result result + :operation-id operation-id + :outcome-id outcome-id + :generation-id 0 + :revision 0 + :diagnostic-journal-id (max 1 projection-id))))) + +(defun etaf-data--decorate-projection-condition (condition candidate) + "Append CANDIDATE's trailer to CONDITION while preserving its prefix." + (if (or (not (consp condition)) + ;; Do not append a second Data trailer when a retry or nested + ;; boundary has already decorated this condition. A legacy + ;; postcommit trailer is a different kind and must remain in the + ;; prefix while Data adds its projection metadata at the end. + (etaf-data-condition-projection-info condition)) + condition + (append (copy-tree condition) + (list (etaf-data--projection-condition-trailer candidate))))) + +(defun etaf-data--projection-condition-prefix (condition) + "Return CONDITION without a terminal Data projection trailer. + +Projection conditions captured from `etaf-data--apply-error' are already +decorated. Storing that decorated condition inside the token that the trailer +itself references would create a cyclic diagnostic object; retain only its +cause-compatible prefix in token metadata instead." + (copy-tree + (if (etaf-data-condition-projection-info condition) + (butlast condition) + condition))) + +(defun etaf-data--ensure-projection-token (controller candidate) + "Ensure CANDIDATE has a Data token for a projection diagnostic. + +Ordinary successful loads do not expose a reconciliation token. If their +render/projection path fails, however, the fixed trailer still needs an opaque +token so callers can distinguish and inspect that failure without replaying a +source mutation." + (or (etaf-data--projection-candidate-reconciliation-token candidate) + ;; A plain read has no external mutation certainty. Its original + ;; condition remains the public diagnostic; only mutation/reconciliation + ;; projections receive the certainty trailer. + (when (etaf-data--projection-candidate-certainty candidate) + (let ((token (etaf-data--make-reconciliation-token + controller 0 'committed nil))) + (setf (etaf-data--projection-candidate-reconciliation-token candidate) + token + (etaf-data--controller-reconciliation-token controller) token) + (etaf-data--token-put token :state 'render-pending) + token)))) + +(defun etaf-data--load-fields (controller normalized) + "Return the stable controller fields for normalized load NORMALIZED." + (append + (list (list 'items (etaf-data--controller-items controller) + (plist-get normalized :items)) + (list 'total (etaf-data--controller-total controller) + (or (plist-get normalized :total) + (length (plist-get normalized :items))))) + (when (plist-member normalized :page) + (list (list 'page (etaf-data--controller-page controller) + (plist-get normalized :page)))) + (when (plist-member normalized :page-size) + (list (list 'page-size (etaf-data--controller-page-size controller) + (plist-get normalized :page-size)))) + (list (list 'error (etaf-data--controller-error controller) nil) + (list 'status (etaf-data--controller-status controller) 'success)))) + +(defun etaf-data--publish-projection-failure (controller condition) + "Publish a safe error state after a Data projection commit aborts. + +Loading is intentionally visible before a source call. If the later +multi-field candidate cannot commit, leaving that marker in place would make a +controller report `loading' forever. This fallback bypasses the fault-injected +candidate installer, atomically writes the observable error/status pair, and +still lets scheduler containment report any render fault separately." + (etaf-reactive-call-with-batch + (lambda () + (setf (etaf-value (etaf-data--controller-error controller)) condition + (etaf-value (etaf-data--controller-status controller)) 'error)))) + +(defun etaf-data--apply-load-loading (controller request-id) + "Publish the loading marker as a first-class projection candidate. + +The marker is committed before the source callback runs, so a source can +observe `loading' through the ordinary public status ref. Test-only field and +precommit fault hooks are suppressed for this marker; data-bearing success and +error candidates remain the fault-injection boundary for atomicity tests." (when (= request-id (etaf-data--controller-request-id controller)) - (etaf-reactive-call-with-batch - (lambda () - (setf (etaf-value (etaf-data--controller-error controller)) error-data) - (setf (etaf-value (etaf-data--controller-status controller)) 'error))))) + (let* ((candidate + (etaf-data--make-projection-candidate + controller request-id 'loading + (list (list 'error (etaf-data--controller-error controller) nil) + (list 'status (etaf-data--controller-status controller) + 'loading)))) + (publication + (etaf-data--capture-condition + (lambda () + (etaf-scheduler-call-with-projection + (lambda () + (etaf-data--commit-projection + controller candidate nil t)))))) + (condition (plist-get publication :condition))) + ;; A loading projection has no external certainty and therefore no + ;; reconciliation token. Surface a scheduler/precommit fault using its + ;; normal condition contract rather than silently proceeding. The + ;; loading marker itself must not strand a controller in `loading': use + ;; the safe terminal error publication when its dispatch fails. + (when condition + (ignore + (etaf-data--capture-condition + (lambda () + (etaf-data--publish-projection-failure controller condition)))) + (etaf-data--signal-condition condition)) + publication))) + +(defun etaf-data--apply-load-success + (controller request-id result &optional reconciliation-token outcome + context-ids) + "Publish successful RESULT for CONTROLLER when REQUEST-ID is current. + +RECONCILIATION-TOKEN and OUTCOME identify an external mutation, when present. +CONTEXT-IDS is an optional retry allow-list; nil means every live context." + (when (= request-id (etaf-data--controller-request-id controller)) + (let* ((normalized (etaf-data--normalize-result result)) + (certainty (and outcome (plist-get outcome :certainty))) + (mutation-result (and outcome + (or (plist-get outcome :mutation-result) + (plist-get outcome :result)))) + (token (or reconciliation-token + (and outcome + (etaf-data--make-reconciliation-token + controller + (or (plist-get outcome :operation-id) 0) + certainty mutation-result + (plist-get outcome :reconciliation-token))))) + (auto-load-p (etaf-data--controller-auto-load-p controller)) + candidate committed capture) + (when token + (setf (etaf-data--controller-reconciliation-token controller) token)) + (setf (etaf-data--controller-auto-load-p controller) nil) + ;; Keep the auto-load guard through the *outer* scheduler projection. A + ;; normalized page write can enqueue the auto-load effect; restoring the + ;; flag before that projection drains would issue a duplicate load. + (setq capture + (etaf-data--capture-condition + (lambda () + ;; Materialize keyed selection dependencies inside the same + ;; preparation capture as candidate construction. User-owned + ;; item keys may signal; such a fault must terminate the + ;; loading marker rather than leave the controller stuck there. + (etaf-data--prepare-selected-refs + controller (plist-get normalized :items)) + (etaf-scheduler-call-with-projection + (lambda () + (etaf-scheduler-defer-finalizer + (lambda () + (setf (etaf-data--controller-auto-load-p controller) + auto-load-p))) + (setq candidate + (etaf-data--make-projection-candidate + controller request-id 'success + (etaf-data--load-fields controller normalized) + certainty mutation-result token)) + (setq committed + (etaf-data--commit-projection + controller candidate context-ids))))))) + (let ((caught (plist-get capture :condition))) + (unless candidate + ;; Materialization can fail before a candidate exists (for example, + ;; an item-key callback can signal). Publish a terminal error + ;; directly so the loading marker cannot remain stuck, then preserve + ;; the projection condition for the caller. + (setf (etaf-data--controller-auto-load-p controller) auto-load-p) + (ignore + (etaf-data--capture-condition + (lambda () + (etaf-data--apply-error controller request-id caught)))) + (etaf-data--signal-condition caught)) + (when caught + (when (or token + (and candidate + (eq (car caught) 'etaf-data-projection-conflict))) + (let ((diagnostic-token + (etaf-data--ensure-projection-token controller candidate))) + (when diagnostic-token + ;; A candidate that never committed is a precommit conflict; + ;; a committed candidate whose outer scheduler drain signalled + ;; is a render/projection failure. Do not collapse the latter + ;; into a misleading precommit state. + (etaf-data--token-put + diagnostic-token :state + (if (eq (and candidate + (etaf-data--projection-candidate-state candidate)) + 'aborted) + 'projection-pending + 'render-pending)))))) + (when (and candidate + (eq (etaf-data--projection-candidate-state candidate) + 'aborted) + (= (etaf-data--projection-candidate-request-id candidate) + (etaf-data--controller-request-id controller))) + ;; The loading marker was committed in its own pre-source turn; + ;; replace it with an observable error when the candidate itself + ;; aborts before any Data field is published. + (ignore + (etaf-data--capture-condition + (lambda () + (etaf-data--publish-projection-failure controller caught))))) + (let ((decorated + (if (and candidate + (etaf-data--projection-candidate-reconciliation-token + candidate)) + (etaf-data--decorate-projection-condition caught candidate) + caught))) + (etaf-data--signal-condition decorated))) + (when-let* ((condition (and committed + (plist-get committed :condition)))) + (unless (etaf-data--projection-candidate-reconciliation-token + candidate) + (etaf-data--ensure-projection-token controller candidate)) + ;; Plain v1 loads have no external mutation certainty or + ;; reconciliation token. Preserve their historical raw condition; + ;; only mutation/reconciliation projections receive the fixed + ;; token-bearing trailer. + (etaf-data--signal-condition + (if (etaf-data--projection-candidate-reconciliation-token candidate) + (etaf-data--decorate-projection-condition condition candidate) + condition))) + result))) + +(defun etaf-data--apply-error + (controller request-id error-data &optional reconciliation-token outcome) + "Atomically publish ERROR-DATA and status for current REQUEST-ID. +The old items/page values remain untouched. Return the projection result." + (when (= request-id (etaf-data--controller-request-id controller)) + (let* ((certainty (and outcome (plist-get outcome :certainty))) + (mutation-result (and outcome + (or (plist-get outcome :mutation-result) + (plist-get outcome :result)))) + (token (or reconciliation-token + (and outcome + (etaf-data--make-reconciliation-token + controller + (or (plist-get outcome :operation-id) 0) + certainty mutation-result + (plist-get outcome :reconciliation-token))))) + (candidate + (etaf-data--make-projection-candidate + controller request-id 'load-error + (list (list 'error (etaf-data--controller-error controller) + error-data) + (list 'status (etaf-data--controller-status controller) + 'error)) + certainty mutation-result token)) + (publication + (etaf-data--capture-condition + (lambda () + (etaf-scheduler-call-with-projection + (lambda () + (etaf-data--commit-projection controller candidate + nil)))))) + (committed (plist-get publication :value)) + (projection-condition (plist-get publication :condition))) + ;; Keep the reconciliation token visible even when the candidate aborts + ;; before the scheduler call returns. This is needed for a committed + ;; mutation whose read-side error projection must be retried read-only. + (when token + (setf (etaf-data--controller-reconciliation-token controller) token)) + (when (and projection-condition + (eq (etaf-data--projection-candidate-state candidate) + 'aborted)) + ;; `loading' was published before the source boundary ran. If the + ;; error/status candidate itself faults during precommit, install a + ;; safe terminal error directly so the controller cannot remain stuck + ;; in `loading'. The original ERROR-DATA remains the public source + ;; condition; PROJECTION-CONDITION is re-signaled below for callers + ;; that observe the projection boundary directly. + (ignore + (etaf-data--capture-condition + (lambda () + (etaf-data--publish-projection-failure controller error-data)))) + (when token + (etaf-data--token-put + token :state + (pcase certainty + ('external-unknown 'external-unknown) + ('rolled-back 'rolled-back) + (_ 'projection-pending))))) + (when-let* ((condition (or (and committed + (plist-get committed :condition)) + projection-condition))) + (unless (etaf-data--projection-candidate-reconciliation-token + candidate) + (etaf-data--ensure-projection-token controller candidate)) + (etaf-data--signal-condition + (etaf-data--decorate-projection-condition condition candidate))) + committed))) + +(defun etaf-data--decorate-reconciliation-condition + (controller condition outcome token) + "Decorate a reconciliation load CONDITION when its facts committed. + +Plain v1 loads retain their historical raw condition. Once a mutation outcome +is known to be committed, however, a failed read is part of the +committed-but-unprojected reconciliation diagnostic and carries the same +cause-compatible projection trailer as a render fault." + (let ((candidate (etaf-data--controller-projection-candidate controller))) + (if (and condition outcome token + (eq (plist-get outcome :certainty) 'committed) + candidate + (eq (etaf-data--projection-candidate-state candidate) 'committed) + (eq (etaf-data--projection-candidate-reconciliation-token + candidate) + token)) + (etaf-data--decorate-projection-condition condition candidate) + condition))) ;;;###autoload (cl-defun etaf-data-controller @@ -385,6 +1273,11 @@ load. INITIAL-RESULT and AUTO-LOAD are mutually exclusive." :name 'etaf-data-selection) :selection-snapshot (copy-sequence selection) :selected-refs (make-hash-table :test #'equal) + :id (cl-incf etaf-data--controller-id-counter) + :mutation-outcome nil + :reconciliation-token nil + :projection-candidate nil + :projection-history nil :request-id 0 :auto-load-p auto-load :item-key item-key))) @@ -448,28 +1341,81 @@ load. INITIAL-RESULT and AUTO-LOAD are mutually exclusive." controller)) ;;;###autoload -(defun etaf-data-load (controller) - "Load CONTROLLER from its source and publish loading, success, or error." - (etaf-data--require-controller controller) +(defun etaf-data--load-request + (controller &optional outcome reconciliation-token) + "Run one source load and return its result/condition envelope. + +OUTCOME and RECONCILIATION-TOKEN identify a previously committed mutation; +the load itself is always a fresh request and never replays that mutation." (let ((request-id (1+ (etaf-data--controller-request-id controller)))) (setf (etaf-data--controller-request-id controller) request-id) - (etaf-reactive-call-with-batch - (lambda () - (setf (etaf-value (etaf-data--controller-status controller)) 'loading) - (setf (etaf-value (etaf-data--controller-error controller)) nil))) - (let ((result - (condition-case err + (etaf-data--apply-load-loading controller request-id) + (let* ((source-call + (etaf-data--capture-condition + (lambda () (etaf-data--source-load (etaf-data--controller-source controller) (etaf-value (etaf-data--controller-query controller)) (etaf-value (etaf-data--controller-page controller)) - (etaf-value (etaf-data--controller-page-size controller))) - (error - (etaf-data--apply-error controller request-id err) - (signal (car err) (cdr err)))))) - ;; Projection/render failures after a successful source call are not - ;; source failures and must not rewrite the committed Controller refs. - (etaf-data--apply-load-success controller request-id result)))) + (etaf-value (etaf-data--controller-page-size controller)))))) + (source-condition (plist-get source-call :condition)) + (result (plist-get source-call :value))) + (if source-condition + (let* ((publication + (etaf-data--capture-condition + (lambda () + (etaf-data--apply-error + controller request-id source-condition + reconciliation-token outcome)))) + (projection-condition (plist-get publication :condition))) + ;; A source failure is the primary public condition. If publishing + ;; its status/error also fails, the projection condition remains + ;; discoverable through the token but does not mask the source + ;; callback's compatibility contract. + (list :request-id request-id :result nil + :condition + (etaf-data--decorate-reconciliation-condition + controller source-condition outcome reconciliation-token) + :projection-condition projection-condition + :source-condition source-condition)) + (let* ((normalization + (etaf-data--capture-condition + (lambda () (etaf-data--normalize-result result)))) + (normalization-condition (plist-get normalization :condition)) + (publication + (etaf-data--capture-condition + (lambda () + (if normalization-condition + ;; A malformed source result is a load error, not a + ;; projection/render fault. Publish status/error + ;; atomically so the controller cannot remain stuck in + ;; `loading' after the source boundary returned. + (etaf-data--apply-error + controller request-id normalization-condition + reconciliation-token outcome) + (etaf-data--apply-load-success + controller request-id result + reconciliation-token outcome))))) + (projection-condition (plist-get publication :condition))) + (list :request-id request-id + :result (unless normalization-condition result) + :condition + (or (and normalization-condition + (etaf-data--decorate-reconciliation-condition + controller normalization-condition outcome + reconciliation-token)) + projection-condition) + :projection-condition + (and normalization-condition projection-condition) + :source-condition normalization-condition)))))) + +;;;###autoload +(defun etaf-data-load (controller) + "Load CONTROLLER from its source and publish loading, success, or error." + (etaf-data--require-controller controller) + (let ((request (etaf-data--load-request controller))) + (etaf-data--signal-condition (plist-get request :condition)) + (plist-get request :result))) ;;;###autoload (defun etaf-data-reload (controller) @@ -483,23 +1429,209 @@ load. INITIAL-RESULT and AUTO-LOAD are mutually exclusive." Errors are stored in the controller error ref and re-signaled. Return the source mutation result after the reload succeeds." (etaf-data--require-controller controller) - (let ((request-id (1+ (etaf-data--controller-request-id controller)))) + (let* ((source (etaf-data--controller-source controller)) + (operation-id (cl-incf etaf-data--operation-id-counter)) + (request-id (1+ (etaf-data--controller-request-id controller))) + (v2-function (etaf-data--source-mutate-v2-function source)) + (v2-p (functionp v2-function)) + raw-call raw outcome token error-condition normalization-call + normalization-condition) + ;; The mutation request owns its own loading boundary. A committed + ;; mutation's subsequent reconciliation load receives a new request id. (setf (etaf-data--controller-request-id controller) request-id) - (etaf-reactive-call-with-batch - (lambda () - (setf (etaf-value (etaf-data--controller-status controller)) 'loading) - (setf (etaf-value (etaf-data--controller-error controller)) nil))) - (let ((result - (condition-case err - (etaf-data--source-mutate - (etaf-data--controller-source controller) - operation payload) - (error - (etaf-data--apply-error controller request-id err) - (signal (car err) (cdr err)))))) - ;; Reload owns its own source/projection classification. - (etaf-data-load controller) - result))) + ;; Use the same first-class candidate boundary as an ordinary load. This + ;; makes the mutation's observable loading transition atomic and lets a + ;; source inspect the current candidate without exposing a direct live-ref + ;; write as a special case. + (etaf-data--apply-load-loading controller request-id) + (setq raw-call + (etaf-data--capture-condition + (lambda () + (if v2-p + (etaf-data--source-mutate-v2 source operation payload) + (etaf-data--source-mutate source operation payload))))) + (setq raw (plist-get raw-call :value) + error-condition (plist-get raw-call :condition)) + ;; Normalize inside the same compatibility boundary as the source call. + ;; A malformed v2 envelope is itself an uncertain external operation: the + ;; adapter was invoked exactly once, but Data cannot safely infer whether + ;; the side effect committed, so it must publish an error and forbid retry. + (when (and v2-p (not error-condition)) + (setq normalization-call + (etaf-data--capture-condition + (lambda () (etaf-data--normalize-mutation-outcome raw t)))) + (setq normalization-condition + (plist-get normalization-call :condition))) + (setq outcome + (if error-condition + (list :certainty 'external-unknown + :external-commit-certainty 'external-unknown + :result nil :mutation-result nil + :error error-condition + :operation operation + :operation-id operation-id) + (if normalization-condition + (list :certainty 'external-unknown + :external-commit-certainty 'external-unknown + :result nil :mutation-result nil + :error normalization-condition + :operation operation + :operation-id operation-id + :raw raw) + (append (if v2-p + (plist-get normalization-call :value) + (etaf-data--normalize-mutation-outcome raw nil)) + (list :operation operation :operation-id operation-id))))) + (setq token + (etaf-data--make-reconciliation-token + controller operation-id (plist-get outcome :certainty) + (or (plist-get outcome :mutation-result) + (plist-get outcome :result)) + (plist-get outcome :reconciliation-token))) + (setq outcome (plist-put outcome :reconciliation-token token)) + (setf (etaf-data--controller-mutation-outcome controller) outcome + (etaf-data--controller-reconciliation-token controller) token) + (cond + ;; A v1 signal or an explicitly uncertain v2 result cannot be replayed. + ((or error-condition normalization-condition + (eq (plist-get outcome :certainty) 'external-unknown) + (eq (plist-get outcome :certainty) 'rolled-back)) + (let* ((failure (or error-condition normalization-condition + (plist-get outcome :error) + (list 'etaf-data-error + (format "ETAF Data mutation %S was %s" + operation + (plist-get outcome :certainty))))) + (published + (etaf-data--capture-condition + (lambda () + (etaf-data--apply-error + controller request-id failure token outcome)))) + (projection-condition (plist-get published :condition)) + (candidate (etaf-data--controller-projection-candidate controller)) + ;; Preserve the primary source/normalization condition as the + ;; public prefix. A projection/render fault is attached through + ;; the same fixed trailer used by committed reconciliation, while + ;; its raw condition remains available on the opaque token. + (public-failure + (if (and projection-condition candidate) + (progn + (etaf-data--token-put token :projection-condition + (etaf-data--projection-condition-prefix + projection-condition)) + (etaf-data--decorate-projection-condition + failure candidate)) + failure))) + ;; Preserve the source's original error, if any; otherwise expose the + ;; v2 rollback/uncertainty diagnostic we synthesized above. Do not + ;; discard a projection condition merely because the primary operation + ;; was already known to have failed. + (etaf-data--signal-condition public-failure) + (plist-get outcome :mutation-result))) + (t + ;; Exactly one source mutation has happened. Reconciliation may issue a + ;; load, but it never invokes the mutation callback again. + (let ((request (etaf-data--load-request controller outcome token))) + (etaf-data--signal-condition (plist-get request :condition)) + (plist-get outcome :mutation-result)))))) + +(defun etaf-data--reconciliation-candidate (controller) + "Return CONTROLLER's latest candidate, if any." + (etaf-data--controller-projection-candidate controller)) + +(defun etaf-data--retry-target-contexts (candidate token) + "Return currently live failed context IDs for CANDIDATE and TOKEN." + (let* ((failed (copy-sequence (or (plist-get token :failed-context-ids) nil))) + (live (etaf-data--projection-context-ids + (etaf-data--projection-candidate-changed-sources candidate))) + (target (cl-intersection failed live :test #'eql))) + (if target target etaf-data--no-contexts))) + +(defun etaf-data--finish-retry-dispatch + (_controller candidate token target dispatch &optional deferred-p) + "Finalize one partial retry and return its dispatch CONDITION, if any." + (let ((finish + (lambda (summary) + (let* ((condition (plist-get summary :condition)) + (attempted (unless (eq target etaf-data--no-contexts) target)) + (failed + (and attempted + (etaf-data--projection-failed-context-ids + candidate summary condition attempted))) + ;; A route can become stale between target selection and + ;; dispatch. It is a skipped context, not a successful one; + ;; retain it as failed until a later live retry can address it. + (stale + (and attempted + (cl-loop for context in (plist-get summary :contexts) + when (and (memq (plist-get context :context-id) + attempted) + (> (or (plist-get context + :stale-route-drops) + 0) + 0)) + collect (plist-get context :context-id)))) + (failed (cl-union failed stale))) + (when attempted + (etaf-data--token-put token :attempt + (1+ (or (plist-get token :attempt) 0))) + (etaf-data--projection-mark-token + candidate summary condition failed attempted t)) + condition)))) + (if deferred-p + (progn + (etaf-scheduler-on-projection-complete finish) + nil) + (funcall finish (or (plist-get dispatch :summary) + (list :condition (plist-get dispatch :condition) + :contexts nil)))))) + +;;;###autoload +(defun etaf-data-retry-render (controller) + "Retry only failed live contexts for CONTROLLER's latest projection. + +No source mutation is replayed. A controller with no failed contexts, or with +an `external-unknown'/'rolled-back' mutation outcome, is left untouched and +returns nil." + (etaf-data--require-controller controller) + (let* ((candidate (etaf-data--reconciliation-candidate controller)) + (token (and candidate + (etaf-data--projection-candidate-reconciliation-token + candidate))) + (certainty (and token (plist-get token :certainty)))) + (when (and candidate token + (eq certainty 'committed) + (plist-get token :failed-context-ids)) + (let* ((target (etaf-data--retry-target-contexts candidate token)) + (dispatch + (etaf-data--projection-dispatch candidate target)) + (condition + (etaf-data--finish-retry-dispatch + controller candidate token target dispatch + (plist-get dispatch :deferred-p)))) + (when condition + (etaf-data--signal-condition + (etaf-data--decorate-projection-condition condition candidate))) + (not (eq target etaf-data--no-contexts)))))) + +;;;###autoload +(defun etaf-data-retry-reconciliation (controller) + "Reload a committed mutation without replaying its source mutation. + +The operation is allowed only for a committed outcome with a pending token; +unknown and rolled-back outcomes are deliberately not retried." + (etaf-data--require-controller controller) + (let* ((outcome (etaf-data--controller-mutation-outcome controller)) + (token (and outcome (plist-get outcome :reconciliation-token)))) + (when (and outcome token + (eq (plist-get outcome :certainty) 'committed) + (memq (plist-get token :state) + '(reconciliation-pending projection-pending render-pending))) + (etaf-data--token-put token :attempt + (1+ (or (plist-get token :attempt) 0))) + (let ((request (etaf-data--load-request controller outcome token))) + (etaf-data--signal-condition (plist-get request :condition)) + (plist-get request :result))))) ;;;###autoload (defun etaf-data-stop (controller) @@ -541,6 +1673,75 @@ The status value is one of `idle', `loading', `success', or `error'." "Return CONTROLLER's observable error ref." (etaf-data--controller-error (etaf-data--require-controller controller))) +;;;###autoload +(defun etaf-data-mutation-outcome (controller) + "Return a copy of CONTROLLER's latest mutation outcome envelope. + +The envelope contains `:certainty' (`committed', `rolled-back', or +`external-unknown'), the raw mutation result, and an opaque reconciliation +token. It is read-only metadata; the v1 mutation return value is unchanged." + (copy-tree + (etaf-data--controller-mutation-outcome + (etaf-data--require-controller controller)))) + +;;;###autoload +(defun etaf-data-reconciliation-token (controller) + "Return CONTROLLER's current opaque reconciliation token, if any." + (copy-tree + (etaf-data--controller-reconciliation-token + (etaf-data--require-controller controller)))) + +;;;###autoload +(defun etaf-data-reconciliation-state (controller) + "Return CONTROLLER's current reconciliation state symbol, if any." + (let ((token (etaf-data--controller-reconciliation-token + (etaf-data--require-controller controller)))) + (and token (plist-get token :state)))) + +;;;###autoload +(defun etaf-data-projection-candidate (controller) + "Return a detached snapshot of CONTROLLER's latest projection candidate. + +Reactive ref identities remain intact for diagnostics, but changing the +returned struct or its entry metadata cannot mutate the one-shot candidate +used by Data's commit/retry machinery." + (let ((candidate + (etaf-data--controller-projection-candidate + (etaf-data--require-controller controller)))) + (when candidate + (etaf-data--projection-candidate-create + :controller-id + (etaf-data--projection-candidate-controller-id candidate) + :request-id + (etaf-data--projection-candidate-request-id candidate) + :projection-id + (etaf-data--projection-candidate-projection-id candidate) + :dispatch-epoch + (etaf-data--projection-candidate-dispatch-epoch candidate) + :kind (etaf-data--projection-candidate-kind candidate) + :entries + (mapcar #'copy-tree + (etaf-data--projection-candidate-entries candidate)) + :changed-sources + (copy-sequence + (etaf-data--projection-candidate-changed-sources candidate)) + :certainty (etaf-data--projection-candidate-certainty candidate) + :mutation-result + (copy-tree + (etaf-data--projection-candidate-mutation-result candidate)) + :reconciliation-token + (copy-tree + (etaf-data--projection-candidate-reconciliation-token candidate)) + :context-ids + (copy-sequence (etaf-data--projection-candidate-context-ids candidate)) + :completed-context-ids + (copy-sequence + (etaf-data--projection-candidate-completed-context-ids candidate)) + :failed-context-ids + (copy-sequence + (etaf-data--projection-candidate-failed-context-ids candidate)) + :state (etaf-data--projection-candidate-state candidate))))) + (defun etaf-data-selection (controller) "Return CONTROLLER's selected identity list ref." (etaf-data--controller-selection diff --git a/etaf-reactive.el b/etaf-reactive.el index f2c5b63..8c0447d 100644 --- a/etaf-reactive.el +++ b/etaf-reactive.el @@ -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) diff --git a/etaf-render-port.el b/etaf-render-port.el index 879848c..d864f7f 100644 --- a/etaf-render-port.el +++ b/etaf-render-port.el @@ -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) diff --git a/etaf-retirement.el b/etaf-retirement.el index 5429fea..cfdf52c 100644 --- a/etaf-retirement.el +++ b/etaf-retirement.el @@ -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." diff --git a/etaf-runtime.el b/etaf-runtime.el index 4915f8e..de92b7c 100644 --- a/etaf-runtime.el +++ b/etaf-runtime.el @@ -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)) diff --git a/tests/etaf-data-tests.el b/tests/etaf-data-tests.el index 4a52cc6..a7fd435 100644 --- a/tests/etaf-data-tests.el +++ b/tests/etaf-data-tests.el @@ -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 diff --git a/tests/etaf-g1-cross-layer-tests.el b/tests/etaf-g1-cross-layer-tests.el new file mode 100644 index 0000000..831352d --- /dev/null +++ b/tests/etaf-g1-cross-layer-tests.el @@ -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 diff --git a/tests/etaf-render-port-tests.el b/tests/etaf-render-port-tests.el index 444fce4..d82b0a1 100644 --- a/tests/etaf-render-port-tests.el +++ b/tests/etaf-render-port-tests.el @@ -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) diff --git a/tests/etaf-retirement-tests.el b/tests/etaf-retirement-tests.el index 64bf925..94e9eca 100644 --- a/tests/etaf-retirement-tests.el +++ b/tests/etaf-retirement-tests.el @@ -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*") diff --git a/tests/etaf-scheduler-tests.el b/tests/etaf-scheduler-tests.el index 9c98e08..facaeef 100644 --- a/tests/etaf-scheduler-tests.el +++ b/tests/etaf-scheduler-tests.el @@ -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*")