From 5a9f3f409d75a643c44eff950d49a8e53b5d1afe Mon Sep 17 00:00:00 2001 From: Kinneyzhang Date: Tue, 8 Sep 2026 21:33:14 +0800 Subject: [PATCH] feat: add opt-in commit-certified SQLite mutations --- README.md | 7 +- README.zh-CN.md | 4 + etaf-sqlite.el | 155 +++++++++++++++++++++++++++++++------ tests/etaf-sqlite-tests.el | 112 +++++++++++++++++++++++++++ 4 files changed, 253 insertions(+), 25 deletions(-) diff --git a/README.md b/README.md index 94a6378..55f4640 100644 --- a/README.md +++ b/README.md @@ -13,9 +13,14 @@ (database (etaf-sqlite-database "~/items.sqlite" table)) (source (etaf-sqlite-source database))) (etaf-sqlite-initialize database) - (etaf-data-controller source :auto-load t)) +(etaf-data-controller source :auto-load t)) ``` +The source keeps the legacy `:mutate` callback by default. The additive +commit-certified wrapper is opt-in: use `(etaf-sqlite-source database +:mutate-v2 t)` when a controller needs explicit commit/rollback certainty and +read-only reconciliation. + Other databases, REST services, files, and ORMs should implement the same source capability in their own packages; they do not belong in ETAF core or in a generic `etaf-adapters` layer. Run `make check EMACS=/Applications/Emacs.app/Contents/MacOS/Emacs` from this directory. diff --git a/README.zh-CN.md b/README.zh-CN.md index b8635ad..0a5c6a5 100644 --- a/README.zh-CN.md +++ b/README.zh-CN.md @@ -16,6 +16,10 @@ (etaf-data-controller source :auto-load t)) ``` +默认 source 仍只暴露兼容的 `:mutate` callback。需要明确的提交/回滚确定性 +和只读 reconciliation 时，显式使用 `(etaf-sqlite-source database +:mutate-v2 t)` 开启增量 wrapper。 + 其他数据库、REST、文件和 ORM 应在各自的具体数据源包中实现同一个 source capability；它们不进入 ETAF core，也不创建笼统的 `etaf-adapters` 层。 在该目录运行 `make check EMACS=/Applications/Emacs.app/Contents/MacOS/Emacs`。 diff --git a/etaf-sqlite.el b/etaf-sqlite.el index 89ef862..fe85908 100644 --- a/etaf-sqlite.el +++ b/etaf-sqlite.el @@ -25,6 +25,19 @@ 'etaf-sqlite-error) (define-error 'etaf-sqlite-unavailable "SQLite is unavailable" 'etaf-sqlite-error) +(define-error 'etaf-sqlite-commit-unknown + "SQLite commit outcome is unknown" + 'etaf-sqlite-error) + +;; Opaque tokens let Data reconcile a committed external mutation without +;; coupling itself to SQLite connection or transaction objects. +(defvar etaf-sqlite--reconciliation-sequence 0) +(defvar etaf-sqlite--mutation-active nil) +(defvar etaf-sqlite--mutation-phase nil) + +(defun etaf-sqlite--reconciliation-token () + "Return a fresh opaque token for one SQLite mutation outcome." + (list :etaf-sqlite (cl-incf etaf-sqlite--reconciliation-sequence))) (cl-defstruct (etaf-sqlite--column (:constructor etaf-sqlite--column-create)) @@ -143,7 +156,12 @@ validated once and never comes from a runtime query." (signal 'etaf-sqlite-unavailable nil))) (defun etaf-sqlite--call (database function) - "Call FUNCTION with a short-lived connection for DATABASE." + "Call FUNCTION with a short-lived connection for DATABASE. + +Keep a cleanup failure after a successful mutation conservative: the write may +already have committed even though closing the connection signalled. When the +body already failed, preserve that primary condition so transaction certainty +is determined by the transaction phase rather than by cleanup noise." (etaf-sqlite--require-available) (let* ((file (etaf-sqlite--database-file database)) (directory (file-name-directory file)) @@ -151,20 +169,67 @@ validated once and never comes from a runtime query." (when directory (make-directory directory t)) (setq connection (sqlite-open file)) - (unwind-protect - (funcall function connection) - (when (sqlitep connection) - (sqlite-close connection))))) + (let (result body-condition close-condition) + ;; Keep the connection cleanup on all non-local exits, including a + ;; caller's `throw'. Error and quit conditions are captured so cleanup + ;; failures can be classified without masking the primary condition. + (unwind-protect + (condition-case err + (setq result (funcall function connection)) + ((error quit) + (setq body-condition err))) + (when (sqlitep connection) + (condition-case err + (sqlite-close connection) + ((error quit) + (setq close-condition err)))) + ) + (when (and close-condition + etaf-sqlite--mutation-active + (memq etaf-sqlite--mutation-phase '(committed committing)) + (not (and body-condition + (eq (car body-condition) + 'etaf-sqlite-commit-unknown)))) + (setq body-condition + (list 'etaf-sqlite-commit-unknown + (list :failure-phase 'close :error close-condition)))) + (when (and close-condition (not body-condition)) + (setq body-condition close-condition)) + (if body-condition + (signal (car body-condition) (cdr body-condition)) + result)))) (defun etaf-sqlite--transaction (connection function) "Run FUNCTION in a transaction on CONNECTION and return its value." (sqlite-transaction connection) - (condition-case err - (prog1 (funcall function connection) - (sqlite-commit connection)) - (error - (sqlite-rollback connection) - (signal (car err) (cdr err))))) + (let ((value + (condition-case body-err + (funcall function connection) + ((error quit) + (setq etaf-sqlite--mutation-phase 'rolling-back) + (let ((rollback-err + (condition-case rollback-condition + (progn (sqlite-rollback connection) nil) + ((error quit) rollback-condition)))) + (if rollback-err + (progn + (setq etaf-sqlite--mutation-phase 'unknown) + (signal 'etaf-sqlite-commit-unknown + (list :failure-phase 'rollback + :error body-err + :rollback-error rollback-err))) + (setq etaf-sqlite--mutation-phase 'rolled-back) + (signal (car body-err) (cdr body-err)))))))) + (condition-case commit-err + (progn + (setq etaf-sqlite--mutation-phase 'committing) + (sqlite-commit connection) + (setq etaf-sqlite--mutation-phase 'committed) + value) + ((error quit) + (setq etaf-sqlite--mutation-phase 'unknown) + (signal 'etaf-sqlite-commit-unknown + (list :failure-phase 'commit :error commit-err)))))) (defun etaf-sqlite--sql-type (type) "Return SQLite DDL type for TYPE." @@ -319,9 +384,11 @@ exposing the inserted identity and affected row count to application code." (unless primary (signal 'etaf-sqlite-schema-error (list "Mutations require a primary key"))) - (etaf-sqlite--call - database - (lambda (connection) + (let ((etaf-sqlite--mutation-active t) + (etaf-sqlite--mutation-phase 'body)) + (etaf-sqlite--call + database + (lambda (connection) (etaf-sqlite--transaction connection (lambda (transaction-connection) @@ -405,27 +472,67 @@ exposing the inserted identity and affected row count to application code." (list (format "Unsupported SQLite mutation: %S" operation))))))) (etaf-sqlite--mutation-result - transaction-connection operation value)))))))) + transaction-connection operation value))))))))) + +(defun etaf-sqlite--mutate-v2 (database operation payload) + "Return a commit-certified outcome for DATABASE mutation OPERATION and PAYLOAD. + +This optional capability deliberately does not replace the v1 `:mutate' +callback. Successful transactions return `:certainty committed' and a +reconciliation token. A body failure is `:certainty rolled-back' only when +rollback succeeds; commit, rollback, or close uncertainty is returned as +`:certainty external-unknown' with the original condition in `:error'." + (let ((token (etaf-sqlite--reconciliation-token))) + (condition-case err + (let ((result (etaf-sqlite--mutate database operation payload))) + (list :certainty 'committed + :external-commit-certainty 'committed + :operation operation + :result result + :mutation-result result + :reconciliation-token token)) + ((error quit) + (list :certainty (if (eq (car err) 'etaf-sqlite-commit-unknown) + 'external-unknown + 'rolled-back) + :external-commit-certainty + (if (eq (car err) 'etaf-sqlite-commit-unknown) + 'external-unknown + 'rolled-back) + :operation operation + :error err + :reconciliation-token token))))) ;;;###autoload -(defun etaf-sqlite-source (database) +(cl-defun etaf-sqlite-source (database &key mutate-v2) "Return an `etaf-data-source' backed by DATABASE. The source accepts equality plist/alist queries and supports `insert', `replace', `update', and `delete' mutations. Mutation results include the operation, affected row count, and inserted identity when applicable. Every operation uses a short connection; controllers remain the owner of reactive -state and lifecycle." +state and lifecycle. The legacy `:mutate' capability is exposed by default. +When MUTATE-V2 is non-nil, add the opt-in `:mutate-v2' capability that returns +explicit commit/rollback certainty and an opaque reconciliation token." (unless (etaf-sqlite--database-p database) (signal 'wrong-type-argument (list 'etaf-sqlite-database-p database))) - (etaf-data-source - :name 'etaf-sqlite - :provider 'sqlite - :load (lambda (query page page-size) - (etaf-sqlite--select-items database query page page-size)) - :mutate (lambda (operation payload) - (etaf-sqlite--mutate database operation payload)))) + (let ((capabilities + (list :name 'etaf-sqlite + :provider 'sqlite + :load (lambda (query page page-size) + (etaf-sqlite--select-items database query page page-size)) + :mutate (lambda (operation payload) + (etaf-sqlite--mutate database operation payload))))) + ;; Keep the typed wrapper opt-in. The M4a additive path must not silently + ;; change existing SQLite controllers from the v1 callback contract. + (when mutate-v2 + (setq capabilities + (append capabilities + (list :mutate-v2 + (lambda (operation payload) + (etaf-sqlite--mutate-v2 database operation payload)))))) + (apply #'etaf-data-source capabilities))) (provide 'etaf-sqlite) diff --git a/tests/etaf-sqlite-tests.el b/tests/etaf-sqlite-tests.el index f7c251a..577033e 100644 --- a/tests/etaf-sqlite-tests.el +++ b/tests/etaf-sqlite-tests.el @@ -88,8 +88,120 @@ (should (eq 'sqlite (plist-get source :provider))) (should (functionp (plist-get source :load))) (should (functionp (plist-get source :mutate))) + (should-not (plist-member source :mutate-v2)) + (should (functionp + (plist-get (etaf-sqlite-source database :mutate-v2 t) + :mutate-v2))) (should-not (plist-member source :dispose))))) +(ert-deftest etaf-sqlite-v2-mutation-outcome-reports-commit () + "The optional v2 capability reports a committed transaction and token." + (etaf-sqlite-test--with-database (database) + (let* ((source (etaf-sqlite-source database :mutate-v2 t)) + (mutate-v2 (plist-get source :mutate-v2)) + (outcome (funcall mutate-v2 'insert + '(:id 3 :name "Alan" :score 30)))) + (should (eq (plist-get outcome :certainty) 'committed)) + (should (plist-get outcome :reconciliation-token)) + (should (equal (plist-get (plist-get outcome :result) :operation) + 'insert)) + (should (= (plist-get (plist-get outcome :result) :id) 3))))) + +(ert-deftest etaf-sqlite-v2-mutation-outcome-reports-rollback () + "A failed v2 mutation reports rollback and preserves the original error." + (etaf-sqlite-test--with-database (database) + (let* ((source (etaf-sqlite-source database :mutate-v2 t)) + (mutate-v2 (plist-get source :mutate-v2)) + (outcome (funcall mutate-v2 'insert + '(:id 1 :name "Duplicate" :score 99))) + (loaded (funcall (plist-get source :load) nil 1 20))) + (should (eq (plist-get outcome :certainty) 'rolled-back)) + (should (consp (plist-get outcome :error))) + (should (plist-get outcome :reconciliation-token)) + (should (= (plist-get loaded :total) 2))))) + +(ert-deftest etaf-sqlite-committed-mutation-load-failure-is-read-only-retry () + "A committed SQLite row survives a failed projection read and retries safely." + (etaf-sqlite-test--with-database (database) + (let* ((base (etaf-sqlite-source database :mutate-v2 t)) + (base-load (plist-get base :load)) + (base-mutate-v2 (plist-get base :mutate-v2)) + (load-count 0) + (mutate-count 0) + (fail-load t) + (source (copy-sequence base))) + (setf (plist-get source :load) + (lambda (&rest args) + (cl-incf load-count) + (if fail-load + (error "injected reconciliation read failure") + (apply base-load args)))) + (setf (plist-get source :mutate-v2) + (lambda (operation payload) + (cl-incf mutate-count) + (funcall base-mutate-v2 operation payload))) + (let* ((initial (funcall base-load nil 1 20)) + (controller (etaf-data-controller source :initial-result initial)) + captured) + (unwind-protect + (progn + (condition-case condition + (etaf-data-mutate + controller 'insert '(:id 3 :name "Alan" :score 30)) + (error (setq captured condition))) + (should captured) + (should (etaf-data-condition-projection-info captured)) + (should (= mutate-count 1)) + (should (= load-count 1)) + (should (equal '(1 2) + (mapcar (lambda (row) (plist-get row :id)) + (etaf-value (etaf-data-items controller))))) + (should (= 3 + (plist-get (funcall base-load nil 1 20) :total))) + (setq fail-load nil) + (etaf-data-retry-reconciliation controller) + (should (= mutate-count 1)) + (should (= load-count 2)) + (should (eq 'success (etaf-value (etaf-data-status controller)))) + (should (equal '(1 2 3) + (mapcar (lambda (row) (plist-get row :id)) + (etaf-value (etaf-data-items controller))))) + (should (eq 'projected + (etaf-data-reconciliation-state controller)))) + (etaf-data-stop controller)))))) + +(ert-deftest etaf-sqlite-v2-post-commit-signal-reports-unknown () + "A signal after sqlite-commit must not claim the committed write rolled back." + (etaf-sqlite-test--with-database (database) + (let* ((source (etaf-sqlite-source database :mutate-v2 t)) + (mutate-v2 (plist-get source :mutate-v2)) + (original-commit (symbol-function 'sqlite-commit)) + (outcome + (cl-letf (((symbol-function 'sqlite-commit) + (lambda (connection) + (funcall original-commit connection) + (error "post-commit fault")))) + (funcall mutate-v2 'insert + '(:id 3 :name "Committed" :score 30)))) + (loaded (funcall (plist-get source :load) nil 1 20))) + (should (eq (plist-get outcome :certainty) 'external-unknown)) + (should (= (plist-get loaded :total) 3))))) + +(ert-deftest etaf-sqlite-v2-close-after-commit-reports-unknown () + "A close signal after commit is also external uncertainty." + (etaf-sqlite-test--with-database (database) + (let* ((source (etaf-sqlite-source database :mutate-v2 t)) + (mutate-v2 (plist-get source :mutate-v2)) + (original-close (symbol-function 'sqlite-close)) + (outcome + (cl-letf (((symbol-function 'sqlite-close) + (lambda (connection) + (funcall original-close connection) + (error "post-commit close fault")))) + (funcall mutate-v2 'insert + '(:id 3 :name "Committed" :score 30))))) + (should (eq (plist-get outcome :certainty) 'external-unknown))))) + (provide 'etaf-sqlite-tests) ;;; etaf-sqlite-tests.el ends here