commit 299b9ff877eed4ffaca0420196195a08a67e10a1 Author: Kinneyzhang Date: Wed Aug 5 06:59:23 2026 +0800 feat(sqlite): add concrete data source Adapt Emacs SQLite to the core ETAF Data Source contract with typed schema validation, safe queries, transactions, pagination, mutations, tests, and bilingual usage documentation. diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..3daa17c --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +*.elc +tests/*.elc diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..7459e14 --- /dev/null +++ b/Makefile @@ -0,0 +1,28 @@ +EMACS ?= emacs +LOAD_PATH = -L . -L ../etaf -L ../emacs-box + +.PHONY: all compile test check checkdoc load clean + +all: check + +compile: + rm -f *.elc tests/*.elc + $(EMACS) -Q --batch $(LOAD_PATH) --eval '(setq load-prefer-newer t)' \ + --eval '(load-file "etaf-sqlite.el")' \ + --eval '(byte-compile-file "etaf-sqlite.el")' + +test: compile + $(EMACS) -Q --batch $(LOAD_PATH) --eval '(setq load-prefer-newer t)' \ + -l tests/etaf-sqlite-tests.el -f ert-run-tests-batch-and-exit + +load: compile + $(EMACS) -Q --batch $(LOAD_PATH) --eval '(require (quote etaf-sqlite))' \ + --eval '(princ "etaf-sqlite load OK\n")' + +checkdoc: + $(EMACS) -Q --batch --eval '(progn (require (quote checkdoc)) (dolist (file (directory-files "." t)) (when (string-suffix-p ".el" file) (checkdoc-file file))))' + +check: checkdoc compile test + +clean: + rm -f *.elc tests/*.elc diff --git a/README.md b/README.md new file mode 100644 index 0000000..94a6378 --- /dev/null +++ b/README.md @@ -0,0 +1,21 @@ +# etaf-sqlite + +`etaf-sqlite` is the concrete SQLite storage package for ETAF. It adapts Emacs' built-in SQLite support to the core `etaf-data-source` capability contract. The Data Controller remains in `etaf`; this package owns only schema validation, short-lived connections, pagination queries, and synchronous mutations. + +```elisp +(require 'etaf-sqlite) + +(let* ((table (etaf-sqlite-table + 'items + (list (etaf-sqlite-column :id "id" :type 'integer :primary t) + (etaf-sqlite-column :name "name" :type 'text)) + :id)) + (database (etaf-sqlite-database "~/items.sqlite" table)) + (source (etaf-sqlite-source database))) + (etaf-sqlite-initialize database) + (etaf-data-controller source :auto-load t)) +``` + +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 new file mode 100644 index 0000000..b8635ad --- /dev/null +++ b/README.zh-CN.md @@ -0,0 +1,21 @@ +# etaf-sqlite + +`etaf-sqlite` 是 ETAF 的具体 SQLite 存储包，把 Emacs 内置 SQLite 能力适配到核心 `etaf-data-source` 契约。Data Controller 仍属于 `etaf`；本包只负责 schema 校验、短连接、分页查询和同步 mutation。 + +```elisp +(require 'etaf-sqlite) + +(let* ((table (etaf-sqlite-table + 'items + (list (etaf-sqlite-column :id "id" :type 'integer :primary t) + (etaf-sqlite-column :name "name" :type 'text)) + :id)) + (database (etaf-sqlite-database "~/items.sqlite" table)) + (source (etaf-sqlite-source database))) + (etaf-sqlite-initialize database) + (etaf-data-controller source :auto-load t)) +``` + +其他数据库、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 new file mode 100644 index 0000000..4a07abd --- /dev/null +++ b/etaf-sqlite.el @@ -0,0 +1,415 @@ +;;; etaf-sqlite.el --- SQLite Data source for ETAF -*- lexical-binding: t; -*- + +;; SPDX-License-Identifier: GPL-3.0-or-later +;; Author: ETAF contributors +;; Version: 0.1.0 +;; Package-Requires: ((emacs "29.1") (etaf "0.1.0")) +;; URL: https://github.com/ginqi7/etaf-sqlite + +;;; Commentary: + +;; This package adapts Emacs' built-in SQLite API to the small capability +;; contract owned by `etaf-data'. It is intentionally a source adapter, not a +;; second Data controller and not a general ORM. Other storage systems can +;; implement the same `etaf-data-source' callbacks without changing ETAF. + +;;; Code: + +(require 'cl-lib) +(require 'subr-x) +(require 'sqlite) +(require 'etaf-data) + +(define-error 'etaf-sqlite-error "Invalid ETAF SQLite operation") +(define-error 'etaf-sqlite-schema-error "Invalid ETAF SQLite schema" + 'etaf-sqlite-error) +(define-error 'etaf-sqlite-unavailable "SQLite is unavailable" + 'etaf-sqlite-error) + +(cl-defstruct (etaf-sqlite--column + (:constructor etaf-sqlite--column-create)) + id sql-name type nullable primary) + +(cl-defstruct (etaf-sqlite--table + (:constructor etaf-sqlite--table-create)) + id columns primary-key index) + +(cl-defstruct (etaf-sqlite--database + (:constructor etaf-sqlite--database-create)) + file table) + +(defconst etaf-sqlite--types + '(integer real text blob any) + "Supported SQLite declaration types.") + +(defun etaf-sqlite--identifier-p (value) + "Return non-nil when VALUE is a safe unquoted SQL identifier." + (and (stringp value) + (string-match-p "\\`[A-Za-z_][A-Za-z0-9_]*\\'" value))) + +(defun etaf-sqlite--identifier (value kind) + "Return quoted SQL identifier VALUE for KIND or signal an error." + (unless (etaf-sqlite--identifier-p value) + (signal 'etaf-sqlite-schema-error + (list (format "Unsafe SQLite %s identifier: %S" kind value)))) + (format "\"%s\"" value)) + +(defun etaf-sqlite--physical-name (value kind) + "Return the SQL name for semantic VALUE of KIND." + (etaf-sqlite--identifier + (cond + ((stringp value) value) + ((symbolp value) (symbol-name value)) + (t (signal 'etaf-sqlite-schema-error + (list (format "SQLite %s must be a symbol or string: %S" + kind value))))) + kind)) + +(defun etaf-sqlite--scalar-id-p (value) + "Return non-nil when VALUE can identify a schema field." + (and value (or (symbolp value) (stringp value) (integerp value)))) + +;;;###autoload +(cl-defun etaf-sqlite-column + (id sql-name &key (type 'any) nullable primary) + "Declare a SQLite column with semantic ID and physical SQL-NAME. + +TYPE is one of `integer', `real', `text', `blob', or `any'. NULLABLE allows +SQL NULL values. PRIMARY marks the table identity column. SQL-NAME is +validated once and never comes from a runtime query." + (unless (etaf-sqlite--scalar-id-p id) + (signal 'etaf-sqlite-schema-error + (list (format "Column ID must be a stable scalar: %S" id)))) + (unless (etaf-sqlite--identifier-p sql-name) + (signal 'etaf-sqlite-schema-error + (list (format "Invalid SQLite column name: %S" sql-name)))) + (unless (memq type etaf-sqlite--types) + (signal 'etaf-sqlite-schema-error + (list (format "Unsupported SQLite column type: %S" type)))) + (etaf-sqlite--column-create + :id id :sql-name sql-name :type type + :nullable (and nullable t) :primary (and primary t))) + +(defun etaf-sqlite--column-index (columns) + "Return an equal-tested index for COLUMNS." + (unless (and (proper-list-p columns) columns) + (signal 'etaf-sqlite-schema-error + (list "SQLite table requires at least one column"))) + (let ((index (make-hash-table :test #'equal)) + (names (make-hash-table :test #'equal))) + (dolist (column columns index) + (unless (etaf-sqlite--column-p column) + (signal 'etaf-sqlite-schema-error (list "Invalid SQLite column"))) + (when (gethash (etaf-sqlite--column-id column) index) + (signal 'etaf-sqlite-schema-error + (list "Duplicate SQLite semantic column ID"))) + (let ((name (downcase (etaf-sqlite--column-sql-name column)))) + (when (gethash name names) + (signal 'etaf-sqlite-schema-error + (list "Duplicate SQLite physical column name"))) + (puthash name t names)) + (puthash (etaf-sqlite--column-id column) column index)))) + +;;;###autoload +(defun etaf-sqlite-table (id columns &optional primary-key) + "Declare table ID from COLUMNS and optional PRIMARY-KEY semantic ID." + (unless (or (symbolp id) (stringp id)) + (signal 'etaf-sqlite-schema-error + (list (format "Table ID must be a stable scalar: %S" id)))) + (let* ((columns (copy-sequence columns)) + (index (etaf-sqlite--column-index columns)) + (primary (and primary-key (gethash primary-key index)))) + (when (and primary-key (not primary)) + (signal 'etaf-sqlite-schema-error + (list (format "Unknown primary column: %S" primary-key)))) + (when primary + (setf (etaf-sqlite--column-primary primary) t + (etaf-sqlite--column-nullable primary) nil)) + (etaf-sqlite--table-create :id id :columns columns + :primary-key primary-key :index index))) + +;;;###autoload +(defun etaf-sqlite-database (file table) + "Describe SQLite FILE using typed TABLE metadata." + (unless (and (stringp file) (not (string-empty-p file))) + (signal 'etaf-sqlite-schema-error (list "SQLite file must be nonempty"))) + (unless (etaf-sqlite--table-p table) + (signal 'etaf-sqlite-schema-error (list "SQLite database needs a table"))) + (etaf-sqlite--database-create :file (expand-file-name file) :table table)) + +(defun etaf-sqlite--require-available () + "Signal when the running Emacs has no SQLite support." + (unless (sqlite-available-p) + (signal 'etaf-sqlite-unavailable nil))) + +(defun etaf-sqlite--call (database function) + "Call FUNCTION with a short-lived connection for DATABASE." + (etaf-sqlite--require-available) + (let* ((file (etaf-sqlite--database-file database)) + (directory (file-name-directory file)) + connection) + (when directory + (make-directory directory t)) + (setq connection (sqlite-open file)) + (unwind-protect + (funcall function connection) + (when (sqlitep connection) + (sqlite-close connection))))) + +(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))))) + +(defun etaf-sqlite--sql-type (type) + "Return SQLite DDL type for TYPE." + (pcase type + ('integer "INTEGER") + ('real "REAL") + ('text "TEXT") + ('blob "BLOB") + (_ "BLOB"))) + +(defun etaf-sqlite--column-ddl (column) + "Return DDL for COLUMN." + (concat (etaf-sqlite--identifier + (etaf-sqlite--column-sql-name column) "column") + " " (etaf-sqlite--sql-type + (etaf-sqlite--column-type column)) + (when (etaf-sqlite--column-primary column) " PRIMARY KEY") + (unless (or (etaf-sqlite--column-nullable column) + (etaf-sqlite--column-primary column)) + " NOT NULL"))) + +;;;###autoload +(defun etaf-sqlite-initialize (database) + "Create DATABASE's table if it does not exist and return DATABASE." + (etaf-sqlite--call + database + (lambda (connection) + (sqlite-execute + connection + (format "CREATE TABLE IF NOT EXISTS %s (%s)" + (etaf-sqlite--physical-name + (etaf-sqlite--table-id (etaf-sqlite--database-table database)) + "table") + (mapconcat #'etaf-sqlite--column-ddl + (etaf-sqlite--table-columns + (etaf-sqlite--database-table database)) ", "))))) + database) + +(defun etaf-sqlite--record-value (record key) + "Return KEY from plist, alist, or hash RECORD." + (cond + ((hash-table-p record) (gethash key record)) + ((and (proper-list-p record) (keywordp (car record))) + (plist-get record key)) + ((listp record) (alist-get key record)) + (t nil))) + +(defun etaf-sqlite--query-pairs (table query) + "Return allowlisted (COLUMN . VALUE) pairs from QUERY using TABLE." + (cond + ((null query) nil) + ((and (proper-list-p query) (keywordp (car query))) + (cl-loop for (key value) on query by #'cddr + collect (cons (gethash key (etaf-sqlite--table-index table)) value))) + ((listp query) + (cl-loop for (key . value) in query + collect (cons (gethash key (etaf-sqlite--table-index table)) value))) + (t + (signal 'etaf-sqlite-error + (list "SQLite query must be a plist or alist"))))) + +(defun etaf-sqlite--where (table query) + "Return (SQL . VALUES) for allowlisted equality QUERY using TABLE." + (let (parts values) + (dolist (pair (etaf-sqlite--query-pairs table query)) + (unless (car pair) + (signal 'etaf-sqlite-error (list "Unknown SQLite query column"))) + (push (format "%s = ?" + (etaf-sqlite--identifier + (etaf-sqlite--column-sql-name (car pair)) "column") + ) parts) + (push (cdr pair) values)) + (cons (if parts (concat " WHERE " (string-join (nreverse parts) " AND ")) "") + (nreverse values)))) + +(defun etaf-sqlite--row-plist (table row) + "Convert positional SQLite ROW to a semantic plist using TABLE." + (let (result) + (cl-loop for column in (etaf-sqlite--table-columns table) + for value in row + do (setq result + (append result + (list (etaf-sqlite--column-id column) value)))) + result)) + +(defun etaf-sqlite--select-items (database query page page-size) + "Load PAGE of PAGE-SIZE items from DATABASE for QUERY." + (let* ((table (etaf-sqlite--database-table database)) + (where (etaf-sqlite--where table query)) + (values (cdr where)) + (page (max 1 (or page 1))) + (page-size (max 1 (or page-size 20))) + (offset (* (1- page) page-size)) + (names (mapcar (lambda (column) + (etaf-sqlite--identifier + (etaf-sqlite--column-sql-name column) "column")) + (etaf-sqlite--table-columns table))) + (table-name (etaf-sqlite--physical-name + (etaf-sqlite--table-id table) "table")) + (order (when-let ((primary (etaf-sqlite--table-primary-key table))) + (format " ORDER BY %s" + (etaf-sqlite--identifier + (etaf-sqlite--column-sql-name + (gethash primary (etaf-sqlite--table-index table))) + "column"))))) + (etaf-sqlite--call + database + (lambda (connection) + (let ((total (sqlite-select + connection + (format "SELECT COUNT(*) FROM %s%s" table-name + (car where)) + values))) + (let ((rows (sqlite-select + connection + (format "SELECT %s FROM %s%s%s LIMIT ? OFFSET ?" + (string-join names ", ") table-name (car where) + (or order "")) + (append values (list page-size offset))))) + (list :items (mapcar (lambda (row) + (etaf-sqlite--row-plist table row)) rows) + :total (caar total) + :page page :page-size page-size))))))) + +(defun etaf-sqlite--payload-columns (table payload) + "Return (COLUMN . VALUE) pairs from writable PAYLOAD fields using TABLE." + (let (result) + (dolist (column (etaf-sqlite--table-columns table) (nreverse result)) + (let ((key (etaf-sqlite--column-id column))) + (when (and (not (etaf-sqlite--column-primary column)) + (or (plist-member payload key) + (and (listp payload) (assoc key payload)))) + (push (cons column (etaf-sqlite--record-value payload key)) result)))))) + +(defun etaf-sqlite--mutate (database operation payload) + "Apply one Data mutation OPERATION with PAYLOAD to DATABASE." + (let* ((table (etaf-sqlite--database-table database)) + (table-name (etaf-sqlite--physical-name + (etaf-sqlite--table-id table) "table")) + (primary (etaf-sqlite--table-primary-key table))) + (unless primary + (signal 'etaf-sqlite-schema-error + (list "Mutations require a primary key"))) + (etaf-sqlite--call + database + (lambda (connection) + (etaf-sqlite--transaction + connection + (lambda (transaction-connection) + (pcase operation + ('insert + (let* ((columns + (cl-remove-if + (lambda (column) + (null + (or (plist-member payload + (etaf-sqlite--column-id column)) + (and (listp payload) + (assoc (etaf-sqlite--column-id column) + payload))))) + (etaf-sqlite--table-columns table))) + (names + (mapcar + (lambda (column) + (etaf-sqlite--identifier + (etaf-sqlite--column-sql-name column) "column")) + columns)) + (marks (make-list (length columns) "?"))) + (unless columns + (signal 'etaf-sqlite-error + (list "Insert payload is empty"))) + (sqlite-execute + transaction-connection + (format "INSERT INTO %s (%s) VALUES (%s)" + table-name (string-join names ", ") + (string-join marks ", ")) + (mapcar + (lambda (column) + (etaf-sqlite--record-value + payload (etaf-sqlite--column-id column))) + columns)))) + ((or 'replace 'update) + (let* ((id (etaf-sqlite--record-value payload primary)) + (columns (etaf-sqlite--payload-columns table payload))) + (unless id + (signal 'etaf-sqlite-error + (list "Update payload lacks primary key"))) + (unless columns + (signal 'etaf-sqlite-error + (list "Update payload has no fields"))) + (sqlite-execute + transaction-connection + (format "UPDATE %s SET %s WHERE %s = ?" + table-name + (mapconcat + (lambda (pair) + (format "%s = ?" + (etaf-sqlite--identifier + (etaf-sqlite--column-sql-name (car pair)) + "column"))) + columns ", ") + (etaf-sqlite--identifier + (etaf-sqlite--column-sql-name + (gethash primary (etaf-sqlite--table-index table))) + "column")) + (append (mapcar #'cdr columns) (list id))))) + ('delete + (let ((id (if (and (listp payload) + (or (plist-member payload primary) + (assoc primary payload))) + (etaf-sqlite--record-value payload primary) + payload))) + (unless id + (signal 'etaf-sqlite-error + (list "Delete payload lacks primary key"))) + (sqlite-execute + transaction-connection + (format "DELETE FROM %s WHERE %s = ?" table-name + (etaf-sqlite--identifier + (etaf-sqlite--column-sql-name + (gethash primary (etaf-sqlite--table-index table))) + "column")) + (list id)))) + (_ + (signal 'etaf-sqlite-error + (list (format "Unsupported SQLite mutation: %S" + operation))))))))))) + +;;;###autoload +(defun etaf-sqlite-source (database) + "Return an `etaf-data-source' backed by DATABASE. + +The source accepts equality plist/alist queries and supports `insert', +`replace', `update', and `delete' mutations. Every operation uses a short +connection; controllers remain the owner of reactive state and lifecycle." + (unless (etaf-sqlite--database-p database) + (signal 'wrong-type-argument + (list 'etaf-sqlite-database-p database))) + (etaf-data-source + :name 'etaf-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)))) + +(provide 'etaf-sqlite) + +;;; etaf-sqlite.el ends here diff --git a/tests/etaf-sqlite-tests.el b/tests/etaf-sqlite-tests.el new file mode 100644 index 0000000..c4fc048 --- /dev/null +++ b/tests/etaf-sqlite-tests.el @@ -0,0 +1,82 @@ +;;; etaf-sqlite-tests.el --- ETAF SQLite source tests -*- lexical-binding: t; -*- + +(require 'ert) +(require 'etaf-sqlite) + +(defun etaf-sqlite-test--database (file) + "Return a small typed test DATABASE at FILE." + (etaf-sqlite-database + file + (etaf-sqlite-table + 'items + (list + (etaf-sqlite-column :id "id" :type 'integer :primary t) + (etaf-sqlite-column :name "name" :type 'text) + (etaf-sqlite-column :score "score" :type 'integer)) + :id))) + +(cl-defmacro etaf-sqlite-test--with-database ((database) &rest body) + "Create a temporary DATABASE while evaluating BODY." + (declare (indent 1)) + `(let* ((directory (make-temp-file "etaf-sqlite-" t)) + (file (expand-file-name "data.sqlite" directory)) + (,database (etaf-sqlite-test--database file))) + (unwind-protect + (progn + (etaf-sqlite-initialize ,database) + (let ((mutate (plist-get (etaf-sqlite-source ,database) :mutate))) + (funcall mutate 'insert '(:id 1 :name "Ada" :score 10)) + (funcall mutate 'insert '(:id 2 :name "Grace" :score 20))) + ,@body) + (when (file-exists-p directory) + (delete-directory directory t))))) + +(ert-deftest etaf-sqlite-schema-rejects-unsafe-identifiers () + "Identifiers are validated before they can reach SQL text." + (should-error (etaf-sqlite-column :id "id; DROP TABLE items") + :type 'etaf-sqlite-schema-error) + (should-error + (etaf-sqlite-table + 'items (list (etaf-sqlite-column :id "id")) :missing) + :type 'etaf-sqlite-schema-error)) + +(ert-deftest etaf-sqlite-source-loads-and-filters-pages () + "The source should implement ETAF Data's load capability." + (etaf-sqlite-test--with-database (database) + (let* ((source (etaf-sqlite-source database)) + (result (funcall (plist-get source :load) nil 1 1)) + (filtered (funcall (plist-get source :load) + '(:name "Grace") 1 10))) + (should (= (plist-get result :total) 2)) + (should (= (length (plist-get result :items)) 1)) + (should (equal (plist-get (car (plist-get result :items)) :name) + "Ada")) + (should (= (plist-get filtered :total) 1))))) + +(ert-deftest etaf-sqlite-source-mutations-are-visible-to-data-controller () + "Insert, update, and delete should share the Data source contract." + (etaf-sqlite-test--with-database (database) + (let ((controller (etaf-data-controller (etaf-sqlite-source database) + :page-size 20 :auto-load t))) + (unwind-protect + (progn + (etaf-data-mutate controller 'insert + '(:id 3 :name "Alan" :score 30)) + (should (= (etaf-value (etaf-data-total controller)) 3)) + (etaf-data-mutate controller 'update + '(:id 3 :name "Alan Turing" :score 31)) + (should (string= (plist-get + (car (cl-remove-if-not + (lambda (row) + (= (plist-get row :id) 3)) + (etaf-value + (etaf-data-items controller)))) + :name) + "Alan Turing")) + (etaf-data-mutate controller 'delete 3) + (should (= (etaf-value (etaf-data-total controller)) 2))) + (etaf-data-stop controller))))) + +(provide 'etaf-sqlite-tests) + +;;; etaf-sqlite-tests.el ends here