455 lines
22 KiB
EmacsLisp
455 lines
22 KiB
EmacsLisp
;;; etaf-generation-tests.el --- M3a generation authority gates -*- lexical-binding: t; -*-
|
|
|
|
;; SPDX-License-Identifier: GPL-3.0-or-later
|
|
|
|
(require 'ert)
|
|
(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)
|
|
(etaf-view
|
|
(text :ref 'generation-target :role 'button
|
|
:on-press #'ignore "visible"))
|
|
(etaf-view (text :ref 'generation-other "other"))))
|
|
|
|
(ert-deftest etaf-generation-authority-is-runtime-single-source ()
|
|
"Runtime compatibility access reads and writes one authority object."
|
|
(let* ((runtime (etaf--runtime-create))
|
|
(first (etaf--generation-create :generation-id 1))
|
|
(second (etaf--generation-create :generation-id 2)))
|
|
(should-not (etaf-runtime-current-generation runtime))
|
|
(setf (etaf-runtime-current-generation runtime) first)
|
|
(let ((authority (etaf-runtime-generation-authority runtime)))
|
|
(should (etaf-generation-authority-p authority))
|
|
(should (eq first (etaf-generation-authority-current authority)))
|
|
(should (eq first (etaf-runtime-current-generation runtime)))
|
|
(setf (etaf-runtime-current-generation runtime) second)
|
|
(should (eq authority (etaf-runtime-generation-authority runtime)))
|
|
(should (eq second (etaf-runtime-current-generation runtime)))
|
|
(should (zerop (etaf-generation-authority-token authority))))))
|
|
|
|
(ert-deftest etaf-generation-projection-is-detached-and-rejects-duplicates ()
|
|
"Compatibility projections copy facts and reject ambiguous keys."
|
|
(let* ((handlers '((host . ((press . callback)))))
|
|
(projection
|
|
(etaf-generation-project-mirrors handlers '((host :role button))))
|
|
(handler-table (plist-get projection :handlers))
|
|
(props-table (plist-get projection :host-props)))
|
|
(setcdr (car handlers) 'mutated)
|
|
(should (equal (gethash 'host handler-table) '((press . callback))))
|
|
(should (equal (gethash 'host props-table) '(:role button)))
|
|
(should-error
|
|
(etaf-generation-project-mirror '((host . one) (host . two)))
|
|
:type 'etaf-generation-error)))
|
|
|
|
(ert-deftest etaf-generation-mirrors-follow-committed-generation ()
|
|
"Every commit projects exact mirrors and removes stale Host facts."
|
|
(let ((buffer-name " *etaf-generation-mirror-test*")
|
|
(visible (etaf-ref t)))
|
|
(unwind-protect
|
|
(progn
|
|
(etaf-mount buffer-name
|
|
(lambda () (etaf-generation-test--view visible)))
|
|
(let ((runtime (etaf-runtime-for-buffer buffer-name)))
|
|
(should (etaf-runtime-generation-mirrors-consistent-p runtime))
|
|
(should (etaf-runtime-handler-for runtime 'generation-target))
|
|
(should (gethash 'generation-target
|
|
(etaf-runtime-handlers runtime)))
|
|
(setf (etaf-value visible) nil)
|
|
(should (etaf-runtime-generation-mirrors-consistent-p runtime))
|
|
(should-not (etaf-runtime-handler-for runtime 'generation-target))
|
|
(should-not (gethash 'generation-target
|
|
(etaf-runtime-handlers runtime)))
|
|
(should (gethash 'generation-other
|
|
(etaf-runtime-host-props runtime)))))
|
|
(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-generation-query-ignores-compatibility-mirror-drift ()
|
|
"Corrupting a mirror never changes committed generation queries."
|
|
(let ((buffer-name " *etaf-generation-query-test*")
|
|
(visible (etaf-ref t)))
|
|
(unwind-protect
|
|
(progn
|
|
(etaf-mount buffer-name
|
|
(lambda () (etaf-generation-test--view visible)))
|
|
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
|
(committed
|
|
(copy-tree
|
|
(etaf-runtime-handler-for runtime 'generation-target))))
|
|
(puthash 'generation-target 'corrupt
|
|
(etaf-runtime-handlers runtime))
|
|
(should-not (etaf-runtime-generation-mirrors-consistent-p runtime))
|
|
(should (equal committed
|
|
(etaf-runtime-handler-for
|
|
runtime 'generation-target)))
|
|
(setf (etaf-value visible) nil)
|
|
(setf (etaf-value visible) t)
|
|
(should (etaf-runtime-generation-mirrors-consistent-p runtime))))
|
|
(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-generation-shadow-route-proves-legacy-equivalence ()
|
|
"The shadow route accepts a legacy projection only when facts are equal."
|
|
(let ((buffer-name " *etaf-generation-shadow-test*")
|
|
(visible (etaf-ref t))
|
|
(etaf-generation-mirror-route 'shadow))
|
|
(unwind-protect
|
|
(progn
|
|
(etaf-mount buffer-name
|
|
(lambda () (etaf-generation-test--view visible)))
|
|
(setf (etaf-value visible) nil)
|
|
(let ((runtime (etaf-runtime-for-buffer buffer-name)))
|
|
(should (etaf-runtime-generation-mirrors-consistent-p runtime))))
|
|
(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-generation-rejects-unknown-mirror-route ()
|
|
"An unknown compatibility route cannot silently publish mirrors."
|
|
(let ((runtime (etaf--runtime-create
|
|
:generation-authority
|
|
(etaf-generation-authority-create)))
|
|
(etaf-generation-mirror-route 'unknown))
|
|
(should-error
|
|
(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))
|
|
captured
|
|
(rollback-count 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))
|
|
(original-rollback
|
|
(symbol-function 'etaf-semantic-candidate-rollback)))
|
|
(cl-letf
|
|
(((symbol-function 'etaf--runtime-install-generation-mirrors)
|
|
(lambda (&rest _arguments)
|
|
(error "injected postcommit mirror failure")))
|
|
((symbol-function 'etaf-semantic-candidate-rollback)
|
|
(lambda (candidate)
|
|
(cl-incf rollback-count)
|
|
(funcall original-rollback candidate))))
|
|
(condition-case condition
|
|
(setf (etaf-value source) 1)
|
|
(error (setq captured condition))))
|
|
(should captured)
|
|
(should (eq (car captured) 'error))
|
|
(should
|
|
(equal (butlast (cdr captured))
|
|
'("injected postcommit mirror failure")))
|
|
(should (etaf-condition-postcommit-info captured))
|
|
(should (zerop rollback-count))
|
|
(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-ebox-report-finalization-fault-does-not-rollback ()
|
|
"A postaccept Ebox report fault still commits ETAF generation and buffer."
|
|
(let ((buffer-name " *etaf-ebox-report-postaccept-test*")
|
|
(source (etaf-ref 0))
|
|
(rollback-count 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))
|
|
(generation (etaf-runtime-generation runtime))
|
|
(original-rollback
|
|
(symbol-function 'etaf-semantic-candidate-rollback)))
|
|
(cl-letf
|
|
(((symbol-function 'ebox-surface--participant-complete)
|
|
(lambda (&rest _arguments)
|
|
(error "injected Ebox report finalization fault")))
|
|
((symbol-function 'etaf-semantic-candidate-rollback)
|
|
(lambda (candidate)
|
|
(cl-incf rollback-count)
|
|
(funcall original-rollback candidate))))
|
|
(setf (etaf-value source) 1))
|
|
(should (zerop rollback-count))
|
|
(should (= (1+ generation)
|
|
(etaf-runtime-generation 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-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
|