db.lisp 8.96 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
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
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
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
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
193
194
195
196
;;;; -*- 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."))
  (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.")
  (: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."))

ryszard.szopa's avatar
ryszard.szopa committed
197
(defmethod update-dao ((dao dao))
ryszard.szopa's avatar
ryszard.szopa committed
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
  (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)