feat(runtime): add postcommit retirement journal
This commit is contained in:
Kinneyzhang
parent
96df9e2858
commit
01f072e4fd
4
Makefile
4
Makefile
@ -1,8 +1,8 @@
|
||||
EMACS ?= emacs
|
||||
LOAD_PATH = -L . -L examples -L scripts -L ../ebox -L ../tp -L ../ecss
|
||||
SOURCES = etaf-view.el etaf-compiler.el etaf-component.el etaf-reactive.el etaf-observer.el etaf-context.el etaf-theme-tp.el etaf-resource.el etaf-data.el etaf-generation.el etaf-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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
258
etaf-retirement.el
Normal file
258
etaf-retirement.el
Normal file
@ -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
|
||||
311
etaf-runtime.el
311
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)))))
|
||||
|
||||
|
||||
1
etaf.el
1
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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)))))
|
||||
|
||||
191
tests/etaf-retirement-tests.el
Normal file
191
tests/etaf-retirement-tests.el
Normal file
@ -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
|
||||
@ -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)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user