1  (in-package :ami.modeling)
  2  
  3  (defclass table-metadata ()
  4    ((name :initarg :name :accessor table-metadata-name)
  5     (fields :initform (make-hash-table) :accessor table-metadata-fields)))
  6  
  7  (defmethod print-object ((tm table-metadata) out)
  8    (print-unreadable-object (tm out :type t)
  9      (format out "~s" (table-metadata-name tm))))
 10  
 11  (defclass column-metadata ()
 12    ((name :initarg :name :accessor col-metadata-name)
 13     (data-type :initarg :data-type :accessor col-metadata-data-type)
 14     (is-nullable :initarg :is-nullable :accessor col-metadata-is-nullable)
 15     (is-unique :initarg :is-unique :accessor col-metadata-is-unique)
 16     (is-primary-key :initarg :is-primary-key :accessor col-metadata-is-primary-key)
 17     (is-foreign-key :initarg :is-foreign-key :accessor col-metadata-is-foreign-key)))
 18  
 19  (defmethod print-object ((cm column-metadata) out)
 20    (print-unreadable-object (cm out :type t)
 21      (format out "~s ~a ~:[~; PRIMARY KEY~]~:[~; NOT NULL~]~:[~; UNIQUE~]"
 22              (col-metadata-name cm)
 23              (col-metadata-data-type cm)
 24              (col-metadata-is-primary-key cm)
 25              (not (col-metadata-is-nullable cm))
 26              (col-metadata-is-unique cm))))
 27  
 28  (defun table-exists (table-name)
 29    (let ((tbl (car (run-query 
 30                     "SELECT table_name FROM information_schema.tables WHERE table_name = $1" 
 31                     `(,table-name)))))
 32      tbl))
 33  
 34  (define-condition migration-error (error) 
 35    ((error-desc :initarg :error-desc :accessor migration-error-desc)))
 36  
 37  (define-condition change-in-uniqueness-not-supported (migration-error) ())
 38  (define-condition change-in-pkey-not-supported (migration-error) ())
 39  (define-condition change-in-fkey-not-supported (migration-error) ())
 40  (define-condition change-in-data-type-not-supported (migration-error) ())
 41  
 42  (defmethod equal-field-p ((cm column-metadata) (fd field-definition))
 43    "Predicate checking if a model field definition matches the column metadata as gotten from the DB"
 44    (and (eql (col-metadata-is-nullable cm) (fdef-nullable fd))
 45         (eql (col-metadata-is-unique cm) (fdef-unique fd))
 46         (eql (col-metadata-is-primary-key cm) (fdef-primary-key fd))
 47         (eql (col-metadata-is-foreign-key cm) (fdef-foreign-key fd))
 48         (eql (col-metadata-data-type cm) (db-type fd))))
 49  
 50  (defmethod generate-field-migration ((cm column-metadata) (fd field-definition))
 51    "Generate the needed SQL statements to make a postgres column match the given field-defition.
 52  
 53  The column metadata has to be given already and can be created by using the `get-table-information' function."
 54    (let ((alters nil))
 55      (when (not (eql (col-metadata-is-nullable cm) (fdef-nullable fd)))
 56        (push (format nil "ALTER COLUMN \"~a\" ~:[DROP~;SET~] NOT NULL" (col-metadata-name cm) (not (fdef-nullable fd))) alters))
 57      (when (not (eql (col-metadata-is-unique cm) (fdef-unique fd)))
 58        (error 'change-in-uniqueness-not-supported))
 59      (when (not (eql (col-metadata-is-primary-key cm) (fdef-primary-key fd)))
 60        (error 'change-in-pkey-not-supported))
 61      (when (not (eql (col-metadata-is-foreign-key cm) (fdef-foreign-key fd)))
 62        (error 'change-in-fkey-not-supported))
 63      (when (not (eql (col-metadata-data-type cm) (db-type fd)))
 64        (error 'change-in-data-type-not-supported))
 65      alters))
 66  
 67  (defun get-table-information (table-name package)
 68    "Returns a `table-metadata' object with all the needed metadata of the given `table-name'.
 69  
 70  The model package has to be given so the model columns can be compared properly.
 71  
 72  TODO(Marce): Maybe instead take a mdef so this implementation detail is not exposed?"
 73    (let ((tbl-info (run-query "
 74  WITH table_constraints AS (
 75          SELECT * FROM information_schema.table_constraints
 76          JOIN information_schema.constraint_column_usage AS cu USING (constraint_name)
 77          WHERE cu.table_name = $1
 78  )
 79  SELECT column_name, data_type, is_nullable = 'YES' AS is_nullable,
 80  EXISTS (SELECT * FROM table_constraints AS tc WHERE tc.column_name = c.column_name AND constraint_type = 'UNIQUE') AS is_unique,
 81  EXISTS (SELECT * FROM table_constraints AS tc WHERE tc.column_name = c.column_name AND constraint_type = 'PRIMARY KEY') AS is_primary_key,
 82  EXISTS (SELECT * FROM table_constraints AS tc WHERE tc.column_name = c.column_name AND constraint_type = 'FOREIGN KEY') AS is_foreign_key
 83  FROM information_schema.columns AS c WHERE table_name = $1"
 84                               `(,table-name)))
 85          (tbl-info-inst (make-instance 'table-metadata :name table-name)))
 86      (dolist (col-info tbl-info)
 87        (let ((col-metadata (make-instance 'column-metadata
 88                                           :name (getf col-info :|column_name|)
 89                                           :data-type (alexandria:format-symbol 
 90                                                       (find-package "KEYWORD")
 91                                                       "~@:(~a~)"
 92                                                       (getf col-info :|data_type|))
 93                                           :is-nullable (getf col-info :|is_nullable|)
 94                                           :is-unique (getf col-info :|is_unique|)
 95                                           :is-primary-key (getf col-info :|is_primary_key|)
 96                                           :is-foreign-key (getf col-info :|is_foregin_key|))))
 97          (setf (gethash (alexandria:format-symbol package "~@:(~a~)" (col-metadata-name col-metadata)) 
 98                         (table-metadata-fields tbl-info-inst))
 99                col-metadata)))
100      tbl-info-inst))
101  
102