From 1815776e1a935ba403c9d50d6205e078912d1bf5 Mon Sep 17 00:00:00 2001 From: kilianmh Date: Tue, 7 May 2024 00:41:51 +0200 Subject: [PATCH] Feat: column slot foreign-key All logic for creating foreign-key-clause-structs is now in `make-clause ((clause-name (eql :foreign-key))` whereas the method signature is slightly changed The slots `on-update` and `on-delete` are now explicit in the struct foreign-key-clause. One more `yield` function has been added to convert foreign-key-structs into a valid foreign key definition. --- README.markdown | 56 ++++++++++++------- src/clause.lisp | 142 +++++++++++++++++++++++++++++++++-------------- src/sxql.lisp | 19 +------ t/clause.lisp | 11 +++- t/statement.lisp | 42 ++++++++++++++ t/sxql.lisp | 18 ++++++ 6 files changed, 211 insertions(+), 77 deletions(-) diff --git a/README.markdown b/README.markdown index 3c16b97..59a2ea1 100644 --- a/README.markdown +++ b/README.markdown @@ -134,36 +134,54 @@ Creates a SELECT query. It takes a field (or a list of fields) and SQL Clauses. ```common-lisp (create-table :enemy - ((name :type 'string + ((name :type 'varchar :primary-key t) (age :type 'integer :not-null t) (address :type 'text - :not-null nil) - (fatal_weakness :type 'text - :not-null t - :default "None") - (identifying_color :type '(:char 20) - :unique t))) -;=> # + :not-null nil + :unique t))) +;=> # (yield *) -;=> "CREATE TABLE enemy (name STRING PRIMARY KEY, age INTEGER NOT NULL, address TEXT, fatal_weakness TEXT NOT NULL DEFAULT ?, identifying_color CHAR(20) UNIQUE)" -; ("None") - -(create-table (:enemy :if-not-exists t) - ((name :type 'string - :primary-key t) - (age :type 'integer +;=> "CREATE TABLE enemy ( +; name VARCHAR PRIMARY KEY, +; age INTEGER NOT NULL, +; address TEXT UNIQUE +; )" +; NIL +``` +```common-lisp +(create-table (:enemy-details :if-not-exists t) + ((name :type :varchar + :references '(:enemy :name)) + :primary-key t) + (time :type 'integer :not-null t) - (address :type 'text - :not-null nil) (fatal_weakness :type 'text :not-null t :default "None") (identifying_color :type '(:char 20) - :unique t))) -;=> # + :unique t)) +;=> # + +(yield *) +;=> "CREATE TABLE IF NOT EXISTS enemy-details ( +; id BIGINT PRIMARY KEY FOREIGN KEY REFERENCES enemy (name), +; time INTEGER NOT NULL, +; fatal_weakness TEXT NOT NULL DEFAULT ?, +; identifying_color CHAR(20) UNIQUE +; )" +; ("None") ``` ### drop-table (table &key if-exists) diff --git a/src/clause.lisp b/src/clause.lisp index 54e234a..fd8e959 100644 --- a/src/clause.lisp +++ b/src/clause.lisp @@ -11,6 +11,9 @@ :sql-symbol-name :sql-list-elements :expression-clause-expression) + (:import-from #:alexandria + #:if-let + #:when-let) (:import-from :sxql.operator :=-op :as-op @@ -179,6 +182,7 @@ (defstruct (unique-key-clause (:include key-clause (name "UNIQUE")) (:constructor make-unique-key-clause (expression)))) +;; FOREIGN KEY DEFINITION @export (defstruct (references-clause (:include expression-clause (name "REFERENCES")) (:constructor make-references-clause (table-name column-names @@ -195,36 +199,30 @@ (slot-value clause 'name) (on-clause-action clause)) nil)) + (defstruct (on-delete-clause (:include on-clause (name "ON DELETE")))) (defstruct (on-update-clause (:include on-clause (name "ON UPDATE")))) @export -(defstruct (foreign-key-clause (:include expression-clause (name "FOREIGN KEY")) - (:constructor make-foreign-key-clause (column-names references on-delete on-update - &aux (expression - (apply #'make-sql-splicing-expression-list - column-names references - (append - (and on-delete - (list - (make-on-delete-clause :action on-delete))) - (and on-update - (list - (make-on-update-clause :action on-update))))))))) - (column-names nil :type sql-list) - (references nil :type references-clause)) +(defstruct (foreign-key-clause (:include expression-clause (name "FOREIGN KEY"))) + (column-names nil :type (or sql-list null)) + (references nil :type references-clause) + (on-delete nil :type (or null on-delete-clause)) + (on-update nil :type (or null on-update-clause))) @export (defstruct (column-definition-clause (:include sql-clause) - (:constructor %make-column-definition-clause (column-name &key type not-null default auto-increment autoincrement unique primary-key))) - column-name - type - not-null - default - auto-increment - autoincrement - unique - primary-key) + (:constructor %make-column-definition-clause + (column-name &key type not-null default auto-increment autoincrement foreign-key unique primary-key))) + (column-name nil :type sql-symbol) + (type nil :type sql-column-type) + (not-null nil :type boolean) + (default nil :type (or sql-variable null)) + (auto-increment nil :type boolean) + (autoincrement nil :type boolean) + (foreign-key nil :type (or foreign-key-clause null)) + (unique nil :type boolean) + (primary-key nil :type boolean)) (defstruct (column-modifier-clause (:include expression-clause) (:constructor nil)) @@ -302,15 +300,22 @@ (:constructor make-drop-column-clause (expression)))) @export -(defun make-column-definition-clause (column-name &rest args &key type not-null default auto-increment autoincrement unique primary-key) - (declare (ignore type not-null default auto-increment autoincrement unique primary-key)) +(defun make-column-definition-clause (column-name &rest args &key type not-null default auto-increment autoincrement unique foreign-key primary-key) + (declare (ignore type not-null default auto-increment autoincrement unique foreign-key primary-key)) (apply #'%make-column-definition-clause (detect-and-convert column-name) (loop for (key val) on args by #'cddr if (eq key :type) append (list key (make-sql-column-type-from-list val)) else - append (list key (detect-and-convert val))))) + if (eq key :foreign-key) + append (list key + (make-clause :foreign-key + :references (getf val :references) + :on-update (getf val :on-update) + :on-delete (getf val :on-delete))) + else + append (list key (detect-and-convert val))))) (defmethod yield ((clause column-definition-clause)) (with-yield-binds @@ -332,6 +337,9 @@ (write-string " UNIQUE" s)) (when (column-definition-clause-primary-key clause) (write-string " PRIMARY KEY" s)) + (when-let (foreign-key + (column-definition-clause-foreign-key clause)) + (format s " ~A" (yield foreign-key))) (when (and (column-definition-clause-autoincrement clause) (not (column-definition-clause-auto-increment clause))) (write-string " AUTOINCREMENT" s))))) @@ -389,7 +397,6 @@ (t 2)) (yield (on-conflict-do-nothing-clause-conflict-target clause)))) - (defstruct (on-conflict-do-update-clause (:include sql-clause (name "ON CONFLICT DO UPDATE")) (:constructor %make-on-conflict-do-update-clause (conflict-target update-set &optional where-condition))) (conflict-target nil :type (or sql-list sql-symbol)) @@ -457,20 +464,6 @@ (defmethod make-clause ((clause-name (eql :unique-key)) &rest args) (apply #'make-key-clause-for-all #'make-unique-key-clause args)) -(defmethod make-clause ((clause-name (eql :foreign-key)) &rest args) - (destructuring-bind (column-names &key references on-delete on-update) args - (destructuring-bind (target-table-name &rest target-column-names) references - (make-foreign-key-clause - (apply #'make-sql-list (mapcar #'detect-and-convert - (if (listp column-names) - column-names - (list column-names)))) - (make-references-clause (detect-and-convert target-table-name) - (apply #'make-sql-list (mapcar #'detect-and-convert - target-column-names))) - on-delete - on-update)))) - (defmethod make-clause ((clause-name (eql :add-column)) &rest args) (apply #'make-column-modifier-clause #'make-add-column-clause nil args)) @@ -503,6 +496,56 @@ (cadr args) (caddr args))) +(defmethod make-clause ((clause-name (eql :foreign-key)) &key column-names references on-delete on-update) + (flet ((canonicalize-action (action) + (etypecase action + (keyword + (ecase action + (:no-action "NO ACTION") + (:set-null "SET NULL") + (:set-default "SET DEFAULT") + ((:restrict :cascade) + (symbol-name action)))) + (string action) + (null action)))) + (unless references + (error "You have to supply references with foreign key.")) + (let* ((target-columns + (cdr references)) + (column-length + (if (atom column-names) + 1 + (list-length column-names))) + (target-column-length + (if (atom target-columns) + 1 + (list-length target-columns)))) + (unless target-columns + (error "You have to supply at least one references target-columns.")) + (when (and (not column-names) + (not (or (atom target-columns) + (eql 1 (list-length target-columns))))) + (error "You have to supply exactly one references target-column with inline references.")) + (unless (eql column-length target-column-length) + (error "Supplied columns count (~A) not identical with target-columns count (~A)." + column-length + target-column-length)) + ;(break) + (make-foreign-key-clause + :column-names (when column-names + (apply #'make-sql-list (mapcar #'detect-and-convert + (if (consp column-names) + column-names + (list column-names))))) + :references (make-references-clause (detect-and-convert (first references)) + (apply #'make-sql-list (mapcar #'detect-and-convert + (cdr references)))) + :on-delete (when on-delete + (make-on-delete-clause :action (canonicalize-action on-delete))) + :on-update (when on-update + (make-on-update-clause :action (canonicalize-action on-update))))))) + + (defmethod yield ((clause limit-clause)) (let ((*use-placeholder* nil)) (call-next-method))) @@ -544,6 +587,23 @@ (format nil "SET ~{~A = ~A~^, ~}" (mapcar #'yield-arg (set=-clause-args clause))))))) + +(defmethod yield ((clause foreign-key-clause)) + (with-yield-binds + (with-output-to-string (s) + (if-let (column-names + (foreign-key-clause-column-names clause)) + (format s "FOREIGN KEY ~A ~A" + (yield column-names) + (yield (foreign-key-clause-references clause))) + (write-string (yield (foreign-key-clause-references clause)) s)) + (when-let (on-delete + (foreign-key-clause-on-delete clause)) + (format s " ~A" (yield on-delete))) + (when-let (on-update + (foreign-key-clause-on-update clause)) + (format s " ~A" (yield on-update)))))) + (defun make-sql-column-type-from-list (val) (destructuring-bind (type &optional args &rest attrs) (if (listp val) diff --git a/src/sxql.lisp b/src/sxql.lisp index d92bc95..d66f673 100644 --- a/src/sxql.lisp +++ b/src/sxql.lisp @@ -279,22 +279,9 @@ (apply #'make-clause :key key-args)) @export -(defun foreign-key (column-names &key references on-delete on-update) - (flet ((canonicalize-action (action) - (etypecase action - (keyword - (ecase action - (:no-action "NO ACTION") - (:set-null "SET NULL") - ((:restrict :cascade) - (symbol-name action)))) - (string action) - (null action)))) - (make-clause :foreign-key - column-names - :references references - :on-delete (canonicalize-action on-delete) - :on-update (canonicalize-action on-update)))) +(defun foreign-key (column-names &rest args &key references on-delete on-update) + (declare (ignore references on-delete on-update)) + (apply #'make-clause (list* :foreign-key :column-names column-names args))) @export (defun add-column (column-name &rest args) diff --git a/t/clause.lisp b/t/clause.lisp index 5e995cb..22c78d9 100644 --- a/t/clause.lisp +++ b/t/clause.lisp @@ -177,9 +177,18 @@ (sxql.sql-type:make-sql-list (sxql.sql-type:make-sql-symbol "id")))) (is (multiple-value-list - (yield (make-clause :foreign-key '(:project_id) :references '(:project :id)))) + (yield (make-clause :foreign-key :column-names '(:project_id) :references '(:project :id)))) (list "FOREIGN KEY (`project_id`) REFERENCES `project` (`id`)" nil)) +(is (multiple-value-list + (yield (make-clause :foreign-key :column-names '(:project_id) :references '(:project :id) :on-update :set-default))) + (list "FOREIGN KEY (`project_id`) REFERENCES `project` (`id`) ON UPDATE SET DEFAULT" + nil)) + +(is (multiple-value-list + (yield (make-clause :foreign-key :column-names nil :references '(:project :id) :on-delete :cascade))) + (list "REFERENCES `project` (`id`) ON DELETE CASCADE" nil)) + (is (yield (sxql.clause::make-sql-column-type-from-list '(:integer))) "INTEGER") (is (yield (sxql.clause::make-sql-column-type-from-list '(:integer 11))) diff --git a/t/statement.lisp b/t/statement.lisp index a39e4fa..8230a16 100644 --- a/t/statement.lisp +++ b/t/statement.lisp @@ -182,6 +182,48 @@ )" ("None")) "CREATE TABLE IF NOT EXISTS") +(is (multiple-value-list + (yield (make-statement :create-table + '(:table3) + '((:fatal_weakness :type text + :not-null t + :default "None" + :foreign-key (:references (:nxt-table :nxt-column) :on-update :restrict)) + (:identifying_color :type (:char 20) + :foreign-key (:references (:iden-table :iden-colum) :on-delete :set-default) + :unique t))))) + '("CREATE TABLE `table3` ( + `fatal_weakness` TEXT NOT NULL DEFAULT ? REFERENCES `nxt-table` (`nxt-column`) ON UPDATE RESTRICT, + `identifying_color` CHAR(20) UNIQUE REFERENCES `iden-table` (`iden-colum`) ON DELETE SET DEFAULT +)" + ("None"))) + +(is (multiple-value-list + (yield (make-statement :create-table + '(:enemy :if-not-exists nil) + '((:age :type integer + :not-null t) + (:address :type text + :not-null nil + :foreign-key (:references (:fk-table :fk-column) :on-delete :set-null :on-update :no-action)))))) + '("CREATE TABLE `enemy` ( + `age` INTEGER NOT NULL, + `address` TEXT REFERENCES `fk-table` (`fk-column`) ON DELETE SET NULL ON UPDATE NO ACTION +)" + nil)) + +(is (multiple-value-list + (yield (make-statement + :create-table + '(:enemy :if-not-exists t) + '((:name :type string + :foreign-key (:references (:foreign-key-table :foreign-key-column)) + :primary-key t))))) + '("CREATE TABLE IF NOT EXISTS `enemy` ( + `name` STRING PRIMARY KEY REFERENCES `foreign-key-table` (`foreign-key-column`) +)" + nil)) + (is (multiple-value-list (yield (make-statement :alter-table :tweet (make-clause :add-column :id diff --git a/t/sxql.lisp b/t/sxql.lisp index e8db252..5fa71f1 100644 --- a/t/sxql.lisp +++ b/t/sxql.lisp @@ -349,6 +349,24 @@ '("FOREIGN KEY (`project_id`) REFERENCES `project` (`id`)" nil)) (is-mv (foreign-key '(:project_id) :references '(:project :id)) '("FOREIGN KEY (`project_id`) REFERENCES `project` (`id`)" nil)) +(is-mv (foreign-key '(:order-id :customer-id) :references '(:orders :order-id :customer-id)) + '("FOREIGN KEY (`order-id`, `customer-id`) REFERENCES `orders` (`order-id`, `customer-id`)" nil)) +(is-mv (foreign-key nil :references '(:project :id)) + '("REFERENCES `project` (`id`)" nil)) +(is-mv (foreign-key '(:order-id :customer-id) :references '(:orders :order-id :customer-id)) + '("FOREIGN KEY (`order-id`, `customer-id`) REFERENCES `orders` (`order-id`, `customer-id`)" nil)) +(is-mv (foreign-key :order-id :references '(:orders :order-id)) + (list "FOREIGN KEY (`order-id`) REFERENCES `orders` (`order-id`)" +nil)) + + +(is-error (foreign-key nil :references '(:project)) + 'simple-error) +(is-error (foreign-key '(:order-id :customer-id) :references '(:orders :order-id :customer-id :wrong-column)) + 'simple-error) +(is-error (foreign-key '(:order-id) :references '(:orders :order-id :customer-id)) + 'simple-error) + (let ((primary-key :id)) (is-mv (primary-key primary-key)