;;;; -*- 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)))) ;; ;; DAO ;; ;; (defclass dao () ((id :type integer :accessor get-id :initarg :id)) (:indices) (:metaclass db-class) (:documentation "Base class for any PostgreSQL aware classes.")) (defgeneric save-dao (object) (:documentation "Save a dao: update it when it already exists, insert it otherwise.") (:method ((dao dao)) (if (dao-exists-p dao) (update-dao dao) (insert-dao dao)))) (defgeneric save-all-foreign-daos (dao) (:documentation "Saves recursively all daos in the slots of DAO") (:method ((dao dao)) (iter (for slot in (non-transient-slots-of dao)) (let ((s-value (slot-value dao slot))) (when (typep s-value 'dao) (save-dao s-value)))))) (defgeneric dao-exists-p (dao) (:documentation "Return a boolean indicating whether the given dao exists in the database.") (:method ((dao dao)) (and (slot-boundp dao 'id) (postmodern::query (:select (:exists (:select 1 :from (class-name-of dao) :where (:= 'id (get-id dao))))) :single)))) (defun set-fields (object) (iter (for field in (slots-of object)) (appending `(',field ,(slot-value-or-id-if-foreign object field))))) (defun id-seq-name (class) (intern (format nil "~A-ID-SEQ" (class-name class)) :keyword)) (defgeneric insert-dao (dao) (:documentation "Insert the given dao into the database.") (:method ((dao dao)) (unless (slot-boundp dao 'id) (setf (slot-value dao 'id) (postmodern::sequence-next (id-seq-name (class-of dao))))) (postmodern::execute (sql-compile `(:insert-into ,(class-name-of dao) :set ,@(set-fields dao)))))) (defgeneric update-dao (dao) (:documentation "Update the dao's representation in the database with the values in the given object.")) (defmethod update-dao ((dao dao)) (postmodern::execute (sql-compile `(:update ,(class-name-of dao) :set ,@(set-fields dao) :where (:= 'id (get-id dao)))))) (defgeneric delete-dao (dao) (:documentation "Delete the given dao from the database.")) (defclass test1 (dao) ((foo :type integer :accessor foo :initarg :foo)) (:metaclass db-class)) (defclass test2 (dao) ((foreign-foo :type test1 :initarg :foo) (transient-slot :type integer :transient t)) (:metaclass db-class)) ; (select object type &optional test)