perf: retain authoritative publication target state

tests/tp-surface-tests.el

@@ -39,6 +39,43 @@
     (error condition)
     (quit condition)))
 
+(defun tp-surface-test--commit-batch-update
+    (surface root batch client-state before-stage)
+  "Update SURFACE through BATCH after calling BEFORE-STAGE with its entry.
+ROOT is the retained object and CLIENT-STATE is transferred by its active
+prepare context."
+  (let ((execute (symbol-function 'tp--publication-batch-execute-stage)))
+    (cl-letf (((symbol-function 'tp--publication-batch-execute-stage)
+               (lambda (candidate)
+                 (let* ((entry
+                         (car (tp-publication-batch-candidate-entries
+                               candidate)))
+                        (prepared
+                         (aref
+                          (tp-publication-target-entry-rollback-snapshot entry)
+                          0)))
+                   (funcall before-stage entry prepared)
+                   (funcall execute candidate)))))
+      (tp-surface-update
+       surface
+       (lambda (context)
+         (tp-object-reuse-subtree context root)
+         (tp-commit-batch-result-create
+          context batch :client-state client-state
+          :reuse-mount-projection t))))))
+
+(defun tp-surface-test--replacement-batch (surface replacement)
+  "Return an equal-extent batch replacing SURFACE's middle character."
+  (tp-commit-batch-create
+   :base-revision (tp-surface-revision surface)
+   :target-revision (1+ (tp-surface-revision surface))
+   :base-extent 3 :target-extent 3
+   :patches
+   (list (list :old-start 1 :old-end 2 :new-start 1 :new-end 2
+               :replacement replacement))
+   :coordinate-patches
+   '((:old-start 1 :old-end 2 :new-start 1 :new-end 2))))
+
 (defun tp-surface-test--shadow-apply-commit-batch-oracle (string batch)
   "Return the former exact replay result for STRING and BATCH."
   (let ((result (copy-sequence string)))
@@ -138,6 +175,96 @@
                        (tp-surface-client-state surface))))
       (should-error (tp-surface-commit-batch surface batch)))))
 
+(ert-deftest tp-surface-test-publication-entry-adopts-prepared-authority ()
+  "A real surface entry references its authenticated prepared values exactly."
+  (tp-surface-test--with-buffer
+    (let* ((surface
+            (tp-surface-mount
+             (current-buffer) (tp-surface-test--leaf 'root "abc")
+             '(:capability content :coordinate-mounts t)))
+           (root (tp-object-resolve surface '(root)))
+           (batch (tp-surface-test--replacement-batch surface "X"))
+           (client-state (list :owned (list 'next)))
+           entry prepared)
+      (tp-surface-test--commit-batch-update
+       surface root batch client-state
+       (lambda (target candidate)
+         (setq entry target prepared candidate)))
+      (should (eq (tp-publication-target-entry-client-state entry)
+                  (tp--prepared-surface-client-state prepared)))
+      (should (eq (tp-publication-target-entry-diff entry)
+                  (tp--prepared-surface-commit-batch prepared)))
+      (should (eq (tp-surface-client-state surface) client-state))
+      (should (equal (buffer-string) "aXc")))))
+
+(ert-deftest tp-surface-test-publication-entry-rejects-binding-tamper ()
+  "Prepared batch, revision, extent, and client identity drift fail before write."
+  (dolist (fault '(batch client-state context-inactive context-surface
+                         base-revision target-revision base-extent
+                         target-extent))
+    (tp-surface-test--with-buffer
+      (let* ((surface
+              (tp-surface-mount
+               (current-buffer) (tp-surface-test--leaf 'root "abc")
+               '(:capability content :coordinate-mounts t)))
+             (root (tp-object-resolve surface '(root)))
+             (batch (tp-surface-test--replacement-batch surface "X"))
+             (client-state (list :owned (list 'next)))
+             captured-context)
+        (should-error
+         (tp-surface-test--commit-batch-update
+          surface root batch client-state
+          (lambda (entry prepared)
+            (setq captured-context (tp--prepared-surface-context prepared))
+            (pcase fault
+              ('batch
+               (setf (tp--prepared-surface-commit-batch prepared)
+                     (tp-surface-test--replacement-batch surface "X")))
+              ('client-state
+               (setf (tp--prepared-surface-client-state prepared)
+                     (copy-tree client-state)))
+              ('context-inactive
+               (setf (tp--context-active captured-context) nil))
+              ('context-surface
+               (setf (tp--context-surface captured-context) nil))
+              ('base-revision
+               (setf (tp-commit-batch-base-revision batch) 0))
+              ('target-revision
+               (setf (tp-commit-batch-target-revision batch) 9))
+              ('base-extent
+               (setf (tp-commit-batch-base-extent batch) 2))
+              ('target-extent
+               (setf (tp-commit-batch-target-extent batch) 4)))
+            (should (tp-publication-target-entry-p entry))))
+         :type 'tp-publication-binding-error)
+        (should (equal (buffer-string) "abc"))
+        (should (= (tp-surface-revision surface) 1))
+        (should-not (tp-surface-client-state surface))
+        (should-not (tp--context-active captured-context))))))
+
+(ert-deftest tp-surface-test-publication-entry-patch-tamper-stays-proven ()
+  "Existing full shadow proof diagnoses in-place patch payload mutation."
+  (tp-surface-test--with-buffer
+    (let* ((surface
+            (tp-surface-mount
+             (current-buffer) (tp-surface-test--leaf 'root "abc")
+             '(:capability content :coordinate-mounts t)))
+           (root (tp-object-resolve surface '(root)))
+           (batch (tp-surface-test--replacement-batch surface "X")))
+      (tp-surface-test--commit-batch-update
+       surface root batch '(:owned next)
+       (lambda (_entry _prepared)
+         (setf (plist-get (car (tp-commit-batch-patches batch)) :replacement)
+               "Z")))
+      (should (equal (buffer-string) "aZc"))
+      (should-not (plist-get tp--last-shadow-proof :equivalent))
+      (should
+       (cl-some
+        (lambda (entry)
+          (and (eq (car entry) 'shadow-proof)
+               (eq (cadr entry) 'commit)))
+        tp--last-transaction-diagnostics)))))
+
 (ert-deftest tp-surface-test-shadow-batch-replay-preserves-exact-properties ()
   "Shadow replay preserves Unicode, properties, order, and input ownership."
   (let* ((opaque (make-symbol "owner"))

tests/tp-transaction-tests.el

@@ -312,10 +312,17 @@
    :type 'tp-publication-binding-error)
   (with-temp-buffer
     (let* ((mount-ids (list 'mount-a))
-           (entry (tp-transaction-test--entry :mount-ids mount-ids))
+           (diff (list :replace (list 1 2)))
+           (client-state (list :client (list 'candidate)))
+           (entry (tp-transaction-test--entry
+                   :mount-ids mount-ids
+                   :diff diff
+                   :client-state client-state))
            (entries (list entry))
            (batch (tp-transaction-test--batch entries)))
       (setcar mount-ids 'mutated-after-create)
+      (setcar (plist-get diff :replace) 'mutated-after-create)
+      (setcar (plist-get client-state :client) 'mutated-after-create)
       (setcar entries (tp-transaction-test--entry
                        :candidate-id 'replacement
                        :surface-id 'replacement-surface
@@ -326,6 +333,10 @@
       (should (equal (tp-publication-target-entry-mount-ids
                       (car (tp-publication-batch-candidate-entries batch)))
                      '(mount-a)))
+      (should (equal (tp-publication-target-entry-diff entry)
+                     '(:replace (1 2))))
+      (should (equal (tp-publication-target-entry-client-state entry)
+                     '(:client (candidate))))
       (should (eq (car (tp-publication-batch-candidate-entries batch)) entry))
       (should-error
        (tp-transaction-test--batch (list entry entry))

tp-surface.el

@@ -3454,24 +3454,6 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
   (when-let* ((state (cl-find buffer views :key #'car :test #'eq)))
     (marker-position (cadr state))))
 
-(defun tp--shadow-prepared-diff (prepared)
-  "Return PREPARED's deterministic v2 diff artifact."
-  (cond
-   ((tp--prepared-surface-commit-batch prepared)
-    (let ((batch (tp--prepared-surface-commit-batch prepared)))
-      (list :kind 'commit-batch
-            :patches (tp-commit-batch-patches batch)
-            :coordinate-patches (tp-commit-batch-coordinate-patches batch))))
-   ((and (tp--prepared-surface-scope-objects prepared)
-         (not (tp--prepared-surface-scope-fallback prepared)))
-    (list :kind 'scoped
-          :patches (tp--prepared-surface-scope-patches prepared)))
-   (t
-    (list :kind 'full
-          :target-extent
-          (and (tp--prepared-surface-rendered prepared)
-               (length (tp--prepared-surface-rendered prepared)))))))
-
 (defun tp--shadow-artifact-equal-p (expected actual)
   "Return non-nil when EXPECTED and ACTUAL publication artifacts are equal."
   (and (eq (plist-get expected :buffer) (plist-get actual :buffer))
@@ -3505,7 +3487,9 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
 (defun tp--surface-shadow-target-entry
     (prepared snapshot journals views batch-id mapping-generation)
   "Build a BATCH-ID target view over PREPARED and SNAPSHOT.
-JOURNALS and VIEWS are exact references to the shared rollback state."
+JOURNALS and VIEWS are exact references to the shared rollback state.
+For real surface entries, the diff slot references PREPARED's exact commit
+batch, or nil when publication does not use a commit batch."
   (let* ((prepared (tp--assign-prepared-mount-ids prepared))
          (surface (tp--prepared-surface-surface prepared))
          (buffer (tp--surface-buffer surface))
@@ -3514,6 +3498,11 @@ JOURNALS and VIEWS are exact references to the shared rollback state."
          (old-ledger
           (tp--shadow-live-ledger-signature
            (tp--surface-snapshot-ledger snapshot)))
+         (context (tp--prepared-surface-context prepared))
+         (commit-batch (tp--prepared-surface-commit-batch prepared))
+         (target-mount-ids (tp--prepared-target-mount-ids prepared))
+         (candidate-id (tp--next-publication-candidate-id))
+         (authority-token (make-symbol "tp-publication-entry-authority"))
          (point (tp--shadow-view-point views buffer))
          (commit-expected
           (list :buffer buffer
@@ -3523,7 +3512,7 @@ JOURNALS and VIEWS are exact references to the shared rollback state."
                 :object-ids
                 (tp--shadow-object-ids
                  (tp--prepared-surface-objects prepared))
-                :mount-ids (tp--prepared-target-mount-ids prepared)
+                :mount-ids target-mount-ids
                 :mounts (tp--prepared-mount-signature prepared)
                 :ledger
                 (tp--shadow-ledger-spec-signature
@@ -3546,36 +3535,50 @@ JOURNALS and VIEWS are exact references to the shared rollback state."
                 :point point
                 :output old-output))
          (expected (list :commit commit-expected
-                         :rollback rollback-expected)))
+                         :rollback rollback-expected))
-    (tp--publication-target-entry-create
+         (old-revision (tp--surface-snapshot-revision snapshot))
+         (new-revision (1+ old-revision))
+         (shadow-validator
+          (lambda (_entry phase)
+            (let* ((target (plist-get expected
+                                      (if (eq phase 'commit)
+                                          :commit
+                                        :rollback)))
+                   (actual (tp--shadow-current-artifact surface)))
+              (list :equivalent (tp--shadow-artifact-equal-p target actual)
+                    :surface-id (tp--surface-id surface)
+                    :expected target :actual actual)))))
+    (unless
+        (and (tp-prepare-context-p context)
+             (tp--context-active context)
+             (eq (tp--context-surface context) surface)
+             (= old-revision (tp--surface-revision surface))
+             (tp--publication-target-entry-arguments-valid-p
+              tp--transaction-id batch-id candidate-id (tp--surface-id surface)
+              target-mount-ids buffer
+              old-revision new-revision authority-token shadow-validator))
+      (signal 'tp-publication-binding-error
+              (list :prepared-target prepared snapshot)))
+    (tp--make-publication-target-entry
      :transaction-id tp--transaction-id
      :batch-id batch-id
-     :candidate-id (tp--next-publication-candidate-id)
+     :candidate-id candidate-id
-     :surface-id (tp--surface-id surface)
+     :surface-id (tp--copy-property-value (tp--surface-id surface))
-     :mount-ids (tp--prepared-target-mount-ids prepared)
+     :mount-ids (tp--copy-property-value target-mount-ids)
      :buffer buffer
-     :old-revision (tp--surface-snapshot-revision snapshot)
+     :old-revision old-revision
-     :new-revision (1+ (tp--surface-snapshot-revision snapshot))
+     :new-revision new-revision
      :plan (tp--prepared-surface-plan prepared)
-     :diff (tp--shadow-prepared-diff prepared)
+     :diff commit-batch
      :ledger (tp--prepared-surface-ledger-specs prepared)
      :objects (tp--prepared-surface-objects prepared)
      :ranges (tp--prepared-surface-mount-specs prepared)
      :client-state (tp--prepared-surface-client-state prepared)
      :rollback-snapshot (vector prepared snapshot journals views)
-     :authority-token (make-symbol "tp-publication-entry-authority")
+     :authority-token authority-token
      :mapping-generation mapping-generation
      :shadow-expected expected
-     :shadow-validator
+     :shadow-validator shadow-validator)))
-     (lambda (_entry phase)
-       (let* ((target (plist-get expected
-                                 (if (eq phase 'commit)
-                                     :commit
-                                   :rollback)))
-              (actual (tp--shadow-current-artifact surface)))
-         (list :equivalent (tp--shadow-artifact-equal-p target actual)
-               :surface-id (tp--surface-id surface)
-               :expected target :actual actual))))))
 
 (defun tp--surface-shadow-target-entries
     (prepared snapshots journals views batch-id mapping-generation)
@@ -3596,9 +3599,19 @@ JOURNALS and VIEWS are exact references to the shared rollback state."
                         (aref rollback 0)))
          (snapshot (and prepared (aref rollback 1)))
          (surface (and (tp--prepared-surface-p prepared)
-                       (tp--prepared-surface-surface prepared))))
+                       (tp--prepared-surface-surface prepared)))
+         (context (and surface (tp--prepared-surface-context prepared)))
+         (commit-batch
+          (and surface (tp--prepared-surface-commit-batch prepared)))
+         (expected (and surface
+                        (tp-publication-target-entry-shadow-expected entry)))
+         (commit-expected (and expected (plist-get expected :commit)))
+         (rollback-expected (and expected (plist-get expected :rollback))))
     (unless
-        (and surface snapshot
+        (and surface (tp--surface-snapshot-p snapshot)
+             (tp-prepare-context-p context)
+             (tp--context-active context)
+             (eq (tp--context-surface context) surface)
              (tp--publication-target-entry-bound-p
               entry
               (tp-publication-batch-candidate-transaction-id candidate)
@@ -3609,6 +3622,8 @@ JOURNALS and VIEWS are exact references to the shared rollback state."
                  (tp--surface-buffer surface))
              (= (tp-publication-target-entry-old-revision entry)
                 (tp--surface-snapshot-revision snapshot))
+             (= (tp-publication-target-entry-old-revision entry)
+                (tp--surface-revision surface))
              (= (tp-publication-target-entry-new-revision entry)
                 (1+ (tp--surface-snapshot-revision snapshot)))
              (eq (tp-publication-target-entry-plan entry)
@@ -3619,8 +3634,20 @@ JOURNALS and VIEWS are exact references to the shared rollback state."
                  (tp--prepared-surface-objects prepared))
              (eq (tp-publication-target-entry-ranges entry)
                  (tp--prepared-surface-mount-specs prepared))
-             (equal (tp-publication-target-entry-client-state entry)
+             (eq (tp-publication-target-entry-client-state entry)
-                    (tp--prepared-surface-client-state prepared))
+                 (tp--prepared-surface-client-state prepared))
+             (eq (tp-publication-target-entry-diff entry) commit-batch)
+             (or
+              (null commit-batch)
+              (and
+               (= (tp-publication-target-entry-old-revision entry)
+                  (tp-commit-batch-base-revision commit-batch))
+               (= (tp-publication-target-entry-new-revision entry)
+                  (tp-commit-batch-target-revision commit-batch))
+               (= (tp-commit-batch-base-extent commit-batch)
+                  (length (plist-get rollback-expected :output)))
+               (= (tp-commit-batch-target-extent commit-batch)
+                  (length (plist-get commit-expected :output)))))
              (= (tp-publication-target-entry-mapping-generation entry)
                 tp--surface-transaction-id))
       (signal 'tp-publication-binding-error

tp-transaction.el

@@ -115,6 +115,20 @@
   (shadow-validator nil :read-only t)
   rollback-result post-rollback-state shadow-actual shadow-proven-p)
 
+(defun tp--publication-target-entry-arguments-valid-p
+    (transaction-id batch-id candidate-id surface-id mount-ids buffer
+                    old-revision new-revision authority-token shadow-validator)
+  "Return non-nil when target arguments bind TRANSACTION-ID and BATCH-ID.
+CANDIDATE-ID, SURFACE-ID, MOUNT-IDS, BUFFER, OLD-REVISION, NEW-REVISION,
+AUTHORITY-TOKEN, and SHADOW-VALIDATOR must have valid publication shapes."
+  (and transaction-id batch-id candidate-id surface-id
+       (bufferp buffer) (buffer-live-p buffer)
+       (integerp old-revision) (>= old-revision 0)
+       (integerp new-revision) (= new-revision (1+ old-revision))
+       (tp--proper-unique-list-p mount-ids)
+       authority-token
+       (or (null shadow-validator) (functionp shadow-validator))))
+
 (cl-defun tp--publication-target-entry-create
     (&key transaction-id batch-id candidate-id surface-id mount-ids buffer
           old-revision new-revision plan diff ledger objects ranges client-state
@@ -126,13 +140,9 @@ DIFF, LEDGER, OBJECTS, RANGES, CLIENT-STATE, ROLLBACK-SNAPSHOT, and
 AUTHORITY-TOKEN describe the target.  MAPPING-GENERATION is optional.
 OPERATION-COUNTS is filled from the live report.  SHADOW-EXPECTED and
 SHADOW-VALIDATOR are private comparison artifacts."
-  (unless (and transaction-id batch-id candidate-id surface-id
+  (unless (tp--publication-target-entry-arguments-valid-p
-               (bufferp buffer) (buffer-live-p buffer)
+           transaction-id batch-id candidate-id surface-id mount-ids buffer
-               (integerp old-revision) (>= old-revision 0)
+           old-revision new-revision authority-token shadow-validator)
-               (integerp new-revision) (= new-revision (1+ old-revision))
-               (tp--proper-unique-list-p mount-ids)
-               authority-token
-               (or (null shadow-validator) (functionp shadow-validator)))
     (signal 'tp-publication-binding-error
             (list :target-entry transaction-id batch-id candidate-id surface-id
                   buffer old-revision new-revision mount-ids authority-token)))