src/rofl.lisp

   1 (in-package :lisp-on-lines)
   2
   3 ;;;; NB: These could really be in upstream
   4
   5 ;;;; * A PLIST reader for postmodern.
   6 (postmodern::def-row-reader symbol-plist-row-reader (fields)
   7   (let ((symbols (map 'list (lambda (desc)
   8                    (postmodern::from-sql-name (postmodern::field-name desc))) fields)))
   9     (loop :while (postmodern::next-row)
  10           :collect (loop :for field :across fields
  11                          :for symbol :in symbols
  12                          :nconc (list symbol (postmodern::next-field field))))))
  13
  14 (s-sql::def-sql-op :between (n start end)
  15   `(,@(s-sql::sql-expand n) " BETWEEN " ,@(s-sql::sql-expand start) " AND " ,@(s-sql::sql-expand end)))
  16
  17 (s-sql::def-sql-op :case (&rest clauses)
  18   `("CASE " ,@(loop for (test expr) in clauses collect (format nil "WHEN ~A THEN ~A " (s-sql::sql-expand test) (s-sql::sql-expand expr))) "END"))
  19
  20
  21 ;;;; now the rofl code itself
  22
  23 (defvar *row-reader* 'symbol-plist-row-reader)
  24
  25 (defun %query (query)
  26   (cl-postgres:exec-query *database* (sql-compile query) 'symbol-plist-row-reader))
  27
  28 (defun select (&rest query)
  29   (%query (cons :select query)))
  30
  31 (defun select-only (num &rest query)
  32   (let ((results (%query `(:limit ,(cons :select query) ,num))))
  33     (if (eql 1 num)
  34         (first results)
  35         results)))
  36
  37 (defun insert-into (table &rest values-plist)
  38   (postmodern:execute
  39    (postmodern:sql-compile `(:insert-into ,table :set ,@values-plist))))
  40
  41
  42 (defclass db-access-slot-definition ()
  43   ((column-name  :initform nil
  44                  :initarg :db-name
  45                  :initarg :column
  46                  :accessor slot-definition-column-name
  47                :documentation
  48               "If non-NIL, contains the name of the column this slot is representing.")
  49    (primary-key :initform nil
  50                 :initarg :primary-key
  51                 :accessor slot-definition-primary-key-p)
  52    (transient  :initform nil :initarg :transient :accessor slot-definition-transient-p
  53                :documentation
  54               "If non-NIL, this slot should be treated as transient and
  55 ignored in all database related operations.")
  56    (not-null :initform nil :initarg :not-null :accessor slot-definition-not-null-p
  57              :documentation "If non-NIL, a NON NULL database
  58 constrained will be introduced.")
  59    (foreign-type
  60     :initform nil
  61     :initarg :foreign-type
  62     :initarg :references
  63     :accessor slot-definition-foreign-type)
  64    (unique :initform nil :initarg :unique :accessor slot-definition-unique)
  65
  66
  67    (on-delete :initform :cascade :initarg :on-delete :accessor slot-definition-on-delete
  68               :documentation "Action to be performed for this slot
  69 when the refering row in the database ceases to exist. Possible
  70 values: :CASCADE, :RESTRICT, :SET-NULL, :SET-DEFAULT. If this slot is
  71 not a foreign key, it does nothing.")
  72    (delayed-constraint :initform nil :accessor slot-definition-delayed-constraint
  73                         :documentation "Closures adding constraints
  74 that, for some reason, could not be executed. If there's a slot with
  75 this attribute not-NIL in a class definition, then there's something
  76 wrong with its SQL counterpart.")))
  77
  78
  79 (defclass db-access-class (standard-class)
  80   ((table-name :initarg :table-name :initform nil :accessor class-table-name)
  81    (indices :initarg :indices :initform () :reader class-indices)
  82    (unique :initarg :unique :initform () :reader class-unique)
  83    #+not!(connection-spec :initarg :connection-spec :initform nil :reader db-class-connection-spec)
  84
  85    (unfinished-classes :initform nil :allocation :class :accessor class-unfinished-classes
  86                        :documentation "A class allocated slot
  87 containing classes for whom not all the constraints could be
  88 applied.")
  89    (foreign-keys :initform nil :accessor class-foreign-keys
  90                  :documentation "List of foreign-key slots.")
  91    (unique-keys :initform nil :accessor class-unique-keys
  92                 :documentation "List of slots whose value should be unique."))
  93   (:documentation "Metaclass for PostgreSQL aware classes. It takes
  94 two additional arguments in DEFTABLE: :INDICES (which slots are used
  95 as indices) and :CONNECTION-SPEC, which specifies how the class should
  96 connect to the database (its format is the same as in
  97 POSTMODERN:CONNECT-TOPLEVEL). If :CONNECTION-SPEC is not provided,
  98 SUBMARINE assumes it is a class created just for the sake of
  99 inheritance and does not create any tables for it."))
 100
 101 (defmethod validate-superclass
 102            ((class db-access-class)
 103             (superclass standard-class))
 104   t)
 105
 106
 107 (defclass db-access-direct-slot-definition (standard-direct-slot-definition
 108                                             db-access-slot-definition)
 109   ())
 110
 111 (defmethod direct-slot-definition-class
 112            ((class db-access-class) &key &allow-other-keys)
 113   (find-class 'db-access-direct-slot-definition))
 114
 115 (defclass db-access-effective-slot-definition
 116     (standard-effective-slot-definition
 117      db-access-slot-definition)
 118   ())
 119
 120 (defmethod effective-slot-definition-class
 121            ((class db-access-class) &key &allow-other-keys)
 122   (find-class 'db-access-effective-slot-definition))
 123
 124 (defmethod compute-effective-slot-definition
 125            ((class db-access-class) name direct-slot-definitions)
 126   (declare (ignore name))
 127   (let ((slotd (call-next-method)))
 128     (setf (slot-definition-primary-key-p slotd)
 129           (some #'slot-definition-primary-key-p direct-slot-definitions)
 130           (slot-definition-column-name slotd)
 131           (or (let ((slot (find-if #'slot-definition-column-name direct-slot-definitions)))
 132                 (when slot
 133                   (slot-definition-column-name slot)))
 134               name)
 135           (slot-definition-transient-p slotd)
 136           (every #'slot-definition-transient-p direct-slot-definitions)
 137           (slot-definition-foreign-type slotd)
 138           (slot-definition-foreign-type (car direct-slot-definitions))
 139           (slot-definition-not-null-p slotd)
 140           (slot-definition-not-null-p (car direct-slot-definitions))
 141           (slot-definition-unique slotd) (slot-definition-unique (car direct-slot-definitions))
 142           (slot-definition-type slotd) (slot-definition-type (car direct-slot-definitions)))
 143     slotd))
 144
 145 (defun class-id-slot-definition (class)
 146   (find-if #'slot-definition-primary-key-p
 147            (class-slots class)))
 148
 149 (defmethod class-table-name :around (class)
 150   (or (call-next-method)
 151       (class-name class)))
 152
 153 (defclass standard-db-access-class (db-access-class)
 154   ())
 155
 156 (defmethod ensure-class-using-class :around ((class standard-db-access-class) name &rest args &key direct-slots &allow-other-keys)
 157        (let ((direct-slots (loop for slot in direct-slots
 158                               collect (let* ((sname (getf slot :name))
 159                                              (readers (getf slot :readers))
 160                                              (writers (getf slot :writers)))
 161                                         (setf (getf slot :readers)
 162                                               (cons (intern (format nil "~A.~A"
 163                                                                     name sname)) readers))
 164                                         (setf (getf slot :writers)
 165                                               (cons `(setf ,(intern (format nil "~A.~A"
 166                                                                     name sname))) writers))
 167                                         slot))))
 168
 169
 170        (apply #'call-next-method class name :direct-slots direct-slots args)))
 171
 172 (defun dao-id-column-name (class)
 173   (slot-definition-column-name
 174    (or (class-id-slot-definition class)
 175        (error "No ID slot (primary key) for ~A" class))))
 176
 177 (defclass described-db-access-class (standard-db-access-class described-class)
 178   ())
 179
 180 (defmethod initialize-instance :around ((class standard-db-access-class) &rest initargs &key (direct-superclasses '()))
 181   (declare (dynamic-extent initargs))
 182   (if (loop for direct-superclass in direct-superclasses
 183          thereis (ignore-errors (subtypep direct-superclass 'standard-db-access-object)))
 184       (call-next-method)
 185       (apply #'call-next-method
 186              class
 187              :direct-superclasses
 188              (append direct-superclasses
 189                      (list (find-class 'standard-db-access-object)))
 190              initargs)))
 191
 192 (defmethod reinitialize-instance :around ((class standard-db-access-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p))
 193   (declare (dynamic-extent initargs))
 194   (if (or (not direct-superclasses-p)
 195           (loop for direct-superclass in direct-superclasses
 196              thereis (ignore-errors (subtypep direct-superclass 'standard-db-access-object))))
 197       (call-next-method)
 198       (apply #'call-next-method
 199              class
 200              :direct-superclasses
 201              (append direct-superclasses
 202                      (list (find-class 'standard-db-access-object)))
 203              initargs)))
 204
 205 (defclass standard-db-access-object (standard-object)
 206   ())
 207
 208 (defun %select-objects (type select-fn query)
 209   (mapcar (curry 'make-object-from-plist type)
 210           (apply select-fn (intern (format nil "*"))
 211                  (if (string-equal (first query) :from)
 212                      query
 213                      (append `(:from ,type) query)))))
 214
 215 (defun select-objects (type &rest query)
 216   (%select-objects type #'select query))
 217
 218 (defun select-only-n-objects (n type &rest query)
 219   (let ((fields (if (eq :fields (car query))
 220                     (loop
 221                        :for cons :on (cdr query)
 222                        :if (not (keywordp (car cons)))
 223                        :collect (car cons) into fields
 224                        :else :do
 225                          (setf query cons)
 226                          (return (nreverse (print fields)))
 227                        :finally
 228                          (setf query cons)
 229                          (return (nreverse (print fields))))
 230
 231                     (list (intern "*")))))
 232     (let ((results
 233            (%query
 234             (print `(:limit (:select
 235                       ,@fields
 236                       ,@(if (string-equal (first query) :from)
 237                             (print query)
 238                             (append `(:from ,type) query)))
 239                      ,n)))))
 240     (if (eql 1 n)
 241         (make-object-from-plist type (first results))
 242         (mapcar (curry 'make-object-from-plist type) results)))))
 243
 244 (defun make-object-from-plist (type plist)
 245   (let* ((class (find-class type))
 246          (object (make-instance class))
 247          (slotds (class-slots class)))
 248
 249     (loop
 250        :for (key val) :on plist :by #'cddr
 251        :do
 252        (dolist (slotd (remove key slotds
 253                               :key #'slot-definition-column-name
 254                               :test-not #'string-equal))
 255
 256              (setf (slot-value-using-class class object slotd) val))
 257        :finally (return (reinitialize-instance object)))))
 258
 259 (defun make-object (type &rest plist)
 260   (make-object-from-plist type plist))
 261
 262
 263
 264 (defun find-dao (type id
 265                  &key (table (class-table-name (find-class type)))
 266                       id-column-name)
 267
 268   "Get the dao corresponding to the given primary key,
 269 or return nil if it does not exist."
 270   (let ((plist
 271               (select-only 1 '*
 272                :from table
 273                :where (list ':= id (or id-column-name
 274                                  (dao-id-column-name
 275                                   (find-class type)))))))
 276     (make-object-from-plist type plist)))
 277
 278 (defmethod shared-initialize :after ((dao standard-db-access-object)
 279                                      slots &rest initargs)
 280   (let ((class (class-of dao))
 281         (foreign-key))
 282     (dolist (slotd (class-slots class))
 283       (with-slots (foreign-type) slotd
 284         (when foreign-type
 285           (when (consp foreign-type)
 286             (setf foreign-key (cdr foreign-type)
 287                   foreign-type (car foreign-type)))
 288           (if (slot-boundp-using-class class dao slotd)
 289               (let ((value (slot-value-using-class class dao slotd)))
 290                 (unless (typep value foreign-type)
 291                   (if (connected-p *database*)
 292                       (setf (slot-value-using-class class dao slotd)
 293                             (find-dao foreign-type value))
 294                       (let ((obj (make-instance foreign-type)))
 295                         (setf (slot-value-using-class
 296                                (class-of obj)
 297                                obj
 298                                (class-id-slot-definition (class-of obj)))
 299                               value)))))))))))
 300
 301 (defgeneric dao-id (dao)
 302   (:method ((dao standard-db-access-object))
 303     (let ((class (class-of dao)))
 304
 305       (slot-value-using-class class dao (class-id-slot-definition class)))))
 306
 307 (defun make-dao-from-row (type row &key slots)
 308   (let* ((class (find-class type))
 309          (dao (make-instance class))
 310          (slotds (class-slots class)))
 311     (loop
 312          :for val :in row
 313          :for slotd
 314        :in (or
 315             (loop
 316                :for slot :in slots
 317                :collect (find slot slotds
 318                               :key #'slot-definition-name))
 319             slotds)
 320          :do (setf (slot-value-using-class class dao slotd) val)
 321          :finally (return (reinitialize-instance dao)))))
 322
 323 ;(defgeneric make-dao (type &rest initargs)
 324 #+nil(defun make-dao (type initargs)
 325   "Create a DAO of the given `TYPE' and initialize it according
 326   to the values of the alist `INITARGS'. `Initargs' may contain
 327   additional values, not used in the initialization proccess."
 328   (let ((instance (make-instance type)))
 329     (iter (for slot in (slots-of instance))
 330           (setf (slot-value instance (slot-definition-name slot))
 331                 (let ((the-value (cdr (assoc (intern (symbol-name (slot-definition-name slot)) 'keyword) initargs))))
 332                   (if (foreign-type-p slot)
 333                       (make-instance (sb-pcl:slot-definition-type slot) :id the-value)
 334                       the-value))))
 335     instance))
 336
 337
 338
 339
 340