diff --git a/mito-core.asd b/mito-core.asd index 653b6e3..e0fe8ca 100644 --- a/mito-core.asd +++ b/mito-core.asd @@ -19,7 +19,7 @@ ((:file "dao" :depends-on ("dao-components")) (:module "dao-components" :pathname "dao" - :depends-on ("connection" "class" "db" "logger" "util") + :depends-on ("connection" "class" "db" "conversion" "logger" "util") :components ((:file "table" :depends-on ("column" "mixin" "view")) (:file "view" :depends-on ("column")) @@ -42,6 +42,7 @@ ((:file "mysql") (:file "postgres") (:file "sqlite3"))) + (:file "conversion") (:file "logger") (:file "error") (:file "util"))))) diff --git a/src/core/conversion.lisp b/src/core/conversion.lisp new file mode 100644 index 0000000..17454a0 --- /dev/null +++ b/src/core/conversion.lisp @@ -0,0 +1,48 @@ +(defpackage mito.conversion + (:use :cl) + (:import-from :local-time) + (:export :convert-for-driver-type)) +(in-package :mito.conversion) + +(defvar *db-datetime-format* + '((:year 4) #\- (:month 2) #\- (:day 2) #\Space (:hour 2) #\: (:min 2) #\: (:sec 2) #\. (:usec 6) :gmt-offset-or-z)) + +(defvar *db-datetime-format-without-timezone* + '((:year 4) #\- (:month 2) #\- (:day 2) #\Space (:hour 2) #\: (:min 2) #\: (:sec 2) #\. (:usec 6))) + +(defvar *db-date-format* + '((:year 4) #\- (:month 2) #\- (:day 2))) + +(defgeneric convert-for-driver-type (driver-type col-type value) + (:method (driver-type col-type value) + (declare (ignore driver-type col-type)) + value) + (:method (driver-type col-type (value string)) + (declare (ignore driver-type col-type)) + value) + (:method ((driver-type (eql :mysql)) (col-type (eql :boolean)) value) + (ecase value + (t 1) + ('nil 0))) + (:method ((driver-type (eql :mysql)) (col-type (eql :datetime)) (value local-time:timestamp)) + (local-time:format-timestring nil value + :format *db-datetime-format-without-timezone*)) + (:method (driver-type (col-type (eql :datetime)) (value local-time:timestamp)) + (local-time:format-timestring nil value + :format *db-datetime-format* + :timezone local-time:+gmt-zone+)) + (:method (driver-type (col-type (eql :date)) (value local-time:timestamp)) + (local-time:format-timestring nil value + :format *db-date-format*)) + (:method (driver-type (col-type (eql :timestamp)) value) + (convert-for-driver-type driver-type :datetime value)) + (:method (driver-type (col-type (eql :timestamptz)) value) + (convert-for-driver-type driver-type :datetime value)) + (:method ((driver-type (eql :sqlite3)) (col-type (eql :boolean)) value) + (ecase value + (t 1) + ('nil 0))) + (:method ((driver-type (eql :postgres)) (col-type (eql :boolean)) value) + (ecase value + (t '(:raw "true")) + ('nil '(:raw "false"))))) diff --git a/src/core/dao.lisp b/src/core/dao.lisp index a820290..dd4fa0d 100644 --- a/src/core/dao.lisp +++ b/src/core/dao.lisp @@ -7,6 +7,8 @@ #:mito.class) (:import-from #:mito.dao.column #:dao-table-column-deflate) + (:import-from #:mito.conversion + #:convert-for-driver-type) (:import-from #:mito.connection #:*connection* #:check-connected @@ -39,8 +41,7 @@ #:ensure-list #:once-only #:with-gensyms) - (:export #:convert-for-driver-type - #:insert-dao + (:export #:insert-dao #:update-dao #:create-dao #:delete-dao @@ -75,49 +76,6 @@ t) (values nil nil)))) -(defvar *db-datetime-format* - '((:year 4) #\- (:month 2) #\- (:day 2) #\Space (:hour 2) #\: (:min 2) #\: (:sec 2) #\. (:usec 6) :gmt-offset-or-z)) - -(defvar *db-datetime-format-without-timezone* - '((:year 4) #\- (:month 2) #\- (:day 2) #\Space (:hour 2) #\: (:min 2) #\: (:sec 2) #\. (:usec 6))) - -(defvar *db-date-format* - '((:year 4) #\- (:month 2) #\- (:day 2))) - -(defgeneric convert-for-driver-type (driver-type col-type value) - (:method (driver-type col-type value) - (declare (ignore driver-type col-type)) - value) - (:method (driver-type col-type (value string)) - (declare (ignore driver-type col-type)) - value) - (:method ((driver-type (eql :mysql)) (col-type (eql :boolean)) value) - (ecase value - (t 1) - ('nil 0))) - (:method ((driver-type (eql :mysql)) (col-type (eql :datetime)) (value local-time:timestamp)) - (local-time:format-timestring nil value - :format *db-datetime-format-without-timezone*)) - (:method (driver-type (col-type (eql :datetime)) (value local-time:timestamp)) - (local-time:format-timestring nil value - :format *db-datetime-format* - :timezone local-time:+gmt-zone+)) - (:method (driver-type (col-type (eql :date)) (value local-time:timestamp)) - (local-time:format-timestring nil value - :format *db-date-format*)) - (:method (driver-type (col-type (eql :timestamp)) value) - (convert-for-driver-type driver-type :datetime value)) - (:method (driver-type (col-type (eql :timestamptz)) value) - (convert-for-driver-type driver-type :datetime value)) - (:method ((driver-type (eql :sqlite3)) (col-type (eql :boolean)) value) - (ecase value - (t 1) - ('nil 0))) - (:method ((driver-type (eql :postgres)) (col-type (eql :boolean)) value) - (ecase value - (t '(:raw "true")) - ('nil '(:raw "false"))))) - (defun make-set-clause (obj) (let ((class (class-of obj))) (apply #'sxql:make-clause :set= diff --git a/src/core/dao/column.lisp b/src/core/dao/column.lisp index 8710525..daf02e7 100644 --- a/src/core/dao/column.lisp +++ b/src/core/dao/column.lisp @@ -4,9 +4,13 @@ #:mito.util) (:import-from #:mito.class.column #:table-column-class - #:table-column-type) + #:table-column-type + #:table-column-info) + (:import-from #:mito.conversion + #:convert-for-driver-type) (:import-from #:local-time) (:import-from #:cl-ppcre) + (:import-from #:closer-mop) (:export #:dao-table-column-class #:dao-table-column-inflate #:dao-table-column-deflate @@ -141,3 +145,15 @@ (deflate-for-col-type :datetime value)) (:method ((col-type (eql :timestamptz)) value) (deflate-for-col-type :datetime value))) + +(defmethod table-column-info :around ((column dao-table-column-class) driver-type) + (let ((column-info (call-next-method))) + (when (and (null (getf (cdr column-info) :default)) + (c2mop:slot-definition-initfunction column)) + (setf (getf (cdr column-info) :default) + (convert-for-driver-type + driver-type + (table-column-type column) + (dao-table-column-deflate column + (funcall (c2mop:slot-definition-initfunction column)))))) + column-info)) diff --git a/src/core/dao/view.lisp b/src/core/dao/view.lisp index 368ac57..6297dec 100644 --- a/src/core/dao/view.lisp +++ b/src/core/dao/view.lisp @@ -38,6 +38,22 @@ (sxql:yield (create-view-view-name statement)) (create-view-as statement)))) +(defstruct (drop-view (:include sxql.sql-type:sql-statement (sxql.sql-type:name "DROP VIEW")) + (:constructor make-drop-view (view-name &key if-exists))) + view-name + if-exists) + +(defmethod sxql:make-statement ((statement-name (eql :drop-view)) &rest args) + (destructuring-bind (view-name &key if-exists) + args + (make-drop-view (sxql.operator:detect-and-convert view-name) :if-exists if-exists))) + +(defmethod sxql:yield ((statement drop-view)) + (sxql.sql-type:with-yield-binds + (format nil "DROP~:[~; IF EXISTS~] VIEW ~A" + (drop-view-if-exists statement) + (drop-view-view-name statement)))) + (defgeneric table-definition (class &key if-not-exists or-replace) (:method ((class symbol) &rest args &key if-not-exists or-replace) (declare (ignore if-not-exists or-replace)) diff --git a/src/core/db/mysql.lisp b/src/core/db/mysql.lisp index cbf311e..869adde 100644 --- a/src/core/db/mysql.lisp +++ b/src/core/db/mysql.lisp @@ -71,7 +71,8 @@ :auto-increment (string= (getf column :|Extra|) "auto_increment") :primary-key (string= (getf column :|Key|) "PRI") :not-null (or (string= (getf column :|Key|) "PRI") - (string= (getf column :|Null|) "NO")))))) + (string= (getf column :|Null|) "NO")) + :default (getf column :|Default|))))) ;; Set :primary-key NIL if there's a composite primary key. (if (< 1 (count-if (lambda (def) (getf (cdr def) :primary-key)) diff --git a/src/core/db/postgres.lisp b/src/core/db/postgres.lisp index e59ada5..7ef5018 100644 --- a/src/core/db/postgres.lisp +++ b/src/core/db/postgres.lisp @@ -58,10 +58,14 @@ ~% CASE~ ~% WHEN p.contype = 'p' THEN true~ ~% ELSE false~ - ~% END AS primary~ + ~% END AS primary,~ + ~% CASE~ + ~% WHEN f.atthasdef THEN pg_get_expr(d.adbin, d.adrelid)~ + ~% END AS default~ ~%FROM pg_attribute f~ ~% JOIN pg_class c ON c.oid = f.attrelid~ ~% LEFT JOIN pg_constraint p ON p.conrelid = f.attrelid AND f.attnum = ANY (p.conkey)~ + ~% LEFT JOIN pg_attrdef d ON d.adrelid = c.oid~ ~%WHERE c.relkind = 'r'::char~ ~% AND c.relname = '~A'~ ~% AND f.attnum > 0~ @@ -73,14 +77,19 @@ (loop with results = (dbi:execute query) for column = (dbi:fetch results) while column - collect (list (getf column :|name|) - :type (getf column :|type|) - :auto-increment (not (null (member (getf column :|name|) + collect (let ((auto-increment (not (null (member (getf column :|name|) serial-keys - :test #'string=))) - :primary-key (getf column :|primary|) - :not-null (or (getf column :|primary|) - (getf column :|notnull|)))) + :test #'string=))))) + (list (getf column :|name|) + :type (getf column :|type|) + :auto-increment auto-increment + :primary-key (getf column :|primary|) + :not-null (or (getf column :|primary|) + (getf column :|notnull|)) + :default (if (or auto-increment + (eq :null (getf column :|default|))) + nil + (getf column :|default|))))) :key #'car :test #'string= :from-end t))) diff --git a/src/migration/table.lisp b/src/migration/table.lisp index 3fa86cf..bd1afb9 100644 --- a/src/migration/table.lisp +++ b/src/migration/table.lisp @@ -38,7 +38,8 @@ #:list-diff #:ensure-class) (:import-from #:alexandria - #:ensure-list) + #:ensure-list + #:remove-from-plist) (:export #:*auto-migration-mode* #:*migration-keep-temp-tables* #:migrate-table @@ -61,6 +62,170 @@ If this variable is T they won't be deleted after migration.") (mapc #'execute-sql (migration-expressions class)))))) +(defun migration-expressions-between (table-name driver-type from-columns to-columns from-indices to-indices) + (multiple-value-bind (columns-intersection + columns-to-delete + columns-to-add) + (list-diff from-columns to-columns + :key #'car) + + (multiple-value-bind (indices-intersection + indices-to-delete + indices-to-add) + (list-diff from-indices to-indices + :key #'cdr + :test #'equalp + :sort-fn + (lambda (a b) + (string< (prin1-to-string (cdr a)) + (prin1-to-string (cdr b))))) + (declare (ignore indices-intersection)) + ;; TODO: take care of the order of columns + (list + ;; add columns + (when columns-to-add + (let ((drop-defaults '())) + (cons + (apply #'sxql:make-statement :alter-table (sxql:make-sql-symbol table-name) + (mapcar (lambda (column) + (sxql:make-clause :add-column (sxql:make-sql-symbol (car column)) + :type + (let ((type (getf (cdr column) :type))) + (if (and (eq driver-type :postgres) + (getf (cdr column) :auto-increment)) + (cond + ((string= type "integer") + "serial") + ((string= type "bigint") + "bigserial") + (t + (error "Invalid PostgreSQL serial type: ~S" type))) + type)) + :default + (if (getf (cdr column) :not-null) + (or (getf (cdr column) :default) + (progn + (warn "Adding a non-null column ~S but there's no :initform to set default" + (car column)) + nil)) + nil) + :primary-key (getf (cdr column) :primary-key) + :not-null (getf (cdr column) :not-null) + :auto-increment (and (eq driver-type :mysql) + (getf (cdr column) :auto-increment)))) + columns-to-add)) + (when drop-defaults + (list + (apply #'sxql:make-statement :alter-table (sxql:make-sql-symbol table-name) + (mapcar (lambda (column-name) + (sxql:alter-column (sxql:make-sql-symbol column-name) + :drop-default t)) + (nreverse drop-defaults)))))))) + ;; drop columns + (when columns-to-delete + (list + (apply #'sxql:make-statement :alter-table (sxql:make-sql-symbol table-name) + (mapcar (lambda (column) + (sxql:drop-column (sxql:make-sql-symbol (car column)))) + columns-to-delete)))) + ;; change columns + (loop with before-alter-sequences = '() + with after-alter-sequences = '() + for db-column in columns-intersection + for table-column = (find (car db-column) to-columns :test #'string= :key #'car) + unless (equalp (remove-from-plist (cdr db-column) :default) + (remove-from-plist (cdr table-column) :default)) + append (case driver-type + (:postgres + (loop for (k v) on (cdr table-column) by #'cddr + for current-value = (getf (cdr db-column) k) + unless (or (eq k :primary-key) ;; ignore :primary-key as it'll be added in the later indices' section + (eql v current-value)) + collect + (case k + (:auto-increment + (let ((seq (format nil "~A_~A_seq" + table-name + (car table-column)))) + (if v + (progn + ;; create a new sequence + (push + (sxql:make-statement :create-sequence (sxql:make-sql-symbol seq)) + before-alter-sequences) + (sxql:make-clause :set-default `(:nextval ,seq))) + (progn + ;; delete the existing sequence + (push + (sxql:make-statement :drop-sequence + (sxql:make-sql-symbol seq)) + after-alter-sequences) + (sxql:make-clause :alter-column + (sxql:make-sql-symbol (car table-column)) + :drop-default t))))) + (:default + (sxql:make-clause :set-default v)) + (otherwise + (sxql:make-clause :alter-column + (sxql:make-sql-symbol (car table-column)) + k v))))) + (otherwise + ;; Don't add PRIMARY KEY if the column is already the primary key + (when (getf (cdr db-column) :primary-key) + (setf (getf (cdr table-column) :primary-key) nil)) + (list + (apply #'sxql:make-clause :modify-column (sxql:make-sql-symbol (car table-column)) + (cdr table-column))))) + into clauses + finally + (return + (nconc + (nreverse before-alter-sequences) + (and clauses + (list (apply #'sxql:make-statement :alter-table (sxql:make-sql-symbol table-name) + clauses))) + (nreverse after-alter-sequences)))) + ;; add indices + (loop for (index-name . options) in indices-to-add + if (getf options :primary-key) + append + ;; Ignore if the columns are just added. + (if (or (cdr (getf options :columns)) + (not (find (first (getf options :columns)) + columns-to-add + :key #'car + :test #'string=))) + (list + (sxql:make-statement :alter-table (sxql:make-sql-symbol table-name) + (apply #'sxql:make-clause :add-primary-key + (mapcar #'sxql:make-sql-symbol (getf options :columns))))) + nil) + else + collect (sxql:create-index + (sxql:make-sql-symbol index-name) + :unique (getf options :unique-key) + :on (list* (sxql:make-sql-symbol table-name) + (mapcar #'sxql:make-sql-symbol (getf options :columns))))) + ;; drop indices + (loop for (index-name . options) in indices-to-delete + ;; Ignore if the index's columns are going to be dropped. + unless (every (lambda (col) + (find col columns-to-delete + :key #'car + :test #'string=)) + (getf options :columns)) + append + (nconc + (when (and (not (eq driver-type :postgres)) + (getf options :primary-key)) + (list (sxql:make-statement :alter-table (sxql:make-sql-symbol table-name) + (sxql:drop-primary-key)))) + (list + (apply #'sxql:drop-index index-name + (if (eq driver-type :postgres) + nil + (list :on (sxql:make-sql-symbol table-name))))))))))) + (defun migration-expressions-for-others (class driver-type) (let* ((table-name (table-name class)) (table-columns @@ -73,182 +238,13 @@ If this variable is T they won't be deleted after migration.") (table-indices (table-indices-info class driver-type)) (db-columns (column-definitions *connection* table-name)) (db-indices (table-indices *connection* table-name))) - (multiple-value-bind (columns-intersection - columns-to-delete - columns-to-add) - (list-diff db-columns table-columns - :key #'car) - - (multiple-value-bind (indices-intersection - indices-to-delete - indices-to-add) - (list-diff db-indices table-indices - :key #'cdr - :test #'equalp - :sort-fn - (lambda (a b) - (string< (prin1-to-string (cdr a)) - (prin1-to-string (cdr b))))) - (declare (ignore indices-intersection)) - ;; TODO: take care of the order of columns - (list - ;; add columns - (if columns-to-add - (let ((drop-defaults '())) - (cons - (apply #'sxql:make-statement :alter-table (sxql:make-sql-symbol table-name) - (mapcar (lambda (column) - (sxql:make-clause :add-column (sxql:make-sql-symbol (car column)) - :type - (let ((type (getf (cdr column) :type))) - (if (and (eq driver-type :postgres) - (getf (cdr column) :auto-increment)) - (cond - ((string= type "integer") - "serial") - ((string= type "bigint") - "bigserial") - (t - (error "Invalid PostgreSQL serial type: ~S" type))) - type)) - :default - (if (getf (cdr column) :not-null) - (let ((slot - (find-slot-by-name class (lispify (car column)) - :test #'string-equal))) - (cond - ((c2mop:slot-definition-initfunction slot) - (push (car column) drop-defaults) - (convert-for-driver-type - (driver-type) - (table-column-type slot) - (dao-table-column-deflate slot - (funcall (c2mop:slot-definition-initfunction slot))))) - (t - (warn "Adding a non-null column ~S but there's no :initform to set default" - (car column)) - nil))) - nil) - :primary-key (getf (cdr column) :primary-key) - :not-null (getf (cdr column) :not-null) - :auto-increment (and (eq driver-type :mysql) - (getf (cdr column) :auto-increment)))) - columns-to-add)) - (when drop-defaults - (list - (apply #'sxql:make-statement :alter-table (sxql:make-sql-symbol table-name) - (mapcar (lambda (column-name) - (sxql:alter-column (sxql:make-sql-symbol column-name) - :drop-default t)) - (nreverse drop-defaults))))))) - nil) - ;; drop columns - (if columns-to-delete - (apply #'sxql:make-statement :alter-table (sxql:make-sql-symbol table-name) - (mapcar (lambda (column) - (sxql:drop-column (sxql:make-sql-symbol (car column)))) - columns-to-delete)) - nil) - ;; change columns - (if columns-intersection - (loop with before-alter-sequences = '() - with after-alter-sequences = '() - for db-column in columns-intersection - for table-column = (find (car db-column) table-columns :test #'string= :key #'car) - unless (equalp db-column table-column) - append (case driver-type - (:postgres - (loop for (k v) on (cdr table-column) by #'cddr - for current-value = (getf (cdr db-column) k) - unless (or (eq k :primary-key) ;; ignore :primary-key as it'll be added in the later indices' section - (eql v current-value)) - collect - (case k - (:auto-increment - (let ((seq (format nil "~A_~A_seq" - table-name - (car table-column)))) - (if v - (progn - ;; create a new sequence - (push - (sxql:make-statement :create-sequence (sxql:make-sql-symbol seq)) - before-alter-sequences) - (sxql:make-clause :set-default `(:nextval ,seq))) - (progn - ;; delete the existing sequence - (push - (sxql:make-statement :drop-sequence - (sxql:make-sql-symbol seq)) - after-alter-sequences) - (sxql:make-clause :alter-column - (sxql:make-sql-symbol (car table-column)) - :drop-default t))))) - (otherwise - (sxql:make-clause :alter-column - (sxql:make-sql-symbol (car table-column)) - k v))))) - (otherwise - ;; Don't add PRIMARY KEY if the column is already the primary key - (when (getf (cdr db-column) :primary-key) - (setf (getf (cdr table-column) :primary-key) nil)) - (list - (apply #'sxql:make-clause :modify-column (sxql:make-sql-symbol (car table-column)) - (cdr table-column))))) - into clauses - finally - (return - (nconc - (nreverse before-alter-sequences) - (and clauses - (list (apply #'sxql:make-statement :alter-table (sxql:make-sql-symbol table-name) - clauses))) - (nreverse after-alter-sequences)))) - nil) - ;; add indices - (if indices-to-add - (loop for (index-name . options) in indices-to-add - if (getf options :primary-key) - append - ;; Ignore if the columns are just added. - (if (or (cdr (getf options :columns)) - (not (find (first (getf options :columns)) - columns-to-add - :key #'car - :test #'string=))) - (list - (sxql:make-statement :alter-table (sxql:make-sql-symbol table-name) - (apply #'sxql:make-clause :add-primary-key - (mapcar #'sxql:make-sql-symbol (getf options :columns))))) - nil) - else - collect (sxql:create-index - (sxql:make-sql-symbol index-name) - :unique (getf options :unique-key) - :on (list* (sxql:make-sql-symbol table-name) - (mapcar #'sxql:make-sql-symbol (getf options :columns))))) - nil) - ;; drop indices - (if indices-to-delete - (loop for (index-name . options) in indices-to-delete - ;; Ignore if the index's columns are going to be dropped. - unless (every (lambda (col) - (find col columns-to-delete - :key #'car - :test #'string=)) - (getf options :columns)) - append - (nconc - (when (and (not (eq driver-type :postgres)) - (getf options :primary-key)) - (list (sxql:make-statement :alter-table (sxql:make-sql-symbol table-name) - (sxql:drop-primary-key)))) - (list - (apply #'sxql:drop-index index-name - (if (eq driver-type :postgres) - nil - (list :on (sxql:make-sql-symbol table-name))))))) - nil)))))) + (values + (migration-expressions-between table-name driver-type + db-columns table-columns + db-indices table-indices) + (migration-expressions-between table-name driver-type + table-columns db-columns + table-indices db-indices)))) (defun migration-expressions-for-sqlite3 (class) (let* ((table-name (table-name class)) @@ -335,26 +331,31 @@ If this variable is T they won't be deleted after migration.") (if (equal (table-view-query *connection* (format nil "__~A" (table-name class))) (table-view-query *connection* (table-name class))) nil - (table-definition class :or-replace t)) + (values + (table-definition class :or-replace t) + (list (sxql:make-statement :drop-view (table-name class))))) (execute-sql - (format nil "DROP VIEW ~@[~A~]__~A~@[~A~]" - sxql:*quote-character* - (table-name class) - sxql:*quote-character*)))) + (sxql:make-statement :drop-view + (sxql:make-sql-symbol (format nil "__~A" (table-name class))))))) (dao-table-class - (if (eq driver-type :sqlite3) - (migration-expressions-for-sqlite3 class) - (destructuring-bind (add-columns - drop-columns - change-columns - add-indices - drop-indices) - (migration-expressions-for-others class driver-type) - (nconc drop-indices - (ensure-list drop-columns) - add-columns - change-columns - add-indices)))))) + (flet ((order-expressions (expressions-groups) + (destructuring-bind (add-columns + drop-columns + change-columns + add-indices + drop-indices) + expressions-groups + (append + drop-indices + drop-columns + add-columns + change-columns + add-indices)))) + (if (eq driver-type :sqlite3) + (migration-expressions-for-sqlite3 class) + (multiple-value-bind (up down) + (migration-expressions-for-others class driver-type) + (values (order-expressions up) (order-expressions down)))))))) (defmethod initialize-instance :after ((class dao-table-class) &rest initargs) (declare (ignore initargs)) diff --git a/src/migration/versions.lisp b/src/migration/versions.lisp index 7a68d4a..42cf696 100644 --- a/src/migration/versions.lisp +++ b/src/migration/versions.lisp @@ -86,11 +86,13 @@ (defun all-migration-expressions () (check-connected) - (mapcan (lambda (class) - (if (table-exists-p *connection* (table-name class)) - (migration-expressions class) - (table-definition class))) - (all-dao-classes))) + (loop for class in (all-dao-classes) + for (up down) = (multiple-value-list (migration-expressions class)) + append up into up-expressions + append down into down-expressions + finally (return + (values up-expressions + down-expressions)))) (defun current-migration-version () (initialize-migrations-table) @@ -122,15 +124,9 @@ 1))))) (defun generate-migrations (directory &key force) - (let* ((schema.sql (merge-pathnames #P"schema.sql" directory)) - (directory (merge-pathnames #P"migrations/" directory)) - (current-version (current-migration-version)) - (version (generate-version current-version)) - (destination (make-pathname :name (format nil "~A.up" version) - :type "sql" - :defaults directory)) - (expressions (all-migration-expressions)) - (sxql:*use-placeholder* nil)) + (let ((schema.sql (merge-pathnames #P"schema.sql" directory)) + (directory (merge-pathnames #P"migrations/" directory)) + (current-version (current-migration-version))) ;; Warn if there're non-applied migration files. (let* ((sql-files (sort (uiop:directory-files directory "*.up.sql") @@ -154,34 +150,49 @@ (format *error-output* "~&Given up.~%") (return-from generate-migrations nil))))) - (if (or expressions force) - (progn - (ensure-directories-exist directory) - (with-open-file (out destination - :direction :output - :if-does-not-exist :create) - (let ((out (make-broadcast-stream *standard-output* out))) - (with-quote-char - (map nil - (lambda (ex) - (format out "~&~A;~%" (sxql:yield ex))) - expressions)))) - (with-open-file (out schema.sql - :direction :output - :if-exists :supersede - :if-does-not-exist :create) - (with-quote-char - (format out "~{~{~A;~%~}~^~%~}" - (mapcar (lambda (class) - (mapcar #'sxql:yield (table-definition class))) - (all-dao-classes))) - (format out "~2&~A;~%" - (sxql:yield (schema-migrations-table-definition))))) - (format t "~&Successfully generated: ~A~%" destination) - destination) - (progn - (format t "~&Nothing to migrate.~%") - nil)))) + (flet ((write-expressions (expressions destination) + (ensure-directories-exist directory) + (with-open-file (out destination + :direction :output + :if-does-not-exist :create) + (let ((out (make-broadcast-stream *standard-output* out))) + (with-quote-char + (map nil + (lambda (ex) + (format out "~&~A;~%" (sxql:yield ex))) + expressions)))) + (with-open-file (out schema.sql + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (with-quote-char + (format out "~{~{~A;~%~}~^~%~}" + (mapcar (lambda (class) + (mapcar #'sxql:yield (table-definition class))) + (all-dao-classes))) + (format out "~2&~A;~%" + (sxql:yield (schema-migrations-table-definition))))) + destination)) + (multiple-value-bind + (up-expressions down-expressions) + (all-migration-expressions) + (cond + ((or up-expressions force) + (let* ((version (generate-version current-version)) + (up-destination (make-pathname :name (format nil "~A.up" version) + :type "sql" + :defaults directory)) + (down-destination (make-pathname :name (format nil "~A.down" version) + :type "sql" + :defaults directory)) + (sxql:*use-placeholder* nil)) + (write-expressions up-expressions up-destination) + (write-expressions down-expressions down-destination) + (format t "~&Successfully generated: ~A~%" up-destination) + (values up-destination down-destination))) + (t + (format t "~&Nothing to migrate.~%") + (values))))))) (defun migration-file-version (file) (let* ((name (pathname-name file)) diff --git a/t/db/main.lisp b/t/db/main.lisp index 1eaa18a..9f62eb9 100644 --- a/t/db/main.lisp +++ b/t/db/main.lisp @@ -11,13 +11,13 @@ (ok (equal (column-definitions conn "tweets") (ecase (dbi:connection-driver-type conn) (:mysql - '(("id" :type "int" :auto-increment t :primary-key t :not-null t) - ("status" :type "text" :auto-increment nil :primary-key nil :not-null t) - ("user" :type "varchar(64)" :auto-increment nil :primary-key nil :not-null t))) + '(("id" :type "int" :auto-increment t :primary-key t :not-null t :default nil) + ("status" :type "text" :auto-increment nil :primary-key nil :not-null t :default nil) + ("user" :type "varchar(64)" :auto-increment nil :primary-key nil :not-null t :default nil))) (:postgres - '(("id" :type "integer" :auto-increment t :primary-key t :not-null t) - ("status" :type "text" :auto-increment nil :primary-key nil :not-null t) - ("user" :type "character varying(64)" :auto-increment nil :primary-key nil :not-null t))) + '(("id" :type "integer" :auto-increment t :primary-key t :not-null t :default nil) + ("status" :type "text" :auto-increment nil :primary-key nil :not-null t :default nil) + ("user" :type "character varying(64)" :auto-increment nil :primary-key nil :not-null t :default nil))) (:sqlite3 '(("id" :type "INTEGER" :auto-increment t :primary-key t :not-null t) ("status" :type "TEXT" :auto-increment nil :primary-key nil :not-null t) diff --git a/t/migration/mysql.lisp b/t/migration/mysql.lisp index 5df6489..b0b6ca5 100644 --- a/t/migration/mysql.lisp +++ b/t/migration/mysql.lisp @@ -53,7 +53,7 @@ (mito.migration.table::migration-expressions-for-others (find-class 'tweets) :mysql) (ok (null add-columns) "No columns to add") - (ok (equal (sxql:yield drop-columns) "ALTER TABLE tweets DROP COLUMN id") + (ok (equal (mapcar #'sxql:yield drop-columns) '("ALTER TABLE tweets DROP COLUMN id")) "Drop column id") (ok (null change-columns) "No columns to change") @@ -83,7 +83,7 @@ (ok (equal (mapcar #'sxql:yield add-columns) '("ALTER TABLE tweets ADD COLUMN status text NOT NULL, ADD COLUMN tweet_id int unsigned NOT NULL AUTO_INCREMENT PRIMARY KEY")) "Add id and status") - (ok (equal (sxql:yield drop-columns) "ALTER TABLE tweets DROP COLUMN id") + (ok (equal (mapcar #'sxql:yield drop-columns) '("ALTER TABLE tweets DROP COLUMN id")) "Drop id") (ok (null change-columns) "No columns to change") @@ -117,7 +117,7 @@ (mito.migration.table::migration-expressions-for-others (find-class 'tweets) :mysql) (ok (equal (mapcar #'sxql:yield add-columns) '("ALTER TABLE tweets ADD COLUMN created_at char(8) NOT NULL"))) - (ok (equal (sxql:yield drop-columns) "ALTER TABLE tweets DROP COLUMN status")) + (ok (equal (mapcar #'sxql:yield drop-columns) '("ALTER TABLE tweets DROP COLUMN status"))) (ok (equal (format nil "~{~A~^~%~}" (mapcar #'sxql:yield change-columns)) "ALTER TABLE tweets MODIFY COLUMN user varchar(64) NOT NULL")) diff --git a/t/migration/postgres.lisp b/t/migration/postgres.lisp index 65339bd..441e9ad 100644 --- a/t/migration/postgres.lisp +++ b/t/migration/postgres.lisp @@ -54,7 +54,7 @@ (mito.migration.table::migration-expressions-for-others (find-class 'tweets) :postgres) (ok (null add-columns) "No columns to add") - (ok (equal (sxql:yield drop-columns) "ALTER TABLE tweets DROP COLUMN id") + (ok (equal (mapcar #'sxql:yield drop-columns) '("ALTER TABLE tweets DROP COLUMN id")) "Drop column id") (ok (null change-columns) "No columns to change") @@ -84,7 +84,7 @@ (ok (equal (mapcar #'sxql:yield add-columns) '("ALTER TABLE tweets ADD COLUMN status text NOT NULL, ADD COLUMN tweet_id serial NOT NULL PRIMARY KEY")) "Add id and status") - (ok (equal (sxql:yield drop-columns) "ALTER TABLE tweets DROP COLUMN id") + (ok (equal (mapcar #'sxql:yield drop-columns) '("ALTER TABLE tweets DROP COLUMN id")) "Drop id") (ok (null change-columns) "No columns to change") @@ -118,7 +118,7 @@ (mito.migration.table::migration-expressions-for-others (find-class 'tweets) :postgres) (ok (equal (mapcar #'sxql:yield add-columns) '("ALTER TABLE tweets ADD COLUMN created_at character(8) NOT NULL"))) - (ok (equal (sxql:yield drop-columns) "ALTER TABLE tweets DROP COLUMN status")) + (ok (equal (mapcar #'sxql:yield drop-columns) '("ALTER TABLE tweets DROP COLUMN status"))) (ok (equal (format nil "~{~A~^~%~}" (mapcar #'sxql:yield change-columns)) "ALTER TABLE tweets ALTER COLUMN user TYPE character varying(64)"))