diff --git a/etaf-reactive.el b/etaf-reactive.el index 0c4a90c..f2c5b63 100644 --- a/etaf-reactive.el +++ b/etaf-reactive.el @@ -127,9 +127,12 @@ Runtime, watchers run synchronously.") (etaf-runtime-route-active-p route) (let ((predicate (etaf-runtime-route-accepts-p route))) (or (null predicate) - (condition-case nil + (condition-case condition (funcall predicate route) - ((error quit) nil)))))) + ((error quit) + (etaf-scheduler-record-route-authority-fault + (etaf--subscriber-scheduler-context route) condition) + nil)))))) (defun etaf-reactive-enqueue-runtime-flush (runtime function &optional scheduler-context) @@ -142,20 +145,27 @@ The default context preserves the legacy two-argument facade." (defun etaf--dispatch-subscriber-group (context source _projection-epoch subscribers) "Notify SOURCE SUBSCRIBERS already grouped for scheduler CONTEXT." - (dolist (subscriber subscribers) - (etaf-scheduler-record-subscriber-visit context) - (cond - ((etaf-runtime-route-p subscriber) - (if (etaf-runtime-route-live-p subscriber) - (funcall (etaf-runtime-route-scheduler subscriber) - subscriber source) - (etaf-scheduler-record-stale-route-drop context))) - ((and (etaf-effect-p subscriber) - (etaf-effect-active-p subscriber) - (etaf-scheduler-claim-effect context subscriber)) - (if-let* ((scheduler (etaf-effect-scheduler subscriber))) - (funcall scheduler subscriber) - (etaf-reactive-effect-run subscriber)))))) + (let (first-condition) + (dolist (subscriber subscribers) + (etaf-scheduler-record-subscriber-visit context) + (condition-case condition + (cond + ((etaf-runtime-route-p subscriber) + (if (etaf-runtime-route-live-p subscriber) + (funcall (etaf-runtime-route-scheduler subscriber) + subscriber source) + (etaf-scheduler-record-stale-route-drop context))) + ((and (etaf-effect-p subscriber) + (etaf-effect-active-p subscriber) + (etaf-scheduler-claim-effect context subscriber)) + (if-let* ((scheduler (etaf-effect-scheduler subscriber))) + (funcall scheduler subscriber) + (etaf-reactive-effect-run subscriber)))) + ((error quit) + (unless first-condition + (setq first-condition condition))))) + (when first-condition + (signal (car first-condition) (cdr first-condition))))) (defun etaf--reactive-same-p (left right) "Return whether LEFT and RIGHT are equal under ETAF's shallow rule." diff --git a/etaf-render-port.el b/etaf-render-port.el index a0e326a..879848c 100644 --- a/etaf-render-port.el +++ b/etaf-render-port.el @@ -286,39 +286,153 @@ (widen) (list :contents (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 :narrowed-p narrowed-p :narrow-start start :narrow-end end :read-only buffer-read-only - :modified-p (buffer-modified-p)))))) + :modified-p (buffer-modified-p) + :undo-list buffer-undo-list + :overlays + (mapcar + (lambda (overlay) + (list :overlay overlay + :start (overlay-start overlay) + :end (overlay-end overlay))) + (delete-dups + (append (car (overlay-lists)) (cdr (overlay-lists)))))))))) -(defun etaf-render-port--v1-restore-buffer (buffer snapshot) - "Restore BUFFER exactly from a pre-render v1 SNAPSHOT." +(defun etaf-render-port--v1-restore-buffer + (buffer snapshot &optional restore-contents-p) + "Restore BUFFER editor state from a pre-render v1 SNAPSHOT. +When RESTORE-CONTENTS-P is non-nil, also re-materialize text as a last-resort +fallback after change-group cancellation itself failed." (unless (buffer-live-p buffer) (error "Legacy Ebox target died during manual cleanup")) (with-current-buffer buffer (let ((inhibit-read-only t) (inhibit-modification-hooks t)) (widen) - (erase-buffer) - (insert (plist-get snapshot :contents)) - (goto-char (min (point-max) - (max (point-min) (plist-get snapshot :point)))) + (when restore-contents-p + (let ((buffer-undo-list t)) + (erase-buffer) + (insert (plist-get snapshot :contents)))) + (let* ((saved-overlays (plist-get snapshot :overlays)) + (saved-identities + (mapcar (lambda (entry) (plist-get entry :overlay)) + saved-overlays))) + (dolist + (overlay + (delete-dups + (append (car (overlay-lists)) (cdr (overlay-lists))))) + (unless (memq overlay saved-identities) + (delete-overlay overlay))) + (dolist (entry saved-overlays) + (let ((overlay (plist-get entry :overlay))) + (move-overlay overlay + (plist-get entry :start) + (plist-get entry :end) + buffer)))) (when (plist-get snapshot :narrowed-p) (narrow-to-region (min (point-max) (plist-get snapshot :narrow-start)) (min (point-max) (plist-get snapshot :narrow-end)))) + (goto-char (min (point-max) + (max (point-min) (plist-get snapshot :point)))) + (let ((mark-marker (plist-get snapshot :mark-marker))) + (set-marker mark-marker (plist-get snapshot :mark-position) buffer) + (set-marker-insertion-type + mark-marker (plist-get snapshot :mark-insertion-type))) + (setq mark-active (plist-get snapshot :mark-active)) (setq buffer-read-only (plist-get snapshot :read-only)) - (set-buffer-modified-p (plist-get snapshot :modified-p)))) + (set-buffer-modified-p (plist-get snapshot :modified-p)) + (setq buffer-undo-list (plist-get snapshot :undo-list)))) buffer) -(defun etaf-render-port--v1-cleanup-step (phase function) - "Run v1 cleanup FUNCTION and return a diagnostic for failure at PHASE." - (let ((inhibit-quit t) (quit-flag nil)) - (condition-case condition - (progn (funcall function) nil) - ((error quit) - (list :phase phase :condition (copy-tree condition)))))) +(defun etaf-render-port--v1-cleanup-failed-initial + (buffer snapshot change-group change-group-active-p stage-entered + observer framework-rollback) + "Clean one failed legacy initial operation and return diagnostics. +BUFFER and SNAPSHOT identify editor custody. CHANGE-GROUP-ACTIVE-P says +whether CHANGE-GROUP still needs cancellation. STAGE-ENTERED controls the +paired FRAMEWORK-ROLLBACK. OBSERVER is detached before Ebox unmount." + (let (cancel-failed-p) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (setq-local etaf-render-port--v1-cleanup-diagnostics nil))) + (cl-labels + ((record + (diagnostic) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (setq-local + etaf-render-port--v1-cleanup-diagnostics + (append etaf-render-port--v1-cleanup-diagnostics + (list diagnostic)))))) + (run-phase + (entry) + (let ((phase (nth 0 entry)) + (function (nth 1 entry)) + (failure-function (nth 2 entry)) + completed-p) + (unwind-protect + (let ((inhibit-quit t) (quit-flag nil)) + (condition-case condition + (progn (funcall function) (setq completed-p t)) + ((error quit) + (setq completed-p t) + (when failure-function (funcall failure-function)) + (record + (list :phase phase + :condition (copy-tree condition)))))) + (unless completed-p + (when failure-function (funcall failure-function)) + (record (list :phase phase :nonlocal-exit t)))))) + (run-phases + (entries) + (when entries + ;; A cleanup callback may perform an arbitrary nonlocal exit. + ;; Nested unwind cleanup guarantees every later phase still runs. + (unwind-protect + (run-phase (car entries)) + (run-phases (cdr entries)))))) + (run-phases + `((framework-rollback + ,(lambda () + (when stage-entered + (funcall framework-rollback nil)))) + (observer-detach + ,(lambda () + (when (and observer (buffer-live-p buffer) + (ebox-surface-buffer-mounted-p buffer)) + (ebox-buffer-set-observer buffer nil)))) + (ebox-unmount + ,(lambda () + (when (and (buffer-live-p buffer) + (ebox-surface-buffer-mounted-p buffer)) + (ebox-unmount-buffer buffer)))) + (revision-reset + ,(lambda () + (when (buffer-live-p buffer) + (with-current-buffer buffer + (setq-local + etaf-render-port--v1-committed-revision nil))))) + (change-group-cancel + ,(lambda () + (when change-group-active-p + (with-current-buffer buffer + (cancel-change-group change-group)))) + ,(lambda () (setq cancel-failed-p t))) + (buffer-restore + ,(lambda () + (etaf-render-port--v1-restore-buffer + buffer snapshot cancel-failed-p)))))) + (and (buffer-live-p buffer) + (etaf-render-port-v1-cleanup-diagnostics buffer)))) (defun etaf-render-port--v1-record-revision (buffer revision) "Record committed v1 REVISION for BUFFER without postaccept failure." @@ -350,60 +464,53 @@ through Ebox's legacy initial option." framework-stage framework-rollback) (let* ((buffer (get-buffer-create buffer)) (snapshot (etaf-render-port--v1-buffer-snapshot buffer)) - (result - (progn - (when (ebox-surface-buffer-mounted-p buffer) - (error "Legacy Ebox initial operation requires an unmounted buffer")) - (with-current-buffer buffer - (setq-local etaf-render-port--v1-cleanup-diagnostics nil - etaf-render-port--v1-committed-revision nil)) - (ebox-render-to-buffer - buffer input (and observer (list :observer observer))))) - stage-entered) - (condition-case primary - (progn - (setq stage-entered t) - (funcall framework-stage nil) - ;; TP surfaces start at committed revision one. Legacy Ebox does - ;; not expose its surface handle, so ETAF owns this compatibility - ;; evidence and advances it from later update reports. - (etaf-render-port--v1-record-revision buffer 1) - result) - ((error quit) - (when stage-entered - (let (diagnostics) - (dolist - (entry - `((framework-rollback - ,(lambda () (funcall framework-rollback nil))) - (observer-detach - ,(lambda () - (when (and observer (buffer-live-p buffer) - (ebox-surface-buffer-mounted-p buffer)) - (ebox-buffer-set-observer buffer nil)))) - (ebox-unmount - ,(lambda () - (when (and (buffer-live-p buffer) - (ebox-surface-buffer-mounted-p buffer)) - (ebox-unmount-buffer buffer)))) - (revision-reset - ,(lambda () - (when (buffer-live-p buffer) - (with-current-buffer buffer - (setq-local - etaf-render-port--v1-committed-revision nil))))) - (buffer-restore - ,(lambda () - (etaf-render-port--v1-restore-buffer buffer snapshot))))) - (when-let* ((diagnostic - (etaf-render-port--v1-cleanup-step - (car entry) (cadr entry)))) - (push diagnostic diagnostics))) - (when (buffer-live-p buffer) - (with-current-buffer buffer - (setq-local etaf-render-port--v1-cleanup-diagnostics - (nreverse diagnostics)))))) - (signal (car primary) (cdr primary)))))) + (change-group (with-current-buffer buffer (prepare-change-group))) + result stage-entered operation-started-p change-group-active-p + cleanup-ran-p) + (cl-labels + ((cleanup + () + (unless cleanup-ran-p + (setq cleanup-ran-p t) + (when operation-started-p + (let ((active-p change-group-active-p)) + (setq change-group-active-p nil) + (etaf-render-port--v1-cleanup-failed-initial + buffer snapshot change-group active-p stage-entered + observer framework-rollback)))))) + (unwind-protect + (condition-case primary + (progn + (when (ebox-surface-buffer-mounted-p buffer) + (error + "Legacy Ebox initial operation requires an unmounted buffer")) + (with-current-buffer buffer + (setq-local etaf-render-port--v1-cleanup-diagnostics nil + etaf-render-port--v1-committed-revision nil) + (activate-change-group change-group) + (setq operation-started-p t + change-group-active-p t) + (save-restriction + (widen) + (setq result + (ebox-render-to-buffer + buffer input + (and observer (list :observer observer)))))) + (setq stage-entered t) + (funcall framework-stage nil) + (with-current-buffer buffer + (accept-change-group change-group)) + (setq change-group-active-p nil) + ;; TP surfaces start at committed revision one. Legacy Ebox + ;; does not expose its surface handle, so ETAF owns this + ;; compatibility evidence and advances it from update reports. + (etaf-render-port--v1-record-revision buffer 1) + result) + ((error quit) + (cleanup) + (signal (car primary) (cdr primary)))) + (when change-group-active-p + (cleanup)))))) (defun etaf-render-port--v1-update (buffer input framework-stage framework-rollback) @@ -535,7 +642,7 @@ FRAMEWORK-STAGE and FRAMEWORK-ROLLBACK are one required callback pair." (etaf-render-port-revision-function etaf-render-port--selected-port) buffer))) - (unless (and (integerp revision) (>= revision 0)) + (unless (and (integerp revision) (> revision 0)) (error "Mounted Ebox surface has no committed revision: %S" revision)) revision)))) diff --git a/etaf-scheduler.el b/etaf-scheduler.el index 7ec5965..b2fa132 100644 --- a/etaf-scheduler.el +++ b/etaf-scheduler.el @@ -367,8 +367,9 @@ DELIVERY receives CONTEXT, SOURCE, and the projection epoch." (max 0 (1- (etaf-scheduler-context-busy-depth context)))))) (defun etaf-scheduler--drain-context-sources (context projection-id) - "Drain one snapshotted CONTEXT source turn for PROJECTION-ID." - (let ((turn (etaf-scheduler-context-source-queue context))) + "Drain one CONTEXT source turn and return its first condition. +PROJECTION-ID identifies the bounded projection owning the detached turn." + (let ((turn (etaf-scheduler-context-source-queue context)) first-condition) ;; New sources discovered by TURN belong to the next bounded scheduler ;; turn. Detaching the current FIFO prevents a chain of distinct source ;; identities from monopolizing one unbudgeted drain. @@ -387,7 +388,12 @@ DELIVERY receives CONTEXT, SOURCE, and the projection epoch." (etaf-scheduler-context-delivered-source-set context)) (cl-incf (etaf-scheduler-context-source-delivery-count context)) (when delivery - (funcall delivery context source projection-id)))))))) + (condition-case condition + (funcall delivery context source projection-id) + ((error quit) + (unless first-condition + (setq first-condition condition))))))))) + first-condition)) (defun etaf-scheduler--detach-runtime-turns (projection) "Detach and return PROJECTION's Runtime queues in context order." @@ -420,18 +426,35 @@ DELIVERY receives CONTEXT, SOURCE, and the projection epoch." (setq first-condition condition))))))))) first-condition)) -(defun etaf-scheduler--record-fault (context projection-id condition) - "Record CONTEXT failure CONDITION for PROJECTION-ID." +(defun etaf-scheduler--record-fault + (context projection-id condition &optional phase) + "Record CONTEXT failure CONDITION for PROJECTION-ID and optional PHASE." (setf (etaf-scheduler-context-fault-state context) (copy-tree condition)) (cl-incf (etaf-scheduler-context-projection-fault-count context)) - (push (list :projection-epoch projection-id - :turn-id (etaf-scheduler-context-active-turn-id context) - :condition (copy-tree condition)) + (push (append (list :projection-epoch projection-id + :turn-id + (etaf-scheduler-context-active-turn-id context)) + (and phase (list :phase phase)) + (list :condition (copy-tree condition))) (etaf-scheduler-context-diagnostics context)) (when (> (length (etaf-scheduler-context-diagnostics context)) 64) (setcdr (nthcdr 63 (etaf-scheduler-context-diagnostics context)) nil)) condition) +(defun etaf-scheduler-record-route-authority-fault (context condition) + "Record contained Host route authority CONDITION in scheduler CONTEXT." + (setq context (etaf-scheduler-context-resolve context)) + (unless (consp condition) + (signal 'wrong-type-argument (list 'consp condition))) + (when etaf-scheduler--active-projection + (etaf-scheduler--append-context etaf-scheduler--active-projection context)) + (etaf-scheduler--record-fault + context + (if etaf-scheduler--active-projection + (etaf-scheduler--projection-id etaf-scheduler--active-projection) + (etaf-scheduler-context-projection-epoch context)) + condition 'route-authority)) + (defun etaf-scheduler--drain-projection (projection) "Drain PROJECTION source-first and re-signal its first context fault." (let ((projection-id (etaf-scheduler--projection-id projection)) @@ -456,8 +479,11 @@ DELIVERY receives CONTEXT, SOURCE, and the projection epoch." (progn (etaf-scheduler--mark-turn context projection-id marked-contexts context-steps) - (etaf-scheduler--drain-context-sources - context projection-id)) + (when-let* ((source-condition + (etaf-scheduler--drain-context-sources + context projection-id))) + (signal (car source-condition) + (cdr source-condition)))) ((error quit) (puthash context t failed-contexts) (unless first-condition (setq first-condition condition)) diff --git a/tests/etaf-render-port-tests.el b/tests/etaf-render-port-tests.el index 19358b2..fa2749e 100644 --- a/tests/etaf-render-port-tests.el +++ b/tests/etaf-render-port-tests.el @@ -166,6 +166,186 @@ (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*")) @@ -206,6 +386,9 @@ (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)) diff --git a/tests/etaf-scheduler-tests.el b/tests/etaf-scheduler-tests.el index be6df30..a6757b4 100644 --- a/tests/etaf-scheduler-tests.el +++ b/tests/etaf-scheduler-tests.el @@ -266,6 +266,92 @@ :runtime-executions))) (should (etaf-scheduler-context-idle-p context)))) +(ert-deftest etaf-scheduler-source-fault-does-not-suppress-context-tail () + "A failing source delivery cannot discard later sources in the same turn." + (let ((context (etaf-scheduler-context-create :name 'source-fault-tail)) + second-ran captured) + (condition-case condition + (etaf-scheduler-call-with-projection + (lambda () + (etaf-scheduler-enqueue-source + context 'first + (lambda (_context _source _projection-id) + (signal 'etaf-scheduler-test-source-condition '("first")))) + (etaf-scheduler-enqueue-source + context 'second + (lambda (_context _source _projection-id) + (setq second-ran t))))) + (etaf-scheduler-test-source-condition (setq captured condition))) + (should (equal captured + '(etaf-scheduler-test-source-condition "first"))) + (should second-ran) + (should (= 2 (etaf-scheduler-test--metric context :source-deliveries))) + (should (etaf-scheduler-context-idle-p context)))) + +(ert-deftest etaf-scheduler-subscriber-fault-does-not-suppress-group-tail () + "A failing subscriber cannot discard later subscribers in the same source." + (let* ((context + (etaf-scheduler-context-create :name 'subscriber-fault-tail)) + second-ran + (first + (etaf-runtime-route-create + :runtime-id 1 :mount-epoch 1 :authority-token 'first + :scheduler-context context + :scheduler + (lambda (_route _source) + (signal 'etaf-scheduler-test-source-condition + '("subscriber"))))) + (second + (etaf-runtime-route-create + :runtime-id 2 :mount-epoch 1 :authority-token 'second + :scheduler-context context + :scheduler (lambda (_route _source) (setq second-ran t)))) + captured) + (condition-case condition + (etaf-scheduler-call-with-projection + (lambda () + (etaf-scheduler-enqueue-source + context 'source + (lambda (delivery-context source projection-id) + (etaf--dispatch-subscriber-group + delivery-context source projection-id (list first second)))))) + (etaf-scheduler-test-source-condition (setq captured condition))) + (should (equal captured + '(etaf-scheduler-test-source-condition "subscriber"))) + (should second-ran) + (should (= 2 (etaf-scheduler-test--metric context :subscriber-visits))) + (should (etaf-scheduler-context-idle-p context)))) + +(ert-deftest etaf-scheduler-authority-predicate-fault-is-diagnostic () + "A broken Host authority predicate stays fail-closed and diagnostically visible." + (let* ((context + (etaf-scheduler-context-create :name 'authority-predicate-fault)) + (source (etaf-ref 0)) + scheduled + (route + (etaf-runtime-route-create + :runtime-id 1 :mount-epoch 1 :authority-token 'authority + :scheduler-context context + :scheduler (lambda (_route _source) (setq scheduled t)) + :accepts-p + (lambda (_route) + (signal 'etaf-scheduler-test-condition '("authority")))))) + (puthash route t (etaf-ref-subscribers source)) + (unwind-protect + (progn + (setf (etaf-value source) 1) + (should-not scheduled) + (should (= 1 (etaf-scheduler-test--metric + context :stale-route-drops))) + (let ((diagnostic + (cl-find 'route-authority + (etaf-scheduler-context-diagnostics context) + :key (lambda (entry) (plist-get entry :phase))))) + (should diagnostic) + (should (equal (plist-get diagnostic :condition) + '(etaf-scheduler-test-condition "authority"))))) + (remhash route (etaf-ref-subscribers source))))) + (ert-deftest etaf-scheduler-body-error-precedes-drain-error-and-quit-drains () "Body failure wins over drain failure; quit still drains queued effects." (let* ((context (etaf-scheduler-context-create :name 'precedence)) diff --git a/tests/fixtures/etaf-m0a-condition-consumers.sexp b/tests/fixtures/etaf-m0a-condition-consumers.sexp index b1a0805..f6925f9 100644 --- a/tests/fixtures/etaf-m0a-condition-consumers.sexp +++ b/tests/fixtures/etaf-m0a-condition-consumers.sexp @@ -9,6 +9,7 @@ (:file "etaf-reactive.el" :form condition-case :conditions (error quit) :owner etaf-reactive :policy generic-containment) (:file "etaf-reactive.el" :form condition-case :conditions (error quit) :owner etaf-reactive :policy generic-containment) (:file "etaf-reactive.el" :form condition-case :conditions (error quit) :owner etaf-reactive :policy generic-containment) + (:file "etaf-reactive.el" :form condition-case :conditions (error quit) :owner etaf-reactive :policy generic-containment) (:file "etaf-render-port.el" :form condition-case :conditions (error quit) :owner etaf-render-port :policy generic-containment) (:file "etaf-render-port.el" :form condition-case :conditions (error quit) :owner etaf-render-port :policy generic-containment) (:file "etaf-render-port.el" :form condition-case :conditions (error quit) :owner etaf-render-port :policy generic-containment) @@ -32,4 +33,5 @@ (:file "etaf-scheduler.el" :form condition-case :conditions (error quit) :owner etaf-scheduler :policy generic-containment) (:file "etaf-scheduler.el" :form condition-case :conditions (error quit) :owner etaf-scheduler :policy generic-containment) (:file "etaf-scheduler.el" :form condition-case :conditions (error quit) :owner etaf-scheduler :policy generic-containment) + (:file "etaf-scheduler.el" :form condition-case :conditions (error quit) :owner etaf-scheduler :policy generic-containment) (:file "etaf-scheduler.el" :form condition-case :conditions (error quit) :owner etaf-scheduler :policy generic-containment))