db.lisp 11.1 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
                         (list :type (if (not-null-p slot)
                                         (slot-definition-type  slot)
Ryszard Szopa's avatar
Ryszard Szopa committed
33
                                         `(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
            (error err))))
    ; here should be some code dropping constraints that are not necessary
80
81
    (apply-foreign-key-constraints class)
    (apply-unique-constraints class)))
ryszard.szopa's avatar
ryszard.szopa committed
82
83
84
85
86

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

87
88
89
90
91
92
93
(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;"
ryszard.szopa's avatar
ryszard.szopa committed
94
                                         (sql-ize  (class-name class))
95
96
97
98
99
100
101
102
103
104
105
106
                                         (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)))
107
  (format nil "UNIQUE \(~A\)"
108
109
          (sql-ize (slot-definition-name slot))))

110
111
112
113
114
115
116
117
118
119
120
121
(defmethod add-constraint ((list list) (constraint (eql :unique)))
  (assert (every (lambda (x)
                   (typep x 'db-class-slot-definition)) list))
  (let ((class (slot-value (car list) 'sb-pcl::allocation-class)))
    (with-class-connection (class)
      (postmodern:execute (format nil "ALTER TABLE ~A ADD UNIQUE (~A~{, ~A~});"
                                  (sql-ize  (class-name class))
                                  (sql-ize (slot-definition-name  (car list)))
                                  (mapcar #'(lambda (x)
                                              (sql-ize (slot-definition-name x))) (cdr list)))))))


122
123
124
125
(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))))
ryszard.szopa's avatar
ryszard.szopa committed
126
127
          (handler-case 
              (funcall closure)
128
129
130
131
132
            (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
133
134
135
136
137
                (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
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155

(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
156
157
158
159
  (: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
160
161
162
  (:method ((class db-class))
    (let ((class-name (class-name class)))
      (labels
163
164
165
166
167
          ((ensure-list (x)
             (if (listp x)
                 x
                 (list x)))
           (prepare-field (field)
ryszard.szopa's avatar
ryszard.szopa committed
168
             (list (sql-ize (slot-definition-name field))
169
170
                   (string-downcase (apply #'sql-type-name (ensure-list (or (and (foreign-type-p field) 'integer)
                                                                            (slot-definition-type field)))))))
ryszard.szopa's avatar
ryszard.szopa committed
171
172
173
174
175
176
177
           (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 
178
               (mapcar #'prepare-field (class-db-slots class)))
ryszard.szopa's avatar
ryszard.szopa committed
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
              (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
210
      ; do here something with constraints involving the table
ryszard.szopa's avatar
ryszard.szopa committed
211
212
      (values))))

ryszard.szopa's avatar
ryszard.szopa committed
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
;;; 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
234
;;;    distribution.