add support for postgres time type
[postmodern.git] / postmodern / table.lisp
blob64803a5f378a4e325606eb634c16fec688fcec5a
1 (in-package :postmodern)
3 (defclass dao-class (standard-class)
4 ((direct-keys :initarg :keys :initform nil :reader direct-keys)
5 (effective-keys :reader dao-keys)
6 (table-name)
7 (column-map :reader dao-column-map))
8 (:documentation "Metaclass for database-access-object classes."))
10 (defmethod dao-keys :before ((class dao-class))
11 (unless (class-finalized-p class)
12 (finalize-inheritance class)))
14 (defmethod validate-superclass ((class dao-class) (super-class standard-class))
17 (defmethod dao-keys ((class-name symbol))
18 (dao-keys (find-class class-name)))
20 (defmethod dao-keys (dao)
21 (mapcar #'(lambda (slot)
22 (slot-value dao slot))
23 (dao-keys (class-of dao))))
25 (defun dao-column-slots (class)
26 "Enumerate the slots in a class that refer to table rows."
27 (mapcar 'slot-column
28 (remove-if-not (lambda (x) (typep x 'effective-column-slot))
29 (class-slots class))))
30 (defun dao-column-fields (class)
31 (mapcar 'slot-definition-name (dao-column-slots class)))
33 (defun dao-table-name (class)
34 (when (symbolp class)
35 (setf class (find-class class)))
36 (if (slot-boundp class 'table-name)
37 (slot-value class 'table-name)
38 (class-name class)))
40 (defmethod shared-initialize :before ((class dao-class) slot-names
41 &key table-name &allow-other-keys)
42 (declare (ignore slot-names))
43 (setf (slot-value class 'direct-keys) nil)
44 (if table-name
45 (setf (slot-value class 'table-name)
46 (if (symbolp (car table-name)) (car table-name) (intern (car table-name))))
47 (slot-makunbound class 'table-name)))
49 (defun dao-superclasses (class)
50 "Build a list of superclasses of a given class that are DAO
51 classes."
52 (let ((found ()))
53 (labels ((explore (class)
54 (when (typep class 'dao-class)
55 (pushnew class found))
56 (mapc #'explore (class-direct-superclasses class))))
57 (explore class)
58 found)))
60 (defmethod finalize-inheritance :after ((class dao-class))
61 "Building a row reader and a set of methods can only be done after
62 inheritance has been finalised."
63 ;; The effective set of keys of a class is the union of its keys and
64 ;; the keys of all its superclasses.
65 (setf (slot-value class 'effective-keys)
66 (reduce 'union (mapcar 'direct-keys (dao-superclasses class))))
67 (unless (every (lambda (x) (member x (dao-column-fields class))) (dao-keys class))
68 (error "Class ~A has a key that is not also a slot." (class-name class)))
69 (build-dao-methods class))
72 (defclass direct-column-slot (standard-direct-slot-definition)
73 ((col-type :initarg :col-type :reader column-type)
74 (col-default :initarg :col-default :reader column-default)
75 (ghost :initform nil :initarg :ghost :reader ghost)
76 (sql-name :reader slot-sql-name))
77 (:documentation "Type of slots that refer to database columns."))
79 (defmethod shared-initialize :after ((slot direct-column-slot) slot-names
80 &key col-type col-default (col-name nil col-name-p) &allow-other-keys)
81 (declare (ignore slot-names))
82 (setf (slot-value slot 'sql-name) (to-sql-name
83 (if col-name-p
84 col-name
85 (slot-definition-name slot))))
86 ;; The default for nullable columns defaults to :null.
87 (when (and (null col-default) (consp col-type) (eq (car col-type) 'or)
88 (member 'db-null col-type) (= (length col-type) 3))
89 (setf (slot-value slot 'col-default) :null)))
91 (defmethod direct-slot-definition-class ((class dao-class) &key column col-type &allow-other-keys)
92 "Slots that have a :col-type option are column-slots."
93 (if (or column col-type)
94 (find-class 'direct-column-slot)
95 (call-next-method)))
97 (defparameter *direct-column-slot* nil
98 "This is used to communicate the fact that a slot is a column to
99 effective-slot-definition-class.")
101 (defclass effective-column-slot (standard-effective-slot-definition)
102 ((direct-slot :initform *direct-column-slot* :reader slot-column)))
104 (defmethod compute-effective-slot-definition ((class dao-class) name direct-slot-definitions)
105 (declare (ignore name))
106 (flet ((is-column (slot) (typep slot 'direct-column-slot)))
107 (let ((*direct-column-slot* (find-if #'is-column direct-slot-definitions)))
108 #+(or) ;; Things seem to work without this check. Removed for now.
109 (when (and *direct-column-slot*
110 (not (every #'is-column direct-slot-definitions)))
111 (error "Slot ~a in class ~a is both a column slot and a regular slot." name class))
112 (call-next-method))))
114 (defmethod effective-slot-definition-class ((class dao-class) &rest initargs)
115 (declare (ignore initargs))
116 (if *direct-column-slot*
117 (find-class 'effective-column-slot)
118 (call-next-method)))
120 (defgeneric dao-exists-p (dao)
121 (:documentation "Return a boolean indicating whether the given dao
122 exists in the database."))
123 (defgeneric insert-dao (dao)
124 (:documentation "Insert the given object into the database."))
125 (defgeneric update-dao (dao)
126 (:documentation "Update the object's representation in the database
127 with the values in the given instance."))
128 (defgeneric delete-dao (dao)
129 (:documentation "Delete the given dao from the database."))
130 (defgeneric upsert-dao (dao)
131 (:documentation "Update or insert the given dao. If its primary key
132 is already in the database and all slots are bound, an update will
133 occur. Otherwise it tries to insert it."))
134 (defgeneric get-dao (type &rest args)
135 (:method ((class-name symbol) &rest args)
136 (let ((class (find-class class-name)))
137 (if (class-finalized-p class)
138 (error "Class ~a has no key slots." (class-name class))
139 (finalize-inheritance class))
140 (apply 'get-dao class-name args)))
141 (:documentation "Get the object corresponding to the given primary
142 key, or return nil if it does not exist."))
143 (defgeneric make-dao (type &rest args &key &allow-other-keys)
144 (:method ((class-name symbol) &rest args &key &allow-other-keys)
145 (let ((class (find-class class-name)))
146 (apply 'make-dao class args)))
147 (:method ((class dao-class) &rest args &key &allow-other-keys)
148 (unless (class-finalized-p class)
149 (finalize-inheritance class))
150 (let ((instance (apply #'make-instance class args)))
151 (insert-dao instance)))
152 (:documentation "Make the instance of the given class and insert it into the database"))
154 (defmacro define-dao-finalization (((dao-name class) &rest keyword-args) &body body)
155 (let ((args-name (gensym)))
156 `(defmethod make-dao :around ((class (eql ',class))
157 &rest ,args-name
158 &key ,@keyword-args &allow-other-keys)
159 (declare (ignorable ,args-name))
160 (let ((,dao-name (call-next-method)))
161 ,@body
162 (update-dao ,dao-name)))))
164 (defgeneric fetch-defaults (object)
165 (:documentation "Used to fetch the default values of an object on
166 creation."))
168 (defun %eval (code)
169 (funcall (compile nil `(lambda () ,code))))
171 (defun build-dao-methods (class)
172 "Synthesise a number of methods for a newly defined DAO class.
173 \(Done this way because some of them are not defined in every
174 situation, and each of them needs to close over some pre-computed
175 values.)"
177 (setf (slot-value class 'column-map)
178 (mapcar (lambda (s) (cons (slot-sql-name s) (slot-definition-name s))) (dao-column-slots class)))
180 (%eval
181 `(let* ((fields (dao-column-fields ,class))
182 (key-fields (dao-keys ,class))
183 (ghost-slots (remove-if-not 'ghost (dao-column-slots ,class)))
184 (ghost-fields (mapcar 'slot-definition-name ghost-slots))
185 (value-fields (remove-if (lambda (x) (or (member x key-fields) (member x ghost-fields))) fields))
186 (table-name (dao-table-name ,class)))
187 (labels ((field-sql-name (field)
188 (make-symbol (car (find field (slot-value ,class 'column-map) :key #'cdr :test #'eql))))
189 (test-fields (fields)
190 `(:and ,@(loop :for field :in fields :collect (list := (field-sql-name field) '$$))))
191 (set-fields (fields)
192 (loop :for field :in fields :append (list (field-sql-name field) '$$)))
193 (slot-values (object &rest slots)
194 (loop :for slot :in (apply 'append slots) :collect (slot-value object slot))))
196 ;; When there is no primary key, a lot of methods make no sense.
197 (when key-fields
198 (let ((tmpl (sql-template `(:select (:exists (:select t :from ,table-name
199 :where ,(test-fields key-fields)))))))
200 (defmethod dao-exists-p ((object ,class))
201 (and (every (lambda (s) (slot-boundp object s)) key-fields)
202 (query (apply tmpl (slot-values object key-fields)) :single))))
204 ;; When all values are primary keys, updating makes no sense.
205 (when value-fields
206 (let ((tmpl (sql-template `(:update ,table-name :set ,@(set-fields value-fields)
207 :where ,(test-fields key-fields)))))
208 (defmethod update-dao ((object ,class))
209 (when (zerop (execute (apply tmpl (slot-values object value-fields key-fields))))
210 (error "Updated row does not exist."))
211 object)
213 (defmethod upsert-dao ((object ,class))
214 (handler-case
215 (if (zerop (execute (apply tmpl (slot-values object value-fields key-fields))))
216 (values (insert-dao object) t)
217 (values object nil))
218 (unbound-slot ()
219 (values (insert-dao object) t))))))
221 (let ((tmpl (sql-template `(:delete-from ,table-name :where ,(test-fields key-fields)))))
222 (defmethod delete-dao ((object ,class))
223 (execute (apply tmpl (slot-values object key-fields)))))
225 (let ((tmpl (sql-template `(:select * :from ,table-name :where ,(test-fields key-fields)))))
226 (defmethod get-dao ((type (eql (class-name ,class))) &rest keys)
227 (car (exec-query *database* (apply tmpl keys) (dao-row-reader ,class))))))
229 (defmethod insert-dao ((object ,class))
230 (let (bound unbound)
231 (loop :for field :in fields
232 :do (if (slot-boundp object field)
233 (push field bound)
234 (push field unbound)))
236 (let* ((values (mapcan (lambda (x) (list (field-sql-name x) (slot-value object x)))
237 (remove-if (lambda (x) (member x ghost-fields)) bound) ))
238 (returned (query (sql-compile `(:insert-into ,table-name
239 :set ,@values
240 ,@(when unbound (cons :returning unbound))))
241 :row)))
242 (when unbound
243 (loop :for value :in returned
244 :for field :in unbound
245 :do (setf (slot-value object field) value)))))
246 object)
249 (let* ((defaulted-slots (remove-if-not (lambda (x) (slot-boundp x 'col-default))
250 (dao-column-slots ,class)))
251 (defaulted-names (mapcar 'slot-definition-name defaulted-slots))
252 (default-values (mapcar 'column-default defaulted-slots)))
253 (if defaulted-slots
254 (defmethod fetch-defaults ((object ,class))
255 (let (names defaults)
256 ;; Gather unbound slots and their default expressions.
257 (loop :for slot-name :in defaulted-names
258 :for default :in default-values
259 :do (unless (slot-boundp object slot-name)
260 (push slot-name names)
261 (push default defaults)))
262 ;; If there are any unbound, defaulted slots, fetch their content.
263 (when names
264 (loop :for value :in (query (sql-compile (cons :select defaults)) :list)
265 :for slot-name :in names
266 :do (setf (slot-value object slot-name) value)))))
267 (defmethod fetch-defaults ((object ,class))
268 nil)))
270 (defmethod shared-initialize :after ((object ,class) slot-names
271 &key (fetch-defaults nil) &allow-other-keys)
272 (declare (ignore slot-names))
273 (when fetch-defaults
274 (fetch-defaults object)))))))
276 (defparameter *custom-column-writers* nil
277 "A hook for locally overriding/adding behaviour to DAO row readers.
278 Should be an alist mapping strings (column names) to symbols or
279 functions. Symbols are interpreted as slot names that values should be
280 written to, functions are called with the new object and the value as
281 arguments.")
283 (defmacro with-column-writers ((&rest defs) &body body)
284 `(let ((*custom-column-writers* (append (list ,@(loop :for (field writer) :on defs :by #'cddr
285 :collect `(cons (to-sql-name ,field) ,writer)))
286 *custom-column-writers*)))
287 ,@body))
289 (defparameter *ignore-unknown-columns* nil)
291 (defun dao-from-fields (class column-map query-fields result-next-field-generator-fn)
292 (let ((instance (allocate-instance class)))
293 (loop :for field :across query-fields
294 :for writer := (cdr (assoc (field-name field) column-map :test #'string=))
295 :do (etypecase writer
296 (null (if *ignore-unknown-columns*
297 (funcall result-next-field-generator-fn field)
298 (error "No slot named ~a in class ~a. DAO out of sync with table, or incorrect query used."
299 (field-name field) (class-name class))))
300 (symbol (setf (slot-value instance writer) (funcall result-next-field-generator-fn field)))
301 (function (funcall writer instance (funcall result-next-field-generator-fn field)))))
302 (initialize-instance instance)
303 instance))
305 (defun dao-row-reader (class)
306 "Defines a row-reader for objects of a given class."
307 (row-reader (query-fields)
308 (let ((column-map (append *custom-column-writers* (dao-column-map class))))
309 (loop :while (next-row)
310 :collect (dao-from-fields class column-map query-fields #'next-field)))))
312 (defun save-dao (dao)
313 "Try to insert the content of a DAO. If this leads to a unique key
314 violation, update it instead."
315 (handler-case (progn (insert-dao dao) t)
316 (cl-postgres-error:unique-violation ()
317 (update-dao dao)
318 nil)))
320 (defun save-dao/transaction (dao)
321 (handler-case (with-savepoint save-dao/transaction (insert-dao dao) t)
322 (cl-postgres-error:unique-violation ()
323 (update-dao dao)
324 nil)))
326 (defun query-dao% (type query row-reader &rest args)
327 (let ((class (find-class type)))
328 (unless (class-finalized-p class)
329 (finalize-inheritance class))
330 (if args
331 (progn
332 (prepare-query *database* "" query)
333 (exec-prepared *database* "" args row-reader))
334 (exec-query *database* query row-reader))))
336 (defmacro query-dao (type query &rest args)
337 "Execute a query and return the result as daos of the given type.
338 The fields returned by the query must match the slots of the dao, both
339 by type and by name."
340 `(query-dao% ,type ,(real-query query) (dao-row-reader (find-class ,type)) ,@args))
342 (defmacro dao-row-reader-with-body ((type type-var) &body body)
343 (let ((fields (gensym))
344 (column-map (gensym)))
345 `(row-reader (,fields)
346 (let ((,column-map (append *custom-column-writers* (dao-column-map (find-class ,type)))))
347 (loop :while (next-row)
348 :do (let ((,type-var (dao-from-fields (find-class ,type) ,column-map ,fields #'next-field)))
349 ,@body))))))
351 (defmacro do-query-dao (((type type-var) query) &body body)
352 "Like query-dao, but rather than returning a list of results,
353 executes BODY once for each result, with TYPE-VAR bound to the DAO
354 representing that result."
355 (let (args)
356 (when (and (consp query) (not (keywordp (first query))))
357 (setf args (cdr query) query (car query)))
358 `(query-dao% ,type ,(real-query query)
359 (dao-row-reader-with-body (,type ,type-var)
360 ,@body)
361 ,@args)))
363 (defun generate-dao-query (type &optional (test t) ordering)
364 (flet ((check-string (x)
365 (if (stringp x) `(:raw ,x) x)))
366 (let ((query `(:select '* :from (dao-table-name (find-class ,type))
367 :where ,(check-string test))))
368 (when ordering
369 (setf query `(:order-by ,query ,@(mapcar #'check-string ordering))))
370 query)))
372 (defmacro select-dao (type &optional (test t) &rest ordering)
373 "Select daos for the rows in its table for which the given test
374 holds, order them by the given criteria."
375 `(query-dao% ,type (sql ,(generate-dao-query type test ordering)) (dao-row-reader (find-class ,type))))
377 (defmacro do-select-dao (((type type-var) &optional (test t) &rest ordering) &body body)
378 "Like select-dao, but rather than returning a list of results,
379 executes BODY once for each result, with TYPE-VAR bound to the DAO
380 representing that result."
381 `(query-dao% ,type (sql ,(generate-dao-query type test ordering))
382 (dao-row-reader-with-body (,type ,type-var)
383 ,@body)))
385 (defun dao-table-definition (table)
386 "Generate the appropriate CREATE TABLE query for this class."
387 (unless (typep table 'dao-class)
388 (setf table (find-class table)))
389 (unless (class-finalized-p table)
390 (finalize-inheritance table))
391 (sql-compile
392 `(:create-table ,(dao-table-name table)
393 ,(loop :for slot :in (dao-column-slots table)
394 :unless (ghost slot)
395 :collect `(,(slot-definition-name slot) :type ,(column-type slot)
396 ,@(when (slot-boundp slot 'col-default)
397 `(:default ,(column-default slot)))))
398 ,@(when (dao-keys table)
399 `((:primary-key ,@(dao-keys table)))))))