perf: retain authoritative publication target state
This commit is contained in:
Kinneyzhang
parent
b2b9462269
commit
47e8d8c256
@ -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"))
|
||||
|
||||
@ -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))
|
||||
|
||||
113
tp-surface.el
113
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)))
|
||||
(tp--publication-target-entry-create
|
||||
:rollback rollback-expected))
|
||||
(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)
|
||||
:surface-id (tp--surface-id surface)
|
||||
:mount-ids (tp--prepared-target-mount-ids prepared)
|
||||
:candidate-id candidate-id
|
||||
:surface-id (tp--copy-property-value (tp--surface-id surface))
|
||||
:mount-ids (tp--copy-property-value target-mount-ids)
|
||||
:buffer buffer
|
||||
:old-revision (tp--surface-snapshot-revision snapshot)
|
||||
:new-revision (1+ (tp--surface-snapshot-revision snapshot))
|
||||
:old-revision old-revision
|
||||
: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
|
||||
(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))))))
|
||||
:shadow-validator shadow-validator)))
|
||||
|
||||
(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)
|
||||
(tp--prepared-surface-client-state prepared))
|
||||
(eq (tp-publication-target-entry-client-state entry)
|
||||
(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
|
||||
|
||||
@ -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
|
||||
(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)))
|
||||
(unless (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)
|
||||
(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)))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user