feat(transaction): cut over to structured publication authority
This commit is contained in:
Kinneyzhang
parent
2e2d9edc84
commit
469bdff17d
13
CHANGELOG.md
13
CHANGELOG.md
@ -9,8 +9,10 @@ All notable changes to the tp library are documented here.
|
||||
- A standalone retained surface runtime with pure defensive plans, prepare-scoped stable objects, keyed/positional reconciliation, content and properties capabilities, marker-backed range anchors, object/mount indexes, scoped updates, opaque client state, generic reports, and lifecycle cleanup.
|
||||
- Exact signal-to-binding and binding-to-binding dependency tracking with conditional rewiring, equality cutoffs, batched transactions, nested-write stabilization, owner disposal, buffer-scoped sources, variable adapters, cycle paths, and public structural counters.
|
||||
- Atomic single- and multi-surface publication with candidate source values, prepare-all/publish-all ordering, explicit property journals, rollback-capable transaction participants, observer isolation, and authoritative kill-buffer cleanup.
|
||||
- Additive transaction protocol v2 artifacts: transaction-scoped publication batches, structured v1 participant bridges, bounded opaque final-accept markers using the closed `tp-vector-slots/v1` primitive, immutable tagged outcomes, and property/revision shadow proofs over the unchanged v1 live writer.
|
||||
- Transaction protocol v2 artifacts: transaction-scoped publication batches, structured v1 participant bridges, bounded opaque final-accept markers using the closed `tp-vector-slots/v1` primitive, immutable tagged outcomes, and property/revision shadow proofs over the selected single live writer.
|
||||
- `tp-runtime-manifest`, advertising `tp-transaction-protocol-v1+v2` without removing the v1 participant route.
|
||||
- Supported `tp-transaction-execution-route` kill switch with `structured` as
|
||||
the default live authority and `v1` as the complete legacy rollback route.
|
||||
- Native property policies and contribution composition with explicit nil/absence, normalization, validation, equality, merge, projection, named direct styles, and explicit `tp-computed` value sources.
|
||||
- `tp-propertize`, `tp-apply`, and `tp-watch` as the one-shot string, one-shot buffer-range, and reactive existing-text conveniences over the same direct property/surface core.
|
||||
- Retained logical objects with `tp-object-retain` and `tp-object-attach-fragment`, allowing one object to own multiple disjoint physical fragments without placing handles or positions in plans.
|
||||
@ -18,6 +20,15 @@ All notable changes to the tp library are documented here.
|
||||
|
||||
### Changed
|
||||
|
||||
- Structured publication batches now own the single live surface-entry loop,
|
||||
participant stage/precommit/commit vector, and candidate-bound final accept.
|
||||
The public `tp-transaction-participate` API remains a v1 adapter over the same
|
||||
participant object; structured and v1 routes are mutually exclusive.
|
||||
- Runtime manifest fields now report active structured batch execution and the
|
||||
supported route list/option, single-writer invariant, and retained v1
|
||||
adapter/rollback route. The package version remains 1.0.1 because
|
||||
this is the planned authority cutover within the unreleased 1.0.1 protocol,
|
||||
with no public API removal or dependency change.
|
||||
- Package metadata now distinguishes builds that include
|
||||
`tp-transaction.el`; consumers can require TP 1.0.1 without an older 1.0.0
|
||||
development snapshot being accepted as a complete transaction runtime.
|
||||
|
||||
1
Makefile
1
Makefile
@ -55,6 +55,7 @@ test-m1a:
|
||||
|
||||
test-v1:
|
||||
$(EMACS) -Q --batch $(LOADPATH) -l tp.el \
|
||||
--eval '(setq tp-transaction-execution-route (quote v1))' \
|
||||
--eval '(setq tp--transaction-artifact-mode (quote v1))' \
|
||||
$(patsubst %,-l %,$(V1_TESTS)) -f ert-run-tests-batch-and-exit
|
||||
|
||||
|
||||
16
README.md
16
README.md
@ -146,12 +146,16 @@ TP records the host baseline and each TP contribution per property interval. Ove
|
||||
|
||||
Observers run only after a successful commit. Their failures are recorded and do not roll back an already committed transaction. A buffer killed during publication remains killed; rollback never recreates it.
|
||||
|
||||
TP also builds an internal transaction-scoped batch view over the same v1
|
||||
participants, journals, surface snapshots, and single final accept. Shadow
|
||||
mode compares canonical target artifacts and tagged outcomes with the one v1
|
||||
writer; it never opens a second change group or writes a buffer twice. Generic
|
||||
opaque authority markers are bounded and whitelist-validated before final
|
||||
accept, then reverse-restored before ordinary rollback on partial apply or
|
||||
TP's default `structured` route drives the single live publication from exact
|
||||
transaction-scoped batch entries, one frozen participant vector, and the
|
||||
candidate-bound final accept. The same journals, surface snapshots, and change
|
||||
group are shared rather than copied. Set `tp-transaction-execution-route` to
|
||||
`v1` before an outer transaction to use the complete legacy writer; the route is
|
||||
frozen for that transaction and the two writers are mutually exclusive. Shadow
|
||||
mode remains read-only compatibility evidence over whichever single route was
|
||||
selected; it never opens a second change group or writes a buffer twice.
|
||||
Generic opaque authority markers are bounded and whitelist-validated before
|
||||
final accept, then reverse-restored before ordinary rollback on partial apply or
|
||||
accept failure. `tp-with-transaction` still returns its body value, and
|
||||
internal outcomes remain observational side-channel evidence.
|
||||
|
||||
|
||||
17
README_CN.md
17
README_CN.md
@ -145,13 +145,16 @@ TP 为每个 property interval 保存 host baseline 和各个 TP contribution。
|
||||
|
||||
observer 只在成功提交之后运行，observer failure 只记录，不回滚已完成的 transaction。publication 过程中被 kill 的 buffer 保持死亡，rollback 不会把它重新创建。
|
||||
|
||||
TP 还会在同一份 v1 participant、journal、surface snapshot 和 single final
|
||||
accept 上建立内部 transaction-scoped batch view。shadow mode 只比较 canonical
|
||||
target artifact 与 tagged outcome，仍由唯一 v1 writer 写入；不会建立第二个
|
||||
change group，也不会双写 Buffer。generic opaque authority marker 在 final
|
||||
accept 前完成固定上界与 whitelist 校验；partial apply 或 accept failure 时先
|
||||
逆序恢复 marker，再执行普通 rollback。`tp-with-transaction` 仍返回 body
|
||||
result，内部 outcome 仅作为只读 side-channel evidence。
|
||||
TP 默认由 `structured` route 从 transaction-scoped batch 的 exact entries、
|
||||
同一个冻结 participant vector 和 candidate-bound final accept 驱动唯一 live
|
||||
publication；journal、surface snapshot 与 change group 仍只保留一份。outer
|
||||
transaction 开始前把 `tp-transaction-execution-route` 设为 `v1`，即可使用完整
|
||||
legacy writer；route 会在该 transaction 内冻结，两条 writer 分支始终互斥。
|
||||
shadow mode 只对已选择的单一路径生成只读兼容证据，不会建立第二个 change
|
||||
group，也不会双写 Buffer。generic opaque authority marker 在 final accept 前
|
||||
完成固定上界与 whitelist 校验；partial apply 或 accept failure 时先逆序恢复
|
||||
marker，再执行普通 rollback。`tp-with-transaction` 仍返回 body result，内部
|
||||
outcome 仅作为只读 side-channel evidence。
|
||||
|
||||
ETAF 集成复用同一事务边界，只注册一个 opaque transaction participant。ETAF
|
||||
先准备 immutable generation 和 Ebox candidate，再由 TP 按固定顺序完成
|
||||
|
||||
@ -233,6 +233,8 @@ tp-binding-dispose 释放单个 binding。
|
||||
|
||||
(tp-transaction-active-p)
|
||||
|
||||
(setq tp-transaction-execution-route 'structured) ; structured 或 v1
|
||||
|
||||
(tp-runtime-manifest)
|
||||
|
||||
(tp-variable-signal 'my-variable)
|
||||
@ -253,12 +255,23 @@ tp-transaction-active-p 是只读边界查询：只在当前 dynamic extent 已
|
||||
对象、participant 或内部状态，调用方只能用它在 mutation 前拒绝不支持的
|
||||
嵌套事务边界。
|
||||
|
||||
`tp-transaction-execution-route` 是受支持的 live authority kill switch，默认
|
||||
为 `structured`，也可在 outer transaction 开始前设为 `v1`。outer transaction
|
||||
会校验并冻结选择；中途修改 public option 不改变当前 transaction，只在下一次
|
||||
outer transaction 生效。`structured` 从 publication batch 的 exact entries、
|
||||
同一个 participant vector 和 candidate-bound final accept 执行；`v1` 恢复原 prepared-list、
|
||||
registration-list 与 transaction final-accept 循环。两条 route 互斥。
|
||||
|
||||
tp-runtime-manifest 返回防御性 capability snapshot；本版本的
|
||||
`:transaction-protocol` 为 `tp-transaction-protocol-v1+v2`。该声明是 additive：
|
||||
旧 `tp-transaction-participate` façade 与 live writer 都仍保留。
|
||||
`:batch-artifacts` 与 `:shadow-proof` 为 non-nil，`:batch-execution` 为
|
||||
`v1-bridge`，而 `:batch-execute` 明确为 nil；structured-core execute owner
|
||||
保留给后续受控 cutover，不在 M1a 伪造第二个 coordinator。
|
||||
`:transaction-protocol` 为 `tp-transaction-protocol-v1+v2`。structured core
|
||||
现在是默认 live authority，因此 `:execution-default` 为 `structured`、
|
||||
`:execution-routes` 为 `(structured v1)`、`:route-option` 为
|
||||
`tp-transaction-execution-route`，兼容字段 `:execution-route` 与
|
||||
`:batch-execution` 也均为 `structured`，`:batch-execute` 为 non-nil。公开
|
||||
`tp-transaction-participate` 仍是 v1 adapter，manifest 以 `:v1-adapter` 和
|
||||
`:v1-rollback-route` 明确声明 adapter 与完整旧 route 均保留；
|
||||
`:single-live-writer` 明确声明 route 不会双写；
|
||||
`:batch-artifacts` 与 `:shadow-proof` 也保持 non-nil。
|
||||
|
||||
ETAF registers one opaque participant for its immutable generation and Ebox
|
||||
client state. Its publish is paired with rollback across TP final accept; the
|
||||
|
||||
@ -196,10 +196,11 @@ TP 为每个 interval 保存：
|
||||
3. 运行 binding graph 与 producers；
|
||||
4. 校验 object、plan、capability、range、conflict 与 lifecycle；
|
||||
5. 为所有 surfaces 准备 text/property operations 与 inverse journals；
|
||||
6. 按稳定 surface id publish；
|
||||
7. 按声明顺序 stage participant，再执行 declared precommit；
|
||||
6. 默认从 publication batch 的 exact entry bindings 按稳定 surface id publish；
|
||||
7. 从 batch 绑定的同一 participant vector 按声明顺序 stage participant，再执行
|
||||
declared precommit；
|
||||
8. commit signal journal；
|
||||
9. 在 single final accept 内按顺序 apply bounded opaque markers，再 accept
|
||||
9. 在 candidate 绑定的 single final accept 内按顺序 apply bounded opaque markers，再 accept
|
||||
change group；marker 只能使用 closed `tp-vector-slots/v1` fixed-write
|
||||
primitive，不能注册 callback；partial apply 或 accept failure 先逆序
|
||||
restore markers；
|
||||
@ -208,14 +209,21 @@ TP 为每个 interval 保存：
|
||||
|
||||
嵌套 transaction 加入最外层。一个 global signal 可以原子触达多个 buffers；任一 surface 失败时，已发布 surfaces 和 source/binding state 全部回滚。
|
||||
|
||||
`tp-transaction-participate` 允许 client side state 在 surfaces 发布后、source commit 前加入同一 rollback boundary。participant key 在一个 outer transaction 中必须唯一。它不是 observer；失败会回滚 transaction。Observer failure 只记录，不回滚已提交结果。
|
||||
`tp-transaction-participate` 允许 client side state 在 surfaces 发布后、source commit 前加入同一 rollback boundary。它保留公共 v1 调用形状，但在默认 structured route 中适配成同一个 participant record 的 `stage` capability，只执行一次。participant key 在一个 outer transaction 中必须唯一。它不是 observer；失败会回滚 transaction。Observer failure 只记录，不回滚已提交结果。
|
||||
|
||||
M1a 的 publication batch、structured participant、final marker 与 tagged
|
||||
outcome 都是现有 v1 dynamic transaction state 的内部结构化 view，不复制第二份
|
||||
participant/journal/change-group，也不切换 live writer。shadow proof 只比较 v1/v2
|
||||
artifact 与 outcome，不双写 Buffer。`tp-with-transaction` 的返回值仍是 body
|
||||
result；success/failure outcome 只走内部 side channel。zero-surface 与
|
||||
output-equal operation 不创建 publication batch。
|
||||
publication batch、structured participant、final marker 与 tagged outcome 共享
|
||||
现有 journal/change-group，不复制第二份 live state。默认 `structured` route 是
|
||||
唯一 live writer：surface 从 candidate entries 执行，participant 从 candidate
|
||||
绑定的同一 identity vector 执行，final accept 从 candidate binding 执行；任何
|
||||
binding/order 漂移都会 fail-fast 并回滚。把
|
||||
`tp-transaction-execution-route` 在 outer transaction 前设为 `v1` 会立即恢复
|
||||
完整 legacy prepared-list、registration-list 与 final-accept route。route 在 outer
|
||||
transaction 入口冻结，中途修改 option 只影响下一次 outer transaction；
|
||||
structured/v1 分支始终互斥，不双写 Buffer
|
||||
或 participant state。`tp--transaction-artifact-mode` 只控制 v1/shadow 兼容证据，
|
||||
不能关闭 structured candidate。`tp-with-transaction` 的返回值仍是 body result；
|
||||
success/failure outcome 只走内部 side channel。zero-surface 与 output-equal
|
||||
operation 不创建 publication batch。
|
||||
|
||||
ETAF uses this API with one opaque participant for its immutable generation and
|
||||
Ebox client state. The participant is published only after candidate
|
||||
|
||||
@ -1,13 +1,13 @@
|
||||
;;; tp-transaction-tests.el --- TP additive transaction contract -*- lexical-binding: t; -*-
|
||||
;;; tp-transaction-tests.el --- TP structured transaction contract -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Geekinney
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Characterization and fault tests for the additive v1+v2 transaction
|
||||
;; protocol. These tests deliberately exercise the internal protocol: the
|
||||
;; public contract remains `tp-with-transaction' body return and primary
|
||||
;; condition preservation.
|
||||
;; Characterization and fault tests for the v1+v2 transaction protocol and its
|
||||
;; controlled structured-authority cutover. These tests deliberately exercise
|
||||
;; the internal protocol: the public contract remains `tp-with-transaction'
|
||||
;; body return and primary condition preservation.
|
||||
|
||||
;;; Code:
|
||||
|
||||
@ -22,8 +22,10 @@
|
||||
(declare-function tp--transaction-participant-journal "tp-reactive" (value))
|
||||
(declare-function tp--transaction-register-final-marker
|
||||
"tp-reactive" (&rest args))
|
||||
(declare-function tp-runtime-manifest "tp" ())
|
||||
|
||||
(defvar tp--transaction-artifact-mode)
|
||||
(defvar tp-transaction-execution-route)
|
||||
(defvar tp--transaction-publication-batch)
|
||||
(defvar tp--transaction-outcome)
|
||||
(defvar tp--last-shadow-proof)
|
||||
@ -454,7 +456,7 @@
|
||||
|
||||
(ert-deftest tp-transaction-test-public-final-marker-wrappers-share-contract ()
|
||||
"Public marker constructors and registration retain the bounded core rules."
|
||||
(tp-transaction-test--with-surface (_buffer _surface source)
|
||||
(tp-transaction-test--with-surface (buffer _surface source)
|
||||
(let ((target (vector 'detached 'token 0)))
|
||||
(tp-with-transaction
|
||||
(tp-signal-set source 2)
|
||||
@ -1145,7 +1147,8 @@
|
||||
(shadow-writes 0))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(let ((tp--transaction-artifact-mode 'v1))
|
||||
(let ((tp-transaction-execution-route 'v1)
|
||||
(tp--transaction-artifact-mode 'v1))
|
||||
(tp-surface-update v1-surface next))
|
||||
(should-not tp--last-transaction-outcome)
|
||||
(should-not tp--last-shadow-proof)
|
||||
@ -1154,7 +1157,8 @@
|
||||
(cl-incf shadow-writes)
|
||||
(funcall writer prepared))))
|
||||
(let ((tp--transaction-artifact-mode 'shadow))
|
||||
(tp-surface-update shadow-surface next)))
|
||||
(let ((tp-transaction-execution-route 'v1))
|
||||
(tp-surface-update shadow-surface next))))
|
||||
(should (= shadow-writes 1))
|
||||
(should (tp-committed-success-outcome-p
|
||||
tp--last-transaction-outcome))
|
||||
@ -1172,6 +1176,223 @@
|
||||
(when (buffer-live-p v1-buffer) (kill-buffer v1-buffer))
|
||||
(when (buffer-live-p shadow-buffer) (kill-buffer shadow-buffer)))))
|
||||
|
||||
(ert-deftest tp-transaction-test-structured-and-v1-routes-are-equivalent ()
|
||||
"Structured and v1 authorities commit equivalent state with one write each."
|
||||
(let* ((structured-buffer (generate-new-buffer " *tp-route-structured*"))
|
||||
(v1-buffer (generate-new-buffer " *tp-route-v1*"))
|
||||
(initial (tp-transaction-test--leaf "old"))
|
||||
(next (tp-transaction-test--leaf "new"))
|
||||
(structured (tp-surface-mount structured-buffer initial
|
||||
'(:capability content)))
|
||||
(v1 (tp-surface-mount v1-buffer initial '(:capability content)))
|
||||
(writer (symbol-function 'tp--publish-one-surface))
|
||||
(writes (make-hash-table :test #'eq)))
|
||||
(unwind-protect
|
||||
(cl-letf (((symbol-function 'tp--publish-one-surface)
|
||||
(lambda (prepared)
|
||||
(let ((surface (tp--prepared-surface-surface prepared)))
|
||||
(puthash surface (1+ (gethash surface writes 0)) writes))
|
||||
(funcall writer prepared))))
|
||||
(let ((tp-transaction-execution-route 'structured)
|
||||
(tp--transaction-artifact-mode 'v1))
|
||||
(tp-surface-update structured next))
|
||||
(let ((tp-transaction-execution-route 'v1)
|
||||
(tp--transaction-artifact-mode 'v1))
|
||||
(tp-surface-update v1 next))
|
||||
(should (= (gethash structured writes 0) 1))
|
||||
(should (= (gethash v1 writes 0) 1))
|
||||
(should (= (tp-surface-revision structured) (tp-surface-revision v1)))
|
||||
(should (equal-including-properties
|
||||
(with-current-buffer structured-buffer (buffer-string))
|
||||
(with-current-buffer v1-buffer (buffer-string)))))
|
||||
(when (buffer-live-p structured-buffer) (kill-buffer structured-buffer))
|
||||
(when (buffer-live-p v1-buffer) (kill-buffer v1-buffer)))))
|
||||
|
||||
(ert-deftest tp-transaction-test-final-accept-source-follows-route ()
|
||||
"Structured validates candidate final accept; v1 shadow uses legacy binding."
|
||||
(let* ((structured-buffer (generate-new-buffer " *tp-final-structured*"))
|
||||
(v1-buffer (generate-new-buffer " *tp-final-v1*"))
|
||||
(initial (tp-transaction-test--leaf "old"))
|
||||
(next (tp-transaction-test--leaf "new"))
|
||||
(structured (tp-surface-mount structured-buffer initial
|
||||
'(:capability content)))
|
||||
(v1 (tp-surface-mount v1-buffer initial '(:capability content)))
|
||||
(sync (symbol-function 'tp--transaction-sync-publication-batch)))
|
||||
(unwind-protect
|
||||
(cl-letf (((symbol-function 'tp--transaction-sync-publication-batch)
|
||||
(lambda ()
|
||||
(funcall sync)
|
||||
(when tp--transaction-publication-batch
|
||||
(setf (tp-publication-batch-candidate-final-accept
|
||||
tp--transaction-publication-batch)
|
||||
#'ignore)))))
|
||||
(let ((tp-transaction-execution-route 'structured))
|
||||
(should-error (tp-surface-update structured next)
|
||||
:type 'tp-publication-binding-error))
|
||||
(with-current-buffer structured-buffer
|
||||
(should (equal (buffer-string) "old")))
|
||||
(let ((tp-transaction-execution-route 'v1)
|
||||
(tp--transaction-artifact-mode 'shadow))
|
||||
(tp-surface-update v1 next))
|
||||
(with-current-buffer v1-buffer
|
||||
(should (equal (buffer-string) "new")))
|
||||
(should (tp-committed-success-outcome-p tp--last-transaction-outcome)))
|
||||
(when (buffer-live-p structured-buffer) (kill-buffer structured-buffer))
|
||||
(when (buffer-live-p v1-buffer) (kill-buffer v1-buffer)))))
|
||||
|
||||
(ert-deftest tp-transaction-test-default-execution-route-is-structured ()
|
||||
"The supported live execution route defaults to the structured core."
|
||||
(should (eq (default-value 'tp-transaction-execution-route) 'structured)))
|
||||
|
||||
(ert-deftest tp-transaction-test-structured-batch-owns-surface-stage-once ()
|
||||
"Structured execution enters the candidate seam and writes each entry once."
|
||||
(let* ((source (tp-signal-create 1))
|
||||
(producer (tp-transaction-test--producer source))
|
||||
(first-buffer (generate-new-buffer " *tp-structured-first*"))
|
||||
(second-buffer (generate-new-buffer " *tp-structured-second*"))
|
||||
(first (tp-surface-mount first-buffer producer '(:capability content)))
|
||||
(second (tp-surface-mount second-buffer producer '(:capability content)))
|
||||
(execute (symbol-function 'tp--publication-batch-execute-stage))
|
||||
(writer (symbol-function 'tp--publish-one-surface))
|
||||
(calls (make-hash-table :test #'eq))
|
||||
(stage-calls 0))
|
||||
(unwind-protect
|
||||
(cl-letf (((symbol-function 'tp--publication-batch-execute-stage)
|
||||
(lambda (candidate)
|
||||
(cl-incf stage-calls)
|
||||
(funcall execute candidate)))
|
||||
((symbol-function 'tp--publish-one-surface)
|
||||
(lambda (prepared)
|
||||
(let ((surface (tp--prepared-surface-surface prepared)))
|
||||
(puthash surface (1+ (gethash surface calls 0)) calls))
|
||||
(funcall writer prepared))))
|
||||
(let ((tp-transaction-execution-route 'structured)
|
||||
(tp--transaction-artifact-mode 'v1))
|
||||
(tp-signal-set source 2))
|
||||
(should (= stage-calls 1))
|
||||
(should (= (gethash first calls 0) 1))
|
||||
(should (= (gethash second calls 0) 1))
|
||||
(should (tp-committed-success-outcome-p tp--last-transaction-outcome)))
|
||||
(when (buffer-live-p first-buffer) (kill-buffer first-buffer))
|
||||
(when (buffer-live-p second-buffer) (kill-buffer second-buffer))
|
||||
(when (tp-signal-live-p source) (tp-signal-dispose source)))))
|
||||
|
||||
(ert-deftest tp-transaction-test-public-v1-adapter-stages-once-from-batch ()
|
||||
"The public v1 adapter is one structured participant in the batch vector."
|
||||
(tp-transaction-test--with-surface (buffer _surface source)
|
||||
(let ((stages 0) captured participant)
|
||||
(tp-with-transaction
|
||||
(tp-transaction-participate
|
||||
'public-v1
|
||||
(lambda ()
|
||||
(cl-incf stages)
|
||||
(setq captured tp--transaction-publication-batch
|
||||
participant
|
||||
(aref (tp-publication-batch-candidate-participants
|
||||
tp--transaction-publication-batch)
|
||||
0)))
|
||||
#'ignore)
|
||||
(tp-signal-set source 2))
|
||||
(should (= stages 1))
|
||||
(should (tp-publication-batch-candidate-p captured))
|
||||
(should (eq (tp--transaction-participant-protocol participant)
|
||||
'v1-bridge))
|
||||
(should (eq (tp--transaction-participant-state participant) 'committed)))))
|
||||
|
||||
(ert-deftest tp-transaction-test-v1-kill-switch-preserves-legacy-authority ()
|
||||
"The v1 kill switch uses legacy loops without a structured batch writer."
|
||||
(tp-transaction-test--with-surface (buffer _surface source)
|
||||
(let ((tp-transaction-execution-route 'v1)
|
||||
(tp--transaction-artifact-mode 'v1)
|
||||
(stage-seam-calls 0)
|
||||
(participant-calls 0)
|
||||
(seam (symbol-function 'tp--publication-batch-execute-stage)))
|
||||
(cl-letf (((symbol-function 'tp--publication-batch-execute-stage)
|
||||
(lambda (candidate)
|
||||
(cl-incf stage-seam-calls)
|
||||
(funcall seam candidate))))
|
||||
(should
|
||||
(eq (tp-with-transaction
|
||||
(tp-transaction-participate
|
||||
'legacy (lambda () (cl-incf participant-calls)) #'ignore)
|
||||
(tp-signal-set source 2)
|
||||
'legacy-result)
|
||||
'legacy-result)))
|
||||
(should (= stage-seam-calls 0))
|
||||
(should (= participant-calls 1))
|
||||
(should-not tp--last-transaction-outcome))))
|
||||
|
||||
(ert-deftest tp-transaction-test-invalid-route-fails-before-body-mutation ()
|
||||
"An invalid route is rejected before the transaction body can mutate state."
|
||||
(let ((tp-transaction-execution-route 'invalid)
|
||||
(body-calls 0))
|
||||
(should-error
|
||||
(tp-with-transaction (cl-incf body-calls))
|
||||
:type 'tp-transaction-contract-error)
|
||||
(should (= body-calls 0))))
|
||||
|
||||
(ert-deftest tp-transaction-test-route-change-applies-to-next-outer-transaction ()
|
||||
"An active outer transaction keeps its snapshot; the next uses the new route."
|
||||
(tp-transaction-test--with-surface (buffer surface source)
|
||||
(let ((revision (tp-surface-revision surface))
|
||||
(tp-transaction-execution-route 'structured)
|
||||
(tp--transaction-artifact-mode 'v1)
|
||||
(stage (symbol-function 'tp--publication-batch-execute-stage))
|
||||
(writer (symbol-function 'tp--publish-one-surface))
|
||||
(stage-calls 0)
|
||||
(writer-calls 0)
|
||||
first-outcome)
|
||||
(cl-letf (((symbol-function 'tp--publication-batch-execute-stage)
|
||||
(lambda (candidate)
|
||||
(cl-incf stage-calls)
|
||||
(funcall stage candidate)))
|
||||
((symbol-function 'tp--publish-one-surface)
|
||||
(lambda (prepared)
|
||||
(cl-incf writer-calls)
|
||||
(funcall writer prepared))))
|
||||
(tp-with-transaction
|
||||
(tp-signal-set source 2)
|
||||
(setq tp-transaction-execution-route 'v1))
|
||||
(setq first-outcome tp--last-transaction-outcome)
|
||||
(tp-signal-set source 3))
|
||||
(should (tp-committed-success-outcome-p first-outcome))
|
||||
(should-not tp--last-transaction-outcome)
|
||||
(should (= stage-calls 1))
|
||||
(should (= writer-calls 2))
|
||||
(should (= (tp-signal-peek source) 3))
|
||||
(should (= (tp-surface-revision surface) (+ revision 2)))
|
||||
(with-current-buffer buffer
|
||||
(should (equal (buffer-string) "3"))))))
|
||||
|
||||
(ert-deftest tp-transaction-test-batch-rejects-foreign-stage-capability ()
|
||||
"A publication batch accepts only the closed package-owned stage seam."
|
||||
(should-error
|
||||
(tp--publication-batch-prepare
|
||||
:transaction-id 'transaction-a
|
||||
:batch-id 'batch-a
|
||||
:entries (list (tp-transaction-test--entry))
|
||||
:participants []
|
||||
:journals nil
|
||||
:stage-entries #'ignore
|
||||
:final-accept #'ignore)
|
||||
:type 'tp-publication-binding-error))
|
||||
|
||||
(ert-deftest tp-transaction-test-participant-vector-drift-rolls-back-surfaces ()
|
||||
"Registration drift after batch binding fails fast and restores live state."
|
||||
(tp-transaction-test--with-surface (buffer surface source)
|
||||
(let ((revision (tp-surface-revision surface))
|
||||
(stage (symbol-function 'tp--publication-batch-execute-stage)))
|
||||
(cl-letf (((symbol-function 'tp--publication-batch-execute-stage)
|
||||
(lambda (candidate)
|
||||
(tp-transaction-participate 'late #'ignore #'ignore)
|
||||
(funcall stage candidate))))
|
||||
(should-error (tp-signal-set source 2)
|
||||
:type 'tp-publication-binding-error))
|
||||
(should (= (tp-signal-peek source) 1))
|
||||
(should (= (tp-surface-revision surface) revision))
|
||||
(with-current-buffer buffer
|
||||
(should (equal (buffer-string) "1"))))))
|
||||
|
||||
(ert-deftest tp-transaction-test-ordinary-update-success-has-zero-markers ()
|
||||
"An ordinary publication records zero final authority markers."
|
||||
(tp-transaction-test--with-surface (buffer _surface source)
|
||||
@ -1366,8 +1587,8 @@
|
||||
(with-current-buffer buffer
|
||||
(should (equal (buffer-string) "1")))))))
|
||||
|
||||
(ert-deftest tp-transaction-test-manifest-advertises-v1-plus-v2 ()
|
||||
"The TP manifest retains v1 while advertising the additive protocol."
|
||||
(ert-deftest tp-transaction-test-manifest-advertises-structured-cutover ()
|
||||
"The manifest advertises structured authority and the retained v1 route."
|
||||
(should (eq tp-transaction-protocol
|
||||
'tp-transaction-protocol-v1+v2))
|
||||
(let ((manifest (tp-runtime-manifest)))
|
||||
@ -1375,14 +1596,30 @@
|
||||
(should (eq (plist-get manifest :transaction-protocol)
|
||||
'tp-transaction-protocol-v1+v2))
|
||||
(should (plist-get manifest :batch-artifacts))
|
||||
(should (eq (plist-get manifest :batch-execution) 'v1-bridge))
|
||||
(should-not (plist-get manifest :batch-execute))
|
||||
(should (eq (plist-get manifest :execution-route) 'structured))
|
||||
(should (eq (plist-get manifest :execution-default) 'structured))
|
||||
(should (equal (plist-get manifest :execution-routes)
|
||||
'(structured v1)))
|
||||
(should (eq (plist-get manifest :route-option)
|
||||
'tp-transaction-execution-route))
|
||||
(should (eq (plist-get manifest :batch-execution) 'structured))
|
||||
(should (plist-get manifest :batch-execute))
|
||||
(should (plist-get manifest :v1-adapter))
|
||||
(should (plist-get manifest :v1-rollback-route))
|
||||
(should (plist-get manifest :single-live-writer))
|
||||
(should (plist-get manifest :shadow-proof))
|
||||
(should (eq (plist-get manifest :final-marker-operation)
|
||||
'tp-vector-slots/v1))
|
||||
(setf (plist-get manifest :transaction-protocol) 'mutated)
|
||||
(should (eq (plist-get (tp-runtime-manifest) :transaction-protocol)
|
||||
'tp-transaction-protocol-v1+v2))))
|
||||
(setcar (plist-get manifest :execution-routes) 'mutated)
|
||||
(setf (plist-get manifest :transaction-protocol) 'mutated
|
||||
(plist-get manifest :execution-route) 'v1
|
||||
(plist-get manifest :batch-execute) nil)
|
||||
(let ((fresh (tp-runtime-manifest)))
|
||||
(should (eq (plist-get fresh :transaction-protocol)
|
||||
'tp-transaction-protocol-v1+v2))
|
||||
(should (eq (plist-get fresh :execution-route) 'structured))
|
||||
(should (equal (plist-get fresh :execution-routes) '(structured v1)))
|
||||
(should (plist-get fresh :batch-execute)))))
|
||||
|
||||
(provide 'tp-transaction-tests)
|
||||
|
||||
|
||||
140
tp-reactive.el
140
tp-reactive.el
@ -94,6 +94,8 @@
|
||||
(defvar tp--transaction-phase-start nil)
|
||||
(defvar tp--transaction-phase-timings nil)
|
||||
(defvar tp--transaction-publication-batch nil)
|
||||
(defvar tp--transaction-structured-participants nil)
|
||||
(defvar tp--transaction-frozen-execution-route nil)
|
||||
(defvar tp--transaction-final-marker-registry nil)
|
||||
(defvar tp--transaction-final-marker-owner-keys nil)
|
||||
(defvar tp--transaction-final-marker-count 0)
|
||||
@ -127,7 +129,16 @@
|
||||
(defvar tp--transaction-committed-functions nil)
|
||||
|
||||
(defvar tp--transaction-artifact-mode 'shadow
|
||||
"Internal artifact route; the live writer remains the v1 coordinator.")
|
||||
"Internal v1/shadow compatibility evidence mode.")
|
||||
|
||||
;;;###autoload
|
||||
(defcustom tp-transaction-execution-route 'structured
|
||||
"Live transaction execution authority.
|
||||
`structured' executes package-owned batch and participant capabilities.
|
||||
`v1' immediately restores the legacy prepared-list and participant-list loops."
|
||||
:type '(choice (const :tag "Structured batch" structured)
|
||||
(const :tag "Legacy v1" v1))
|
||||
:group 'tp)
|
||||
|
||||
(defvar tp--transaction-participant-precommit-allowed-functions nil
|
||||
"Declared internal structured-participant precommit validators.")
|
||||
@ -660,7 +671,7 @@ When CREATE is non-nil, install and return a fresh hash table when absent."
|
||||
(fboundp function))))
|
||||
|
||||
(defun tp--transaction-register-participant (participant)
|
||||
"Register structured PARTICIPANT in the authoritative v1 participant list."
|
||||
"Register PARTICIPANT once for structured and legacy transaction views."
|
||||
(unless tp--transaction-active
|
||||
(signal 'tp-reactive-error
|
||||
(list :participant-outside-transaction
|
||||
@ -722,7 +733,7 @@ structured view over the same participant object."
|
||||
|
||||
(cl-defun tp--transaction-participate-v2
|
||||
(&key key stage rollback precommit after-commit journal)
|
||||
"Register internal KEY with STAGE and ROLLBACK through the v1 coordinator.
|
||||
"Register internal KEY with structured STAGE and ROLLBACK capabilities.
|
||||
PRECOMMIT and AFTER-COMMIT are optional declared callbacks. JOURNAL is the
|
||||
participant's opaque owner-local state."
|
||||
(unless tp--transaction-active
|
||||
@ -745,6 +756,39 @@ participant's opaque owner-local state."
|
||||
(setf (tp--transaction-participant-state participant) 'staged)
|
||||
(funcall (tp--transaction-participant-publish participant))))
|
||||
|
||||
(defun tp--transaction-validate-structured-participants ()
|
||||
"Return the frozen participant vector after exact identity validation."
|
||||
(let* ((participants tp--transaction-structured-participants)
|
||||
(registered (tp--transaction-participants-in-registration-order))
|
||||
(count (length registered)))
|
||||
(unless (and (vectorp participants) (= (length participants) count))
|
||||
(signal 'tp-publication-binding-error
|
||||
(list :participant-count participants registered)))
|
||||
(cl-loop for participant in registered
|
||||
for index from 0
|
||||
unless (eq participant (aref participants index))
|
||||
do (signal 'tp-publication-binding-error
|
||||
(list :participant-order index participant
|
||||
(aref participants index))))
|
||||
(when tp--transaction-publication-batch
|
||||
(let ((candidate-participants
|
||||
(tp-publication-batch-candidate-participants
|
||||
tp--transaction-publication-batch)))
|
||||
(unless (eq candidate-participants participants)
|
||||
(signal 'tp-publication-binding-error
|
||||
(list :participant-vector candidate-participants
|
||||
participants)))))
|
||||
participants))
|
||||
|
||||
(defun tp--stage-structured-transaction-participants ()
|
||||
"Stage the frozen structured participant vector in declaration order."
|
||||
(let ((participants (tp--transaction-validate-structured-participants)))
|
||||
(dotimes (index (length participants))
|
||||
(let ((participant (aref participants index)))
|
||||
(push participant tp--transaction-published-participants)
|
||||
(setf (tp--transaction-participant-state participant) 'staged)
|
||||
(funcall (tp--transaction-participant-stage participant))))))
|
||||
|
||||
(defun tp--rollback-transaction-participants ()
|
||||
"Rollback published participants and return any failures."
|
||||
(let (failures)
|
||||
@ -772,6 +816,18 @@ participant's opaque owner-local state."
|
||||
(list :invalid-participant-precommit function)))
|
||||
(funcall function))))
|
||||
|
||||
(defun tp--run-structured-transaction-participant-precommits ()
|
||||
"Run validators from the frozen structured participant vector."
|
||||
(let ((participants (tp--transaction-validate-structured-participants)))
|
||||
(dotimes (index (length participants))
|
||||
(when-let* ((function
|
||||
(tp--transaction-participant-precommit
|
||||
(aref participants index))))
|
||||
(unless (tp--transaction-participant-precommit-function-p function)
|
||||
(signal 'tp-reactive-error
|
||||
(list :invalid-participant-precommit function)))
|
||||
(funcall function)))))
|
||||
|
||||
(defun tp--commit-transaction-participants ()
|
||||
"Commit participant states and queue their contained after-commit work."
|
||||
(dolist (participant (tp--transaction-participants-in-registration-order))
|
||||
@ -781,6 +837,17 @@ participant's opaque owner-local state."
|
||||
(tp--transaction-participant-after-commit participant)))
|
||||
(tp--enqueue-after-commit function)))))
|
||||
|
||||
(defun tp--commit-structured-transaction-participants ()
|
||||
"Commit states from the frozen structured participant vector."
|
||||
(let ((participants (tp--transaction-validate-structured-participants)))
|
||||
(dotimes (index (length participants))
|
||||
(let ((participant (aref participants index)))
|
||||
(when (eq (tp--transaction-participant-state participant) 'staged)
|
||||
(setf (tp--transaction-participant-state participant) 'committed)
|
||||
(when-let* ((function
|
||||
(tp--transaction-participant-after-commit participant)))
|
||||
(tp--enqueue-after-commit function)))))))
|
||||
|
||||
(defun tp--dequeue-dirty-binding ()
|
||||
"Return and remove the next queued dirty binding."
|
||||
(let (binding)
|
||||
@ -875,6 +942,26 @@ participant's opaque owner-local state."
|
||||
(_ (signal 'tp-transaction-contract-error
|
||||
(list :artifact-mode tp--transaction-artifact-mode)))))
|
||||
|
||||
(defun tp--transaction-validate-execution-route (route)
|
||||
"Return supported execution ROUTE or signal before transaction mutation."
|
||||
(unless (memq route '(structured v1))
|
||||
(signal 'tp-transaction-contract-error (list :execution-route route)))
|
||||
route)
|
||||
|
||||
(defun tp--transaction-current-execution-route ()
|
||||
"Return the validated route frozen at outer transaction entry."
|
||||
(tp--transaction-validate-execution-route
|
||||
tp--transaction-frozen-execution-route))
|
||||
|
||||
(defun tp--transaction-structured-route-p ()
|
||||
"Return non-nil when the frozen live route is `structured'."
|
||||
(eq (tp--transaction-current-execution-route) 'structured))
|
||||
|
||||
(defun tp--transaction-publication-candidate-enabled-p ()
|
||||
"Return non-nil when this transaction must build a publication candidate."
|
||||
(or (tp--transaction-structured-route-p)
|
||||
(tp--transaction-v2-artifacts-enabled-p)))
|
||||
|
||||
(defun tp--transaction-current-outcome-cell ()
|
||||
"Return the active transaction's caller-retainable one-slot outcome cell."
|
||||
(unless tp--transaction-active
|
||||
@ -913,22 +1000,23 @@ participant's opaque owner-local state."
|
||||
surface-journals))
|
||||
|
||||
(defun tp--transaction-begin-publication-batch
|
||||
(batch-id entries surface-journals)
|
||||
"Install BATCH-ID as the candidate for ENTRIES and SURFACE-JOURNALS."
|
||||
(batch-id entries surface-journals stage-entries)
|
||||
"Install BATCH-ID for ENTRIES, SURFACE-JOURNALS, and STAGE-ENTRIES."
|
||||
(unless tp--transaction-active
|
||||
(signal 'tp-reactive-error (list :batch-outside-transaction batch-id)))
|
||||
(when tp--transaction-publication-batch
|
||||
(signal 'tp-publication-state-error
|
||||
(list :duplicate-transaction-batch batch-id)))
|
||||
(when (tp--transaction-v2-artifacts-enabled-p)
|
||||
(when (tp--transaction-publication-candidate-enabled-p)
|
||||
(setq tp--transaction-publication-batch
|
||||
(tp--publication-batch-prepare
|
||||
:transaction-id tp--transaction-id
|
||||
:batch-id batch-id
|
||||
:entries entries
|
||||
:participants
|
||||
(vconcat (tp--transaction-participants-in-registration-order))
|
||||
tp--transaction-structured-participants
|
||||
:journals (tp--transaction-batch-journal-view surface-journals)
|
||||
:stage-entries stage-entries
|
||||
:final-accept tp--transaction-final-accept-function
|
||||
:diagnostics nil)))
|
||||
tp--transaction-publication-batch)
|
||||
@ -1146,7 +1234,18 @@ through TP's closed marker-operation whitelist."
|
||||
(unwind-protect
|
||||
(progn
|
||||
(tp--transaction-apply-final-markers)
|
||||
(funcall tp--transaction-final-accept-function)
|
||||
(if (and (tp--transaction-structured-route-p)
|
||||
tp--transaction-publication-batch)
|
||||
(let ((candidate-function
|
||||
(tp-publication-batch-candidate-final-accept
|
||||
tp--transaction-publication-batch)))
|
||||
(unless (eq candidate-function
|
||||
tp--transaction-final-accept-function)
|
||||
(signal 'tp-publication-binding-error
|
||||
(list :final-accept candidate-function
|
||||
tp--transaction-final-accept-function)))
|
||||
(funcall candidate-function))
|
||||
(funcall tp--transaction-final-accept-function))
|
||||
(setq accepted t))
|
||||
(unless accepted
|
||||
(setq tp--transaction-marker-restore-failures
|
||||
@ -1168,7 +1267,7 @@ through TP's closed marker-operation whitelist."
|
||||
(tp--transaction-publish-outcome outcome))))))
|
||||
|
||||
(defun tp--transaction-run-shadow-proof (phase)
|
||||
"Compare v2 artifacts with the single v1 live result for PHASE."
|
||||
"Compare structured artifacts with the selected single live result for PHASE."
|
||||
(when (and tp--transaction-publication-batch
|
||||
(tp--transaction-v2-artifacts-enabled-p))
|
||||
(let ((ok t) results outcome-equivalent)
|
||||
@ -1407,7 +1506,10 @@ the primary condition data."
|
||||
"Call FUNCTION in one atomic signal and binding transaction."
|
||||
(if tp--transaction-active
|
||||
(funcall function)
|
||||
(let (after-commit result
|
||||
(let ((frozen-route
|
||||
(tp--transaction-validate-execution-route
|
||||
tp-transaction-execution-route))
|
||||
after-commit result
|
||||
(tp--transaction-contained-failures nil))
|
||||
(setq tp--last-transaction-outcome nil
|
||||
tp--last-shadow-proof nil)
|
||||
@ -1435,6 +1537,8 @@ the primary condition data."
|
||||
(tp--transaction-published-participants nil)
|
||||
(tp--transaction-signal-commit-journal nil)
|
||||
(tp--transaction-publication-batch nil)
|
||||
(tp--transaction-structured-participants nil)
|
||||
(tp--transaction-frozen-execution-route frozen-route)
|
||||
(tp--transaction-final-marker-registry
|
||||
(make-vector tp--final-marker-max-count nil))
|
||||
(tp--transaction-final-marker-owner-keys
|
||||
@ -1460,13 +1564,21 @@ the primary condition data."
|
||||
(tp--transaction-enter-phase 'recompute)
|
||||
(tp--flush-dirty-bindings)
|
||||
(tp--transaction-enter-phase 'publication)
|
||||
(tp--transaction-current-execution-route)
|
||||
(setq tp--transaction-structured-participants
|
||||
(vconcat
|
||||
(tp--transaction-participants-in-registration-order)))
|
||||
(run-hooks 'tp--transaction-publish-functions)
|
||||
(tp--transaction-batch-transition 'participants)
|
||||
(tp--transaction-enter-phase 'participants)
|
||||
(tp--publish-transaction-participants)
|
||||
(if (tp--transaction-structured-route-p)
|
||||
(tp--stage-structured-transaction-participants)
|
||||
(tp--publish-transaction-participants))
|
||||
(tp--transaction-batch-transition 'precommit)
|
||||
(tp--transaction-enter-phase 'precommit)
|
||||
(tp--run-transaction-participant-precommits)
|
||||
(if (tp--transaction-structured-route-p)
|
||||
(tp--run-structured-transaction-participant-precommits)
|
||||
(tp--run-transaction-participant-precommits))
|
||||
(tp--run-transaction-precommit-functions)
|
||||
(tp--transaction-freeze-final-markers)
|
||||
(tp--transaction-sync-publication-batch)
|
||||
@ -1491,7 +1603,9 @@ the primary condition data."
|
||||
tp--transaction-final-accept-function)))
|
||||
(tp--transaction-run-final-accept)
|
||||
(setq success t)
|
||||
(tp--commit-transaction-participants)
|
||||
(if (tp--transaction-structured-route-p)
|
||||
(tp--commit-structured-transaction-participants)
|
||||
(tp--commit-transaction-participants))
|
||||
(tp--transaction-run-shadow-proof 'commit)
|
||||
(when quit-flag
|
||||
(setq pending-quit t
|
||||
|
||||
@ -3500,9 +3500,9 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
|
||||
:output (tp--shadow-surface-output surface)))
|
||||
|
||||
(defun tp--surface-shadow-target-entry
|
||||
(prepared snapshot journals views batch-id)
|
||||
(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 existing v1 rollback state."
|
||||
JOURNALS and VIEWS are exact references to the shared rollback state."
|
||||
(let* ((prepared (tp--assign-prepared-mount-ids prepared))
|
||||
(surface (tp--prepared-surface-surface prepared))
|
||||
(buffer (tp--surface-buffer surface))
|
||||
@ -3561,7 +3561,7 @@ JOURNALS and VIEWS are exact references to the existing v1 rollback state."
|
||||
:client-state (tp--prepared-surface-client-state prepared)
|
||||
:rollback-snapshot (vector prepared snapshot journals views)
|
||||
:authority-token (make-symbol "tp-publication-entry-authority")
|
||||
:mapping-generation tp--surface-transaction-id
|
||||
:mapping-generation mapping-generation
|
||||
:shadow-expected expected
|
||||
:shadow-validator
|
||||
(lambda (_entry phase)
|
||||
@ -3575,7 +3575,7 @@ JOURNALS and VIEWS are exact references to the existing v1 rollback state."
|
||||
:expected target :actual actual))))))
|
||||
|
||||
(defun tp--surface-shadow-target-entries
|
||||
(prepared snapshots journals views batch-id)
|
||||
(prepared snapshots journals views batch-id mapping-generation)
|
||||
"Return BATCH-ID entries for PREPARED using SNAPSHOTS, JOURNALS, and VIEWS."
|
||||
(mapcar
|
||||
(lambda (candidate)
|
||||
@ -3583,11 +3583,71 @@ JOURNALS and VIEWS are exact references to the existing v1 rollback state."
|
||||
(unless snapshot
|
||||
(signal 'tp-surface-error (list :missing-shadow-snapshot candidate)))
|
||||
(tp--surface-shadow-target-entry
|
||||
candidate snapshot journals views batch-id)))
|
||||
candidate snapshot journals views batch-id mapping-generation)))
|
||||
prepared))
|
||||
|
||||
(defun tp--surface-validate-publication-entry (candidate entry)
|
||||
"Return ENTRY's exact prepared binding after validating CANDIDATE authority."
|
||||
(let* ((rollback (tp-publication-target-entry-rollback-snapshot entry))
|
||||
(prepared (and (vectorp rollback) (= (length rollback) 4)
|
||||
(aref rollback 0)))
|
||||
(snapshot (and prepared (aref rollback 1)))
|
||||
(surface (and (tp--prepared-surface-p prepared)
|
||||
(tp--prepared-surface-surface prepared))))
|
||||
(unless
|
||||
(and surface snapshot
|
||||
(tp--publication-target-entry-bound-p
|
||||
entry
|
||||
(tp-publication-batch-candidate-transaction-id candidate)
|
||||
(tp-publication-batch-candidate-id candidate))
|
||||
(equal (tp-publication-target-entry-surface-id entry)
|
||||
(tp--surface-id surface))
|
||||
(eq (tp-publication-target-entry-buffer entry)
|
||||
(tp--surface-buffer surface))
|
||||
(= (tp-publication-target-entry-old-revision entry)
|
||||
(tp--surface-snapshot-revision snapshot))
|
||||
(= (tp-publication-target-entry-new-revision entry)
|
||||
(1+ (tp--surface-snapshot-revision snapshot)))
|
||||
(eq (tp-publication-target-entry-plan entry)
|
||||
(tp--prepared-surface-plan prepared))
|
||||
(eq (tp-publication-target-entry-ledger entry)
|
||||
(tp--prepared-surface-ledger-specs prepared))
|
||||
(eq (tp-publication-target-entry-objects entry)
|
||||
(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))
|
||||
(= (tp-publication-target-entry-mapping-generation entry)
|
||||
tp--surface-transaction-id))
|
||||
(signal 'tp-publication-binding-error
|
||||
(list :prepared-entry entry prepared)))
|
||||
prepared))
|
||||
|
||||
(defun tp--surface-stage-publication-entries (candidate)
|
||||
"Publish exactly CANDIDATE's entry-bound prepared surfaces once each."
|
||||
(let ((generation
|
||||
(tp-publication-target-entry-mapping-generation
|
||||
(car (tp-publication-batch-candidate-entries candidate)))))
|
||||
(unless (= generation (1+ tp--surface-transaction-id))
|
||||
(signal 'tp-publication-binding-error
|
||||
(list :mapping-generation generation
|
||||
tp--surface-transaction-id)))
|
||||
(setq tp--surface-transaction-id generation))
|
||||
(dolist (entry (tp-publication-batch-candidate-entries candidate))
|
||||
(let ((prepared (tp--surface-validate-publication-entry candidate entry)))
|
||||
(tp--publish-one-surface prepared)
|
||||
(tp--surface-record-publication-operation-counts prepared))))
|
||||
|
||||
(defun tp--surface-stage-v1-prepared (prepared next-generation)
|
||||
"Publish legacy PREPARED list after exposing NEXT-GENERATION."
|
||||
(setq tp--surface-transaction-id next-generation)
|
||||
(dolist (candidate prepared)
|
||||
(tp--publish-one-surface candidate)
|
||||
(tp--surface-record-publication-operation-counts candidate)))
|
||||
|
||||
(defun tp--surface-record-publication-operation-counts (prepared)
|
||||
"Record PREPARED's actual v1 report counts into its exact batch entry."
|
||||
"Record PREPARED's actual live report counts into its exact batch entry."
|
||||
(when tp--transaction-publication-batch
|
||||
(let* ((surface (tp--prepared-surface-surface prepared))
|
||||
(entry
|
||||
@ -3620,7 +3680,8 @@ JOURNALS and VIEWS are exact references to the existing v1 rollback state."
|
||||
(let* ((buffers (tp--prepared-buffers prepared))
|
||||
(journals (tp--capture-property-journals prepared))
|
||||
(views (tp--capture-view-state buffers))
|
||||
snapshots group)
|
||||
snapshots group
|
||||
(next-generation (1+ tp--surface-transaction-id)))
|
||||
(puthash 'changed prepared state)
|
||||
(puthash 'journals journals state)
|
||||
(puthash 'views views state)
|
||||
@ -3630,19 +3691,20 @@ JOURNALS and VIEWS are exact references to the existing v1 rollback state."
|
||||
(puthash 'change-group group state)
|
||||
(puthash 'surface-transaction-id-before
|
||||
tp--surface-transaction-id state)
|
||||
(cl-incf tp--surface-transaction-id)
|
||||
(when (tp--transaction-v2-artifacts-enabled-p)
|
||||
(when (tp--transaction-publication-candidate-enabled-p)
|
||||
(let* ((batch-id (tp--next-publication-batch-id))
|
||||
(entries
|
||||
(tp--surface-shadow-target-entries
|
||||
prepared snapshots journals views batch-id)))
|
||||
prepared snapshots journals views batch-id
|
||||
next-generation)))
|
||||
(tp--transaction-begin-publication-batch
|
||||
batch-id entries state)
|
||||
batch-id entries state 'tp--surface-stage-publication-entries)
|
||||
(tp--transaction-batch-transition 'staged)))
|
||||
(let ((tp--surface-publishing t))
|
||||
(dolist (candidate prepared)
|
||||
(tp--publish-one-surface candidate)
|
||||
(tp--surface-record-publication-operation-counts candidate)))))))
|
||||
(if (tp--transaction-structured-route-p)
|
||||
(tp--publication-batch-execute-stage
|
||||
tp--transaction-publication-batch)
|
||||
(tp--surface-stage-v1-prepared prepared next-generation)))))))
|
||||
|
||||
(defun tp--surface-precommit-step (step state)
|
||||
"Report precommit STEP for transaction STATE."
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
;;; tp-transaction.el --- Additive publication transaction contracts -*- lexical-binding: t; -*-
|
||||
;;; tp-transaction.el --- Structured publication transaction contracts -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Geekinney
|
||||
|
||||
@ -11,10 +11,12 @@
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Internal immutable artifacts and one-shot state machines used to shadow TP's
|
||||
;; v1 publication coordinator. This module owns no live writer and never edits
|
||||
;; a buffer. `tp-reactive' drives the state machine, while `tp-surface' supplies
|
||||
;; exact target entries backed by the v1 prepare journals and snapshots.
|
||||
;; Internal immutable artifacts and one-shot state machines for TP publication.
|
||||
;; The default structured route executes the package-owned entry-stage
|
||||
;; capability stored in a batch candidate; the retained v1 route bypasses that
|
||||
;; capability. This module never edits a buffer itself: `tp-reactive' drives
|
||||
;; the state machine and `tp-surface' supplies and stages exact target entries
|
||||
;; backed by the shared prepare journals and snapshots.
|
||||
|
||||
;;; Code:
|
||||
|
||||
@ -48,6 +50,10 @@
|
||||
'(committed rolled-back discarded)
|
||||
"Terminal publication batch candidate states.")
|
||||
|
||||
(defconst tp--publication-batch-stage-entry-functions
|
||||
'(tp--surface-stage-publication-entries)
|
||||
"Closed package-owned publication entry stage capabilities.")
|
||||
|
||||
(defconst tp--final-marker-max-count 8
|
||||
"Maximum number of opaque final markers in one transaction.")
|
||||
|
||||
@ -119,7 +125,7 @@
|
||||
CANDIDATE-ID, SURFACE-ID, MOUNT-IDS, BUFFER, OLD-REVISION, NEW-REVISION, PLAN,
|
||||
DIFF, LEDGER, OBJECTS, RANGES, CLIENT-STATE, ROLLBACK-SNAPSHOT, and
|
||||
AUTHORITY-TOKEN describe the target. MAPPING-GENERATION is optional.
|
||||
OPERATION-COUNTS is filled from the v1 report. SHADOW-EXPECTED and
|
||||
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)
|
||||
@ -222,7 +228,7 @@ SHADOW-VALIDATOR are private comparison artifacts."
|
||||
(cl-defstruct (tp-publication-batch-candidate
|
||||
(:constructor tp--make-publication-batch-candidate)
|
||||
(:copier nil))
|
||||
"A one-shot structured view over the existing v1 transaction state."
|
||||
"A one-shot structured publication authority over shared rollback state."
|
||||
(transaction-id nil :read-only t)
|
||||
(id nil :read-only t)
|
||||
state
|
||||
@ -230,6 +236,7 @@ SHADOW-VALIDATOR are private comparison artifacts."
|
||||
(entries nil :read-only t)
|
||||
(participants nil :read-only t)
|
||||
(journals nil :read-only t)
|
||||
(stage-entries nil :read-only t)
|
||||
final-accept
|
||||
(final-accept-id nil :read-only t)
|
||||
diagnostics
|
||||
@ -271,16 +278,22 @@ SHADOW-VALIDATOR are private comparison artifacts."
|
||||
entries))))
|
||||
|
||||
(cl-defun tp--publication-batch-prepare
|
||||
(&key transaction-id batch-id entries participants journals final-accept
|
||||
diagnostics)
|
||||
(&key transaction-id batch-id entries participants journals stage-entries
|
||||
final-accept diagnostics)
|
||||
"Prepare TRANSACTION-ID and BATCH-ID over exact ENTRIES.
|
||||
PARTICIPANTS is an ordered reference vector, JOURNALS is the existing v1 state
|
||||
view, FINAL-ACCEPT is the single coordinator function, and DIAGNOSTICS contains
|
||||
known preaccept observations."
|
||||
PARTICIPANTS is an ordered reference vector, JOURNALS is the shared rollback
|
||||
view, STAGE-ENTRIES is an optional package-owned execution capability,
|
||||
FINAL-ACCEPT is the single coordinator function, and DIAGNOSTICS contains known
|
||||
preaccept observations."
|
||||
(unless (and transaction-id batch-id
|
||||
(tp--publication-batch-entries-valid-p
|
||||
entries transaction-id batch-id)
|
||||
(vectorp participants)
|
||||
(or (null stage-entries)
|
||||
(and (symbolp stage-entries)
|
||||
(memq stage-entries
|
||||
tp--publication-batch-stage-entry-functions)
|
||||
(fboundp stage-entries)))
|
||||
(functionp final-accept))
|
||||
(signal 'tp-publication-binding-error
|
||||
(list :batch transaction-id batch-id entries participants)))
|
||||
@ -291,10 +304,21 @@ known preaccept observations."
|
||||
:entries (copy-sequence entries)
|
||||
:participants participants
|
||||
:journals journals
|
||||
:stage-entries stage-entries
|
||||
:final-accept final-accept
|
||||
:final-accept-id (tp--next-final-accept-id)
|
||||
:diagnostics (tp--copy-property-value diagnostics)))
|
||||
|
||||
(defun tp--publication-batch-execute-stage (candidate)
|
||||
"Execute CANDIDATE's package-owned entry stage capability exactly once."
|
||||
(unless (and (tp-publication-batch-candidate-p candidate)
|
||||
(eq (tp-publication-batch-candidate-state candidate) 'staged)
|
||||
(memq (tp-publication-batch-candidate-stage-entries candidate)
|
||||
tp--publication-batch-stage-entry-functions))
|
||||
(signal 'tp-publication-state-error
|
||||
(list :batch-stage candidate)))
|
||||
(funcall (tp-publication-batch-candidate-stage-entries candidate) candidate))
|
||||
|
||||
(defun tp--publication-batch-terminal-p (candidate)
|
||||
"Return non-nil when CANDIDATE has one terminal disposition."
|
||||
(and (tp-publication-batch-candidate-p candidate)
|
||||
|
||||
11
tp.el
11
tp.el
@ -69,8 +69,15 @@
|
||||
`(:package tp :version "1.0.1"
|
||||
:transaction-protocol ,tp-transaction-protocol
|
||||
:batch-artifacts t
|
||||
:batch-execution v1-bridge
|
||||
:batch-execute nil
|
||||
:execution-route structured
|
||||
:execution-default structured
|
||||
:execution-routes (structured v1)
|
||||
:route-option tp-transaction-execution-route
|
||||
:batch-execution structured
|
||||
:batch-execute t
|
||||
:v1-adapter t
|
||||
:v1-rollback-route t
|
||||
:single-live-writer t
|
||||
:shadow-proof t
|
||||
:final-marker-operation tp-vector-slots/v1)
|
||||
"Immutable package capability facts for cross-package compatibility checks.")
|
||||
|
||||
Loading…
Reference in New Issue
Block a user