299b9ff877
Adapt Emacs SQLite to the core ETAF Data Source contract with typed schema validation, safe queries, transactions, pagination, mutations, tests, and bilingual usage documentation.
416 lines
17 KiB
EmacsLisp
416 lines
17 KiB
EmacsLisp
;;; 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
|