feat: commit semantic generations with versioned CAS
This commit is contained in:
Kinneyzhang
parent
0cde865d3a
commit
86dd00cf6d
@ -458,6 +458,14 @@ back into it. The migration-only `legacy`, `project`, and `shadow` routes prove
|
||||
projection equivalence and rollback safety without introducing a second
|
||||
committed truth.
|
||||
|
||||
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
|
||||
journal on failure. A semantic-only change runs that CAS under ETAF ownership
|
||||
without creating an Ebox commit or TP revision. Mirror projection and obsolete
|
||||
route cleanup after CAS are postcommit work and cannot reverse the committed
|
||||
token if they fail.
|
||||
|
||||
Each 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
|
||||
|
||||
@ -447,6 +447,13 @@ generation；Runtime 中同名 hash table 只是由 generation 单向重建的
|
||||
`legacy`/`project`/`shadow` 路由只用于证明投影等价与安全回退，不增加第二份
|
||||
committed truth。
|
||||
|
||||
每个 semantic candidate 同时捕获 expected generation、semantic token，以及
|
||||
instance/resource/artifact/route store versions。render 路径在 Ebox framework
|
||||
stage 中暂存一次 CAS，失败时由同一个 inverse journal 恢复；没有可见 Ebox
|
||||
变化的 semantic-only 路径由 ETAF 自己执行同一 CAS，不创建 Ebox commit 或 TP
|
||||
revision。CAS 后的 mirror 与旧 route 清理属于 postcommit，失败不能反向恢复已提交
|
||||
token。
|
||||
|
||||
每次 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
|
||||
|
||||
@ -14,17 +14,48 @@
|
||||
(require 'subr-x)
|
||||
|
||||
(define-error 'etaf-generation-error "Invalid ETAF generation authority")
|
||||
(define-error 'etaf-generation-conflict
|
||||
"Stale ETAF semantic generation candidate"
|
||||
'etaf-generation-error)
|
||||
|
||||
(cl-defstruct
|
||||
(etaf-generation-store-versions
|
||||
(:constructor etaf-generation-store-versions--create))
|
||||
"Committed versions for ETAF's independently journaled stores."
|
||||
(instances 0 :read-only t)
|
||||
(resources 0 :read-only t)
|
||||
(artifacts 0 :read-only t)
|
||||
(routes 0 :read-only t))
|
||||
|
||||
(defun etaf-generation-store-versions-create ()
|
||||
"Return an immutable zeroed ETAF store-version snapshot."
|
||||
(etaf-generation-store-versions--create))
|
||||
|
||||
(defun etaf-generation-store-versions-next (versions)
|
||||
"Return the immutable successor of store VERSIONS snapshot."
|
||||
(unless (etaf-generation-store-versions-p versions)
|
||||
(signal 'wrong-type-argument
|
||||
(list 'etaf-generation-store-versions-p versions)))
|
||||
(etaf-generation-store-versions--create
|
||||
:instances (1+ (etaf-generation-store-versions-instances versions))
|
||||
:resources (1+ (etaf-generation-store-versions-resources versions))
|
||||
:artifacts (1+ (etaf-generation-store-versions-artifacts versions))
|
||||
:routes (1+ (etaf-generation-store-versions-routes versions))))
|
||||
|
||||
(cl-defstruct
|
||||
(etaf-generation-authority
|
||||
(:constructor etaf-generation-authority--create))
|
||||
"Mutable authority for one Runtime's committed generation."
|
||||
generation
|
||||
(token 0))
|
||||
(token 0)
|
||||
(store-versions (etaf-generation-store-versions-create)))
|
||||
|
||||
(defun etaf-generation-authority-create (&optional generation)
|
||||
"Return fresh authority initially pointing at GENERATION."
|
||||
(etaf-generation-authority--create :generation generation :token 0))
|
||||
(etaf-generation-authority--create
|
||||
:generation generation
|
||||
:token 0
|
||||
:store-versions (etaf-generation-store-versions-create)))
|
||||
|
||||
(defun etaf-generation-authority-current (authority)
|
||||
"Return AUTHORITY's current committed generation."
|
||||
@ -43,6 +74,214 @@ versioned compare-and-swap boundary owns token changes."
|
||||
(setf (etaf-generation-authority-generation authority) generation)
|
||||
generation)
|
||||
|
||||
(defun etaf-generation-authority-snapshot (authority)
|
||||
"Return AUTHORITY's immutable generation/token/version snapshot."
|
||||
(unless (etaf-generation-authority-p authority)
|
||||
(signal 'wrong-type-argument
|
||||
(list 'etaf-generation-authority-p authority)))
|
||||
(list :generation (etaf-generation-authority-generation authority)
|
||||
:token (etaf-generation-authority-token authority)
|
||||
:store-versions
|
||||
(etaf-generation-authority-store-versions authority)))
|
||||
|
||||
(defun etaf-generation-authority-validate
|
||||
(authority expected-generation expected-token expected-store-versions)
|
||||
"Validate AUTHORITY against EXPECTED-GENERATION and EXPECTED-TOKEN.
|
||||
EXPECTED-STORE-VERSIONS must also equal the committed version snapshot."
|
||||
(unless (and (eq (etaf-generation-authority-generation authority)
|
||||
expected-generation)
|
||||
(eql (etaf-generation-authority-token authority)
|
||||
expected-token)
|
||||
(equal (etaf-generation-authority-store-versions authority)
|
||||
expected-store-versions))
|
||||
(signal 'etaf-generation-conflict
|
||||
(list
|
||||
:expected-generation expected-generation
|
||||
:actual-generation
|
||||
(etaf-generation-authority-generation authority)
|
||||
:expected-token expected-token
|
||||
:actual-token (etaf-generation-authority-token authority)
|
||||
:expected-store-versions expected-store-versions
|
||||
:actual-store-versions
|
||||
(etaf-generation-authority-store-versions authority))))
|
||||
t)
|
||||
|
||||
(defun etaf-generation-authority-compare-and-swap
|
||||
(authority expected-generation expected-token expected-store-versions
|
||||
next-generation next-token next-store-versions)
|
||||
"Atomically swap AUTHORITY from EXPECTED-GENERATION to NEXT-GENERATION.
|
||||
EXPECTED-TOKEN and EXPECTED-STORE-VERSIONS guard the old authority;
|
||||
NEXT-TOKEN and NEXT-STORE-VERSIONS become committed together."
|
||||
(etaf-generation-authority-validate
|
||||
authority expected-generation expected-token expected-store-versions)
|
||||
(unless (and (integerp next-token) (> next-token expected-token))
|
||||
(signal 'etaf-generation-error
|
||||
(list :invalid-next-token next-token)))
|
||||
(unless (etaf-generation-store-versions-p next-store-versions)
|
||||
(signal 'wrong-type-argument
|
||||
(list 'etaf-generation-store-versions-p next-store-versions)))
|
||||
(let ((inhibit-quit t))
|
||||
(setf (etaf-generation-authority-generation authority) next-generation
|
||||
(etaf-generation-authority-token authority) next-token
|
||||
(etaf-generation-authority-store-versions authority)
|
||||
next-store-versions))
|
||||
next-generation)
|
||||
|
||||
(defun etaf-generation-authority-rollback-swap
|
||||
(authority expected-generation expected-token expected-store-versions
|
||||
candidate-generation candidate-token candidate-store-versions)
|
||||
"Restore EXPECTED-GENERATION and EXPECTED-TOKEN in AUTHORITY.
|
||||
EXPECTED-STORE-VERSIONS are restored only while CANDIDATE-GENERATION,
|
||||
CANDIDATE-TOKEN, and CANDIDATE-STORE-VERSIONS still match exactly."
|
||||
(when (and (eq (etaf-generation-authority-generation authority)
|
||||
candidate-generation)
|
||||
(eql (etaf-generation-authority-token authority) candidate-token)
|
||||
(equal (etaf-generation-authority-store-versions authority)
|
||||
candidate-store-versions))
|
||||
(let ((inhibit-quit t))
|
||||
(setf (etaf-generation-authority-generation authority)
|
||||
expected-generation
|
||||
(etaf-generation-authority-token authority) expected-token
|
||||
(etaf-generation-authority-store-versions authority)
|
||||
expected-store-versions))
|
||||
t))
|
||||
|
||||
(defcustom etaf-semantic-commit-route 'cas
|
||||
"Semantic generation commit route.
|
||||
`legacy' changes only the compatibility generation pointer, `cas' performs the
|
||||
versioned token/store compare-and-swap, and `shadow' validates the same expected
|
||||
facts before using the CAS route."
|
||||
:type '(choice (const legacy) (const cas) (const shadow))
|
||||
:group 'etaf)
|
||||
|
||||
(cl-defstruct
|
||||
(etaf-semantic-candidate
|
||||
(:constructor etaf-semantic-candidate--create))
|
||||
"One-shot ETAF semantic authority candidate."
|
||||
operation-id
|
||||
candidate-id
|
||||
runtime-id
|
||||
mount-epoch
|
||||
authority
|
||||
expected-generation
|
||||
candidate-generation
|
||||
expected-store-versions
|
||||
candidate-store-versions
|
||||
expected-token
|
||||
candidate-token
|
||||
inverse-journal
|
||||
route
|
||||
(state 'prepared))
|
||||
|
||||
(defun etaf-semantic-candidate-create
|
||||
(authority candidate-generation operation-id candidate-id runtime-id
|
||||
mount-epoch)
|
||||
"Prepare a semantic candidate for AUTHORITY and CANDIDATE-GENERATION.
|
||||
OPERATION-ID, CANDIDATE-ID, RUNTIME-ID, and MOUNT-EPOCH provide immutable
|
||||
correlation and authority identity."
|
||||
(unless (etaf-generation-authority-p authority)
|
||||
(signal 'wrong-type-argument
|
||||
(list 'etaf-generation-authority-p authority)))
|
||||
(let* ((snapshot (etaf-generation-authority-snapshot authority))
|
||||
(expected-token (plist-get snapshot :token))
|
||||
(expected-versions (plist-get snapshot :store-versions)))
|
||||
(etaf-semantic-candidate--create
|
||||
:operation-id operation-id
|
||||
:candidate-id candidate-id
|
||||
:runtime-id runtime-id
|
||||
:mount-epoch mount-epoch
|
||||
:authority authority
|
||||
:expected-generation (plist-get snapshot :generation)
|
||||
:candidate-generation candidate-generation
|
||||
:expected-store-versions expected-versions
|
||||
:candidate-store-versions
|
||||
(etaf-generation-store-versions-next expected-versions)
|
||||
:expected-token expected-token
|
||||
:candidate-token (1+ expected-token))))
|
||||
|
||||
(defun etaf-semantic-candidate-stage (candidate)
|
||||
"Install CANDIDATE provisionally through its selected authority route."
|
||||
(unless (eq (etaf-semantic-candidate-state candidate) 'prepared)
|
||||
(signal 'etaf-generation-error
|
||||
(list :candidate-not-prepared
|
||||
(etaf-semantic-candidate-state candidate))))
|
||||
(let ((authority (etaf-semantic-candidate-authority candidate))
|
||||
(route etaf-semantic-commit-route))
|
||||
(pcase route
|
||||
('legacy
|
||||
(etaf-generation-authority-validate
|
||||
authority
|
||||
(etaf-semantic-candidate-expected-generation candidate)
|
||||
(etaf-semantic-candidate-expected-token candidate)
|
||||
(etaf-semantic-candidate-expected-store-versions candidate))
|
||||
(etaf-generation-authority-set-current
|
||||
authority (etaf-semantic-candidate-candidate-generation candidate)))
|
||||
((or 'cas 'shadow)
|
||||
(etaf-generation-authority-compare-and-swap
|
||||
authority
|
||||
(etaf-semantic-candidate-expected-generation candidate)
|
||||
(etaf-semantic-candidate-expected-token candidate)
|
||||
(etaf-semantic-candidate-expected-store-versions candidate)
|
||||
(etaf-semantic-candidate-candidate-generation candidate)
|
||||
(etaf-semantic-candidate-candidate-token candidate)
|
||||
(etaf-semantic-candidate-candidate-store-versions candidate)))
|
||||
(_
|
||||
(signal 'etaf-generation-error
|
||||
(list :unknown-semantic-commit-route route))))
|
||||
(setf (etaf-semantic-candidate-route candidate) route
|
||||
(etaf-semantic-candidate-state candidate) 'staged)
|
||||
candidate))
|
||||
|
||||
(defun etaf-semantic-candidate-commit (candidate)
|
||||
"Mark provisionally installed CANDIDATE committed exactly once."
|
||||
(unless (eq (etaf-semantic-candidate-state candidate) 'staged)
|
||||
(signal 'etaf-generation-error
|
||||
(list :candidate-not-staged
|
||||
(etaf-semantic-candidate-state candidate))))
|
||||
(let ((authority (etaf-semantic-candidate-authority candidate)))
|
||||
(unless (eq (etaf-generation-authority-generation authority)
|
||||
(etaf-semantic-candidate-candidate-generation candidate))
|
||||
(signal 'etaf-generation-conflict
|
||||
(list :candidate-generation-lost
|
||||
(etaf-semantic-candidate-candidate-id candidate))))
|
||||
(unless (or (eq (etaf-semantic-candidate-route candidate) 'legacy)
|
||||
(eql (etaf-generation-authority-token authority)
|
||||
(etaf-semantic-candidate-candidate-token candidate)))
|
||||
(signal 'etaf-generation-conflict
|
||||
(list :candidate-token-lost
|
||||
(etaf-semantic-candidate-candidate-id candidate))))
|
||||
(setf (etaf-semantic-candidate-state candidate) 'committed)
|
||||
candidate))
|
||||
|
||||
(defun etaf-semantic-candidate-rollback (candidate)
|
||||
"Rollback staged CANDIDATE exactly once and return CANDIDATE."
|
||||
(pcase (etaf-semantic-candidate-state candidate)
|
||||
('prepared
|
||||
(setf (etaf-semantic-candidate-state candidate) 'rolled-back))
|
||||
('staged
|
||||
(let ((authority (etaf-semantic-candidate-authority candidate)))
|
||||
(if (eq (etaf-semantic-candidate-route candidate) 'legacy)
|
||||
(when (eq (etaf-generation-authority-generation authority)
|
||||
(etaf-semantic-candidate-candidate-generation candidate))
|
||||
(etaf-generation-authority-set-current
|
||||
authority
|
||||
(etaf-semantic-candidate-expected-generation candidate)))
|
||||
(etaf-generation-authority-rollback-swap
|
||||
authority
|
||||
(etaf-semantic-candidate-expected-generation candidate)
|
||||
(etaf-semantic-candidate-expected-token candidate)
|
||||
(etaf-semantic-candidate-expected-store-versions candidate)
|
||||
(etaf-semantic-candidate-candidate-generation candidate)
|
||||
(etaf-semantic-candidate-candidate-token candidate)
|
||||
(etaf-semantic-candidate-candidate-store-versions candidate)))
|
||||
(setf (etaf-semantic-candidate-state candidate) 'rolled-back)))
|
||||
('rolled-back nil)
|
||||
(_
|
||||
(signal 'etaf-generation-error
|
||||
(list :candidate-not-rollback-capable
|
||||
(etaf-semantic-candidate-state candidate)))))
|
||||
candidate)
|
||||
|
||||
(defun etaf-generation-project-mirror (entries &optional test)
|
||||
"Project immutable contribution ENTRIES into a fresh hash table.
|
||||
TEST defaults to `equal'. Duplicate keys are rejected so a compatibility
|
||||
|
||||
244
etaf-runtime.el
244
etaf-runtime.el
@ -136,7 +136,7 @@ the operation preserves committed values and removal semantics."
|
||||
|
||||
(cl-defstruct (etaf--generation-participant
|
||||
(:constructor etaf--generation-participant-create))
|
||||
runtime old candidate paint-journal (state 'unpublished))
|
||||
runtime semantic-candidate paint-journal (state 'unpublished))
|
||||
|
||||
(cl-defstruct (etaf-generation
|
||||
(:constructor etaf--generation-create))
|
||||
@ -332,6 +332,7 @@ the sequential `etaf--pvec-put' contract."
|
||||
diagnostics
|
||||
observer
|
||||
(next-operation-id 0)
|
||||
(next-semantic-candidate-id 0)
|
||||
(event-depth 0)
|
||||
dirty-effect-queue-tail)
|
||||
|
||||
@ -351,7 +352,23 @@ checking them against a fresh generation projection."
|
||||
|
||||
(defun etaf-runtime-current-generation (runtime)
|
||||
"Return RUNTIME's uniquely authoritative committed generation."
|
||||
(etaf-generation-authority-current
|
||||
(let ((authority (etaf--runtime-generation-authority runtime)))
|
||||
(unless (and (integerp (etaf-generation-authority-token authority))
|
||||
(>= (etaf-generation-authority-token authority) 0)
|
||||
(etaf-generation-store-versions-p
|
||||
(etaf-generation-authority-store-versions authority)))
|
||||
(signal 'etaf-generation-error
|
||||
(list :invalid-committed-authority authority)))
|
||||
(etaf-generation-authority-current authority)))
|
||||
|
||||
(defun etaf-runtime-generation-token (runtime)
|
||||
"Return RUNTIME's committed semantic generation token."
|
||||
(etaf-generation-authority-token
|
||||
(etaf--runtime-generation-authority runtime)))
|
||||
|
||||
(defun etaf-runtime-store-versions (runtime)
|
||||
"Return RUNTIME's immutable committed store-version snapshot."
|
||||
(etaf-generation-authority-store-versions
|
||||
(etaf--runtime-generation-authority runtime)))
|
||||
|
||||
(defun etaf-runtime--set-current-generation (runtime generation)
|
||||
@ -4064,17 +4081,6 @@ Generation, including its effects and Host contributions."
|
||||
(>= (plist-get props :tab-index) 0)
|
||||
(not (plist-get props :disabled)))
|
||||
(setf (etaf-runtime-focus-ref runtime) nil))))
|
||||
(maphash
|
||||
(lambda (_identity semantic)
|
||||
(when-let* ((instance
|
||||
(gethash (etaf--semantic-component-resource-key semantic)
|
||||
(etaf-runtime-resource-registry runtime))))
|
||||
(setf (etaf--component-instance-context instance)
|
||||
(etaf--semantic-component-context-frame semantic))))
|
||||
(etaf-runtime-candidate-semantic-nodes runtime))
|
||||
(dolist (instance (etaf-runtime-candidate-created runtime))
|
||||
(puthash (etaf--component-instance-identity instance) instance
|
||||
(etaf-runtime-instances runtime)))
|
||||
(dolist (delta (etaf-runtime-candidate-source-deltas runtime))
|
||||
(let ((source (car delta)) (effects (nth 2 delta)))
|
||||
(when (null effects)
|
||||
@ -4082,16 +4088,47 @@ Generation, including its effects and Host contributions."
|
||||
(etaf--source-subscribers source))
|
||||
(remhash source (etaf-runtime-route-sources runtime))))))
|
||||
|
||||
(defun etaf--runtime-swap-generation (runtime old candidate)
|
||||
"Swap RUNTIME from OLD to CANDIDATE with an exact authority guard."
|
||||
(defun etaf--runtime-new-semantic-candidate (runtime generation)
|
||||
"Return RUNTIME's next versioned semantic candidate for GENERATION."
|
||||
(let ((candidate-id
|
||||
(cl-incf (etaf-runtime-next-semantic-candidate-id runtime)))
|
||||
(operation-id
|
||||
(if etaf--observer-context
|
||||
(etaf--observer-context-operation-id etaf--observer-context)
|
||||
0)))
|
||||
(etaf-semantic-candidate-create
|
||||
(etaf--runtime-generation-authority runtime)
|
||||
generation operation-id candidate-id
|
||||
(etaf-runtime-mount-epoch runtime)
|
||||
(etaf-runtime-mount-epoch runtime))))
|
||||
|
||||
(defun etaf--runtime-swap-generation
|
||||
(runtime old candidate &optional semantic-candidate)
|
||||
"Swap RUNTIME from OLD to CANDIDATE with an exact authority guard.
|
||||
SEMANTIC-CANDIDATE selects the versioned token/store CAS path."
|
||||
(if semantic-candidate
|
||||
(progn
|
||||
(unless (and
|
||||
(eq old
|
||||
(etaf-semantic-candidate-expected-generation
|
||||
semantic-candidate))
|
||||
(eq candidate
|
||||
(etaf-semantic-candidate-candidate-generation
|
||||
semantic-candidate)))
|
||||
(signal 'etaf-generation-error
|
||||
(list :participant-candidate-mismatch)))
|
||||
(etaf-semantic-candidate-stage semantic-candidate))
|
||||
(unless (eq (etaf-runtime-current-generation runtime) old)
|
||||
(error "ETAF generation authority changed during publication"))
|
||||
(setf (etaf-runtime-current-generation runtime) candidate))
|
||||
(setf (etaf-runtime-current-generation runtime) candidate)))
|
||||
|
||||
(defun etaf--runtime-rollback-generation (runtime old candidate)
|
||||
(defun etaf--runtime-rollback-generation
|
||||
(runtime old candidate &optional semantic-candidate)
|
||||
"Idempotently restore OLD when RUNTIME still points at CANDIDATE."
|
||||
(if semantic-candidate
|
||||
(etaf-semantic-candidate-rollback semantic-candidate)
|
||||
(when (eq (etaf-runtime-current-generation runtime) candidate)
|
||||
(setf (etaf-runtime-current-generation runtime) old)))
|
||||
(setf (etaf-runtime-current-generation runtime) old))))
|
||||
|
||||
(defun etaf--runtime-preinstall-resources (runtime old generation)
|
||||
"Install RUNTIME resources/artifacts for GENERATION and return journal.
|
||||
@ -4113,9 +4150,35 @@ removed inside the same rollback journal."
|
||||
(unwind-protect
|
||||
(progn
|
||||
(dolist (instance (etaf-runtime-candidate-created runtime))
|
||||
(let ((key (etaf--component-instance-resource-key instance)))
|
||||
(let* ((key (etaf--component-instance-resource-key instance))
|
||||
(identity (etaf--component-instance-identity instance))
|
||||
(missing (make-symbol "etaf-instance-missing"))
|
||||
(old-instance
|
||||
(gethash identity (etaf-runtime-instances runtime)
|
||||
missing)))
|
||||
(push (list 'resource key instance) journal)
|
||||
(puthash key instance (etaf-runtime-resource-registry runtime))))
|
||||
(puthash key instance (etaf-runtime-resource-registry runtime))
|
||||
(push (list 'instance identity
|
||||
(not (eq old-instance missing)) old-instance instance)
|
||||
journal)
|
||||
(puthash identity instance (etaf-runtime-instances runtime))))
|
||||
(maphash
|
||||
(lambda (_identity semantic)
|
||||
(when-let* ((instance
|
||||
(gethash
|
||||
(etaf--semantic-component-resource-key semantic)
|
||||
(etaf-runtime-resource-registry runtime))))
|
||||
(let ((old-context
|
||||
(etaf--component-instance-context instance))
|
||||
(new-context
|
||||
(etaf--semantic-component-context-frame semantic)))
|
||||
(unless (eq old-context new-context)
|
||||
(push (list 'instance-context instance
|
||||
old-context new-context)
|
||||
journal)
|
||||
(setf (etaf--component-instance-context instance)
|
||||
new-context)))))
|
||||
(etaf-runtime-candidate-semantic-nodes runtime))
|
||||
(when (and (hash-table-p
|
||||
(etaf-runtime-candidate-behavior-resource-keys runtime))
|
||||
(hash-table-p
|
||||
@ -4210,6 +4273,22 @@ removed inside the same rollback journal."
|
||||
"Remove RUNTIME resources still owned by failed JOURNAL entries."
|
||||
(dolist (entry journal)
|
||||
(pcase (car entry)
|
||||
('instance
|
||||
(let ((identity (nth 1 entry))
|
||||
(present-p (nth 2 entry))
|
||||
(old (nth 3 entry))
|
||||
(candidate (nth 4 entry)))
|
||||
(when (eq (gethash identity (etaf-runtime-instances runtime))
|
||||
candidate)
|
||||
(if present-p
|
||||
(puthash identity old (etaf-runtime-instances runtime))
|
||||
(remhash identity (etaf-runtime-instances runtime))))))
|
||||
('instance-context
|
||||
(let ((instance (nth 1 entry))
|
||||
(old-context (nth 2 entry))
|
||||
(new-context (nth 3 entry)))
|
||||
(when (eq (etaf--component-instance-context instance) new-context)
|
||||
(setf (etaf--component-instance-context instance) old-context))))
|
||||
('resource
|
||||
(when (eq (gethash (nth 1 entry)
|
||||
(etaf-runtime-resource-registry runtime))
|
||||
@ -4247,12 +4326,51 @@ removed inside the same rollback journal."
|
||||
(error "ETAF artifact authority changed during rollback: %S" key)))))))
|
||||
nil)
|
||||
|
||||
(defun etaf--runtime-bind-semantic-inverse-journal
|
||||
(candidate runtime resource-journal route-journal)
|
||||
"Bind CANDIDATE inverse journals for RUNTIME before authority staging.
|
||||
RESOURCE-JOURNAL and ROUTE-JOURNAL remain opaque owner-local entries."
|
||||
(setf (etaf-semantic-candidate-inverse-journal candidate)
|
||||
(list :runtime runtime
|
||||
:resource-journal resource-journal
|
||||
:route-journal route-journal
|
||||
:state 'armed))
|
||||
candidate)
|
||||
|
||||
(defun etaf--runtime-rollback-semantic-inverse-journal (candidate)
|
||||
"Rollback CANDIDATE route/resource journals exactly once."
|
||||
(when-let* ((inverse (etaf-semantic-candidate-inverse-journal candidate))
|
||||
((eq (plist-get inverse :state) 'armed)))
|
||||
(let ((runtime (plist-get inverse :runtime)))
|
||||
(plist-put inverse :state 'rolling-back)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf--runtime-rollback-prearm
|
||||
runtime (plist-get inverse :route-journal))
|
||||
(etaf--runtime-rollback-resource-journal
|
||||
runtime (plist-get inverse :resource-journal)))
|
||||
(plist-put inverse :state 'rolled-back))))
|
||||
candidate)
|
||||
|
||||
(defun etaf--runtime-commit-semantic-inverse-journal (candidate)
|
||||
"Mark CANDIDATE inverse journal committed and no longer rollback-capable."
|
||||
(when-let* ((inverse (etaf-semantic-candidate-inverse-journal candidate)))
|
||||
(unless (eq (plist-get inverse :state) 'armed)
|
||||
(signal 'etaf-generation-error
|
||||
(list :inverse-journal-not-armed
|
||||
(plist-get inverse :state))))
|
||||
(plist-put inverse :state 'committed))
|
||||
candidate)
|
||||
|
||||
(defun etaf--runtime-participant-publish (participant)
|
||||
"Publish PARTICIPANT generation, restoring old authority on any failure."
|
||||
(let ((success nil)
|
||||
(let* ((success nil)
|
||||
(runtime (etaf--generation-participant-runtime participant))
|
||||
(old (etaf--generation-participant-old participant))
|
||||
(candidate (etaf--generation-participant-candidate participant))
|
||||
(semantic-candidate
|
||||
(etaf--generation-participant-semantic-candidate participant))
|
||||
(old (etaf-semantic-candidate-expected-generation semantic-candidate))
|
||||
(candidate
|
||||
(etaf-semantic-candidate-candidate-generation semantic-candidate))
|
||||
paint-updates)
|
||||
(when-let* ((table
|
||||
(etaf-runtime-candidate-theme-paint-updates runtime)))
|
||||
@ -4265,30 +4383,41 @@ removed inside the same rollback journal."
|
||||
(setf (etaf--generation-participant-paint-journal participant)
|
||||
(tp-paint-slot-apply-updates
|
||||
(etaf-runtime-buffer runtime) paint-updates)))
|
||||
(etaf--runtime-swap-generation runtime old candidate)
|
||||
(etaf--runtime-swap-generation
|
||||
runtime old candidate semantic-candidate)
|
||||
(setf (etaf--generation-participant-state participant) 'published
|
||||
success t))
|
||||
(unless success
|
||||
(when-let* ((paint-journal
|
||||
(etaf--generation-participant-paint-journal participant)))
|
||||
(tp-paint-slot-rollback-updates paint-journal)
|
||||
(setf (etaf--generation-participant-paint-journal participant) nil))
|
||||
(etaf--runtime-rollback-generation runtime old candidate)))
|
||||
(etaf--runtime-participant-rollback participant)))
|
||||
participant))
|
||||
|
||||
(defun etaf--runtime-participant-rollback (participant)
|
||||
"Rollback PARTICIPANT generation exactly and idempotently."
|
||||
(unless (eq (etaf--generation-participant-state participant) 'rolled-back)
|
||||
(let ((semantic-candidate
|
||||
(etaf--generation-participant-semantic-candidate participant)))
|
||||
(etaf--runtime-rollback-generation
|
||||
(etaf--generation-participant-runtime participant)
|
||||
(etaf-semantic-candidate-expected-generation semantic-candidate)
|
||||
(etaf-semantic-candidate-candidate-generation semantic-candidate)
|
||||
semantic-candidate)
|
||||
(when-let* ((paint-journal
|
||||
(etaf--generation-participant-paint-journal participant)))
|
||||
(tp-paint-slot-rollback-updates paint-journal)
|
||||
(setf (etaf--generation-participant-paint-journal participant) nil))
|
||||
(etaf--runtime-rollback-generation
|
||||
(etaf--generation-participant-runtime participant)
|
||||
(etaf--generation-participant-old participant)
|
||||
(etaf--generation-participant-candidate participant))
|
||||
(setf (etaf--generation-participant-state participant) 'rolled-back)
|
||||
(etaf--runtime-rollback-semantic-inverse-journal semantic-candidate)
|
||||
(setf (etaf--generation-participant-state participant) 'rolled-back)))
|
||||
participant)
|
||||
|
||||
(defun etaf--runtime-participant-commit (participant)
|
||||
"Commit PARTICIPANT semantic candidate after render final accept."
|
||||
(let ((candidate
|
||||
(etaf--generation-participant-semantic-candidate participant)))
|
||||
(etaf-semantic-candidate-commit candidate)
|
||||
(etaf--runtime-commit-semantic-inverse-journal candidate)
|
||||
(setf (etaf--generation-participant-state participant) 'committed)
|
||||
participant))
|
||||
|
||||
(defun etaf--runtime-begin-component-overlay (runtime generation)
|
||||
"Seed RUNTIME candidate tables from committed GENERATION without traversal."
|
||||
(etaf--runtime-begin-candidate runtime)
|
||||
@ -5401,7 +5530,8 @@ RENDERED-IDENTITIES names the Component render participants."
|
||||
queued-effect-ids))
|
||||
changes range-changes inline-changes host-property-semantics host-changes
|
||||
backend-component-identities
|
||||
journal resource-journal candidate-generation participant)
|
||||
journal resource-journal candidate-generation semantic-candidate
|
||||
participant)
|
||||
(etaf--runtime-begin-component-overlay runtime old)
|
||||
;; A source notification can race a generation promotion and leave an old
|
||||
;; effect id in the FIFO. Keep the dirty-id set and FIFO coherent before
|
||||
@ -5625,6 +5755,9 @@ RENDERED-IDENTITIES names the Component render participants."
|
||||
semantic-id)
|
||||
host-changes)))))
|
||||
(setq host-changes (nreverse host-changes))
|
||||
(setq semantic-candidate
|
||||
(etaf--runtime-new-semantic-candidate
|
||||
runtime candidate-generation))
|
||||
(condition-case err
|
||||
(progn
|
||||
(setq resource-journal
|
||||
@ -5632,9 +5765,11 @@ RENDERED-IDENTITIES names the Component render participants."
|
||||
runtime old candidate-generation)
|
||||
participant
|
||||
(etaf--generation-participant-create
|
||||
:runtime runtime :old old :candidate candidate-generation)
|
||||
:runtime runtime :semantic-candidate semantic-candidate)
|
||||
journal
|
||||
(etaf--runtime-prearm-generation runtime candidate-generation))
|
||||
(etaf--runtime-bind-semantic-inverse-journal
|
||||
semantic-candidate runtime resource-journal journal)
|
||||
(if (and (null changes)
|
||||
(null range-changes)
|
||||
(cl-every
|
||||
@ -5686,6 +5821,10 @@ RENDERED-IDENTITIES names the Component render participants."
|
||||
(lambda (_report)
|
||||
(etaf--runtime-participant-rollback participant))))))
|
||||
((error quit)
|
||||
(when semantic-candidate
|
||||
(etaf-semantic-candidate-rollback semantic-candidate)
|
||||
(etaf--runtime-rollback-semantic-inverse-journal
|
||||
semantic-candidate))
|
||||
(etaf--runtime-rollback-prearm runtime journal)
|
||||
(etaf--runtime-rollback-resource-journal runtime resource-journal)
|
||||
(etaf--runtime-clear-dirty-effects runtime)
|
||||
@ -5694,6 +5833,7 @@ RENDERED-IDENTITIES names the Component render participants."
|
||||
(etaf--runtime-dispose-created-candidate runtime)
|
||||
(etaf--runtime-clear-candidate runtime)
|
||||
(signal (car err) (cdr err))))
|
||||
(etaf--runtime-participant-commit participant)
|
||||
(etaf--runtime-complete-generation runtime candidate-generation)
|
||||
(etaf--runtime-install-generation-mirrors
|
||||
runtime candidate-generation nil)
|
||||
@ -5719,8 +5859,8 @@ RENDERED-IDENTITIES names the Component render participants."
|
||||
"Build and publish one Root-owned candidate for RUNTIME."
|
||||
(setf (etaf-runtime-candidate-full-rebuild-p runtime) t)
|
||||
(let ((old-generation (etaf-runtime-current-generation runtime))
|
||||
next-root root-node candidate-generation journal resource-journal
|
||||
participant)
|
||||
next-root root-node candidate-generation semantic-candidate
|
||||
journal resource-journal participant)
|
||||
(condition-case err
|
||||
(let* ((source-builder (ebox-source-builder-create))
|
||||
(etaf--render-runtime runtime)
|
||||
@ -5746,13 +5886,18 @@ RENDERED-IDENTITIES names the Component render participants."
|
||||
(ebox-source-builder-finish source-builder)))
|
||||
(setq candidate-generation
|
||||
(etaf--runtime-build-generation runtime old-generation)
|
||||
semantic-candidate
|
||||
(etaf--runtime-new-semantic-candidate
|
||||
runtime candidate-generation)
|
||||
resource-journal (etaf--runtime-preinstall-resources
|
||||
runtime old-generation candidate-generation)
|
||||
participant (etaf--generation-participant-create
|
||||
:runtime runtime :old old-generation
|
||||
:candidate candidate-generation)
|
||||
:runtime runtime
|
||||
:semantic-candidate semantic-candidate)
|
||||
journal
|
||||
(etaf--runtime-prearm-generation runtime candidate-generation))
|
||||
(etaf--runtime-bind-semantic-inverse-journal
|
||||
semantic-candidate runtime resource-journal journal)
|
||||
(if old-generation
|
||||
(let ((candidate (ebox-candidate-begin
|
||||
(etaf-runtime-buffer runtime))))
|
||||
@ -5767,14 +5912,12 @@ RENDERED-IDENTITIES names the Component render participants."
|
||||
(etaf-runtime-buffer runtime) next-root
|
||||
(when (etaf-runtime-observer runtime)
|
||||
(list :observer #'etaf--runtime-forward-ebox-report)))
|
||||
(etaf--runtime-participant-publish participant))
|
||||
(etaf--runtime-complete-generation runtime candidate-generation)
|
||||
(etaf--runtime-install-generation-mirrors
|
||||
runtime candidate-generation t)
|
||||
(setf (etaf-runtime-root-node runtime) root-node
|
||||
(etaf-runtime-root-dirty-p runtime) nil)
|
||||
(etaf--runtime-clear-dirty-effects runtime))
|
||||
(etaf--runtime-participant-publish participant)))
|
||||
((error quit)
|
||||
(when semantic-candidate
|
||||
(etaf-semantic-candidate-rollback semantic-candidate)
|
||||
(etaf--runtime-rollback-semantic-inverse-journal
|
||||
semantic-candidate))
|
||||
(etaf--runtime-rollback-prearm runtime journal)
|
||||
(etaf--runtime-rollback-resource-journal runtime resource-journal)
|
||||
(etaf--runtime-clear-dirty-effects runtime)
|
||||
@ -5782,6 +5925,13 @@ RENDERED-IDENTITIES names the Component render participants."
|
||||
(etaf--runtime-rollback-behaviors runtime)
|
||||
(etaf--runtime-clear-candidate runtime)
|
||||
(signal (car err) (cdr err))))
|
||||
(etaf--runtime-participant-commit participant)
|
||||
(etaf--runtime-complete-generation runtime candidate-generation)
|
||||
(etaf--runtime-install-generation-mirrors
|
||||
runtime candidate-generation t)
|
||||
(setf (etaf-runtime-root-node runtime) root-node
|
||||
(etaf-runtime-root-dirty-p runtime) nil)
|
||||
(etaf--runtime-clear-dirty-effects runtime)
|
||||
;; 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.
|
||||
|
||||
@ -6,6 +6,16 @@
|
||||
(require 'etaf)
|
||||
(require 'etaf-generation)
|
||||
|
||||
(etaf-define-component etaf-generation-test-dependency-only (&key source)
|
||||
"Track SOURCE while producing an equal Ebox artifact."
|
||||
:view
|
||||
(text (expr (progn (etaf-value source) "same"))))
|
||||
|
||||
(etaf-define-component etaf-generation-test-visible (&key source)
|
||||
"Render SOURCE as visible text for semantic conflict tests."
|
||||
:view
|
||||
(text (expr (format "value=%s" (etaf-value source)))))
|
||||
|
||||
(defun etaf-generation-test--view (visible)
|
||||
"Return a root View selected by reactive VISIBLE."
|
||||
(if (etaf-value visible)
|
||||
@ -122,6 +132,271 @@
|
||||
(etaf--runtime-install-generation-mirrors runtime nil t)
|
||||
:type 'etaf-generation-error)))
|
||||
|
||||
(ert-deftest etaf-semantic-candidate-cas-and-rollback-are-exactly-once ()
|
||||
"CAS stages generation/token/versions together and rollback restores all."
|
||||
(let* ((old (list 'old-generation))
|
||||
(next (list 'next-generation))
|
||||
(authority (etaf-generation-authority-create old))
|
||||
(candidate
|
||||
(etaf-semantic-candidate-create
|
||||
authority next 7 11 13 17)))
|
||||
(etaf-semantic-candidate-stage candidate)
|
||||
(should (eq next (etaf-generation-authority-current authority)))
|
||||
(should (= (etaf-generation-authority-token authority) 1))
|
||||
(should
|
||||
(equal (etaf-generation-authority-store-versions authority)
|
||||
(etaf-semantic-candidate-candidate-store-versions candidate)))
|
||||
(should-error (etaf-semantic-candidate-stage candidate)
|
||||
:type 'etaf-generation-error)
|
||||
(etaf-semantic-candidate-rollback candidate)
|
||||
(should (eq old (etaf-generation-authority-current authority)))
|
||||
(should (zerop (etaf-generation-authority-token authority)))
|
||||
(should
|
||||
(equal (etaf-generation-authority-store-versions authority)
|
||||
(etaf-semantic-candidate-expected-store-versions candidate)))
|
||||
(etaf-semantic-candidate-rollback candidate)
|
||||
(should-error (etaf-semantic-candidate-commit candidate)
|
||||
:type 'etaf-generation-error)))
|
||||
|
||||
(ert-deftest etaf-semantic-candidate-rejects-stale-authority-snapshots ()
|
||||
"Generation, token, and store-version conflicts fail before authority swap."
|
||||
(dolist (kind '(generation token stores))
|
||||
(let* ((old (list 'old-generation))
|
||||
(next (list 'next-generation))
|
||||
(authority (etaf-generation-authority-create old))
|
||||
(candidate
|
||||
(etaf-semantic-candidate-create authority next 1 2 3 4)))
|
||||
(pcase kind
|
||||
('generation
|
||||
(etaf-generation-authority-set-current authority (list 'foreign)))
|
||||
('token
|
||||
(setf (etaf-generation-authority-token authority) 9))
|
||||
('stores
|
||||
(setf (etaf-generation-authority-store-versions authority)
|
||||
(etaf-generation-store-versions-next
|
||||
(etaf-generation-authority-store-versions authority)))))
|
||||
(should-error (etaf-semantic-candidate-stage candidate)
|
||||
:type 'etaf-generation-conflict)
|
||||
(should (eq (etaf-semantic-candidate-state candidate) 'prepared)))))
|
||||
|
||||
(ert-deftest etaf-semantic-candidate-commit-is-terminal ()
|
||||
"A committed semantic candidate cannot rollback or commit twice."
|
||||
(let* ((authority (etaf-generation-authority-create 'old))
|
||||
(candidate
|
||||
(etaf-semantic-candidate-create authority 'next 1 2 3 4)))
|
||||
(etaf-semantic-candidate-stage candidate)
|
||||
(etaf-semantic-candidate-commit candidate)
|
||||
(should (eq (etaf-semantic-candidate-state candidate) 'committed))
|
||||
(should-error (etaf-semantic-candidate-commit candidate)
|
||||
:type 'etaf-generation-error)
|
||||
(should-error (etaf-semantic-candidate-rollback candidate)
|
||||
:type 'etaf-generation-error)
|
||||
(should (eq (etaf-generation-authority-current authority) 'next))))
|
||||
|
||||
(ert-deftest etaf-semantic-only-commit-advances-token-without-ebox-or-tp ()
|
||||
"Equal output commits semantic token/version only, with no surface revision."
|
||||
(let ((buffer-name " *etaf-semantic-token-test*")
|
||||
(source (etaf-ref 0))
|
||||
(ebox-updates 0))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf--view-call 'etaf-generation-test-dependency-only
|
||||
(list :source source) nil))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(surface (with-current-buffer buffer-name
|
||||
(car tp--buffer-surfaces)))
|
||||
(generation (etaf-runtime-generation runtime))
|
||||
(token (etaf-runtime-generation-token runtime))
|
||||
(versions (etaf-runtime-store-versions runtime))
|
||||
(revision (tp-surface-revision surface))
|
||||
(original
|
||||
(symbol-function 'etaf-render-port-update)))
|
||||
(cl-letf (((symbol-function 'etaf-render-port-update)
|
||||
(lambda (&rest arguments)
|
||||
(cl-incf ebox-updates)
|
||||
(apply original arguments))))
|
||||
(setf (etaf-value source) 1))
|
||||
(should (= (1+ generation)
|
||||
(etaf-runtime-generation runtime)))
|
||||
(should (= (1+ token)
|
||||
(etaf-runtime-generation-token runtime)))
|
||||
(should
|
||||
(equal (etaf-generation-store-versions-next versions)
|
||||
(etaf-runtime-store-versions runtime)))
|
||||
(should (zerop ebox-updates))
|
||||
(should (= revision (tp-surface-revision surface)))))
|
||||
(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-semantic-store-conflict-restores-and-retries ()
|
||||
"A stale store version leaves generation/buffer old and a fresh retry wins."
|
||||
(let ((buffer-name " *etaf-semantic-conflict-test*")
|
||||
(source (etaf-ref 0)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf--view-call 'etaf-generation-test-visible
|
||||
(list :source source) nil))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(authority (etaf-runtime-generation-authority runtime))
|
||||
(generation (etaf-runtime-current-generation runtime))
|
||||
(token (etaf-runtime-generation-token runtime))
|
||||
(versions (etaf-runtime-store-versions runtime))
|
||||
(original
|
||||
(symbol-function 'etaf--runtime-participant-publish)))
|
||||
(cl-letf
|
||||
(((symbol-function 'etaf--runtime-participant-publish)
|
||||
(lambda (participant)
|
||||
(setf (etaf-generation-authority-store-versions authority)
|
||||
(etaf-generation-store-versions-next versions))
|
||||
(funcall original participant))))
|
||||
(should-error (setf (etaf-value source) 1)
|
||||
:type 'etaf-generation-conflict))
|
||||
(should (eq generation
|
||||
(etaf-runtime-current-generation runtime)))
|
||||
(should (= token (etaf-runtime-generation-token runtime)))
|
||||
(should (equal "value=0"
|
||||
(with-current-buffer buffer-name
|
||||
(buffer-string))))
|
||||
(etaf-runtime-flush runtime)
|
||||
(should (= (1+ token) (etaf-runtime-generation-token runtime)))
|
||||
(should (equal "value=1"
|
||||
(with-current-buffer buffer-name
|
||||
(buffer-string))))))
|
||||
(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-semantic-postcommit-mirror-failure-keeps-token-committed ()
|
||||
"A postcommit mirror error cannot reverse generation/token or TP facts."
|
||||
(let ((buffer-name " *etaf-semantic-postcommit-test*")
|
||||
(source (etaf-ref 0)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf--view-call 'etaf-generation-test-dependency-only
|
||||
(list :source source) nil))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(surface (with-current-buffer buffer-name
|
||||
(car tp--buffer-surfaces)))
|
||||
(generation (etaf-runtime-generation runtime))
|
||||
(token (etaf-runtime-generation-token runtime))
|
||||
(revision (tp-surface-revision surface)))
|
||||
(cl-letf
|
||||
(((symbol-function 'etaf--runtime-install-generation-mirrors)
|
||||
(lambda (&rest _arguments)
|
||||
(error "injected postcommit mirror failure"))))
|
||||
(should-error (setf (etaf-value source) 1) :type 'error))
|
||||
(should (= (1+ generation)
|
||||
(etaf-runtime-generation runtime)))
|
||||
(should (= (1+ token)
|
||||
(etaf-runtime-generation-token runtime)))
|
||||
(should (= revision (tp-surface-revision surface)))
|
||||
(should (equal "same"
|
||||
(with-current-buffer buffer-name
|
||||
(buffer-string))))))
|
||||
(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-semantic-render-rollback-restores-all-authority-in-callback ()
|
||||
"Framework rollback restores token, stores, and journals before TP returns."
|
||||
(let ((buffer-name " *etaf-semantic-render-rollback-test*")
|
||||
(source (etaf-ref 0))
|
||||
rollback-evidence)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf--view-call 'etaf-generation-test-visible
|
||||
(list :source source) nil))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(generation (etaf-runtime-current-generation runtime))
|
||||
(token (etaf-runtime-generation-token runtime))
|
||||
(versions (etaf-runtime-store-versions runtime))
|
||||
(original-precommit
|
||||
(symbol-function 'tp--run-transaction-precommit-functions))
|
||||
(original-rollback
|
||||
(symbol-function 'etaf--runtime-participant-rollback)))
|
||||
(cl-letf
|
||||
(((symbol-function 'tp--run-transaction-precommit-functions)
|
||||
(lambda ()
|
||||
(funcall original-precommit)
|
||||
(error "injected precommit failure")))
|
||||
((symbol-function 'etaf--runtime-participant-rollback)
|
||||
(lambda (participant)
|
||||
(prog1 (funcall original-rollback participant)
|
||||
(let* ((semantic
|
||||
(etaf--generation-participant-semantic-candidate
|
||||
participant))
|
||||
(inverse
|
||||
(etaf-semantic-candidate-inverse-journal semantic)))
|
||||
(setq rollback-evidence
|
||||
(list
|
||||
:generation
|
||||
(eq generation
|
||||
(etaf-runtime-current-generation runtime))
|
||||
:token
|
||||
(= token (etaf-runtime-generation-token runtime))
|
||||
:versions
|
||||
(equal versions
|
||||
(etaf-runtime-store-versions runtime))
|
||||
:candidate-state
|
||||
(etaf-semantic-candidate-state semantic)
|
||||
:journal-state
|
||||
(plist-get inverse :state))))))))
|
||||
(should-error (setf (etaf-value source) 1) :type 'error))
|
||||
(should
|
||||
(equal rollback-evidence
|
||||
'(:generation t :token t :versions t
|
||||
:candidate-state rolled-back
|
||||
:journal-state rolled-back)))
|
||||
(should (equal "value=0"
|
||||
(with-current-buffer buffer-name
|
||||
(buffer-string))))
|
||||
(etaf-runtime-flush runtime)
|
||||
(should (equal "value=1"
|
||||
(with-current-buffer buffer-name
|
||||
(buffer-string))))))
|
||||
(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-semantic-legacy-and-shadow-routes-remain-recoverable ()
|
||||
"Legacy keeps its token while shadow validates and advances the CAS token."
|
||||
(dolist (route '(legacy shadow))
|
||||
(let ((buffer-name
|
||||
(format " *etaf-semantic-%s-route-test*" route))
|
||||
(source (etaf-ref 0))
|
||||
(etaf-semantic-commit-route route))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf--view-call 'etaf-generation-test-visible
|
||||
(list :source source) nil))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(generation (etaf-runtime-generation runtime))
|
||||
(token (etaf-runtime-generation-token runtime)))
|
||||
(setf (etaf-value source) 1)
|
||||
(should (= (1+ generation)
|
||||
(etaf-runtime-generation runtime)))
|
||||
(should (= (etaf-runtime-generation-token runtime)
|
||||
(if (eq route 'legacy) token (1+ token))))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer))))))
|
||||
|
||||
(provide 'etaf-generation-tests)
|
||||
|
||||
;;; etaf-generation-tests.el ends here
|
||||
|
||||
Loading…
Reference in New Issue
Block a user