etaf/tests/etaf-render-port-tests.el

522 lines
25 KiB
EmacsLisp

;;; etaf-render-port-tests.el --- M3a renderer-port gates -*- lexical-binding: t; -*-
;; SPDX-License-Identifier: GPL-3.0-or-later
(require 'cl-lib)
(require 'ert)
(require 'etaf-render-port)
(defconst etaf-render-port-test--root
(file-name-directory
(directory-file-name
(file-name-directory (or load-file-name buffer-file-name))))
"ETAF package root used by static bootstrap-owner checks.")
(ert-deftest etaf-render-port-selects-valid-v2-immutably ()
"A valid provider produces one immutable v2 selected port."
(let* ((port (etaf-render-port--bootstrap))
(capabilities (etaf-render-port-capabilities port)))
(should (etaf-render-port-p port))
(should (eq (etaf-render-port-route port) 'v2))
(should (= (etaf-render-port-spi-version port) 2))
(should (eq (etaf-render-port-schema-version port)
'ebox-framework-spi-schema/v2))
(should (eq (etaf-render-port-tp-protocol port)
'tp-transaction-protocol-v1+v2))
(should (eq (etaf-render-port-initial-function port)
'ebox-framework-spi-initial))
(should (eq (etaf-render-port-update-function port)
'ebox-framework-spi-update))
(should (eq (etaf-render-port-revision-function port)
'ebox-surface-buffer-revision))
(should (eq (etaf-render-port-bootstrap-outcome port)
'valid-v2-selected))
(setcar capabilities 'mutated)
(should (eq (car (etaf-render-port-capabilities port))
'initial-paired-stage-rollback))
(should-error
(eval `(setf (etaf-render-port--route ',port) 'broken)))))
(ert-deftest etaf-render-port-falls-back-only-when-v2-is-fully-absent ()
"Only complete feature/predicate absence selects the immutable v1 port."
(let ((original-featurep (symbol-function 'featurep)))
(cl-letf (((symbol-function 'featurep)
(lambda (feature)
(and (not (eq feature 'ebox-framework-spi-v2))
(funcall original-featurep feature))))
((symbol-function 'ebox-framework-spi-capabilities) nil))
(let ((port (etaf-render-port--bootstrap)))
(should (eq (etaf-render-port-route port) 'v1))
(should (= (etaf-render-port-spi-version port) 1))
(should (eq (etaf-render-port-initial-function port)
'etaf-render-port--v1-initial))
(should (eq (etaf-render-port-update-function port)
'etaf-render-port--v1-update))
(should (eq (etaf-render-port-revision-function port)
'etaf-render-port--v1-revision))
(should (eq (etaf-render-port-bootstrap-outcome port)
'v2-absent-v1-selected))))))
(ert-deftest etaf-render-port-rejects-half-present-v2 ()
"Feature-only and predicate-only providers fail instead of downgrading."
(cl-letf (((symbol-function 'ebox-framework-spi-capabilities) nil))
(should-error (etaf-render-port--bootstrap)
:type 'etaf-spi-bootstrap-error))
(let ((original-featurep (symbol-function 'featurep)))
(cl-letf (((symbol-function 'featurep)
(lambda (feature)
(and (not (eq feature 'ebox-framework-spi-v2))
(funcall original-featurep feature)))))
(should-error (etaf-render-port--bootstrap)
:type 'etaf-spi-bootstrap-error))))
(ert-deftest etaf-render-port-rejects-broken-v2-provider ()
"Throwing, non-record, and malformed providers fail closed."
(cl-letf
(((symbol-function 'ebox-framework-spi-capabilities)
(lambda () (error "injected provider failure"))))
(should-error (etaf-render-port--bootstrap)
:type 'etaf-spi-bootstrap-error))
(cl-letf
(((symbol-function 'ebox-framework-spi-capabilities)
(lambda () 'not-a-provider)))
(should-error (etaf-render-port--bootstrap)
:type 'etaf-spi-bootstrap-error))
(let ((provider (ebox-framework-spi-capabilities)))
(cl-letf
(((symbol-function 'ebox-framework-spi-capabilities)
(lambda () provider))
((symbol-function 'ebox-framework-spi-provider-capabilities)
(lambda (_provider) "not-a-capability-list")))
(should-error (etaf-render-port--bootstrap)
:type 'etaf-spi-bootstrap-error))))
(ert-deftest etaf-render-port-rejects-incompatible-v2-provider ()
"Version, required-capability, and TP protocol mismatches are incompatible."
(let ((provider (ebox-framework-spi-capabilities)))
(cl-letf
(((symbol-function 'ebox-framework-spi-capabilities)
(lambda () provider))
((symbol-function 'ebox-framework-spi-provider-spi-version)
(lambda (_provider) 99)))
(should-error (etaf-render-port--bootstrap)
:type 'etaf-spi-incompatible-error))
(cl-letf
(((symbol-function 'ebox-framework-spi-capabilities)
(lambda () provider))
((symbol-function 'ebox-framework-spi-provider-capabilities)
(lambda (_provider)
'(initial-paired-stage-rollback
update-paired-stage-rollback
same-object-legacy-report))))
(should-error (etaf-render-port--bootstrap)
:type 'etaf-spi-incompatible-error))
(cl-letf
(((symbol-function 'ebox-framework-spi-capabilities)
(lambda () provider))
((symbol-function 'ebox-framework-spi-provider-tp-protocol)
(lambda (_provider) 'tp-transaction-protocol-v0)))
(should-error (etaf-render-port--bootstrap)
:type 'etaf-spi-incompatible-error))))
(ert-deftest etaf-render-port-v1-initial-runs-manual-framework-cleanup ()
"A failed legacy initial stage invokes its paired cleanup exactly once."
(let ((buffer (generate-new-buffer " *etaf-v1-manual-cleanup*")) trace)
(unwind-protect
(cl-letf (((symbol-function 'ebox-render-to-buffer)
(lambda (&rest _arguments)
(push 'render trace)
buffer)))
(should-error
(etaf-render-port--v1-initial
buffer 'input
(lambda (_report)
(push 'stage trace)
(error "injected v1 initial failure"))
(lambda (_report) (push 'rollback trace))))
(should (equal (nreverse trace) '(render stage rollback))))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest etaf-render-port-v1-initial-restores-real-ebox-surface ()
"A failed legacy stage removes Ebox authority and restores buffer content."
(let ((buffer (generate-new-buffer " *etaf-v1-real-cleanup*"))
(input (ebox-build '(box "committed")))
(rollback-count 0)
captured)
(unwind-protect
(progn
(with-current-buffer buffer (insert "sentinel"))
(condition-case condition
(etaf-render-port--v1-initial
buffer input
(lambda (_report)
(error "injected real v1 stage failure"))
(lambda (_report) (cl-incf rollback-count)))
(error (setq captured condition)))
(should (equal captured '(error "injected real v1 stage failure")))
(should (= rollback-count 1))
(should-not (ebox-surface-buffer-mounted-p buffer))
(should-not (ebox-surface-buffer-observer buffer))
(should (equal "sentinel"
(with-current-buffer buffer (buffer-string))))
(should-not
(etaf-render-port-v1-cleanup-diagnostics buffer)))
(when (and (buffer-live-p buffer)
(ebox-surface-buffer-mounted-p buffer))
(ebox-unmount-buffer buffer))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest etaf-render-port-v1-failure-restores-exact-editor-custody ()
"Legacy stage rollback preserves Emacs-owned editor identities and undo."
(let ((buffer (generate-new-buffer " *etaf-v1-editor-custody*"))
(input (ebox-build '(box "committed")))
overlay left-marker right-marker snapshot captured)
(unwind-protect
(progn
(with-current-buffer buffer
(buffer-enable-undo)
(insert (propertize "sentinel" 'face 'bold))
(undo-boundary)
(goto-char 4)
(set-mark 2)
(setq mark-active t)
(setq overlay (make-overlay 2 6 buffer t t)
left-marker (copy-marker 3 nil)
right-marker (copy-marker 5 t))
(overlay-put overlay 'etaf-test-property '(owned value))
(narrow-to-region 2 7)
(set-buffer-modified-p nil)
(setq snapshot
(list
:contents
(save-restriction
(widen)
(buffer-substring (point-min) (point-max)))
:point (point)
:mark-marker (mark-marker)
:mark-position (mark t)
:mark-insertion-type
(marker-insertion-type (mark-marker))
:mark-active mark-active
:narrow-start (point-min)
:narrow-end (point-max)
:overlay-start (overlay-start overlay)
:overlay-end (overlay-end overlay)
:overlay-properties (overlay-properties overlay)
:left-position (marker-position left-marker)
:left-insertion-type (marker-insertion-type left-marker)
:right-position (marker-position right-marker)
:right-insertion-type (marker-insertion-type right-marker)
:undo-list (copy-tree buffer-undo-list)
:modified-p (buffer-modified-p))))
(condition-case condition
(etaf-render-port--v1-initial
buffer input
(lambda (_report) (error "editor custody primary"))
#'ignore)
(error (setq captured condition)))
(should (equal captured '(error "editor custody primary")))
(should-not (ebox-surface-buffer-mounted-p buffer))
(should-not (ebox-surface-buffer-observer buffer))
(with-current-buffer buffer
(should
(equal (save-restriction
(widen)
(buffer-substring (point-min) (point-max)))
(plist-get snapshot :contents)))
(should (= (point) (plist-get snapshot :point)))
(should (eq (mark-marker) (plist-get snapshot :mark-marker)))
(should (= (mark t) (plist-get snapshot :mark-position)))
(should
(eq (marker-insertion-type (mark-marker))
(plist-get snapshot :mark-insertion-type)))
(should (eq mark-active (plist-get snapshot :mark-active)))
(should (= (point-min) (plist-get snapshot :narrow-start)))
(should (= (point-max) (plist-get snapshot :narrow-end)))
(should (overlayp overlay))
(should (eq (overlay-buffer overlay) buffer))
(should (= (overlay-start overlay)
(plist-get snapshot :overlay-start)))
(should (= (overlay-end overlay)
(plist-get snapshot :overlay-end)))
(should (equal (overlay-properties overlay)
(plist-get snapshot :overlay-properties)))
(should (eq (marker-buffer left-marker) buffer))
(should (= (marker-position left-marker)
(plist-get snapshot :left-position)))
(should
(eq (marker-insertion-type left-marker)
(plist-get snapshot :left-insertion-type)))
(should (eq (marker-buffer right-marker) buffer))
(should (= (marker-position right-marker)
(plist-get snapshot :right-position)))
(should
(eq (marker-insertion-type right-marker)
(plist-get snapshot :right-insertion-type)))
(should (equal buffer-undo-list (plist-get snapshot :undo-list)))
(should (eq (buffer-modified-p)
(plist-get snapshot :modified-p)))))
(when (overlayp overlay) (delete-overlay overlay))
(when (markerp left-marker) (set-marker left-marker nil))
(when (markerp right-marker) (set-marker right-marker nil))
(when (and (buffer-live-p buffer)
(ebox-surface-buffer-mounted-p buffer))
(ebox-unmount-buffer buffer))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest etaf-render-port-v1-nonlocal-exit-runs-exact-cleanup ()
"A legacy stage throw cannot escape with mounted or editor state retained."
(let ((buffer (generate-new-buffer " *etaf-v1-nonlocal-cleanup*"))
(input (ebox-build '(box "committed")))
(rollback-count 0))
(unwind-protect
(progn
(with-current-buffer buffer (insert "before"))
(should
(eq
(catch 'etaf-v1-test-escape
(etaf-render-port--v1-initial
buffer input
(lambda (_report)
(throw 'etaf-v1-test-escape 'escaped))
(lambda (_report) (cl-incf rollback-count)))
'not-escaped)
'escaped))
(should (= rollback-count 1))
(should-not (ebox-surface-buffer-mounted-p buffer))
(should-not (ebox-surface-buffer-observer buffer))
(should (equal "before"
(with-current-buffer buffer (buffer-string))))
(should-not
(etaf-render-port-v1-cleanup-diagnostics buffer)))
(when (and (buffer-live-p buffer)
(ebox-surface-buffer-mounted-p buffer))
(ebox-unmount-buffer buffer))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest etaf-render-port-v1-precondition-keeps-existing-mount ()
"Rejecting an already mounted target must not clean up foreign authority."
(let ((buffer (generate-new-buffer " *etaf-v1-existing-mount*")))
(unwind-protect
(progn
(ebox-render-to-buffer buffer (ebox-build '(box "existing")))
(let ((revision (ebox-surface-buffer-revision buffer)))
(should-error
(etaf-render-port--v1-initial
buffer (ebox-build '(box "replacement")) #'ignore #'ignore)
:type 'error)
(should (ebox-surface-buffer-mounted-p buffer))
(should (= revision (ebox-surface-buffer-revision buffer)))
(should (equal "existing"
(with-current-buffer buffer (buffer-string))))))
(when (and (buffer-live-p buffer)
(ebox-surface-buffer-mounted-p buffer))
(ebox-unmount-buffer buffer))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest etaf-render-port-v1-rollback-throw-cannot-stop-cleanup-tail ()
"A framework rollback throw still unmounts and restores legacy editor state."
(let ((buffer (generate-new-buffer " *etaf-v1-rollback-throw*"))
(input (ebox-build '(box "committed"))))
(unwind-protect
(progn
(with-current-buffer buffer (insert "before"))
(should
(eq
(catch 'etaf-v1-rollback-escape
(etaf-render-port--v1-initial
buffer input
(lambda (_report) (error "primary before rollback throw"))
(lambda (_report)
(throw 'etaf-v1-rollback-escape 'rollback-escaped)))
'not-escaped)
'rollback-escaped))
(should-not (ebox-surface-buffer-mounted-p buffer))
(should-not (ebox-surface-buffer-observer buffer))
(should (equal "before"
(with-current-buffer buffer (buffer-string))))
(let ((diagnostic
(cl-find 'framework-rollback
(etaf-render-port-v1-cleanup-diagnostics buffer)
:key (lambda (entry) (plist-get entry :phase)))))
(should diagnostic)
(should (plist-get diagnostic :nonlocal-exit))))
(when (and (buffer-live-p buffer)
(ebox-surface-buffer-mounted-p buffer))
(ebox-unmount-buffer buffer))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest etaf-render-port-v1-cleanup-fault-keeps-primary-and-continues ()
"A secondary v1 cleanup fault is diagnosed while Ebox cleanup continues."
(let ((buffer (generate-new-buffer " *etaf-v1-cleanup-fault*"))
(input (ebox-build '(box "committed")))
captured)
(unwind-protect
(progn
(with-current-buffer buffer (insert "before"))
(condition-case condition
(etaf-render-port--v1-initial
buffer input
(lambda (_report) (error "primary stage failure"))
(lambda (_report) (error "secondary rollback failure")))
(error (setq captured condition)))
(should (equal captured '(error "primary stage failure")))
(should-not (ebox-surface-buffer-mounted-p buffer))
(should (equal "before"
(with-current-buffer buffer (buffer-string))))
(let ((diagnostics
(etaf-render-port-v1-cleanup-diagnostics buffer)))
(should (= 1 (length diagnostics)))
(should (eq (plist-get (car diagnostics) :phase)
'framework-rollback))
(should (equal (plist-get (car diagnostics) :condition)
'(error "secondary rollback failure")))))
(when (and (buffer-live-p buffer)
(ebox-surface-buffer-mounted-p buffer))
(ebox-unmount-buffer buffer))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest etaf-render-port-revision-fails-closed-for-mounted-surface ()
"Revision is zero only without a mount; mounted lookup errors stay visible."
(let ((buffer (generate-new-buffer " *etaf-revision-contract*")))
(unwind-protect
(progn
(should (zerop (etaf-render-port-revision buffer)))
(ebox-render-to-buffer buffer (ebox-build '(box "mounted")))
(should (> (etaf-render-port-revision buffer) 0))
(cl-letf (((symbol-function 'ebox-surface-buffer-revision)
(lambda (_buffer) (error "injected report failure"))))
(should-error (etaf-render-port-revision buffer) :type 'error))
(cl-letf (((symbol-function 'ebox-surface-buffer-revision)
(lambda (_buffer) 0)))
(should-error (etaf-render-port-revision buffer) :type 'error)))
(when (and (buffer-live-p buffer)
(ebox-surface-buffer-mounted-p buffer))
(ebox-unmount-buffer buffer))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest etaf-render-port-v1-revision-needs-no-v2-ebox-accessor ()
"A v1-only Ebox retains revisions without a v2-only query symbol."
(let ((buffer (generate-new-buffer " *etaf-v1-revision*"))
(etaf-render-port--selected-port (etaf-render-port--v1-fallback)))
(unwind-protect
(cl-letf (((symbol-function 'ebox-surface-buffer-revision) nil))
(etaf-render-port-initial
buffer (ebox-build '(box "one")) #'ignore #'ignore)
(should (= (etaf-render-port-revision buffer) 1))
(let ((report
(etaf-render-port-update
buffer (ebox-build '(box "two")) #'ignore #'ignore)))
(should (= (etaf-render-port-revision buffer)
(plist-get report :surface-revision))))
(with-current-buffer buffer
(setq-local etaf-render-port--v1-committed-revision nil))
(should-error (etaf-render-port-revision buffer) :type 'error))
(when (and (buffer-live-p buffer)
(ebox-surface-buffer-mounted-p buffer))
(ebox-unmount-buffer buffer))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest etaf-render-port-v1-missing-update-revision-fails-later ()
"A committed v1 update may finish, but missing revision evidence fails closed."
(let ((buffer (generate-new-buffer " *etaf-v1-missing-revision*"))
(etaf-render-port--selected-port (etaf-render-port--v1-fallback))
(report (list :strategy 'injected-without-revision)))
(unwind-protect
(progn
(etaf-render-port-initial
buffer (ebox-build '(box "one")) #'ignore #'ignore)
(cl-letf (((symbol-function 'ebox-commit)
(lambda (_buffer _input framework-stage _rollback)
(funcall framework-stage report)
report)))
(should
(eq (etaf-render-port-update
buffer (ebox-build '(box "two")) #'ignore #'ignore)
report)))
(should-error (etaf-render-port-revision buffer) :type 'error))
(when (and (buffer-live-p buffer)
(ebox-surface-buffer-mounted-p buffer))
(ebox-unmount-buffer buffer))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest etaf-render-port-is-the-only-protocol-probe-owner ()
"No downstream ETAF module probes Ebox framework SPI protocol state."
(dolist (file (directory-files etaf-render-port-test--root t "\\.el\\'"))
(unless (string= (file-name-nondirectory file) "etaf-render-port.el")
(with-temp-buffer
(insert-file-contents file)
(let ((source (buffer-string)))
(should-not (string-match-p "ebox-framework-spi" source))
(should-not (string-match-p "ebox-framework-spi-v2" source)))))))
(ert-deftest etaf-render-port-owns-runtime-update-routing ()
"Runtime updates use the selected port instead of calling Ebox directly."
(with-temp-buffer
(insert-file-contents
(expand-file-name "etaf-runtime.el" etaf-render-port-test--root))
(let ((source (buffer-string)))
(should (string-match-p "(etaf-render-port-update" source))
(should-not (string-match-p "(ebox-commit" source)))))
(ert-deftest etaf-render-port-owns-all-live-publication-routing ()
"No ETAF module except the selected-port owner publishes directly to Ebox."
(dolist (file (directory-files etaf-render-port-test--root t "\\.el\\'"))
(unless (string= (file-name-nondirectory file) "etaf-render-port.el")
(with-temp-buffer
(insert-file-contents file)
(let ((source (buffer-string)))
(dolist (call '("(ebox-render-to-buffer"
"(ebox-commit"
"(ebox-surface-"))
(should-not (string-match-p (regexp-quote call) source))))))))
(ert-deftest etaf-render-port-routes-standalone-renderer-mount ()
"The no-Runtime compatibility mount uses the immutable selected port."
(require 'etaf-renderer)
(let ((buffer (generate-new-buffer " *etaf-standalone-port-mount*"))
seen-input seen-viewport)
(unwind-protect
(cl-letf (((symbol-function 'etaf-runtime-mount) nil)
((symbol-function 'etaf-render-port-initial)
(lambda (target input framework-stage framework-rollback
&optional _observer)
(setq seen-input input
seen-viewport
(list ebox-viewport-width ebox-viewport-height))
(funcall framework-stage nil)
(ignore framework-rollback)
(list :status 'success :buffer target))))
(should
(eq (etaf-mount
buffer (etaf-view (text "standalone"))
'(:viewport-width 91 :viewport-height 17))
buffer))
(should (ebox-canonical-input-p seen-input))
(should (equal seen-viewport '(91 17))))
(when (and (buffer-live-p buffer)
(ebox-surface-buffer-mounted-p buffer))
(ebox-unmount-buffer buffer))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest etaf-render-port-standalone-render-failure-creates-no-buffer ()
"Pure lowering must fail before standalone mount allocates its target buffer."
(require 'etaf-renderer)
(let ((name " *etaf-standalone-render-failure*"))
(when-let* ((buffer (get-buffer name))) (kill-buffer buffer))
(cl-letf (((symbol-function 'etaf-runtime-mount) nil))
(should-error (etaf-mount name 'invalid-etaf-view)
:type 'etaf-renderer-error))
(should-not (get-buffer name))))
(ert-deftest etaf-render-port-selected-port-is-process-stable ()
"Every downstream read returns the one bootstrap-selected port identity."
(should (eq (etaf-render-port-selected)
(etaf-render-port-selected)))
(should (memq (etaf-render-port-route (etaf-render-port-selected))
'(v1 v2))))
(provide 'etaf-render-port-tests)
;;; etaf-render-port-tests.el ends here