postmodern/table.lisp

   1 (in-package :postmodern)
   2
   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."))
   9
  10 (defmethod dao-keys :before ((class dao-class))
  11   (unless (class-finalized-p class)
  12     (finalize-inheritance class)))
  13
  14 (defmethod validate-superclass ((class dao-class) (super-class standard-class))
  15   t)
  16
  17 (defmethod dao-keys ((class-name symbol))
  18   (dao-keys (find-class class-name)))
  19
  20 (defmethod dao-keys (dao)
  21   (mapcar #'(lambda (slot)
  22               (slot-value dao slot))
  23           (dao-keys (class-of dao))))
  24
  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)))
  32
  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)))
  39
  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)))
  48
  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)))
  59
  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))
  70
  71
  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."))
  78
  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)))
  90
  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)))
  96
  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.")
 100
 101 (defclass effective-column-slot (standard-effective-slot-definition)
 102   ((direct-slot :initform *direct-column-slot* :reader slot-column)))
 103
 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))))
 113
 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)))
 119
 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"))
 153
 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)))))
 163
 164 (defgeneric fetch-defaults (object)
 165   (:documentation "Used to fetch the default values of an object on
 166   creation."))
 167
 168 (defun %eval (code)
 169   (funcall (compile nil `(lambda () ,code))))
 170
 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.)"
 176
 177   (setf (slot-value class 'column-map)
 178         (mapcar (lambda (s) (cons (slot-sql-name s) (slot-definition-name s))) (dao-column-slots class)))
 179
 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))))
 195
 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))))
 203
 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)
 212
 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))))))
 220
 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)))))
 224
 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))))))
 228
 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)))
 235
 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)
 247
 248
 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)))
 269
 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)))))))
 275
 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.")
 282
 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))
 288
 289 (defparameter *ignore-unknown-columns* nil)
 290
 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))
 304
 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)))))
 311
 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)))
 319
 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)))
 325
 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))))
 335
 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))
 341
 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))))))
 350
 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)))
 362
 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)))
 371
 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))))
 376
 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)))
 384
 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)))))))