;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; -*- (in-package :submarine) ;; ;; Database stuff ;; ;; (defgeneric create-table (class) (:documentation "Create a table whose columns match the fields of CLASS in the connected database. If CLASS is a symbol, the class it names is used.")) (defmethod create-table ((class db-class)) (unless (class-finalized-p class) (error "The class is not finalized.")) (with-connection-fun (db-class-connection-spec class) (lambda () (handler-case (let ((class-name (class-name class))) (labels ((index-name (fields) (format nil "~A~{_~A~}_index" (to-sql-name class-name) (mapcar #'to-sql-name fields))) (type-and-reference (slot) (if (foreign-type-p slot) (list :type 'integer :references (list (list (slot-definition-type slot) 'id) :cascade)) ;is this cascade ok? `(:type ,(slot-definition-type slot))))) (postmodern:execute (sql-compile `(:create-table ,class-name ,(iter (for slot in (class-non-transient-slots class)) (collect (cons (slot-definition-name slot) (type-and-reference slot)))) (:primary-key id)))) ;id is hardcoded as a primary key (dolist (index (mapcar (lambda (x) (if (consp x) x (list x)))(db-class-indices class))) (postmodern:execute (sql-compile `(:create-index (:raw ,(index-name index)) :on ,class-name :fields ,@index)))) (postmodern:execute (:create-sequence (id-seq-name class))))) (database-error (err) (if (string= (database-error-code err) "42P07") ;table already exists (progn (postmodern:with-transaction () ;; FIXME: This may be considered as a quick ;; hack. S-SQL should be changed to support ALTER ;; commands. (handler-case (database-consistent-with-specification class) (sql-column-does-not-exist (err) (restart-case (error err) (fix-it () :report "Add the column to the table. (Note that all the changes for one table are done in a transaction, so if at any time you choose abort the changes will be reverted.)" (postmodern:execute (format nil "ALTER TABLE ~A ADD COLUMN ~A ~A;" (table-name err) (column-name err) (column-type err)))) (ignore () ()))) (sql-column-error (err) (restart-case (error err) (fix-it () :report "Alter the type of the column. (Note that all the changes for one table are done in a transaction, so if at any time you choose abort the changes will be reverted." (postmodern:execute (format nil "ALTER TABLE ~A ALTER COLUMN ~A TYPE ~A" (table-name err) (column-name err) (needed-type err)))) (ignore () ()))))) (warn "Table ~A already exists." (class-name class))) (error err))))))) (defmethod create-table ((name symbol)) (let ((class (find-class name))) (create-table class))) (define-condition sql-error (simple-error) ((table :initarg :table-name :reader table-name)) (:documentation "Base class for SQL related errors.")) (define-condition sql-column-error (sql-error) ((name :initarg :name :reader column-name) (needed-type :initarg :needed :reader needed-type) (actual-type :initarg :actual :reader actual-type)) (:documentation "An error symbolizing that there is a column of the right name in the table, but its type is wrong")) (define-condition sql-column-does-not-exist (sql-error) ((name :initarg :name :reader column-name) (type :initarg :type :reader column-type)) (:documentation "Condition signaling a missing column in an existing table.")) (defgeneric database-consistent-with-specification (class) (:documentation "Return nothing if TABLE in the connected-p database meets its specification. Otherwise, throw an appropriate error. There must exist a connection to the DATABASE in order to run this function.") (:method ((class db-class)) (let ((class-name (class-name class))) (labels ((prepare-field (field) (list (sql-ize (slot-definition-name field)) (string-downcase (sql-type-name (or (and (foreign-type-p field) 'integer) (slot-definition-type field)))))) (extract-type (field) (read-from-string (second field))) (field= (field1 field2) (and (equal (car field1) (car field2)) (string= (extract-type field1) (extract-type field2))))) (let ((fields (mapcar #'prepare-field (class-non-transient-slots class))) (columns (postmodern::query (sql (:select 'column-name 'data-type :from 'information_schema.columns :where (:= 'table-name (sql-ize class-name))))))) ;; we test whether there are any additional columns in the table ;; in the database (iter (for column in columns) (unless (member column fields :test #'equal) (warn "There's an additional column \"~A\" of type ~A in table ~A. This may indicate that something is wrong." (first column) (second column) class-name))) ;; we test if all the specified fields have an appropriate column ;; counterpart in the db (iter (for field in fields) (unless (and (member field columns :test #'field=)) (if (member (car field) (mapcar #'car columns) :test #'string=) ;; column exists, but type is wrong (error 'sql-column-error :table-name class-name :name (first field) :needed (second field) :actual (assoc (car field) columns :test #'string=) :format-control "Column ~A exists in table ~A, but its type is wrong." :format-arguments (list field class-name)) ;; the column does not exist (error 'sql-column-does-not-exist :table-name class-name :name (first field) :type (second field) :format-control "Column ~A in table ~A does not exist." :format-arguments (list (car field) class-name))))))) (values))))