diff --git a/Makefile b/Makefile index fd5dff6..09987cf 100644 --- a/Makefile +++ b/Makefile @@ -1,8 +1,8 @@ EMACS ?= emacs LOAD_PATH = -L . -L examples -L scripts -L ../ebox -L ../tp -L ../ecss -SOURCES = etaf-view.el etaf-compiler.el etaf-component.el etaf-reactive.el etaf-observer.el etaf-context.el etaf-theme-tp.el etaf-resource.el etaf-data.el etaf-generation.el etaf-host.el etaf-render-port.el etaf-renderer.el etaf-runtime.el etaf-behavior.el etaf-actions.el etaf-events.el etaf-performance.el etaf.el scripts/emacs-gui-verifier.el +SOURCES = etaf-view.el etaf-compiler.el etaf-component.el etaf-reactive.el etaf-observer.el etaf-context.el etaf-theme-tp.el etaf-resource.el etaf-data.el etaf-generation.el etaf-host.el etaf-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 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 = 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 .PHONY: test compile load checkdoc docs-check check clean diff --git a/docs/architecture.en.md b/docs/architecture.en.md index 0ff3152..bc40d49 100644 --- a/docs/architecture.en.md +++ b/docs/architecture.en.md @@ -474,6 +474,25 @@ source routes validate both attached state and token. Detach invalidates the token at one O(1) boundary before removing registries, routes, Component scopes, or Behaviors, so cleanup volume or failure cannot revive the old Host. +Lifecycle callbacks and structural cleanup run after that commit boundary in +an `etaf-retirement-journal`. Every entry has a stable identity, ordering key, +attempt count, policy, and terminal state. Public mounted, updated, and +unmounted callbacks are run once; the first public failure abandons later +public callbacks while structural cleanup continues. Idempotent framework +cleanup has a bounded retry count, and contained cleanup records diagnostics +without changing the committed generation, Ebox revision, or Host authority. +Completed journals are retained separately from committed outcomes on the +Runtime, with a bounded history. + +When an explicit operation must expose a postcommit callback failure, ETAF +re-signals the original condition symbol and preserves its original data as a +prefix. It appends one fixed `:etaf-condition-trailer/v1` datum containing the +operation, outcome, generation, Ebox revision, and diagnostic-journal IDs. +`etaf-condition-postcommit-info` validates and reads that trailer, so callers +can distinguish “committed, then callback failed” from a rollback failure. +The buffer-kill path drains or contains retirement work but never throws a +retirement condition from the kill hook. + Each Runtime flush records a candidate-aware effect tuple containing the generation id, effect-to-source edges and source versions, plus an immutable semantic-node stamp for candidate input/context/output facts. A repeated tuple diff --git a/docs/architecture.zh.md b/docs/architecture.zh.md index bafa665..9f8cd56 100644 --- a/docs/architecture.zh.md +++ b/docs/architecture.zh.md @@ -461,6 +461,22 @@ lookup、event 和 source route 同时校验 attached state 与 token。detach 边界让 token 失效,再清理 registry、routes、Component scopes 和 Behaviors;因此 cleanup 数量或错误不能让旧 Host 重新获得 authority。 +lifecycle callback 与结构 cleanup 在该 commit boundary 之后进入 +`etaf-retirement-journal`。每个 entry 都有稳定 identity、ordering key、attempt +count、policy 与 terminal state。mounted、updated、unmounted 等公开 callback +只运行一次;第一个公开 callback 失败后,后续公开 callback 标记为 abandoned, +但结构 cleanup 继续。可幂等的框架 cleanup 只做有上限的重试;contained cleanup +只写 diagnostics,不改变已提交 generation、Ebox revision 或 Host authority。 +Runtime 以有界历史保存已完成 journal,且它们与 committed outcome 分离。 + +当显式操作需要向调用者暴露 postcommit callback 错误时,ETAF 会用原 condition +symbol 重新 signal,并逐项保留原 condition data 前缀;末尾只追加一个固定 +`:etaf-condition-trailer/v1` datum,其中包含 operation、outcome、generation、 +Ebox revision 与 diagnostic-journal ID。`etaf-condition-postcommit-info` 会校验并 +读取该 trailer,让调用者机械区分“已经提交、随后 callback 失败”和 rollback +failure。buffer-kill 路径会 drain 或 contain retirement 工作,但绝不会从 kill +hook 抛 retirement condition。 + 每次 Runtime flush 都记录 candidate-aware effect tuple:其中包含 generation id、 effect→source 边和 source version,以及 candidate input/context/output facts 的 immutable semantic-node stamp。重复 tuple 会报告有序的 effect/edge path;step diff --git a/etaf-render-port.el b/etaf-render-port.el index b607d61..50e81a4 100644 --- a/etaf-render-port.el +++ b/etaf-render-port.el @@ -393,6 +393,12 @@ FRAMEWORK-STAGE and FRAMEWORK-ROLLBACK are one required callback pair." "Return non-nil when BUFFER owns a live retained Ebox surface." (ebox-surface-buffer-mounted-p buffer)) +(defun etaf-render-port-revision (buffer) + "Return BUFFER's latest committed Ebox surface revision, or zero." + (condition-case nil + (or (plist-get (ebox-buffer-update-report buffer) :surface-revision) 0) + (error 0))) + (provide 'etaf-render-port) ;;; etaf-render-port.el ends here diff --git a/etaf-retirement.el b/etaf-retirement.el new file mode 100644 index 0000000..a5ce16d --- /dev/null +++ b/etaf-retirement.el @@ -0,0 +1,258 @@ +;;; etaf-retirement.el --- ETAF postcommit retirement journal -*- lexical-binding: t; -*- + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;;; Commentary: + +;; Defines run-once public lifecycle entries, bounded idempotent structural +;; cleanup, append-only diagnostics, and cause-compatible postcommit condition +;; trailers. Retirement never owns or rolls back committed generation/surface +;; authority. + +;;; Code: + +(require 'cl-lib) +(require 'subr-x) + +(define-error 'etaf-retirement-error "Invalid ETAF retirement journal") + +(defvar etaf-retirement--journal-id-counter 0) +(defvar etaf-retirement--entry-id-counter 0) + +(cl-defstruct + (etaf-retirement-entry + (:constructor etaf-retirement-entry--create)) + "One stable postcommit retirement action." + id owner kind payload ordering-key + (attempt-count 0) + (max-attempts 1) + policy + (state 'pending) + condition) + +(cl-defstruct + (etaf-retirement-journal + (:constructor etaf-retirement-journal--create)) + "Append-only postcommit retirement and diagnostic journal." + id operation-id outcome-id generation-id revision + entries diagnostics + (state 'open)) + +(cl-defun etaf-retirement-journal-create + (&key operation-id outcome-id generation-id revision) + "Create a journal bound to OPERATION-ID and OUTCOME-ID. +GENERATION-ID and REVISION identify already committed facts." + (unless (and (integerp operation-id) (>= operation-id 0) + outcome-id + (integerp generation-id) (>= generation-id 0) + (integerp revision) (>= revision 0)) + (signal 'etaf-retirement-error + (list :invalid-journal-metadata + operation-id outcome-id generation-id revision))) + (etaf-retirement-journal--create + :id (cl-incf etaf-retirement--journal-id-counter) + :operation-id operation-id + :outcome-id outcome-id + :generation-id generation-id + :revision revision + :entries nil + :diagnostics nil)) + +(cl-defun etaf-retirement-enqueue + (journal &key owner kind payload ordering-key policy max-attempts) + "Append one retirement entry to JOURNAL. +OWNER, KIND, PAYLOAD, ORDERING-KEY, POLICY, and MAX-ATTEMPTS describe the +action." + (unless (and (etaf-retirement-journal-p journal) + (eq (etaf-retirement-journal-state journal) 'open) + owner kind (functionp payload) + (memq policy '(run-once-public retryable-idempotent + contained-once)) + (integerp max-attempts) (> max-attempts 0)) + (signal 'etaf-retirement-error + (list :invalid-entry owner kind policy max-attempts))) + (let ((entry + (etaf-retirement-entry--create + :id (cl-incf etaf-retirement--entry-id-counter) + :owner owner + :kind kind + :payload payload + :ordering-key ordering-key + :policy policy + :max-attempts max-attempts))) + (push entry (etaf-retirement-journal-entries journal)) + entry)) + +(defun etaf-retirement--ordering-value-rank (value) + "Return a stable type rank for retirement ordering VALUE." + (cond + ((null value) 0) + ((numberp value) 1) + ((symbolp value) 2) + ((stringp value) 3) + ((consp value) 4) + (t 5))) + +(defun etaf-retirement--compare-ordering-values (left right) + "Compare retirement ordering values LEFT and RIGHT. +Return a negative integer when LEFT precedes RIGHT, zero when their ordering +forms are equal, and a positive integer otherwise." + (cond + ((equal left right) 0) + ((and (numberp left) (numberp right)) + (cond ((= left right) 0) ((< left right) -1) (t 1))) + ((and (symbolp left) (symbolp right)) + (if (string< (symbol-name left) (symbol-name right)) -1 1)) + ((and (stringp left) (stringp right)) + (if (string< left right) -1 1)) + ((and (consp left) (consp right)) + (let ((left-tail left) (right-tail right) (result 0)) + (while (and (consp left-tail) (consp right-tail) (= result 0)) + (setq result + (etaf-retirement--compare-ordering-values + (car left-tail) (car right-tail)) + left-tail (cdr left-tail) + right-tail (cdr right-tail))) + (if (= result 0) + (etaf-retirement--compare-ordering-values left-tail right-tail) + result))) + (t + (let ((left-rank (etaf-retirement--ordering-value-rank left)) + (right-rank (etaf-retirement--ordering-value-rank right))) + (cond + ((< left-rank right-rank) -1) + ((> left-rank right-rank) 1) + ((string< (prin1-to-string left) (prin1-to-string right)) -1) + (t 1)))))) + +(defun etaf-retirement--entry-less-p (left right) + "Return non-nil when LEFT sorts before RIGHT deterministically." + (let ((order + (etaf-retirement--compare-ordering-values + (etaf-retirement-entry-ordering-key left) + (etaf-retirement-entry-ordering-key right)))) + (if (= order 0) + (< (etaf-retirement-entry-id left) + (etaf-retirement-entry-id right)) + (< order 0)))) + +(defun etaf-retirement--record-failure (journal entry condition terminal-state) + "Record ENTRY CONDITION in JOURNAL and assign TERMINAL-STATE." + (setf (etaf-retirement-entry-condition entry) condition + (etaf-retirement-entry-state entry) terminal-state) + (push (list :entry-id (etaf-retirement-entry-id entry) + :owner (copy-tree (etaf-retirement-entry-owner entry)) + :kind (etaf-retirement-entry-kind entry) + :policy (etaf-retirement-entry-policy entry) + :attempt-count (etaf-retirement-entry-attempt-count entry) + :state terminal-state + :condition (copy-tree condition)) + (etaf-retirement-journal-diagnostics journal))) + +(defun etaf-retirement--run-entry (journal entry) + "Run JOURNAL ENTRY according to its bounded policy and return a condition." + (let (condition done) + (while (and (not done) + (< (etaf-retirement-entry-attempt-count entry) + (etaf-retirement-entry-max-attempts entry))) + (cl-incf (etaf-retirement-entry-attempt-count entry)) + (setf (etaf-retirement-entry-state entry) 'running) + (setq condition + (condition-case failure + (progn + (funcall (etaf-retirement-entry-payload entry)) + nil) + ((error quit) failure))) + (if (null condition) + (setq done t) + (unless (eq (etaf-retirement-entry-policy entry) + 'retryable-idempotent) + (setq done t)))) + (if (null condition) + (setf (etaf-retirement-entry-state entry) 'completed) + (etaf-retirement--record-failure + journal entry condition 'failed-contained)) + condition)) + +(defun etaf-retirement-drain (journal) + "Drain JOURNAL once and return the first public lifecycle condition." + (unless (and (etaf-retirement-journal-p journal) + (eq (etaf-retirement-journal-state journal) 'open)) + (signal 'etaf-retirement-error + (list :journal-not-open + (and (etaf-retirement-journal-p journal) + (etaf-retirement-journal-state journal))))) + (let ((entries + (sort (copy-sequence (etaf-retirement-journal-entries journal)) + #'etaf-retirement--entry-less-p)) + public-condition public-failed-p) + (dolist (entry entries) + (cond + ((and public-failed-p + (eq (etaf-retirement-entry-policy entry) 'run-once-public)) + (setf (etaf-retirement-entry-state entry) 'abandoned-contained) + (push (list :entry-id (etaf-retirement-entry-id entry) + :owner (copy-tree (etaf-retirement-entry-owner entry)) + :kind (etaf-retirement-entry-kind entry) + :policy 'run-once-public + :attempt-count 0 + :state 'abandoned-contained) + (etaf-retirement-journal-diagnostics journal))) + (t + (when-let* ((condition (etaf-retirement--run-entry journal entry))) + (when (and (eq (etaf-retirement-entry-policy entry) + 'run-once-public) + (null public-condition)) + (setq public-condition condition + public-failed-p t)))))) + (setf (etaf-retirement-journal-entries journal) entries + (etaf-retirement-journal-diagnostics journal) + (nreverse (etaf-retirement-journal-diagnostics journal)) + (etaf-retirement-journal-state journal) 'completed) + public-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)))) + +(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) + (eq (plist-get payload :committed-p) t) + (eq (plist-get payload :kind) 'postcommit) + (integerp (plist-get payload :operation-id)) + (plist-get payload :outcome-id) + (integerp (plist-get payload :generation-id)) + (integerp (plist-get payload :revision)) + (integerp (plist-get payload :diagnostic-journal-id))) + (copy-tree payload))))) + +(defun etaf-retirement-resignal (condition journal) + "Re-signal original CONDITION with JOURNAL's committed trailer appended." + (unless (and (consp condition) (symbolp (car condition))) + (signal 'wrong-type-argument (list 'error-condition condition))) + (if (etaf-condition-postcommit-info condition) + (signal (car condition) (cdr condition)) + (signal (car condition) + (append (copy-tree (cdr condition)) + (list (etaf-retirement-condition-trailer journal)))))) + +(provide 'etaf-retirement) + +;;; etaf-retirement.el ends here diff --git a/etaf-runtime.el b/etaf-runtime.el index 47e91e5..c46c33d 100644 --- a/etaf-runtime.el +++ b/etaf-runtime.el @@ -17,6 +17,7 @@ (require 'etaf-reactive) (require 'etaf-generation) (require 'etaf-host) +(require 'etaf-retirement) (require 'etaf-render-port) (require 'etaf-renderer) (require 'etaf-context) @@ -332,6 +333,7 @@ the sequential `etaf--pvec-put' contract." flushing-p pending-p diagnostics + retirement-journals observer (next-operation-id 0) (next-semantic-candidate-id 0) @@ -1286,6 +1288,46 @@ effect-to-source edges. It is intentionally immutable and suitable as an (etaf-runtime-diagnostics runtime)) nil) +(defcustom etaf-retirement-journal-limit 64 + "Maximum completed retirement journals retained by one Runtime." + :type 'positive-integer + :group 'etaf) + +(defun etaf--runtime-new-retirement-journal (runtime outcome-id) + "Create RUNTIME retirement journal correlated with committed OUTCOME-ID." + (etaf-retirement-journal-create + :operation-id + (if etaf--observer-context + (etaf--observer-context-operation-id etaf--observer-context) + (or (etaf-runtime-next-operation-id runtime) 0)) + :outcome-id outcome-id + :generation-id (etaf-runtime-generation runtime) + :revision (etaf-render-port-revision (etaf-runtime-buffer runtime)))) + +(defun etaf--runtime-retain-retirement-journal (runtime journal) + "Retain completed JOURNAL and its diagnostics on RUNTIME." + (push journal (etaf-runtime-retirement-journals runtime)) + (when (> (length (etaf-runtime-retirement-journals runtime)) + (max 1 etaf-retirement-journal-limit)) + (setcdr (nthcdr (1- (max 1 etaf-retirement-journal-limit)) + (etaf-runtime-retirement-journals runtime)) + nil)) + (dolist (diagnostic (etaf-retirement-journal-diagnostics journal)) + (push (append (list :phase 'retirement + :diagnostic-journal-id + (etaf-retirement-journal-id journal)) + (copy-tree diagnostic)) + (etaf-runtime-diagnostics runtime))) + journal) + +(defun etaf--runtime-drain-retirement (runtime journal &optional contained-p) + "Drain RUNTIME JOURNAL and re-signal public failure unless CONTAINED-P." + (let ((condition (etaf-retirement-drain journal))) + (etaf--runtime-retain-retirement-journal runtime journal) + (when (and condition (not contained-p)) + (etaf-retirement-resignal condition journal)) + condition)) + (defun etaf-runtime-call-operation (runtime kind label function) "Call FUNCTION as one observed RUNTIME operation. KIND is a stable symbol and LABEL is a user-facing string. Nested calls for @@ -1940,32 +1982,44 @@ need to know how Behavior attributes are merged." :props merged :children (etaf--view-node-children node))))) -(defun etaf--runtime-promote-behaviors (runtime) - "Publish candidate Behavior state for RUNTIME and dispose old state." +(defun etaf--runtime-promote-behaviors (runtime retirement-journal) + "Publish RUNTIME Behaviors and enqueue cleanup in RETIREMENT-JOURNAL." (let ((old-resources (or (etaf-runtime-behavior-resource-keys runtime) (make-hash-table :test #'equal))) (candidate-resources (or (etaf-runtime-candidate-behavior-resource-keys runtime) (make-hash-table :test #'equal)))) - (dolist (entry (sort (let (entries) + (cl-loop for entry in (sort (let (entries) (maphash (lambda (key value) (push (cons key value) entries)) (etaf-runtime-behaviors runtime)) entries) (lambda (left right) (string< (prin1-to-string (car left)) - (prin1-to-string (car right)))))) + (prin1-to-string (car right))))) + for index from 0 + do (let* ((identity (car entry)) (old (cdr entry)) (candidate (gethash identity (etaf-runtime-candidate-behaviors runtime))) (old-key (gethash identity old-resources)) (candidate-key (gethash identity candidate-resources))) (unless (and candidate (eq candidate old)) - (when-let* ((cleanup (cdr old))) - (etaf--runtime-run-contained-cleanup - runtime 'behavior-remove identity cleanup)) (when old-key - (remhash old-key (etaf-runtime-resource-registry runtime)))) + (remhash old-key (etaf-runtime-resource-registry runtime))) + (when-let* ((cleanup (cdr old))) + (if retirement-journal + (let ((callback cleanup)) + (etaf-retirement-enqueue + retirement-journal + :owner (copy-tree identity) + :kind 'behavior-remove + :payload callback + :ordering-key (list 4 index) + :policy 'retryable-idempotent + :max-attempts 2)) + (etaf--runtime-run-contained-cleanup + runtime 'behavior-remove identity cleanup)))) (when (and candidate candidate-key) (puthash candidate-key candidate (etaf-runtime-resource-registry runtime))))) @@ -3551,14 +3605,58 @@ raw Emacs properties; Text presentation is projected by Ebox." (when (and styles (not (equal path root-path))) (setq result (etaf--apply-inline-style-rules result styles nil))))))) -(defun etaf--runtime-dispose-instance (instance &optional run-hooks-p) - "Dispose INSTANCE, optionally running hooks when RUN-HOOKS-P is non-nil." +(defun etaf--runtime-enqueue-instance-hooks + (journal instance kind hooks ordering-prefix) + "Enqueue INSTANCE HOOKS of KIND into JOURNAL after ORDERING-PREFIX." + (cl-loop for hook in (reverse hooks) + for index from 0 + do + (let ((callback hook)) + (etaf-retirement-enqueue + journal + :owner (copy-tree (etaf--component-instance-identity instance)) + :kind kind + :payload (lambda () + (let ((etaf--render-phase-p nil)) + (funcall callback))) + :ordering-key (append ordering-prefix (list 0 index)) + :policy 'run-once-public + :max-attempts 1)))) + +(defun etaf--runtime-dispose-instance + (instance &optional run-hooks-p retirement-journal ordering-prefix) + "Dispose INSTANCE and run public hooks when RUN-HOOKS-P is non-nil. +When RETIREMENT-JOURNAL is non-nil, enqueue public hooks and structural scope +cleanup after ORDERING-PREFIX instead of running them inline." (when (etaf--component-instance-p instance) - (when (and run-hooks-p (etaf--component-instance-mounted-p instance)) - (let ((etaf--render-phase-p nil)) - (etaf--run-hooks (etaf--component-instance-unmounted-hooks instance)))) - (setf (etaf--component-instance-mounted-p instance) nil) - (etaf-scope-stop (etaf--component-instance-scope instance)))) + (let ((mounted-p (etaf--component-instance-mounted-p instance)) + (scope (etaf--component-instance-scope instance))) + ;; Authority is removed before any user or structural cleanup runs. + (setf (etaf--component-instance-mounted-p instance) nil) + (if retirement-journal + (progn + (when (and run-hooks-p mounted-p) + (etaf--runtime-enqueue-instance-hooks + retirement-journal instance 'unmounted + (etaf--component-instance-unmounted-hooks instance) + ordering-prefix)) + (etaf-retirement-enqueue + retirement-journal + :owner (copy-tree (etaf--component-instance-identity instance)) + :kind 'scope-stop + :payload + (lambda () + (when-let* ((errors (etaf-scope-stop scope))) + (signal (caar errors) (cdar errors)))) + :ordering-key (append ordering-prefix '(1 0)) + :policy 'contained-once + :max-attempts 1)) + (progn + (when (and run-hooks-p mounted-p) + (let ((etaf--render-phase-p nil)) + (etaf--run-hooks + (etaf--component-instance-unmounted-hooks instance)))) + (etaf-scope-stop scope)))))) (defun etaf--runtime-dispose-created-candidate (runtime) "Dispose RUNTIME's instances created by an uncommitted candidate." @@ -3604,8 +3702,8 @@ raw Emacs properties; Text presentation is projected by Ebox." (etaf-runtime-candidate-behaviors runtime) nil (etaf-runtime-candidate-behavior-resource-keys runtime) nil)) -(defun etaf--runtime-promote (runtime) - "Promote RUNTIME's successful candidate and return its lifecycle groups." +(defun etaf--runtime-promote (runtime retirement-journal) + "Promote RUNTIME candidate and enqueue removals in RETIREMENT-JOURNAL." (let (removed added existing) (maphash (lambda (identity instance) @@ -3616,17 +3714,22 @@ raw Emacs properties; Text presentation is projected by Ebox." (push instance removed))) (etaf-runtime-instances runtime)) ;; Removed descendants are disposed before their parents. - (dolist (instance (sort removed + (cl-loop for instance in (sort removed (lambda (left right) (> (length (etaf--component-instance-identity left)) - (length (etaf--component-instance-identity right)))))) + (length (etaf--component-instance-identity right))))) + for index from 0 + do (remhash (etaf--component-instance-identity instance) (etaf-runtime-instances runtime)) (remhash (etaf--component-instance-resource-key instance) (etaf-runtime-resource-registry runtime)) - (etaf--runtime-dispose-instance instance t)) - (dolist (entry (etaf-runtime-candidate-old-instances runtime)) - (etaf--runtime-dispose-instance (cadr entry) t)) + (etaf--runtime-dispose-instance + instance t retirement-journal (list 0 index))) + (cl-loop for entry in (etaf-runtime-candidate-old-instances runtime) + for index from 0 + do (etaf--runtime-dispose-instance + (cadr entry) t retirement-journal (list 1 index))) (dolist (instance added) (setf (etaf--component-instance-mounted-p instance) t)) (list @@ -3636,14 +3739,20 @@ raw Emacs properties; Text presentation is projected by Ebox." (length (etaf--component-instance-identity right))))) existing))) -(defun etaf--runtime-run-lifecycle (groups) - "Run mounted and updated lifecycle hooks in GROUPS after publication." - (dolist (instance (car groups)) - (let ((etaf--render-phase-p nil)) - (etaf--run-hooks (etaf--component-instance-mounted-hooks instance)))) - (dolist (instance (cadr groups)) - (let ((etaf--render-phase-p nil)) - (etaf--run-hooks (etaf--component-instance-updated-hooks instance))))) +(defun etaf--runtime-run-lifecycle (groups retirement-journal) + "Enqueue mounted and updated GROUPS in RETIREMENT-JOURNAL." + (cl-loop for instance in (car groups) + for index from 0 + do (etaf--runtime-enqueue-instance-hooks + retirement-journal instance 'mounted + (etaf--component-instance-mounted-hooks instance) + (list 2 index))) + (cl-loop for instance in (cadr groups) + for index from 0 + do (etaf--runtime-enqueue-instance-hooks + retirement-journal instance 'updated + (etaf--component-instance-updated-hooks instance) + (list 3 index)))) (defun etaf--runtime-begin-candidate (runtime) "Reset candidate bookkeeping before a RUNTIME render." @@ -5857,22 +5966,29 @@ RENDERED-IDENTITIES names the Component render participants." (etaf--runtime-install-generation-mirrors runtime candidate-generation nil) (etaf--runtime-clear-dirty-effects runtime) - (unwind-protect - (progn - (dolist (instance (etaf-runtime-candidate-created runtime)) - (setf (etaf--component-instance-mounted-p instance) t) - (etaf--run-hooks (etaf--component-instance-mounted-hooks instance))) - (dolist (entry (etaf--generation-index-entries - candidate-generation 'lifecycle)) - (let ((identity (car entry))) - (when-let* ((semantic (etaf--generation-semantic old identity)) - (instance - (gethash - (etaf--semantic-component-resource-key semantic) - (etaf-runtime-resource-registry runtime)))) - (etaf--run-hooks - (etaf--component-instance-updated-hooks instance)))))) - (etaf--runtime-clear-candidate runtime))))) + (let ((retirement + (etaf--runtime-new-retirement-journal + runtime (etaf-semantic-candidate-candidate-id semantic-candidate))) + updated) + (unwind-protect + (progn + (dolist (instance (etaf-runtime-candidate-created runtime)) + (setf (etaf--component-instance-mounted-p instance) t)) + (dolist (entry (etaf--generation-index-entries + candidate-generation 'lifecycle)) + (let ((identity (car entry))) + (when-let* ((semantic (etaf--generation-semantic old identity)) + (instance + (gethash + (etaf--semantic-component-resource-key semantic) + (etaf-runtime-resource-registry runtime)))) + (push instance updated)))) + (etaf--runtime-run-lifecycle + (list (etaf-runtime-candidate-created runtime) + (nreverse updated)) + retirement) + (etaf--runtime-drain-retirement runtime retirement)) + (etaf--runtime-clear-candidate runtime)))))) (defun etaf--runtime-render-effect (runtime) "Build and publish one Root-owned candidate for RUNTIME." @@ -5966,12 +6082,16 @@ RENDERED-IDENTITIES names the Component render participants." ;; Publication has completed. Lifecycle and cleanup callbacks run after ;; the retained state is promoted; their errors remain visible without ;; incorrectly rolling back an already published Ebox tree. - (unwind-protect - (let ((groups (etaf--runtime-promote runtime))) - (etaf--runtime-promote-behaviors runtime) - (etaf--runtime-run-lifecycle groups)) - (etaf--runtime-rollback-behaviors runtime) - (etaf--runtime-clear-candidate runtime)) + (let ((retirement + (etaf--runtime-new-retirement-journal + runtime (etaf-semantic-candidate-candidate-id semantic-candidate)))) + (unwind-protect + (let ((groups (etaf--runtime-promote runtime retirement))) + (etaf--runtime-promote-behaviors runtime retirement) + (etaf--runtime-run-lifecycle groups retirement) + (etaf--runtime-drain-retirement runtime retirement)) + (etaf--runtime-rollback-behaviors runtime) + (etaf--runtime-clear-candidate runtime))) next-root)) (defun etaf--runtime-render-root-turn (runtime &optional force-components-p) @@ -6162,10 +6282,15 @@ CAUSE is `buffer-kill' for the contained dead-buffer path, or nil for explicit unmount. Host authority is invalidated before any unbounded cleanup." (unless (etaf-runtime-p runtime) (signal 'wrong-type-argument (list 'etaf-runtime-p runtime))) - (ignore cause) (if (not (etaf-runtime-mounted-p runtime)) runtime - (let ((authority (etaf-runtime-host-authority runtime))) + (let* ((authority (etaf-runtime-host-authority runtime)) + (retirement + (etaf--runtime-new-retirement-journal + runtime + (list 'host-detach + (etaf-runtime-mount-epoch runtime) + (etaf-host-authority-version authority))))) (when (etaf-host-authority-attached-p authority) (etaf-host-authority-begin-detach authority)) (unless (eq (etaf-host-authority-state authority) 'terminal) @@ -6181,7 +6306,15 @@ unmount. Host authority is invalidated before any unbounded cleanup." (unless (eq cause 'buffer-kill) (when (etaf-render-port-mounted-p (etaf-runtime-buffer runtime)) - (etaf-render-port-unmount (etaf-runtime-buffer runtime)))) + (let ((buffer (etaf-runtime-buffer runtime))) + (etaf-retirement-enqueue + retirement + :owner (list 'ebox (etaf-runtime-mount-epoch runtime)) + :kind 'ebox-unmount + :payload (lambda () (etaf-render-port-unmount buffer)) + :ordering-key '(0 0) + :policy 'retryable-idempotent + :max-attempts 2)))) (remhash (etaf-runtime-buffer runtime) etaf--runtime-table) (remhash (etaf-runtime-mount-epoch runtime) etaf--runtime-route-registry) @@ -6194,24 +6327,64 @@ unmount. Host authority is invalidated before any unbounded cleanup." (let (instances) (maphash (lambda (_identity instance) (push instance instances)) (etaf-runtime-instances runtime)) - (dolist - (instance - (sort instances - (lambda (left right) - (> (length - (etaf--component-instance-identity left)) - (length - (etaf--component-instance-identity right)))))) - (etaf--runtime-dispose-instance instance t))) - (etaf-scope-stop (etaf-runtime-scope runtime)) + (cl-loop + for instance in + (sort instances + (lambda (left right) + (> (length (etaf--component-instance-identity left)) + (length + (etaf--component-instance-identity right))))) + for index from 0 + do + (remhash (etaf--component-instance-identity instance) + (etaf-runtime-instances runtime)) + (remhash (etaf--component-instance-resource-key instance) + (etaf-runtime-resource-registry runtime)) + (etaf--runtime-dispose-instance + instance t retirement (list 1 index)))) + (let ((scope (etaf-runtime-scope runtime))) + (etaf-retirement-enqueue + retirement + :owner (list 'runtime-scope + (etaf-runtime-mount-epoch runtime)) + :kind 'runtime-scope-stop + :payload + (lambda () + (when-let* ((errors (etaf-scope-stop scope))) + (signal (caar errors) (cdar errors)))) + :ordering-key '(8 0) + :policy 'contained-once + :max-attempts 1)) + (let (behavior-entries) (maphash (lambda (identity state) - (when-let* ((cleanup (cdr state))) - (etaf--runtime-run-contained-cleanup - runtime 'behavior-unmount identity cleanup))) - (etaf-runtime-behaviors runtime)) + (push (cons identity state) behavior-entries)) + (etaf-runtime-behaviors runtime)) + (clrhash (etaf-runtime-behaviors runtime)) + (cl-loop for entry in behavior-entries + for index from 0 + do + (when-let* ((resource-key + (gethash + (car entry) + (etaf-runtime-behavior-resource-keys + runtime)))) + (remhash resource-key + (etaf-runtime-resource-registry runtime))) + (when-let* ((cleanup (cdr (cdr entry)))) + (let ((callback cleanup)) + (etaf-retirement-enqueue + retirement + :owner (copy-tree (car entry)) + :kind 'behavior-unmount + :payload callback + :ordering-key (list 7 index) + :policy 'retryable-idempotent + :max-attempts 2))))) (clrhash (etaf-runtime-instances runtime)) (clrhash (etaf-runtime-resource-registry runtime)) + (etaf--runtime-drain-retirement + runtime retirement (eq cause 'buffer-kill)) runtime) (etaf-host-authority-finish-detach authority))))) diff --git a/etaf.el b/etaf.el index d34218f..2a64efe 100644 --- a/etaf.el +++ b/etaf.el @@ -37,6 +37,7 @@ (require 'etaf-data) (require 'etaf-generation) (require 'etaf-host) +(require 'etaf-retirement) (require 'etaf-render-port) (require 'etaf-renderer) (etaf--prefer-local-files) diff --git a/scripts/etaf-m0a-inventory.el b/scripts/etaf-m0a-inventory.el index ad8838b..d4f4cc8 100644 --- a/scripts/etaf-m0a-inventory.el +++ b/scripts/etaf-m0a-inventory.el @@ -74,10 +74,10 @@ etaf-runtime-killed-buffer-unmounts-owned-scope etaf-m0a-repeated-public-unmount-signals-runtime-error)) (:id condition-trailer - :evidence-mode observed-baseline + :evidence-mode current-contract :activation-milestone M3a :owner etaf-runtime - :summary "current consumers receive raw condition symbols/data; typed compatibility trailer is not active" + :summary "postcommit errors preserve the raw condition symbol/data prefix and append the v1 committed trailer" :tests (etaf-m0a-public-update-preserves-raw-condition-symbol-and-data)) (:id document-examples :evidence-mode observed-baseline diff --git a/tests/etaf-m0a-current-characterization-tests.el b/tests/etaf-m0a-current-characterization-tests.el index 2503601..150926c 100644 --- a/tests/etaf-m0a-current-characterization-tests.el +++ b/tests/etaf-m0a-current-characterization-tests.el @@ -116,9 +116,10 @@ (etaf-test-m0a-lifecycle-condition (setq captured condition))) (should - (equal captured - (cons 'etaf-test-m0a-lifecycle-condition - etaf-test-m0a-condition-data))) + (eq (car captured) 'etaf-test-m0a-lifecycle-condition)) + (should (equal (butlast (cdr captured)) + etaf-test-m0a-condition-data)) + (should (etaf-condition-postcommit-info captured)) (should (equal "B" (with-current-buffer buffer-name (buffer-string))))) diff --git a/tests/etaf-retirement-tests.el b/tests/etaf-retirement-tests.el new file mode 100644 index 0000000..8ec3b14 --- /dev/null +++ b/tests/etaf-retirement-tests.el @@ -0,0 +1,191 @@ +;;; etaf-retirement-tests.el --- M3a retirement gates -*- lexical-binding: t; -*- + +;; SPDX-License-Identifier: GPL-3.0-or-later + +(require 'cl-lib) +(require 'ert) +(require 'etaf) +(require 'etaf-retirement) + +(define-error 'etaf-retirement-test-condition + "ETAF retirement test condition") + +(defvar etaf-retirement-test-update-fail-p nil) +(defvar etaf-retirement-test-update-count 0) +(defvar etaf-retirement-test-unmount-first-count 0) +(defvar etaf-retirement-test-unmount-second-count 0) +(defvar etaf-retirement-test-scope-cleanup-count 0) + +(etaf-define-component etaf-retirement-test-updated (&key source) + "Render SOURCE and expose a failing updated lifecycle entry." + :setup + (progn + (etaf-on-updated + (lambda () + (cl-incf etaf-retirement-test-update-count) + (when etaf-retirement-test-update-fail-p + (signal 'etaf-retirement-test-condition + '("update failed" :payload update))))) + nil) + :view + (text (expr (format "updated=%s" (etaf-value source))))) + +(etaf-define-component etaf-retirement-test-unmounted () + "Expose ordered unmounted hooks and structural scope cleanup." + :setup + (progn + (etaf-on-unmounted + (lambda () + (cl-incf etaf-retirement-test-unmount-first-count) + (signal 'etaf-retirement-test-condition + '("unmount failed" :payload unmount)))) + (etaf-on-unmounted + (lambda () (cl-incf etaf-retirement-test-unmount-second-count))) + (etaf-on-scope-dispose + (lambda () (cl-incf etaf-retirement-test-scope-cleanup-count))) + nil) + :view (text "retire")) + +(ert-deftest etaf-retirement-drain-stops-public-and-continues-structure () + "First public failure abandons later hooks but retries structural cleanup." + (let ((journal + (etaf-retirement-journal-create + :operation-id 1 :outcome-id 2 :generation-id 3 :revision 4)) + (attempts 0) + trace) + (etaf-retirement-enqueue + journal :owner 'first :kind 'updated + :payload (lambda () + (push 'first trace) + (signal 'etaf-retirement-test-condition '("first"))) + :ordering-key 1 :policy 'run-once-public :max-attempts 1) + (etaf-retirement-enqueue + journal :owner 'second :kind 'updated + :payload (lambda () (push 'second trace)) + :ordering-key 2 :policy 'run-once-public :max-attempts 1) + (etaf-retirement-enqueue + journal :owner 'structure :kind 'route-cleanup + :payload (lambda () + (cl-incf attempts) + (push 'structure trace) + (when (= attempts 1) (error "retry"))) + :ordering-key 3 :policy 'retryable-idempotent :max-attempts 2) + (let ((condition (etaf-retirement-drain journal))) + (should (eq (car condition) 'etaf-retirement-test-condition)) + (should (equal (nreverse trace) '(first structure structure))) + (should (= attempts 2)) + (should + (equal (mapcar #'etaf-retirement-entry-state + (etaf-retirement-journal-entries journal)) + '(failed-contained abandoned-contained completed)))))) + +(ert-deftest etaf-retirement-ordering-keys-sort-structurally () + "Numeric ordering remains correct after single-digit entry counts." + (let ((journal + (etaf-retirement-journal-create + :operation-id 4 :outcome-id 5 :generation-id 6 :revision 7)) + trace) + (dolist (key '((2 10 0) (2 2 0) (1 12 0) (1 3 0))) + (let ((captured-key key)) + (etaf-retirement-enqueue + journal :owner captured-key :kind 'ordering + :payload (lambda () (push captured-key trace)) + :ordering-key captured-key :policy 'contained-once :max-attempts 1))) + (should-not (etaf-retirement-drain journal)) + (should (equal (nreverse trace) + '((1 3 0) (1 12 0) (2 2 0) (2 10 0)))))) + +(ert-deftest etaf-retirement-condition-trailer-is-cause-compatible () + "Re-signal keeps symbol/data prefix and the reader rejects lookalikes." + (let* ((journal + (etaf-retirement-journal-create + :operation-id 7 :outcome-id 8 :generation-id 9 :revision 10)) + captured) + (condition-case condition + (etaf-retirement-resignal + '(etaf-retirement-test-condition "original" (:business t)) + journal) + (etaf-retirement-test-condition (setq captured condition))) + (should (eq (car captured) 'etaf-retirement-test-condition)) + (should (equal (butlast (cdr captured)) + '("original" (:business t)))) + (should + (equal (etaf-condition-postcommit-info captured) + (list :kind 'postcommit :committed-p t :operation-id 7 + :outcome-id 8 :generation-id 9 :revision 10 + :diagnostic-journal-id + (etaf-retirement-journal-id journal)))) + (should-not + (etaf-condition-postcommit-info + '(error (:etaf-condition-trailer/v1 (:kind postcommit)) business))) + (should-not + (etaf-condition-postcommit-info + '(error business + (:etaf-condition-trailer/v2 + (:kind postcommit :committed-p t))))))) + +(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*") + (source (etaf-ref "A")) + captured) + (setq etaf-retirement-test-update-count 0 + etaf-retirement-test-update-fail-p nil) + (unwind-protect + (progn + (etaf-mount + buffer-name + (etaf--view-call 'etaf-retirement-test-updated + (list :source source) nil)) + (let* ((runtime (etaf-runtime-for-buffer buffer-name)) + (generation (etaf-runtime-generation runtime)) + (token (etaf-runtime-generation-token runtime))) + (setq etaf-retirement-test-update-fail-p t) + (condition-case condition + (setf (etaf-value source) "B") + (etaf-retirement-test-condition (setq captured condition))) + (should captured) + (should (equal (butlast (cdr captured)) + '("update failed" :payload update))) + (should (etaf-condition-postcommit-info captured)) + (should (= (1+ generation) (etaf-runtime-generation runtime))) + (should (= (1+ token) (etaf-runtime-generation-token runtime))) + (should (= etaf-retirement-test-update-count 1)) + (should (equal "updated=B" + (with-current-buffer buffer-name (buffer-string)))) + (setq etaf-retirement-test-update-fail-p nil) + (setf (etaf-value source) "C") + (should (= etaf-retirement-test-update-count 2)))) + (when-let* ((runtime (etaf-runtime-for-buffer buffer-name))) + (etaf-unmount runtime)) + (when-let* ((buffer (get-buffer buffer-name))) + (kill-buffer buffer))))) + +(ert-deftest etaf-retirement-unmount-error-drains-structure-before-resignal () + "Explicit unmount remains detached, abandons later hooks, and cleans scope." + (let ((buffer-name " *etaf-retirement-unmount-test*") runtime authority captured) + (setq etaf-retirement-test-unmount-first-count 0 + etaf-retirement-test-unmount-second-count 0 + etaf-retirement-test-scope-cleanup-count 0) + (unwind-protect + (progn + (etaf-mount buffer-name (etaf-view (etaf-retirement-test-unmounted))) + (setq runtime (etaf-runtime-for-buffer buffer-name) + authority (etaf-runtime-host-authority runtime)) + (condition-case condition + (etaf-unmount runtime) + (etaf-retirement-test-condition (setq captured condition))) + (should captured) + (should (etaf-condition-postcommit-info captured)) + (should (= etaf-retirement-test-unmount-first-count 1)) + (should (zerop etaf-retirement-test-unmount-second-count)) + (should (= etaf-retirement-test-scope-cleanup-count 1)) + (should-not (etaf-runtime-mounted-p runtime)) + (should (eq (etaf-host-authority-state authority) 'terminal)) + (should-not (etaf-render-port-mounted-p (get-buffer buffer-name)))) + (when-let* ((buffer (get-buffer buffer-name))) + (kill-buffer buffer))))) + +(provide 'etaf-retirement-tests) + +;;; etaf-retirement-tests.el ends here diff --git a/tests/fixtures/etaf-m0a-condition-consumers.sexp b/tests/fixtures/etaf-m0a-condition-consumers.sexp index 0510762..70f6d22 100644 --- a/tests/fixtures/etaf-m0a-condition-consumers.sexp +++ b/tests/fixtures/etaf-m0a-condition-consumers.sexp @@ -12,8 +12,10 @@ (:file "etaf-render-port.el" :form condition-case :conditions (error quit) :owner etaf-render-port :policy generic-containment) (:file "etaf-render-port.el" :form condition-case :conditions (error quit) :owner etaf-render-port :policy generic-containment) (:file "etaf-render-port.el" :form condition-case :conditions (etaf-spi-incompatible-error etaf-spi-bootstrap-error) :owner etaf-render-port :policy specific-compatibility) + (:file "etaf-render-port.el" :form condition-case :conditions (error) :owner etaf-render-port :policy generic-containment) (:file "etaf-resource.el" :form condition-case :conditions (error) :owner etaf-resource :policy generic-containment) (:file "etaf-resource.el" :form condition-case :conditions (error) :owner etaf-resource :policy generic-containment) + (:file "etaf-retirement.el" :form condition-case :conditions (error quit) :owner etaf-retirement :policy generic-containment) (:file "etaf-runtime.el" :form condition-case :conditions (error) :owner etaf-runtime :policy generic-containment) (:file "etaf-runtime.el" :form condition-case :conditions (error quit) :owner etaf-runtime :policy generic-containment) (:file "etaf-runtime.el" :form condition-case :conditions (error) :owner etaf-runtime :policy generic-containment)