db.lisp 10.3 KB
Newer Older
ryszard.szopa's avatar
ryszard.szopa committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
;;;; -*- 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."))

17
18
19
;; FIXME: CREATE-TABLE tests for the right columns and column-types,
;; but doesn't test if the constraints of the table are right. So, if
;; we change a foreign key in the class, PostgreSQL doesn't notice it.
ryszard.szopa's avatar
ryszard.szopa committed
20
21
22
(defmethod create-table ((class db-class))
  (unless (class-finalized-p class)
    (error "The class is not finalized."))
ryszard.szopa's avatar
ryszard.szopa committed
23
24
25
26
27
28
29
  (with-class-connection (class)
    (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)
ryszard.szopa's avatar
ryszard.szopa committed
30
                         (list :type (if (not-null-p slot) 'integer '(or db-null integer)))
31
32
33
                         (list :type (if (not-null-p slot)
                                         (slot-definition-type  slot)
                                         `(or db-null ,(slot-definition-type  slot)))))))
34
35
36
37
            (postmodern:with-transaction ()
              (postmodern:execute
               (sql-compile
                `(:create-table ,class-name
38
                  ,(iter (for slot in (class-db-slots  class))
39
40
41
42
43
44
45
46
47
                         (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))))))
ryszard.szopa's avatar
ryszard.szopa committed
48
49
50
51
52
53
54
55
56
57
58
59
60
      (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
ryszard.szopa's avatar
ryszard.szopa committed
61
62
63
table. (Note that allocate-instance the changes for one table are done
in a transaction, so if at any time you choose abort the changes will
be reverted.)"
ryszard.szopa's avatar
ryszard.szopa committed
64
                              (postmodern:execute (format nil "ALTER TABLE ~A ADD COLUMN ~A ~A;"
65
                                                          (sql-ize (table-name err)) (column-name err) (column-type err))))
ryszard.szopa's avatar
ryszard.szopa committed
66
67
68
69
                      (ignore () ())))
                  (sql-column-error (err)
                    (restart-case (error err)
                      (fix-it () :report "Alter the type of the
ryszard.szopa's avatar
ryszard.szopa committed
70
71
72
   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."
ryszard.szopa's avatar
ryszard.szopa committed
73
                              (postmodern:execute (format nil "ALTER TABLE ~A ALTER COLUMN ~A TYPE ~A"
74
                                                          (sql-ize (table-name err)) (column-name err) (needed-type err))))
ryszard.szopa's avatar
ryszard.szopa committed
75
76
77
                      (ignore () ())))))
              
              (warn "Table ~A already exists." (class-name class)))
ryszard.szopa's avatar
ryszard.szopa committed
78
79
80
            (error err))))
    ; here should be some code dropping constraints that are not necessary
    (apply-foreign-key-constraints class)))
ryszard.szopa's avatar
ryszard.szopa committed
81
82
83
84
85

(defmethod create-table ((name symbol))
  (let ((class (find-class name)))
    (create-table class)))

86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
(defgeneric add-constraint (slot constraint)
  (:documentation "Add a constraint to this slot's class' table."))

(defmethod add-constraint :around ((slot db-class-slot-definition) constraint)
         (let ((class (slot-value slot 'sb-pcl::allocation-class)))
           (with-class-connection (class)
             (postmodern:execute (format nil "ALTER TABLE ~A ADD ~A;"
                                         (class-name class)
                                         (call-next-method))))))

(defmethod add-constraint ((slot db-class-slot-definition) (constraint (eql :foreign-key)))
  (format nil "FOREIGN KEY (~A) REFERENCES ~A ON DELETE ~A"
          (sql-ize (slot-definition-name slot))
          (sql-ize (slot-definition-type slot))
          (case (on-delete slot)
            (:set-null "SET NULL")
            (:set-default "SET DEFAULT")
            (otherwise (on-delete slot)))))

(defmethod add-constraint ((slot db-class-slot-definition) (constraint (eql :unique)))
  (format nil "UNIQUE ~A"
          (sql-ize (slot-definition-name slot))))

(defmethod apply-foreign-key-constraints ((class db-class))
  (iter (for slot in (db-class-foreign-keys class))
        (let ((closure (lambda ()
                         (add-constraint slot :foreign-key))))
          ;todo: in case of errors store the closure
          (handler-case (funcall closure)
            (database-error ()
              (setf (delayed-constraint slot) closure)
              (unless (member class (db-class-unfinished-classes class)
                              :test (lambda (x y)
                                      (eql (class-name x) (class-name y))))
ryszard.szopa's avatar
ryszard.szopa committed
120
121
122
123
124
                (push class (db-class-unfinished-classes class))))))))

(defmethod apply-unique-constraints ((class db-class))
  (iter (for slot in (db-class-unique-keys class))
        (add-constraint slot :unique)))
ryszard.szopa's avatar
ryszard.szopa committed
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142

(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)
ryszard.szopa's avatar
ryszard.szopa committed
143
144
145
146
  (: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.")
ryszard.szopa's avatar
ryszard.szopa committed
147
148
149
150
151
152
153
154
155
156
157
158
159
160
  (: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 
161
               (mapcar #'prepare-field (class-db-slots class)))
ryszard.szopa's avatar
ryszard.szopa committed
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
              (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)))))))
ryszard.szopa's avatar
ryszard.szopa committed
193
      ; do here something with constraints involving the table
ryszard.szopa's avatar
ryszard.szopa committed
194
195
      (values))))

ryszard.szopa's avatar
ryszard.szopa committed
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
;;; Copyright (C) 2007
;;; Ryszard Szopa <ryszard.szopa@gmail.com> & 
;;; Streamtech http://streamtech.nl/
;;;
;;; This software is provided 'as-is', without any express or implied
;;; warranty. In no event will the authors be held liable for any
;;; damages arising from the use of this software.
;;;
;;; Permission is granted to anyone to use this software for any
;;; purpose, including commercial applications, and to alter it and
;;; redistribute it freely, subject to the following restrictions:
;;;
;;; 1. The origin of this software must not be misrepresented; you must
;;;    not claim that you wrote the original software. If you use this
;;;    software in a product, an acknowledgment in the product
;;;    documentation would be appreciated but is not required.
;;;
;;; 2. Altered source versions must be plainly marked as such, and must
;;;    not be misrepresented as being the original software.
;;;
;;; 3. This notice may not be removed or altered from any source
;;;    distribution.