1493 lines
70 KiB
EmacsLisp
1493 lines
70 KiB
EmacsLisp
;;; tp-transaction-tests.el --- TP structured transaction contract -*- lexical-binding: t; -*-
|
|
|
|
;; Copyright (C) 2026 Geekinney
|
|
|
|
;;; Commentary:
|
|
|
|
;; Characterization and fault tests for the v2 transaction protocol. These
|
|
;; tests deliberately exercise
|
|
;; the internal protocol: the public contract remains `tp-with-transaction'
|
|
;; body return and primary condition preservation.
|
|
|
|
;;; Code:
|
|
|
|
(require 'cl-lib)
|
|
(require 'ert)
|
|
(require 'tp-transaction)
|
|
(require 'tp-surface)
|
|
|
|
(declare-function tp--transaction-participate-v2 "tp-reactive" (&rest args))
|
|
(declare-function tp-transaction-participate-v2 "tp-reactive" (&rest args))
|
|
(declare-function tp--transaction-participant-protocol "tp-reactive" (value))
|
|
(declare-function tp--transaction-participant-state "tp-reactive" (value))
|
|
(declare-function tp--transaction-participant-journal "tp-reactive" (value))
|
|
(declare-function tp--transaction-register-final-marker
|
|
"tp-reactive" (&rest args))
|
|
(defvar tp--transaction-publication-batch)
|
|
(defvar tp--transaction-outcome)
|
|
(defvar tp--last-shadow-proof)
|
|
|
|
(define-error 'tp-transaction-test-error "Injected TP transaction failure")
|
|
|
|
(defvar tp-transaction-test--precommit-condition nil)
|
|
(defvar tp-transaction-test--trace nil)
|
|
|
|
(defun tp--transaction-test-precommit-inject ()
|
|
"Record precommit and signal the configured test condition."
|
|
(push 'precommit tp-transaction-test--trace)
|
|
(when tp-transaction-test--precommit-condition
|
|
(signal (car tp-transaction-test--precommit-condition)
|
|
(cdr tp-transaction-test--precommit-condition))))
|
|
|
|
(defun tp--transaction-test-participant-precommit ()
|
|
"Record one declared structured-participant precommit."
|
|
(push 'participant-precommit tp-transaction-test--trace))
|
|
|
|
(defun tp-transaction-test--leaf (text)
|
|
"Return a retained content leaf displaying TEXT."
|
|
(tp-surface-plan-create
|
|
:key 'root :kind 'text :text text :capability 'content))
|
|
|
|
(defun tp-transaction-test--producer (source)
|
|
"Return a retained producer reading SOURCE."
|
|
(lambda (context)
|
|
(tp-object-ensure context nil 'root 'text)
|
|
(tp-transaction-test--leaf
|
|
(number-to-string (tp-signal-read source)))))
|
|
|
|
(defun tp-transaction-test--capture (function)
|
|
"Call FUNCTION and return its complete signaled condition."
|
|
(condition-case condition
|
|
(progn (funcall function) nil)
|
|
((error quit) condition)))
|
|
|
|
(defun tp-transaction-test--entry (&rest overrides)
|
|
"Return one valid publication target entry with OVERRIDES."
|
|
(let ((buffer (or (plist-get overrides :buffer)
|
|
(current-buffer))))
|
|
(let ((arguments
|
|
(list :surface-id 'surface-a
|
|
:transaction-id 'transaction-a
|
|
:batch-id 'batch-a
|
|
:candidate-id 'candidate-a
|
|
:mount-ids '(mount-a)
|
|
:buffer buffer
|
|
:old-revision 7
|
|
:new-revision 8
|
|
:plan '(:plan old)
|
|
:diff '(:replace 1 2)
|
|
:ledger '(:ledger candidate)
|
|
:objects '(:object candidate)
|
|
:ranges '((1 . 2))
|
|
:client-state '(:client candidate)
|
|
:rollback-snapshot '(:snapshot old)
|
|
:authority-token 'entry-authority-a
|
|
:mapping-generation 3)))
|
|
(while overrides
|
|
(setq arguments
|
|
(plist-put arguments (pop overrides) (pop overrides))))
|
|
(apply #'tp--publication-target-entry-create arguments))))
|
|
|
|
(defun tp-transaction-test--batch (&optional entries)
|
|
"Return a prepared batch for ENTRIES or one default target."
|
|
(tp--publication-batch-prepare
|
|
:transaction-id 'transaction-a
|
|
:batch-id 'batch-a
|
|
:entries (or entries (list (tp-transaction-test--entry)))
|
|
:participants []
|
|
:journals nil
|
|
:final-accept #'ignore
|
|
:diagnostics nil))
|
|
|
|
(defun tp-transaction-test--slot-writes (target values)
|
|
"Return fixed slot writes assigning VALUES into TARGET from index zero."
|
|
(vconcat
|
|
(cl-loop for value across values
|
|
for index from 0
|
|
collect
|
|
(tp--final-marker-slot-write-create
|
|
:target target :index index :value value))))
|
|
|
|
(defun tp-transaction-test--marker-arguments
|
|
(target next-values inverse-values &rest overrides)
|
|
"Return TARGET marker args for NEXT-VALUES, INVERSE-VALUES, and OVERRIDES."
|
|
(let* ((token-index (- (length target) 2))
|
|
(version-index (1- (length target)))
|
|
(arguments
|
|
(list
|
|
:owner-key 'owner-a
|
|
:expected-token
|
|
(tp--final-marker-expectation-create
|
|
:target target :index token-index :value (aref target token-index))
|
|
:expected-version
|
|
(tp--final-marker-expectation-create
|
|
:target target :index version-index
|
|
:value (aref target version-index))
|
|
:next-values (tp-transaction-test--slot-writes target next-values)
|
|
:inverse-values
|
|
(tp-transaction-test--slot-writes target inverse-values)
|
|
:slot-write-count (length next-values)
|
|
:operation-key 'tp-vector-slots/v1)))
|
|
(while overrides
|
|
(setq arguments
|
|
(plist-put arguments (pop overrides) (pop overrides))))
|
|
arguments))
|
|
|
|
(defun tp-transaction-test--property-producer (source anchor)
|
|
"Return a properties-only producer reading SOURCE over ANCHOR."
|
|
(lambda (context)
|
|
(let ((object (tp-object-ensure context nil 'root 'range))
|
|
(value (tp-signal-read source)))
|
|
(tp-object-attach-range context object anchor)
|
|
(tp-surface-result-create
|
|
(tp-surface-plan-create
|
|
:key 'root :kind 'range
|
|
:props (list 'face (if (= value 1) 'bold 'italic))
|
|
:capability 'properties)
|
|
(list :value value)))))
|
|
|
|
(defun tp-transaction-test--property-state (surface)
|
|
"Return exact rollback-sensitive observational state for SURFACE."
|
|
(let ((buffer (tp--surface-buffer surface)))
|
|
(with-current-buffer buffer
|
|
(list :point (point)
|
|
:mount-ids (copy-sequence (tp--live-mount-ids surface))
|
|
:mounts (tp--copy-property-value
|
|
(tp--live-mount-signature surface))
|
|
:ledger (tp--copy-property-value
|
|
(tp--shadow-live-ledger-signature
|
|
(tp--surface-ledger surface)))
|
|
:client-state
|
|
(tp--copy-property-value (tp--surface-client-state surface))
|
|
:revision (tp-surface-revision surface)
|
|
:output (buffer-substring (point-min) (point-max))))))
|
|
|
|
(defun tp-transaction-test--should-match-property-state (surface expected)
|
|
"Assert that SURFACE exactly matches rollback EXPECTED."
|
|
(let ((actual (tp-transaction-test--property-state surface)))
|
|
(dolist (key '(:point :mount-ids :mounts :ledger
|
|
:client-state :revision))
|
|
(should (equal (plist-get actual key) (plist-get expected key))))
|
|
(should (equal-including-properties
|
|
(plist-get actual :output) (plist-get expected :output)))))
|
|
|
|
(defun tp-transaction-test--set-batch-proof-fields (candidate)
|
|
"Install deterministic proof fields on low-level CANDIDATE."
|
|
(setf (tp-publication-batch-candidate-operation-counts candidate)
|
|
'(:text 1)
|
|
(tp-publication-batch-candidate-phase-timings candidate)
|
|
'(:total 0.1)
|
|
(tp-publication-batch-candidate-diagnostics candidate) nil)
|
|
candidate)
|
|
|
|
(defun tp-transaction-test--should-match-outcome-counts (outcome surfaces)
|
|
"Assert OUTCOME mapping generation and counts match SURFACES' reports."
|
|
(let* ((entries (tp-committed-success-outcome-entries outcome))
|
|
(aggregate (tp-committed-success-outcome-operation-counts outcome))
|
|
(generation (tp-committed-success-outcome-mapping-generation outcome))
|
|
(text 0) (properties 0) (touched 0))
|
|
(should generation)
|
|
(should (= (length entries) (length surfaces)))
|
|
(dolist (surface surfaces)
|
|
(let* ((surface-id (tp--surface-id surface))
|
|
(report (tp-surface-report surface))
|
|
(entry
|
|
(cl-find surface-id entries
|
|
:key #'tp-publication-outcome-entry-surface-id
|
|
:test #'equal))
|
|
(counts
|
|
(and entry
|
|
(tp-publication-outcome-entry-operation-counts entry))))
|
|
(should entry)
|
|
(should (equal (tp-publication-outcome-entry-mapping-generation entry)
|
|
generation))
|
|
(should (equal (plist-get counts :mapping-generation) generation))
|
|
(dolist (key '(:old-revision :new-revision :text-operations
|
|
:property-operations
|
|
:touched-characters))
|
|
(should (equal (plist-get counts key) (plist-get report key))))
|
|
(cl-incf text (plist-get report :text-operations))
|
|
(cl-incf properties (plist-get report :property-operations))
|
|
(cl-incf touched (plist-get report :touched-characters))))
|
|
(should (= (plist-get aggregate :targets) (length surfaces)))
|
|
(should (= (plist-get aggregate :text-operations) text))
|
|
(should (= (plist-get aggregate :property-operations) properties))
|
|
(should (= (plist-get aggregate :touched-characters) touched))
|
|
(should (= (length (plist-get aggregate :target-counts))
|
|
(length surfaces)))))
|
|
|
|
(cl-defmacro tp-transaction-test--with-surface
|
|
((buffer surface source) &rest body)
|
|
"Create BUFFER, SOURCE and SURFACE, then evaluate BODY."
|
|
(declare (indent 1) (debug ((symbolp symbolp symbolp) body)))
|
|
`(let* ((,buffer (generate-new-buffer " *tp-transaction-test*"))
|
|
(,source (tp-signal-create 1))
|
|
(,surface
|
|
(tp-surface-mount
|
|
,buffer (tp-transaction-test--producer ,source)
|
|
'(:capability content))))
|
|
(unwind-protect
|
|
(progn ,@body)
|
|
(when (buffer-live-p ,buffer)
|
|
(kill-buffer ,buffer))
|
|
(when (tp-signal-live-p ,source)
|
|
(tp-signal-dispose ,source)))))
|
|
|
|
(ert-deftest tp-transaction-test-v2-body-return-and-phase-order ()
|
|
"The v2 facade returns BODY and retains its established phase order."
|
|
(let ((tp-transaction-test--trace nil)
|
|
(tp--transaction-precommit-functions
|
|
'(tp--transaction-test-precommit-inject))
|
|
(tp--transaction-precommit-allowed-functions
|
|
'(tp--transaction-test-precommit-inject)))
|
|
(should
|
|
(equal
|
|
(tp-with-transaction
|
|
(tp-transaction-participate-v2
|
|
:key 'v2
|
|
:stage (lambda () (push 'participant tp-transaction-test--trace))
|
|
:rollback (lambda () (push 'rollback tp-transaction-test--trace)))
|
|
(tp--enqueue-after-commit
|
|
(lambda () (push 'after-commit tp-transaction-test--trace)))
|
|
(push 'body tp-transaction-test--trace)
|
|
'body-value)
|
|
'body-value))
|
|
(should (equal (nreverse tp-transaction-test--trace)
|
|
'(body participant precommit after-commit)))))
|
|
|
|
(ert-deftest tp-transaction-test-v2-participant-and-precommit-fault-order ()
|
|
"A late v2 fault rolls staged participants back in reverse order."
|
|
(let* ((injected '(tp-transaction-test-error :phase precommit :raw (1 2)))
|
|
(tp-transaction-test--trace nil)
|
|
(tp-transaction-test--precommit-condition injected)
|
|
(tp--transaction-precommit-functions
|
|
'(tp--transaction-test-precommit-inject))
|
|
(tp--transaction-precommit-allowed-functions
|
|
'(tp--transaction-test-precommit-inject))
|
|
(failure
|
|
(tp-transaction-test--capture
|
|
(lambda ()
|
|
(tp-with-transaction
|
|
(tp-transaction-participate-v2
|
|
:key 'first
|
|
:stage (lambda () (push 'stage-first tp-transaction-test--trace))
|
|
:rollback (lambda () (push 'rollback-first tp-transaction-test--trace)))
|
|
(tp-transaction-participate-v2
|
|
:key 'second
|
|
:stage (lambda () (push 'stage-second tp-transaction-test--trace))
|
|
:rollback (lambda () (push 'rollback-second tp-transaction-test--trace))))))))
|
|
(should (equal failure injected))
|
|
(should (equal (nreverse tp-transaction-test--trace)
|
|
'(stage-first stage-second precommit
|
|
rollback-second rollback-first)))))
|
|
|
|
(ert-deftest tp-transaction-test-final-accept-fault-preserves-body-state ()
|
|
"A final-accept fault restores source, surface revision and buffer."
|
|
(tp-transaction-test--with-surface (buffer surface source)
|
|
(let ((old-revision (tp-surface-revision surface))
|
|
(injected '(tp-transaction-test-error :phase final-accept)))
|
|
(should
|
|
(equal
|
|
(cl-letf (((symbol-function 'accept-change-group)
|
|
(lambda (_group)
|
|
(signal (car injected) (cdr injected)))))
|
|
(tp-transaction-test--capture
|
|
(lambda ()
|
|
(tp-with-transaction
|
|
(tp-signal-set source 2)
|
|
'unobservable-body-value))))
|
|
injected))
|
|
(should (= (tp-signal-peek source) 1))
|
|
(should (= (tp-signal-revision source) 0))
|
|
(should (= (tp-surface-revision surface) old-revision))
|
|
(with-current-buffer buffer
|
|
(should (equal (buffer-string) "1"))))))
|
|
|
|
(ert-deftest tp-transaction-test-batch-validates-entries-and-owns-input ()
|
|
"Batch preparation rejects invalid entries and owns mutable input."
|
|
(should-error
|
|
(tp--publication-batch-prepare
|
|
:transaction-id 'transaction-a :batch-id 'batch-a
|
|
:entries nil :participants [] :final-accept #'ignore)
|
|
:type 'tp-publication-binding-error)
|
|
(with-temp-buffer
|
|
(let* ((mount-ids (list 'mount-a))
|
|
(entry (tp-transaction-test--entry :mount-ids mount-ids))
|
|
(entries (list entry))
|
|
(batch (tp-transaction-test--batch entries)))
|
|
(setcar mount-ids 'mutated-after-create)
|
|
(setcar entries (tp-transaction-test--entry
|
|
:candidate-id 'replacement
|
|
:surface-id 'replacement-surface
|
|
:authority-token 'replacement-authority))
|
|
(should (tp-publication-target-entry-p entry))
|
|
(should (tp-publication-batch-candidate-p batch))
|
|
(should (eq (tp-publication-batch-candidate-state batch) 'prepared))
|
|
(should (equal (tp-publication-target-entry-mount-ids
|
|
(car (tp-publication-batch-candidate-entries batch)))
|
|
'(mount-a)))
|
|
(should (eq (car (tp-publication-batch-candidate-entries batch)) entry))
|
|
(should-error
|
|
(tp-transaction-test--batch (list entry entry))
|
|
:type 'tp-publication-binding-error))))
|
|
|
|
(ert-deftest tp-transaction-test-batch-is-one-shot-and-discard-is-prestage-only ()
|
|
"Batch state is monotonic and has exactly one terminal disposition."
|
|
(with-temp-buffer
|
|
(let ((batch (tp-transaction-test--batch)))
|
|
(should-error (tp--publication-batch-transition batch 'participants)
|
|
:type 'tp-publication-state-error)
|
|
(dolist (state '(staged participants precommit final-accepting committed))
|
|
(should (eq (tp--publication-batch-transition batch state) batch))
|
|
(should (eq (tp-publication-batch-candidate-state batch) state)))
|
|
(should-error (tp--publication-batch-transition batch 'committed)
|
|
:type 'tp-publication-state-error)
|
|
(should-error (tp--publication-batch-discard batch 'too-late)
|
|
:type 'tp-publication-state-error))
|
|
(let ((discarded (tp-transaction-test--batch)))
|
|
(should-not (tp--publication-batch-discard discarded 'unused))
|
|
(should (eq (tp-publication-batch-candidate-state discarded) 'discarded))
|
|
(should-error (tp--publication-batch-discard discarded 'twice)
|
|
:type 'tp-publication-state-error)
|
|
(should-error (tp--publication-batch-transition discarded 'staged)
|
|
:type 'tp-publication-state-error))))
|
|
|
|
(ert-deftest tp-transaction-test-v2-participant-is-single-structured-record ()
|
|
"The v2 facade installs one structured record with no legacy bridge."
|
|
(let (saved)
|
|
(tp-with-transaction
|
|
(tp-transaction-participate-v2 :key 'structured :stage #'ignore
|
|
:rollback #'ignore)
|
|
(setq saved (car tp--transaction-participants))
|
|
(should (= (length tp--transaction-participants) 1))
|
|
(should (eq (tp--transaction-participant-protocol saved) 'v2))
|
|
(should (eq (tp--transaction-participant-state saved) 'prepared)))
|
|
(should (eq (tp--transaction-participant-state saved) 'committed))))
|
|
|
|
(ert-deftest tp-transaction-test-v2-participant-stage-precommit-and-after-commit ()
|
|
"A structured participant owns its journal and advances exactly once."
|
|
(let ((tp-transaction-test--trace nil)
|
|
(tp--transaction-participant-precommit-allowed-functions
|
|
'(tp--transaction-test-participant-precommit))
|
|
participant)
|
|
(tp-with-transaction
|
|
(tp--transaction-participate-v2
|
|
:key 'structured
|
|
:stage (lambda () (push 'stage tp-transaction-test--trace))
|
|
:rollback (lambda () (push 'rollback tp-transaction-test--trace))
|
|
:precommit 'tp--transaction-test-participant-precommit
|
|
:after-commit (lambda () (push 'participant-after-commit
|
|
tp-transaction-test--trace))
|
|
:journal '(:owner old-state))
|
|
(setq participant (car tp--transaction-participants)))
|
|
(should (equal (nreverse tp-transaction-test--trace)
|
|
'(stage participant-precommit participant-after-commit)))
|
|
(should (equal (tp--transaction-participant-journal participant)
|
|
'(:owner old-state)))
|
|
(should (eq (tp--transaction-participant-state participant) 'committed))))
|
|
|
|
(ert-deftest tp-transaction-test-public-v2-participant-api-registers-v2-record ()
|
|
"The public v2 API registers one v2 object on the sole live route."
|
|
(let ((tp-transaction-test--trace nil)
|
|
participant)
|
|
(should
|
|
(eq
|
|
(tp-with-transaction
|
|
(should
|
|
(eq
|
|
(tp-transaction-participate-v2
|
|
:key 'public-v2
|
|
:stage (lambda () (push 'stage tp-transaction-test--trace))
|
|
:rollback (lambda () (push 'rollback tp-transaction-test--trace))
|
|
:journal '(:owner public))
|
|
'public-v2))
|
|
(setq participant (car tp--transaction-participants))
|
|
'body-result)
|
|
'body-result))
|
|
(should (equal tp-transaction-test--trace '(stage)))
|
|
(should (eq (tp--transaction-participant-protocol participant) 'v2))
|
|
(should (equal (tp--transaction-participant-journal participant)
|
|
'(:owner public)))
|
|
(should (eq (tp--transaction-participant-state participant) 'committed))))
|
|
|
|
(ert-deftest tp-transaction-test-v2-participant-stage-fault-rolls-back-prior-only ()
|
|
"A structured stage fault reverses only participants that entered staged."
|
|
(let ((tp-transaction-test--trace nil)
|
|
(injected '(tp-transaction-test-error :phase participant-stage)))
|
|
(should
|
|
(equal
|
|
(tp-transaction-test--capture
|
|
(lambda ()
|
|
(tp-with-transaction
|
|
(tp--transaction-participate-v2
|
|
:key 'first
|
|
:stage (lambda () (push 'stage-first tp-transaction-test--trace))
|
|
:rollback (lambda () (push 'rollback-first
|
|
tp-transaction-test--trace)))
|
|
(tp--transaction-participate-v2
|
|
:key 'second
|
|
:stage (lambda ()
|
|
(push 'stage-second tp-transaction-test--trace)
|
|
(signal (car injected) (cdr injected)))
|
|
:rollback (lambda () (push 'rollback-second
|
|
tp-transaction-test--trace))))))
|
|
injected))
|
|
(should (equal (nreverse tp-transaction-test--trace)
|
|
'(stage-first stage-second rollback-second rollback-first)))))
|
|
|
|
(ert-deftest tp-transaction-test-final-marker-validates-registry-contract ()
|
|
"Built-in marker registration validates owner, expectation, and payload."
|
|
(tp-transaction-test--with-surface (buffer _surface source)
|
|
(let ((target (vector 'old 'token-a 4)))
|
|
(tp-with-transaction
|
|
(tp-signal-set source 2)
|
|
(apply #'tp--transaction-register-final-marker
|
|
(tp-transaction-test--marker-arguments
|
|
target [new] [old]))
|
|
(should-error
|
|
(apply #'tp--transaction-register-final-marker
|
|
(tp-transaction-test--marker-arguments
|
|
target [new] [old]))
|
|
:type 'tp-final-marker-error))
|
|
(should (eq (aref target 0) 'new))
|
|
(dolist (case '(operation expectation payload))
|
|
(aset target 0 'old)
|
|
(should-error
|
|
(tp-with-transaction
|
|
(tp-signal-set source (1+ (tp-signal-peek source)))
|
|
(apply #'tp--transaction-register-final-marker
|
|
(pcase case
|
|
('operation
|
|
(tp-transaction-test--marker-arguments
|
|
target [new] [old]
|
|
:owner-key 'bad-operation
|
|
:operation-key 'not-whitelisted))
|
|
('expectation
|
|
(tp-transaction-test--marker-arguments
|
|
target [new] [old]
|
|
:owner-key 'bad-expectation
|
|
:expected-version
|
|
(tp--final-marker-expectation-create
|
|
:target target :index 2 :value 3)))
|
|
('payload
|
|
(tp-transaction-test--marker-arguments
|
|
target [new] [old]
|
|
:owner-key 'bad-payload :slot-write-count 2)))))
|
|
:type 'tp-final-marker-error)
|
|
(should (eq (aref target 0) 'old))))))
|
|
|
|
(ert-deftest tp-transaction-test-public-final-marker-wrappers-share-contract ()
|
|
"Public marker constructors and registration retain the bounded core rules."
|
|
(tp-transaction-test--with-surface (buffer _surface source)
|
|
(let ((target (vector 'detached 'token 0)))
|
|
(tp-with-transaction
|
|
(tp-signal-set source 2)
|
|
(tp-transaction-register-final-marker
|
|
:owner-key 'public-host
|
|
:expected-token
|
|
(tp-final-marker-expectation-create
|
|
:target target :index 1 :value 'token)
|
|
:expected-version
|
|
(tp-final-marker-expectation-create
|
|
:target target :index 2 :value 0)
|
|
:next-values
|
|
(vector
|
|
(tp-final-marker-slot-write-create
|
|
:target target :index 0 :value 'attached))
|
|
:inverse-values
|
|
(vector
|
|
(tp-final-marker-slot-write-create
|
|
:target target :index 0 :value 'detached))
|
|
:slot-write-count 1
|
|
:operation-key 'tp-vector-slots/v1))
|
|
(should (eq (aref target 0) 'attached)))))
|
|
|
|
(ert-deftest tp-transaction-test-marker-partial-apply-restores-in-reverse ()
|
|
"Partial marker apply restores applied owners before normal rollback."
|
|
(tp-transaction-test--with-surface (buffer _surface source)
|
|
(let* ((first (vector 'old 'token 1))
|
|
(second (vector 'old 'token 1))
|
|
(trace nil)
|
|
(apply-one (symbol-function
|
|
'tp--transaction-apply-one-final-marker))
|
|
(restore-one (symbol-function
|
|
'tp--transaction-restore-one-final-marker)))
|
|
(cl-letf
|
|
(((symbol-function 'tp--transaction-apply-one-final-marker)
|
|
(lambda (marker)
|
|
(funcall apply-one marker)
|
|
(let ((owner (tp-final-accept-marker-owner-key marker)))
|
|
(push (list 'apply owner) trace)
|
|
(when (eq owner 'second-owner)
|
|
(signal 'tp-transaction-test-error
|
|
'(:phase marker-apply))))))
|
|
((symbol-function 'tp--transaction-restore-one-final-marker)
|
|
(lambda (marker)
|
|
(funcall restore-one marker)
|
|
(push (list 'restore
|
|
(tp-final-accept-marker-owner-key marker))
|
|
trace))))
|
|
(should-error
|
|
(tp-with-transaction
|
|
(tp-signal-set source 2)
|
|
(apply #'tp--transaction-register-final-marker
|
|
(tp-transaction-test--marker-arguments
|
|
first [new] [old] :owner-key 'first-owner))
|
|
(apply #'tp--transaction-register-final-marker
|
|
(tp-transaction-test--marker-arguments
|
|
second [new] [old] :owner-key 'second-owner)))
|
|
:type 'tp-transaction-test-error))
|
|
(should (eq (aref first 0) 'old))
|
|
(should (eq (aref second 0) 'old))
|
|
(should
|
|
(equal (nreverse trace)
|
|
'((apply first-owner) (apply second-owner)
|
|
(restore second-owner) (restore first-owner)))))))
|
|
|
|
(ert-deftest tp-transaction-test-accept-fault-restores-all-markers-reverse ()
|
|
"An accept fault reverses all applied markers before transaction rollback."
|
|
(tp-transaction-test--with-surface (buffer _surface source)
|
|
(let* ((first (vector 'old 'token 1))
|
|
(second (vector 'old 'token 1))
|
|
(trace nil)
|
|
(apply-one (symbol-function
|
|
'tp--transaction-apply-one-final-marker))
|
|
(restore-one (symbol-function
|
|
'tp--transaction-restore-one-final-marker)))
|
|
(should-error
|
|
(cl-letf
|
|
(((symbol-function 'tp--transaction-apply-one-final-marker)
|
|
(lambda (marker)
|
|
(funcall apply-one marker)
|
|
(push (list 'apply
|
|
(tp-final-accept-marker-owner-key marker))
|
|
trace)))
|
|
((symbol-function 'tp--transaction-restore-one-final-marker)
|
|
(lambda (marker)
|
|
(funcall restore-one marker)
|
|
(push (list 'restore
|
|
(tp-final-accept-marker-owner-key marker))
|
|
trace)))
|
|
((symbol-function 'accept-change-group)
|
|
(lambda (_group)
|
|
(signal 'tp-transaction-test-error '(:phase accept)))))
|
|
(tp-with-transaction
|
|
(tp-signal-set source 2)
|
|
(apply #'tp--transaction-register-final-marker
|
|
(tp-transaction-test--marker-arguments
|
|
first [new] [old] :owner-key 'first-owner))
|
|
(apply #'tp--transaction-register-final-marker
|
|
(tp-transaction-test--marker-arguments
|
|
second [new] [old] :owner-key 'second-owner))))
|
|
:type 'tp-transaction-test-error)
|
|
(should (equal first [old token 1]))
|
|
(should (equal second [old token 1]))
|
|
(should
|
|
(equal (nreverse trace)
|
|
'((apply first-owner) (apply second-owner)
|
|
(restore second-owner) (restore first-owner)))))))
|
|
|
|
(ert-deftest tp-transaction-test-success-outcome-is-side-channel-only ()
|
|
"Committed evidence appears after accept without replacing BODY return."
|
|
(tp-transaction-test--with-surface (buffer surface source)
|
|
(let ((tp--last-transaction-outcome nil))
|
|
(should (eq (tp-with-transaction
|
|
(tp-signal-set source 2)
|
|
'body-value)
|
|
'body-value))
|
|
(should (tp-committed-success-outcome-p
|
|
tp--last-transaction-outcome))
|
|
(should-not (tp-publication-failure-outcome-p
|
|
tp--last-transaction-outcome))
|
|
(tp-transaction-test--should-match-outcome-counts
|
|
tp--last-transaction-outcome (list surface))
|
|
(should (equal (plist-get tp--last-shadow-proof :phase) 'commit))
|
|
(should (plist-get tp--last-shadow-proof :equivalent))
|
|
(should (plist-get tp--last-shadow-proof :outcome-equivalent))
|
|
(should (= (plist-get tp--last-shadow-proof :entry-count) 1))
|
|
(should (eq (plist-get
|
|
(tp--committed-success-outcome-snapshot
|
|
tp--last-transaction-outcome)
|
|
:tag)
|
|
'committed-success))
|
|
(should-not (fboundp 'tp-committed-success-outcome-promote))
|
|
(should-not (fboundp 'tp-committed-success-outcome-mutate)))))
|
|
|
|
(ert-deftest tp-transaction-test-failure-outcome-is-observational ()
|
|
"Failure evidence preserves the primary condition and cannot pass success."
|
|
(tp-transaction-test--with-surface (buffer surface source)
|
|
(let ((tp--last-transaction-outcome nil)
|
|
(old-text (with-current-buffer buffer (buffer-string)))
|
|
(old-revision (tp-surface-revision surface))
|
|
(injected '(tp-transaction-test-error :phase precommit))
|
|
(tp-transaction-test--precommit-condition
|
|
'(tp-transaction-test-error :phase precommit))
|
|
(tp--transaction-precommit-functions
|
|
'(tp--transaction-test-precommit-inject))
|
|
(tp--transaction-precommit-allowed-functions
|
|
'(tp--transaction-test-precommit-inject)))
|
|
(should (equal (tp-transaction-test--capture
|
|
(lambda () (tp-signal-set source 2)))
|
|
injected))
|
|
(should (tp-publication-failure-outcome-p
|
|
tp--last-transaction-outcome))
|
|
(should-not (tp-committed-success-outcome-p
|
|
tp--last-transaction-outcome))
|
|
(should-not (tp--committed-success-outcome-valid-for-p
|
|
tp--last-transaction-outcome 'any-batch))
|
|
(should (equal (plist-get tp--last-shadow-proof :phase) 'rollback))
|
|
(should (plist-get tp--last-shadow-proof :equivalent))
|
|
(should (plist-get tp--last-shadow-proof :outcome-equivalent))
|
|
(should (= (plist-get tp--last-shadow-proof :entry-count) 1))
|
|
(should (= (tp-surface-revision surface) old-revision))
|
|
(with-current-buffer buffer
|
|
(should (equal (buffer-string) old-text))))))
|
|
|
|
(ert-deftest tp-transaction-test-success-outcome-binding-rejects-replay ()
|
|
"Outcome validation rejects a different candidate at the same revision."
|
|
(with-temp-buffer
|
|
(let* ((entry (tp-transaction-test--entry))
|
|
(candidate
|
|
(tp-transaction-test--set-batch-proof-fields
|
|
(tp-transaction-test--batch (list entry)))))
|
|
(dolist (state '(staged participants precommit final-accepting committed))
|
|
(tp--publication-batch-transition candidate state))
|
|
(let* ((outcome
|
|
(tp--committed-success-outcome-finalize
|
|
(tp--committed-success-outcome-draft
|
|
candidate '(:text 1) '(:total 0.1) nil 0)))
|
|
(replay-entry
|
|
(tp-transaction-test--entry
|
|
:candidate-id 'same-revision-different-candidate
|
|
:authority-token 'different-authority))
|
|
(replay
|
|
(tp-transaction-test--set-batch-proof-fields
|
|
(tp-transaction-test--batch (list replay-entry)))))
|
|
(dolist (state
|
|
'(staged participants precommit final-accepting committed))
|
|
(tp--publication-batch-transition replay state))
|
|
(should (tp--committed-success-outcome-valid-for-p
|
|
outcome candidate 3))
|
|
(should-not (tp--committed-success-outcome-valid-for-p
|
|
outcome replay 3))
|
|
(should-not (tp--committed-success-outcome-valid-for-p
|
|
outcome candidate 4))
|
|
(setcar (cdr (tp-committed-success-outcome-operation-counts outcome))
|
|
2)
|
|
(should-not (tp--committed-success-outcome-valid-for-p
|
|
outcome candidate 3))
|
|
(should (equal (buffer-string) ""))))))
|
|
|
|
(ert-deftest tp-transaction-test-outcome-rejects-cross-surface-and-mount-replay ()
|
|
"Exact replay rejects cross-surface and different-mount candidates purely."
|
|
(let ((first-buffer (generate-new-buffer " *tp-replay-first*"))
|
|
(second-buffer (generate-new-buffer " *tp-replay-second*"))
|
|
(state (vector 'unchanged)))
|
|
(unwind-protect
|
|
(progn
|
|
(with-current-buffer first-buffer (insert "first"))
|
|
(with-current-buffer second-buffer (insert "second"))
|
|
(let* ((entry
|
|
(with-current-buffer first-buffer
|
|
(tp-transaction-test--entry :buffer first-buffer)))
|
|
(candidate
|
|
(tp-transaction-test--set-batch-proof-fields
|
|
(tp-transaction-test--batch (list entry)))))
|
|
(dolist (next
|
|
'(staged participants precommit final-accepting committed))
|
|
(tp--publication-batch-transition candidate next))
|
|
(let* ((outcome
|
|
(tp--committed-success-outcome-finalize
|
|
(tp--committed-success-outcome-draft
|
|
candidate '(:text 1) '(:total 0.1) nil 0)))
|
|
(cross-entry
|
|
(with-current-buffer second-buffer
|
|
(tp-transaction-test--entry
|
|
:surface-id 'surface-b :buffer second-buffer
|
|
:authority-token 'entry-authority-b)))
|
|
(mount-entry
|
|
(with-current-buffer first-buffer
|
|
(tp-transaction-test--entry
|
|
:mount-ids '(different-mount))))
|
|
(cross
|
|
(tp-transaction-test--set-batch-proof-fields
|
|
(tp-transaction-test--batch (list cross-entry))))
|
|
(mount
|
|
(tp-transaction-test--set-batch-proof-fields
|
|
(tp-transaction-test--batch (list mount-entry)))))
|
|
(dolist (replay (list cross mount))
|
|
(dolist (next
|
|
'(staged participants precommit
|
|
final-accepting committed))
|
|
(tp--publication-batch-transition replay next))
|
|
(should-not
|
|
(tp--committed-success-outcome-valid-for-p
|
|
outcome replay 3)))
|
|
(should (equal state [unchanged]))
|
|
(with-current-buffer first-buffer
|
|
(should (equal (buffer-string) "first")))
|
|
(with-current-buffer second-buffer
|
|
(should (equal (buffer-string) "second"))))))
|
|
(when (buffer-live-p first-buffer) (kill-buffer first-buffer))
|
|
(when (buffer-live-p second-buffer) (kill-buffer second-buffer)))))
|
|
|
|
(ert-deftest tp-transaction-test-multifragment-mount-ids-are-stable-in-outcome ()
|
|
"One logical object's distinct fragment mounts retain exact outcome IDs."
|
|
(let ((buffer (generate-new-buffer " *tp-multifragment-outcome*"))
|
|
(left "A") (right "C") logical)
|
|
(unwind-protect
|
|
(let* ((producer
|
|
(lambda (context)
|
|
(let* ((root (tp-object-ensure context nil 'root 'group))
|
|
(left-object
|
|
(tp-object-ensure context root 'left 'text))
|
|
(gap-object
|
|
(tp-object-ensure context root 'gap 'text))
|
|
(right-object
|
|
(tp-object-ensure context root 'right 'text)))
|
|
(setq logical
|
|
(tp-object-ensure context root 'logical 'item))
|
|
(tp-object-retain context logical)
|
|
(tp-object-attach-fragment
|
|
context logical left-object '(:slot left))
|
|
(tp-object-attach-fragment
|
|
context logical right-object '(:slot right))
|
|
(ignore gap-object))
|
|
(tp-surface-plan-create
|
|
:key 'root :kind 'group :capability 'content
|
|
:children
|
|
(list
|
|
(tp-surface-plan-create
|
|
:key 'left :kind 'text :text left :capability 'content)
|
|
(tp-surface-plan-create
|
|
:key 'gap :kind 'text :text "|" :capability 'content)
|
|
(tp-surface-plan-create
|
|
:key 'right :kind 'text :text right
|
|
:capability 'content)))))
|
|
(surface
|
|
(tp-surface-mount buffer producer '(:capability content)))
|
|
(before
|
|
(mapcar #'tp--ensure-surface-mount-id
|
|
(cl-remove-if-not
|
|
(lambda (mount)
|
|
(eq (tp--surface-mount-object mount) logical))
|
|
(tp--surface-mounts surface)))))
|
|
(should (= (length before) 2))
|
|
(should-not (= (car before) (cadr before)))
|
|
(setq left "LEFT" right "RIGHT")
|
|
(tp-surface-update-scoped surface (list logical) producer)
|
|
(let* ((after
|
|
(mapcar #'tp--ensure-surface-mount-id
|
|
(cl-remove-if-not
|
|
(lambda (mount)
|
|
(eq (tp--surface-mount-object mount) logical))
|
|
(tp--surface-mounts surface))))
|
|
(entry (car (tp-committed-success-outcome-entries
|
|
tp--last-transaction-outcome)))
|
|
(outcome-ids
|
|
(tp-publication-outcome-entry-mount-ids entry)))
|
|
(should (equal after before))
|
|
(dolist (id before)
|
|
(should (memq id outcome-ids)))
|
|
(tp-transaction-test--should-match-outcome-counts
|
|
tp--last-transaction-outcome (list surface))))
|
|
(when (buffer-live-p buffer) (kill-buffer buffer)))))
|
|
|
|
(ert-deftest tp-transaction-test-candidates-remain-invisible-until-staged ()
|
|
"Preparing a candidate does not mutate any live buffer or revision."
|
|
(tp-transaction-test--with-surface (buffer surface source)
|
|
(let ((text (with-current-buffer buffer (buffer-string)))
|
|
(revision (tp-surface-revision surface)))
|
|
(with-current-buffer buffer
|
|
(tp-transaction-test--batch
|
|
(list (tp-transaction-test--entry
|
|
:surface-id (tp--surface-id surface)
|
|
:buffer buffer
|
|
:old-revision revision
|
|
:new-revision (1+ revision)))))
|
|
(should (= (tp-surface-revision surface) revision))
|
|
(with-current-buffer buffer
|
|
(should (equal (buffer-string) text))))))
|
|
|
|
(ert-deftest tp-transaction-test-v2-is-multisurface-and-single-writer ()
|
|
"The v2 artifacts cover all surfaces while each live writer runs once."
|
|
(let* ((source (tp-signal-create 1))
|
|
(producer (tp-transaction-test--producer source))
|
|
(first-buffer (generate-new-buffer " *tp-transaction-first*"))
|
|
(second-buffer (generate-new-buffer " *tp-transaction-second*"))
|
|
(first (tp-surface-mount first-buffer producer '(:capability content)))
|
|
(second (tp-surface-mount second-buffer producer '(:capability content)))
|
|
(calls (make-hash-table :test #'eq))
|
|
(writer (symbol-function 'tp--publish-one-surface))
|
|
(tp--last-transaction-outcome nil))
|
|
(unwind-protect
|
|
(cl-letf (((symbol-function 'tp--publish-one-surface)
|
|
(lambda (prepared)
|
|
(let ((surface (tp--prepared-surface-surface prepared)))
|
|
(puthash surface (1+ (gethash surface calls 0)) calls))
|
|
(funcall writer prepared))))
|
|
(tp-signal-set source 2)
|
|
(should (= (gethash first calls 0) 1))
|
|
(should (= (gethash second calls 0) 1))
|
|
(should (tp-committed-success-outcome-p
|
|
tp--last-transaction-outcome))
|
|
(tp-transaction-test--should-match-outcome-counts
|
|
tp--last-transaction-outcome (list first second))
|
|
(should (equal (plist-get tp--last-shadow-proof :phase) 'commit))
|
|
(should (plist-get tp--last-shadow-proof :equivalent))
|
|
(should (plist-get tp--last-shadow-proof :outcome-equivalent))
|
|
(should (= (plist-get tp--last-shadow-proof :entry-count) 2))
|
|
(should (integerp
|
|
(tp-committed-success-outcome-mapping-generation
|
|
tp--last-transaction-outcome)))
|
|
(should (= (length (tp-committed-success-outcome-entries
|
|
tp--last-transaction-outcome))
|
|
2))
|
|
(dolist (entry (tp-committed-success-outcome-entries
|
|
tp--last-transaction-outcome))
|
|
(should (= (tp-publication-outcome-entry-new-revision entry)
|
|
(1+ (tp-publication-outcome-entry-old-revision entry))))
|
|
(should (= (tp-publication-outcome-entry-mapping-generation entry)
|
|
(tp-committed-success-outcome-mapping-generation
|
|
tp--last-transaction-outcome)))))
|
|
(when (buffer-live-p first-buffer) (kill-buffer first-buffer))
|
|
(when (buffer-live-p second-buffer) (kill-buffer second-buffer))
|
|
(when (tp-signal-live-p source) (tp-signal-dispose source)))))
|
|
|
|
(ert-deftest tp-transaction-test-canonical-artifact-mismatch-is-diagnostic ()
|
|
"A postcommit canonical artifact mismatch is detected and contained."
|
|
(tp-transaction-test--with-surface (buffer surface source)
|
|
(let ((current-artifact (symbol-function 'tp--shadow-current-artifact)))
|
|
(cl-letf (((symbol-function 'tp--shadow-current-artifact)
|
|
(lambda (target)
|
|
(let ((artifact (funcall current-artifact target)))
|
|
(plist-put artifact :revision
|
|
(1+ (plist-get artifact :revision)))))))
|
|
(tp-signal-set source 2))
|
|
(should (= (tp-signal-peek source) 2))
|
|
(should (= (tp-surface-revision surface) 2))
|
|
(with-current-buffer buffer
|
|
(should (equal (buffer-string) "2")))
|
|
(should (equal (plist-get tp--last-shadow-proof :phase) 'commit))
|
|
(should-not (plist-get tp--last-shadow-proof :equivalent))
|
|
(should (plist-get tp--last-shadow-proof :outcome-equivalent))
|
|
(should (= (plist-get tp--last-shadow-proof :entry-count) 1))
|
|
(should
|
|
(cl-some
|
|
(lambda (entry)
|
|
(and (eq (car entry) 'shadow-proof)
|
|
(eq (cadr entry) 'commit)))
|
|
tp--last-transaction-diagnostics)))))
|
|
|
|
(ert-deftest tp-transaction-test-zero-surface-does-not-create-batch-or-outcome ()
|
|
"Pure, semantic and external-only transactions stay outside batch API."
|
|
(let ((tp--last-transaction-outcome 'sentinel)
|
|
captured-batch captured-outcome)
|
|
(should (eq (tp-with-transaction
|
|
(setq captured-batch tp--transaction-publication-batch
|
|
captured-outcome tp--transaction-outcome)
|
|
'pure-result)
|
|
'pure-result))
|
|
(should-not captured-batch)
|
|
(should-not captured-outcome)
|
|
(should-not tp--last-transaction-outcome)
|
|
(tp-with-transaction
|
|
(tp-transaction-participate-v2 :key 'external-only
|
|
:stage #'ignore :rollback #'ignore))
|
|
(should-not tp--last-transaction-outcome)))
|
|
|
|
(ert-deftest tp-transaction-test-unobserved-signal-excludes-publication-batch ()
|
|
"An unobserved semantic signal commit creates no publication evidence."
|
|
(let ((signal (tp-signal-create 1))
|
|
(begin-batch (symbol-function 'tp--transaction-begin-publication-batch))
|
|
(batch-calls 0))
|
|
(unwind-protect
|
|
(cl-letf (((symbol-function 'tp--transaction-begin-publication-batch)
|
|
(lambda (&rest arguments)
|
|
(cl-incf batch-calls)
|
|
(apply begin-batch arguments))))
|
|
(tp-signal-set signal 2)
|
|
(should (= (tp-signal-peek signal) 2))
|
|
(should (= (tp-signal-revision signal) 1))
|
|
(should (= batch-calls 0))
|
|
(should-not tp--last-transaction-outcome))
|
|
(when (tp-signal-live-p signal) (tp-signal-dispose signal)))))
|
|
|
|
(ert-deftest tp-transaction-test-surface-unmount-excludes-publication-batch ()
|
|
"Surface teardown uses its external path without batch or outcome evidence."
|
|
(let* ((buffer (generate-new-buffer " *tp-unmount-exclusion*"))
|
|
(surface
|
|
(tp-surface-mount
|
|
buffer (tp-transaction-test--leaf "mounted")
|
|
'(:capability content)))
|
|
(begin-batch (symbol-function 'tp--transaction-begin-publication-batch))
|
|
(batch-calls 0))
|
|
(unwind-protect
|
|
(progn
|
|
(setq tp--last-transaction-outcome nil)
|
|
(cl-letf
|
|
(((symbol-function 'tp--transaction-begin-publication-batch)
|
|
(lambda (&rest arguments)
|
|
(cl-incf batch-calls)
|
|
(apply begin-batch arguments))))
|
|
(tp-surface-unmount surface))
|
|
(should (= batch-calls 0))
|
|
(should-not tp--last-transaction-outcome)
|
|
(should-not (tp-surface-live-p surface))
|
|
(with-current-buffer buffer
|
|
(should (equal (buffer-string) ""))))
|
|
(when (buffer-live-p buffer) (kill-buffer buffer)))))
|
|
|
|
(ert-deftest tp-transaction-test-output-equal-does-not-create-batch-or-outcome ()
|
|
"A recompute with no surface artifact change stays outside batch API."
|
|
(let* ((buffer (generate-new-buffer " *tp-transaction-output-equal*"))
|
|
(source (tp-signal-create 1))
|
|
(surface
|
|
(tp-surface-mount
|
|
buffer
|
|
(lambda (context)
|
|
(tp-object-ensure context nil 'root 'text)
|
|
(tp-signal-read source)
|
|
(tp-transaction-test--leaf "constant"))
|
|
'(:capability content)))
|
|
(revision (tp-surface-revision surface))
|
|
(tp--last-transaction-outcome 'sentinel)
|
|
captured-batch)
|
|
(unwind-protect
|
|
(progn
|
|
(tp-with-transaction
|
|
(tp-signal-set source 2)
|
|
(setq captured-batch tp--transaction-publication-batch))
|
|
(should-not captured-batch)
|
|
(should-not tp--last-transaction-outcome)
|
|
(should (= (tp-surface-revision surface) revision))
|
|
(with-current-buffer buffer
|
|
(should (equal (buffer-string) "constant"))))
|
|
(when (buffer-live-p buffer) (kill-buffer buffer))
|
|
(when (tp-signal-live-p source) (tp-signal-dispose source)))))
|
|
|
|
(ert-deftest tp-transaction-test-live-candidate-is-body-invisible-and-outcome-cell-separated ()
|
|
"The body sees old live state while its retained cell receives evidence."
|
|
(tp-transaction-test--with-surface (buffer surface source)
|
|
(let ((old-revision (tp-surface-revision surface))
|
|
outcome-cell body-batch body-text body-revision)
|
|
(should
|
|
(eq
|
|
(tp-with-transaction
|
|
(tp-signal-set source 2)
|
|
(setq outcome-cell (tp--transaction-current-outcome-cell)
|
|
body-batch tp--transaction-publication-batch
|
|
body-text (with-current-buffer buffer (buffer-string))
|
|
body-revision (tp-surface-revision surface))
|
|
'body-result)
|
|
'body-result))
|
|
(should-not body-batch)
|
|
(should (equal body-text "1"))
|
|
(should (= body-revision old-revision))
|
|
(should (vectorp outcome-cell))
|
|
(should (= (length outcome-cell) 1))
|
|
(should (tp-committed-success-outcome-p (aref outcome-cell 0)))
|
|
(should (eq (aref outcome-cell 0) tp--last-transaction-outcome))
|
|
(should (= (tp-surface-revision surface) (1+ old-revision)))
|
|
(with-current-buffer buffer
|
|
(should (equal (buffer-string) "2"))))))
|
|
|
|
(ert-deftest tp-transaction-test-scoped-content-v2-publication ()
|
|
"Scoped content artifacts equal the single committed writer result."
|
|
(let ((buffer (generate-new-buffer " *tp-transaction-scoped*"))
|
|
(middle "B")
|
|
(middle-face 'bold)
|
|
middle-object)
|
|
(unwind-protect
|
|
(let* ((producer
|
|
(lambda (context)
|
|
(let ((root (tp-object-ensure context nil 'root 'group)))
|
|
(tp-object-ensure context root 'left 'text)
|
|
(setq middle-object
|
|
(tp-object-ensure context root 'middle 'text))
|
|
(tp-object-ensure context root 'right 'text))
|
|
(tp-surface-plan-create
|
|
:key 'root :kind 'group :capability 'content
|
|
:children
|
|
(list
|
|
(tp-surface-plan-create
|
|
:key 'left :kind 'text :text "A"
|
|
:capability 'content)
|
|
(tp-surface-plan-create
|
|
:key 'middle :kind 'text :text middle
|
|
:props (list 'face middle-face)
|
|
:capability 'content)
|
|
(tp-surface-plan-create
|
|
:key 'right :kind 'text :text "C"
|
|
:capability 'content)))))
|
|
(surface
|
|
(tp-surface-mount buffer producer '(:capability content)))
|
|
(revision (tp-surface-revision surface)))
|
|
(setq middle "LONG"
|
|
middle-face 'italic)
|
|
(tp-surface-update-scoped
|
|
surface (list middle-object) producer)
|
|
(should (= (tp-surface-revision surface) (1+ revision)))
|
|
(with-current-buffer buffer
|
|
(should (equal (buffer-string) "ALONGC"))
|
|
(should (eq (get-text-property 2 'face) 'italic)))
|
|
(should (tp-committed-success-outcome-p
|
|
tp--last-transaction-outcome))
|
|
(tp-transaction-test--should-match-outcome-counts
|
|
tp--last-transaction-outcome (list surface)))
|
|
(when (buffer-live-p buffer) (kill-buffer buffer)))))
|
|
|
|
(ert-deftest tp-transaction-test-properties-only-v2-publication ()
|
|
"Properties-only artifacts equal live properties without replacing text."
|
|
(let ((buffer (generate-new-buffer " *tp-transaction-properties*"))
|
|
(value 'bold))
|
|
(unwind-protect
|
|
(with-current-buffer buffer
|
|
(insert "host")
|
|
(let* ((anchor (tp-range-anchor-create buffer 1 5))
|
|
(producer
|
|
(lambda (context)
|
|
(let ((object
|
|
(tp-object-ensure context nil 'root 'range)))
|
|
(tp-object-attach-range context object anchor))
|
|
(tp-surface-plan-create
|
|
:key 'root :kind 'range :props (list 'face value)
|
|
:capability 'properties)))
|
|
(surface
|
|
(tp-surface-mount
|
|
buffer producer '(:capability properties)))
|
|
(revision (tp-surface-revision surface)))
|
|
(setq value 'italic)
|
|
(tp-surface-update surface producer)
|
|
(should (equal (buffer-string) "host"))
|
|
(should (eq (get-text-property 2 'face) 'italic))
|
|
(should (= (tp-surface-revision surface) (1+ revision)))
|
|
(should (tp-committed-success-outcome-p
|
|
tp--last-transaction-outcome))
|
|
(tp-transaction-test--should-match-outcome-counts
|
|
tp--last-transaction-outcome (list surface))))
|
|
(when (buffer-live-p buffer) (kill-buffer buffer)))))
|
|
|
|
(ert-deftest tp-transaction-test-property-surface-fault-matrix-restores-exact-state ()
|
|
"Every late fault restores exact multi-surface property publication state."
|
|
(dolist (phase '(second-surface participant precommit final-accept))
|
|
(let* ((source (tp-signal-create 1))
|
|
(first-buffer (generate-new-buffer " *tp-property-fault-first*"))
|
|
(second-buffer
|
|
(generate-new-buffer " *tp-property-fault-second*"))
|
|
first-anchor second-anchor first second first-state second-state
|
|
(injected
|
|
(list 'tp-transaction-test-error :phase phase :payload '(raw))))
|
|
(unwind-protect
|
|
(progn
|
|
(with-current-buffer first-buffer
|
|
(insert "first")
|
|
(goto-char 3)
|
|
(setq first-anchor
|
|
(tp-range-anchor-create first-buffer 1 (point-max))))
|
|
(with-current-buffer second-buffer
|
|
(insert "second")
|
|
(goto-char 4)
|
|
(setq second-anchor
|
|
(tp-range-anchor-create second-buffer 1 (point-max))))
|
|
(setq first
|
|
(with-current-buffer first-buffer
|
|
(tp-surface-mount
|
|
first-buffer
|
|
(tp-transaction-test--property-producer
|
|
source first-anchor)
|
|
'(:capability properties)))
|
|
second
|
|
(with-current-buffer second-buffer
|
|
(tp-surface-mount
|
|
second-buffer
|
|
(tp-transaction-test--property-producer
|
|
source second-anchor)
|
|
'(:capability properties)))
|
|
first-state (tp-transaction-test--property-state first)
|
|
second-state (tp-transaction-test--property-state second))
|
|
(let ((tp--surface-publication-step-function
|
|
(and
|
|
(eq phase 'second-surface)
|
|
(lambda (step surface)
|
|
(when (and (eq step 'client-state)
|
|
(eq surface second))
|
|
(signal (car injected) (cdr injected))))))
|
|
(tp-transaction-test--precommit-condition
|
|
(and (eq phase 'precommit) injected))
|
|
(tp--transaction-precommit-functions
|
|
(if (eq phase 'precommit)
|
|
'(tp--transaction-test-precommit-inject)
|
|
tp--transaction-precommit-functions))
|
|
(tp--transaction-precommit-allowed-functions
|
|
(if (eq phase 'precommit)
|
|
'(tp--transaction-test-precommit-inject)
|
|
tp--transaction-precommit-allowed-functions)))
|
|
(should
|
|
(equal
|
|
(cl-letf
|
|
(((symbol-function 'accept-change-group)
|
|
(let ((accept (symbol-function 'accept-change-group)))
|
|
(lambda (group)
|
|
(if (eq phase 'final-accept)
|
|
(signal (car injected) (cdr injected))
|
|
(funcall accept group))))))
|
|
(tp-transaction-test--capture
|
|
(lambda ()
|
|
(tp-with-transaction
|
|
(when (eq phase 'participant)
|
|
(tp-transaction-participate-v2
|
|
:key 'property-fault-participant
|
|
:stage (lambda ()
|
|
(signal (car injected) (cdr injected)))
|
|
:rollback #'ignore))
|
|
(tp-signal-set source 2)))))
|
|
injected)))
|
|
(should (= (tp-signal-peek source) 1))
|
|
(should (= (tp-signal-revision source) 0))
|
|
(tp-transaction-test--should-match-property-state
|
|
first first-state)
|
|
(tp-transaction-test--should-match-property-state
|
|
second second-state)
|
|
(with-current-buffer first-buffer
|
|
(should (eq (get-text-property 2 'face) 'bold)))
|
|
(with-current-buffer second-buffer
|
|
(should (eq (get-text-property 2 'face) 'bold)))
|
|
(should (tp-publication-failure-outcome-p
|
|
tp--last-transaction-outcome)))
|
|
(when (buffer-live-p first-buffer) (kill-buffer first-buffer))
|
|
(when (buffer-live-p second-buffer) (kill-buffer second-buffer))
|
|
(when (tp-signal-live-p source) (tp-signal-dispose source))))))
|
|
|
|
(ert-deftest tp-transaction-test-final-accept-source-uses-v2-binding ()
|
|
"V2 validates the candidate final accept binding before publication."
|
|
(let* ((structured-buffer (generate-new-buffer " *tp-final-structured*"))
|
|
(initial (tp-transaction-test--leaf "old"))
|
|
(next (tp-transaction-test--leaf "new"))
|
|
(structured (tp-surface-mount structured-buffer initial
|
|
'(:capability content)))
|
|
(sync (symbol-function 'tp--transaction-sync-publication-batch)))
|
|
(unwind-protect
|
|
(cl-letf (((symbol-function 'tp--transaction-sync-publication-batch)
|
|
(lambda ()
|
|
(funcall sync)
|
|
(when tp--transaction-publication-batch
|
|
(setf (tp-publication-batch-candidate-final-accept
|
|
tp--transaction-publication-batch)
|
|
#'ignore)))))
|
|
(should-error (tp-surface-update structured next)
|
|
:type 'tp-publication-binding-error)
|
|
(with-current-buffer structured-buffer
|
|
(should (equal (buffer-string) "old")))
|
|
(should (tp-publication-failure-outcome-p
|
|
tp--last-transaction-outcome)))
|
|
(when (buffer-live-p structured-buffer) (kill-buffer structured-buffer))
|
|
)))
|
|
|
|
(ert-deftest tp-transaction-test-structured-batch-owns-surface-stage-once ()
|
|
"Structured execution enters the candidate seam and writes each entry once."
|
|
(let* ((source (tp-signal-create 1))
|
|
(producer (tp-transaction-test--producer source))
|
|
(first-buffer (generate-new-buffer " *tp-structured-first*"))
|
|
(second-buffer (generate-new-buffer " *tp-structured-second*"))
|
|
(first (tp-surface-mount first-buffer producer '(:capability content)))
|
|
(second (tp-surface-mount second-buffer producer '(:capability content)))
|
|
(execute (symbol-function 'tp--publication-batch-execute-stage))
|
|
(writer (symbol-function 'tp--publish-one-surface))
|
|
(calls (make-hash-table :test #'eq))
|
|
(stage-calls 0))
|
|
(unwind-protect
|
|
(cl-letf (((symbol-function 'tp--publication-batch-execute-stage)
|
|
(lambda (candidate)
|
|
(cl-incf stage-calls)
|
|
(funcall execute candidate)))
|
|
((symbol-function 'tp--publish-one-surface)
|
|
(lambda (prepared)
|
|
(let ((surface (tp--prepared-surface-surface prepared)))
|
|
(puthash surface (1+ (gethash surface calls 0)) calls))
|
|
(funcall writer prepared))))
|
|
(tp-signal-set source 2)
|
|
(should (= stage-calls 1))
|
|
(should (= (gethash first calls 0) 1))
|
|
(should (= (gethash second calls 0) 1))
|
|
(should (tp-committed-success-outcome-p tp--last-transaction-outcome)))
|
|
(when (buffer-live-p first-buffer) (kill-buffer first-buffer))
|
|
(when (buffer-live-p second-buffer) (kill-buffer second-buffer))
|
|
(when (tp-signal-live-p source) (tp-signal-dispose source)))))
|
|
|
|
(ert-deftest tp-transaction-test-public-v2-participant-stages-once-from-batch ()
|
|
"The public v2 participant is one structured participant in the batch vector."
|
|
(tp-transaction-test--with-surface (buffer _surface source)
|
|
(let ((stages 0) captured participant)
|
|
(tp-with-transaction
|
|
(tp-transaction-participate-v2
|
|
:key 'public-v2
|
|
:stage (lambda ()
|
|
(cl-incf stages)
|
|
(setq captured tp--transaction-publication-batch
|
|
participant
|
|
(aref (tp-publication-batch-candidate-participants
|
|
tp--transaction-publication-batch)
|
|
0)))
|
|
:rollback #'ignore)
|
|
(tp-signal-set source 2))
|
|
(should (= stages 1))
|
|
(should (tp-publication-batch-candidate-p captured))
|
|
(should (eq (tp--transaction-participant-protocol participant) 'v2))
|
|
(should (eq (tp--transaction-participant-state participant) 'committed)))))
|
|
|
|
(ert-deftest tp-transaction-test-batch-rejects-foreign-stage-capability ()
|
|
"A publication batch accepts only the closed package-owned stage seam."
|
|
(should-error
|
|
(tp--publication-batch-prepare
|
|
:transaction-id 'transaction-a
|
|
:batch-id 'batch-a
|
|
:entries (list (tp-transaction-test--entry))
|
|
:participants []
|
|
:journals nil
|
|
:stage-entries #'ignore
|
|
:final-accept #'ignore)
|
|
:type 'tp-publication-binding-error))
|
|
|
|
(ert-deftest tp-transaction-test-participant-vector-drift-rolls-back-surfaces ()
|
|
"Registration drift after batch binding fails fast and restores live state."
|
|
(tp-transaction-test--with-surface (buffer surface source)
|
|
(let ((revision (tp-surface-revision surface))
|
|
(stage (symbol-function 'tp--publication-batch-execute-stage)))
|
|
(cl-letf (((symbol-function 'tp--publication-batch-execute-stage)
|
|
(lambda (candidate)
|
|
(tp-transaction-participate-v2 :key 'late
|
|
:stage #'ignore
|
|
:rollback #'ignore)
|
|
(funcall stage candidate))))
|
|
(should-error (tp-signal-set source 2)
|
|
:type 'tp-publication-binding-error))
|
|
(should (= (tp-signal-peek source) 1))
|
|
(should (= (tp-surface-revision surface) revision))
|
|
(with-current-buffer buffer
|
|
(should (equal (buffer-string) "1"))))))
|
|
|
|
(ert-deftest tp-transaction-test-ordinary-update-success-has-zero-markers ()
|
|
"An ordinary publication records zero final authority markers."
|
|
(tp-transaction-test--with-surface (buffer _surface source)
|
|
(tp-signal-set source 2)
|
|
(should (tp-committed-success-outcome-p tp--last-transaction-outcome))
|
|
(should (= (tp-committed-success-outcome-marker-count
|
|
tp--last-transaction-outcome)
|
|
0))
|
|
(let ((timings
|
|
(tp-committed-success-outcome-phase-timings
|
|
tp--last-transaction-outcome)))
|
|
(dolist (phase '(body recompute publication participants
|
|
precommit signal-commit))
|
|
(should (numberp (alist-get phase timings)))
|
|
(should (>= (alist-get phase timings) 0.0))))))
|
|
|
|
(ert-deftest tp-transaction-test-final-marker-global-count-bound ()
|
|
"The fixed marker registry rejects one owner beyond its global bound."
|
|
(tp-transaction-test--with-surface (buffer _surface source)
|
|
(let (targets)
|
|
(dotimes (_ tp--final-marker-max-count)
|
|
(push (vector 'old 'token 1) targets))
|
|
(setq targets (nreverse targets))
|
|
(tp-with-transaction
|
|
(tp-signal-set source 2)
|
|
(cl-loop for target in targets
|
|
for index from 0
|
|
do
|
|
(apply #'tp--transaction-register-final-marker
|
|
(tp-transaction-test--marker-arguments
|
|
target [new] [old]
|
|
:owner-key (intern (format "owner-%d" index)))))
|
|
(let ((extra (vector 'old 'token 1)))
|
|
(should-error
|
|
(apply #'tp--transaction-register-final-marker
|
|
(tp-transaction-test--marker-arguments
|
|
extra [new] [old] :owner-key 'owner-overflow))
|
|
:type 'tp-final-marker-error)
|
|
(should (eq (aref extra 0) 'old))))
|
|
(dolist (target targets)
|
|
(should (eq (aref target 0) 'new))))))
|
|
|
|
(ert-deftest tp-transaction-test-final-marker-aggregate-slot-write-bound ()
|
|
"Real three-slot and one-slot payloads obey the aggregate write bound."
|
|
(tp-transaction-test--with-surface (buffer _surface source)
|
|
(let ((three-slot-targets
|
|
(cl-loop repeat 5 collect
|
|
(vector 'old 'old 'old 'token 1)))
|
|
(one-slot-target (vector 'old 'token 1))
|
|
(overflow-target (vector 'old 'token 1)))
|
|
(tp-with-transaction
|
|
(tp-signal-set source 2)
|
|
(cl-loop for target in three-slot-targets
|
|
for index from 0
|
|
do
|
|
(apply #'tp--transaction-register-final-marker
|
|
(tp-transaction-test--marker-arguments
|
|
target [new new new] [old old old]
|
|
:owner-key
|
|
(intern (format "three-slot-owner-%d" index)))))
|
|
(apply #'tp--transaction-register-final-marker
|
|
(tp-transaction-test--marker-arguments
|
|
one-slot-target [new] [old] :owner-key 'one-slot-owner))
|
|
(should-error
|
|
(apply #'tp--transaction-register-final-marker
|
|
(tp-transaction-test--marker-arguments
|
|
overflow-target [new] [old] :owner-key 'slot-overflow))
|
|
:type 'tp-final-marker-error))
|
|
(dolist (target three-slot-targets)
|
|
(should (equal (seq-subseq target 0 3) [new new new])))
|
|
(should (eq (aref one-slot-target 0) 'new))
|
|
(should (eq (aref overflow-target 0) 'old)))))
|
|
|
|
(ert-deftest tp-transaction-test-marker-restore-faults-exhaust-all-markers ()
|
|
"Restore error, quit, and throw cannot skip markers or rollback."
|
|
(dolist (kind '(error quit throw))
|
|
(tp-transaction-test--with-surface (buffer surface source)
|
|
(let* ((targets
|
|
(list (vector 'old 'token 1)
|
|
(vector 'old 'token 1)
|
|
(vector 'old 'token 1)))
|
|
(revision (tp-surface-revision surface))
|
|
(restore-one (symbol-function
|
|
'tp--transaction-restore-one-final-marker))
|
|
(injected '(tp-transaction-test-error :phase accept))
|
|
result)
|
|
(cl-letf
|
|
(((symbol-function 'tp--transaction-restore-one-final-marker)
|
|
(lambda (marker)
|
|
(funcall restore-one marker)
|
|
(when (eq (tp-final-accept-marker-owner-key marker)
|
|
'middle-owner)
|
|
(pcase kind
|
|
('error
|
|
(signal 'tp-transaction-test-error
|
|
'(:phase marker-restore)))
|
|
('quit (signal 'quit nil))
|
|
('throw
|
|
(throw 'tp-transaction-test-restore-throw kind))))))
|
|
((symbol-function 'accept-change-group)
|
|
(lambda (_group) (signal (car injected) (cdr injected)))))
|
|
(let ((transaction
|
|
(lambda ()
|
|
(tp-with-transaction
|
|
(tp-signal-set source 2)
|
|
(cl-loop
|
|
for target in targets
|
|
for owner in '(first-owner middle-owner last-owner)
|
|
do
|
|
(apply #'tp--transaction-register-final-marker
|
|
(tp-transaction-test--marker-arguments
|
|
target [new] [old] :owner-key owner)))))))
|
|
(setq result
|
|
(if (eq kind 'throw)
|
|
(catch 'tp-transaction-test-restore-throw
|
|
(funcall transaction)
|
|
'not-thrown)
|
|
(tp-transaction-test--capture transaction)))))
|
|
(if (eq kind 'throw)
|
|
(should (eq result 'throw))
|
|
(should (equal (seq-take result 3) injected))
|
|
(should (tp--transaction-condition-trailer
|
|
result :rollback-failures)))
|
|
(dolist (target targets)
|
|
(should (equal target [old token 1])))
|
|
(should (= (tp-signal-peek source) 1))
|
|
(should (= (tp-signal-revision source) 0))
|
|
(should (= (tp-surface-revision surface) revision))
|
|
(with-current-buffer buffer
|
|
(should (equal (buffer-string) "1")))))))
|
|
|
|
(ert-deftest tp-transaction-test-participant-after-commit-fault-is-contained ()
|
|
"After-commit participant failure is diagnostic and stays committed."
|
|
(let (participant)
|
|
(should
|
|
(eq
|
|
(tp-with-transaction
|
|
(tp--transaction-participate-v2
|
|
:key 'contained-after-commit
|
|
:stage #'ignore
|
|
:rollback (lambda ()
|
|
(error "Committed participant must not roll back"))
|
|
:after-commit
|
|
(lambda ()
|
|
(signal 'tp-transaction-test-error '(:phase after-commit))))
|
|
(setq participant (car tp--transaction-participants))
|
|
'body-result)
|
|
'body-result))
|
|
(should (eq (tp--transaction-participant-state participant) 'committed))
|
|
(should
|
|
(cl-some
|
|
(lambda (entry)
|
|
(and (eq (car entry) 'after-commit)
|
|
(equal (caddr entry)
|
|
'(tp-transaction-test-error :phase after-commit))))
|
|
tp--last-transaction-diagnostics))))
|
|
|
|
(ert-deftest tp-transaction-test-marker-nonlocal-throw-restores-state ()
|
|
"Marker apply and accept throws reverse authority and live publication."
|
|
(dolist (phase '(apply accept))
|
|
(tp-transaction-test--with-surface (buffer surface source)
|
|
(let* ((target (vector 'old 'token 1))
|
|
(revision (tp-surface-revision surface))
|
|
(apply-one (symbol-function
|
|
'tp--transaction-apply-one-final-marker))
|
|
(accept (symbol-function 'accept-change-group)))
|
|
(should
|
|
(eq
|
|
(catch 'tp-transaction-test-nonlocal
|
|
(cl-letf (((symbol-function
|
|
'tp--transaction-apply-one-final-marker)
|
|
(lambda (marker)
|
|
(funcall apply-one marker)
|
|
(when (eq phase 'apply)
|
|
(throw 'tp-transaction-test-nonlocal phase))))
|
|
((symbol-function 'accept-change-group)
|
|
(lambda (group)
|
|
(if (eq phase 'accept)
|
|
(throw 'tp-transaction-test-nonlocal phase)
|
|
(funcall accept group)))))
|
|
(tp-with-transaction
|
|
(tp-signal-set source 2)
|
|
(apply #'tp--transaction-register-final-marker
|
|
(tp-transaction-test--marker-arguments
|
|
target [new] [old] :owner-key phase))))
|
|
'not-thrown)
|
|
phase))
|
|
(should (equal target [old token 1]))
|
|
(should (= (tp-signal-peek source) 1))
|
|
(should (= (tp-signal-revision source) 0))
|
|
(should (= (tp-surface-revision surface) revision))
|
|
(with-current-buffer buffer
|
|
(should (equal (buffer-string) "1")))))))
|
|
|
|
(ert-deftest tp-transaction-test-manifest-advertises-v2-only-contract ()
|
|
"The manifest advertises v2 without any legacy route capability."
|
|
(should (eq tp-transaction-protocol 'tp-transaction-protocol-v2))
|
|
(let ((manifest (tp-runtime-manifest)))
|
|
(should (equal (plist-get manifest :version) "2.0.0"))
|
|
(should (eq (plist-get manifest :transaction-protocol)
|
|
'tp-transaction-protocol-v2))
|
|
(should (eq (plist-get manifest :structured-participant-api)
|
|
'tp-transaction-participate-v2))
|
|
(should (plist-get manifest :batch-artifacts))
|
|
(should (plist-get manifest :batch-execute))
|
|
(should (plist-get manifest :single-live-writer))
|
|
(dolist (property '(:execution-route :execution-default :execution-routes
|
|
:route-option :batch-execution :v1-adapter
|
|
:v1-rollback-route))
|
|
(should-not (plist-member manifest property)))))
|
|
|
|
(ert-deftest tp-transaction-test-v1-public-controls-are-absent ()
|
|
"TP 2.0 exposes no executable v1 facade or route switches."
|
|
(should-not (fboundp 'tp-transaction-participate))
|
|
(should-not (fboundp 'tp--publish-transaction-participants))
|
|
(should-not (fboundp 'tp--surface-stage-v1-prepared))
|
|
(should-not (fboundp 'tp--transaction-validate-execution-route))
|
|
(should-not (boundp 'tp-transaction-execution-route))
|
|
(should-not (boundp 'tp--transaction-artifact-mode)))
|
|
|
|
(provide 'tp-transaction-tests)
|
|
|
|
;;; tp-transaction-tests.el ends here
|