;;; 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-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