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) *row-reader*))
  27
  28 (defun select (&rest query)
  29   (%query (cons :select query)))
  30
  31 (defun prepare (&rest query)
  32   (cl-postgres:prepare-query *database* "test2" (sql-compile (cons :select query))))
  33
  34
  35 (defun select-only (num &rest query)
  36   (let ((results (%query `(:limit ,(cons :select query) ,num))))
  37     (if (eql 1 num)
  38         (first results)
  39         results)))
  40
  41 (defun insert-into (table &rest values-plist)
  42   (postmodern:execute
  43    (postmodern:sql-compile `(:insert-into ,table :set ,@values-plist))))
  44
  45 (defun update (table &rest query)
  46   (postmodern:execute
  47    (postmodern:sql-compile `(:update ,table ,@query))))
  48
  49
  50 (defclass db-access-slot-definition ()
  51   ((column-name  :initform nil
  52                  :initarg :db-name
  53                  :initarg :column
  54                  :accessor slot-definition-column-name
  55                :documentation
  56               "If non-NIL, contains the name of the column this slot is representing.")
  57    (primary-key :initform nil
  58                 :initarg :primary-key
  59                 :accessor slot-definition-primary-key-p)
  60    (transient  :initform nil :initarg :transient :accessor slot-definition-transient-p
  61                :documentation
  62               "If non-NIL, this slot should be treated as transient and
  63 ignored in all database related operations.")
  64    (not-null :initform nil :initarg :not-null :accessor slot-definition-not-null-p
  65              :documentation "If non-NIL, a NON NULL database
  66 constrained will be introduced.")
  67    (foreign-type
  68     :initform nil
  69     :initarg :foreign-type
  70     :initarg :references
  71     :accessor slot-definition-foreign-type)
  72    (foreign-relation
  73     :initform nil
  74     :initarg :referenced-from
  75     :initarg :referenced-by
  76     :accessor slot-definition-foreign-relation)
  77    (foreign-join-spec
  78     :initform nil
  79     :initarg :on
  80     :initarg :using
  81     :accessor slot-definition-foreign-join-spec)
  82    (unique :initform nil :initarg :unique :accessor slot-definition-unique)
  83
  84
  85    (on-delete :initform :cascade :initarg :on-delete :accessor slot-definition-on-delete
  86               :documentation "Action to be performed for this slot
  87 when the refering row in the database ceases to exist. Possible
  88 values: :CASCADE, :RESTRICT, :SET-NULL, :SET-DEFAULT. If this slot is
  89 not a foreign key, it does nothing.")
  90    (delayed-constraint :initform nil :accessor slot-definition-delayed-constraint
  91                         :documentation "Closures adding constraints
  92 that, for some reason, could not be executed. If there's a slot with
  93 this attribute not-NIL in a class definition, then there's something
  94 wrong with its SQL counterpart.")))
  95
  96
  97 (defclass db-access-class (standard-class)
  98   ((table-name :initarg :table-name :initform nil :accessor class-table-name)
  99    (indices :initarg :indices :initform () :reader class-indices)
 100    (unique :initarg :unique :initform () :reader class-unique)
 101    #+not!(connection-spec :initarg :connection-spec :initform nil :reader db-class-connection-spec)
 102
 103    (unfinished-classes :initform nil :allocation :class :accessor class-unfinished-classes
 104                        :documentation "A class allocated slot
 105 containing classes for whom not all the constraints could be
 106 applied.")
 107    (foreign-keys :initform nil :accessor class-foreign-keys
 108                  :documentation "List of foreign-key slots.")
 109    (unique-keys :initform nil :accessor class-unique-keys
 110                 :documentation "List of slots whose value should be unique."))
 111   (:documentation "Metaclass for PostgreSQL aware classes. It takes
 112 two additional arguments in DEFTABLE: :INDICES (which slots are used
 113 as indices) and :CONNECTION-SPEC, which specifies how the class should
 114 connect to the database (its format is the same as in
 115 POSTMODERN:CONNECT-TOPLEVEL). If :CONNECTION-SPEC is not provided,
 116 SUBMARINE assumes it is a class created just for the sake of
 117 inheritance and does not create any tables for it."))
 118
 119 (defmethod validate-superclass
 120            ((class db-access-class)
 121             (superclass standard-class))
 122   t)
 123
 124
 125 (defclass db-access-direct-slot-definition (standard-direct-slot-definition
 126                                             db-access-slot-definition)
 127   ())
 128
 129 (defmethod direct-slot-definition-class
 130            ((class db-access-class) &key &allow-other-keys)
 131   (find-class 'db-access-direct-slot-definition))
 132
 133 (defclass db-access-effective-slot-definition
 134     (standard-effective-slot-definition
 135      db-access-slot-definition)
 136   ())
 137
 138 (defmethod effective-slot-definition-class
 139            ((class db-access-class) &key &allow-other-keys)
 140   (find-class 'db-access-effective-slot-definition))
 141
 142 (defmethod compute-effective-slot-definition
 143            ((class db-access-class) name direct-slot-definitions)
 144   (declare (ignore name))
 145   (let ((slotd (call-next-method)))
 146     (setf (slot-definition-primary-key-p slotd)
 147           (some #'slot-definition-primary-key-p direct-slot-definitions)
 148           (slot-definition-column-name slotd)
 149           (or (let ((slot (find-if #'slot-definition-column-name direct-slot-definitions)))
 150                 (when slot
 151                   (slot-definition-column-name slot)))
 152               name)
 153           (slot-definition-transient-p slotd)
 154           (every #'slot-definition-transient-p direct-slot-definitions)
 155           (slot-definition-foreign-type slotd)
 156           (slot-definition-foreign-type (car direct-slot-definitions))
 157           (slot-definition-foreign-relation slotd)
 158           (slot-definition-foreign-relation (car direct-slot-definitions))
 159           (slot-definition-foreign-join-spec slotd)
 160           (slot-definition-foreign-join-spec (car direct-slot-definitions))
 161           (slot-definition-not-null-p slotd)
 162           (slot-definition-not-null-p (car direct-slot-definitions))
 163           (slot-definition-unique slotd) (slot-definition-unique (car direct-slot-definitions))
 164           (slot-definition-type slotd) (slot-definition-type (car direct-slot-definitions)))
 165     slotd))
 166
 167 (defun class-id-slot-definition (class)
 168   (find-if #'slot-definition-primary-key-p
 169            (class-slots class)))
 170
 171 (defmethod class-table-name :around (class)
 172   (or (call-next-method)
 173       (class-name class)))
 174
 175 (defclass standard-db-access-class (db-access-class)
 176   ())
 177
 178 (defun find-foreign-relations (class object slotd)
 179   (when (slot-boundp object (dao-id-column-name class))
 180   (select-objects (slot-definition-foreign-relation slotd)
 181                   :where `(:= ,(or (slot-definition-foreign-join-spec slotd)
 182                                    (dao-id-column-name class))
 183                            ,(slot-value object (dao-id-column-name class))))))
 184
 185 (defmethod slot-boundp-using-class :around
 186     ((class standard-db-access-class) object slotd)
 187   (let ((bound? (call-next-method)))
 188     (when (and (not bound?) (slot-definition-foreign-relation slotd))
 189           (setf (slot-value-using-class class object slotd)
 190                 (find-foreign-relations class object slotd)))
 191
 192     (call-next-method)))
 193
 194 (defmethod slot-value-using-class :around
 195     ((class standard-db-access-class) object slotd)
 196   (if (slot-definition-foreign-relation slotd)
 197       (if (slot-boundp-using-class class object slotd)
 198           (call-next-method)
 199           (setf (slot-value-using-class class object slotd)
 200                 (find-foreign-relations class object slotd)))
 201       (call-next-method)))
 202
 203 (defun set-fkey-from-slotd (value object slotd)
 204   (when (slot-boundp value (dao-id-column-name (class-of value)))
 205     (setf (slot-value object (slot-definition-column-name slotd))
 206           (slot-value value (dao-id-column-name (class-of value))))))
 207
 208 (defmethod (setf slot-value-using-class) :after
 209     (value (class standard-db-access-class) object slotd)
 210   (when (and value
 211              (typep value 'standard-db-access-object)
 212              (slot-definition-foreign-type slotd)
 213              (primary-key-boundp value))
 214
 215     (set-fkey-from-slotd value object slotd)))
 216
 217 (defun find-foreign-objects (db-object)
 218     (let* ((class (class-of db-object))
 219          (foreign-objects ))
 220       (mapcar (lambda (x)
 221                 (and (slot-value-using-class class db-object x)
 222                      (slot-value-using-class class db-object  x)))
 223               (remove-if-not #'lol::slot-definition-foreign-type
 224                              (lol::class-slots class)))))
 225
 226
 227  (defun dao-id-column-name (class)
 228   (slot-definition-column-name
 229    (or (class-id-slot-definition class)
 230        (error "No ID slot (primary key) for ~A" class))))
 231
 232 (defun db-access-object-p (thing)
 233   (typep thing 'standard-db-access-object))
 234
 235 (defun primary-key-boundp (object)
 236   (check-type object standard-db-access-object)
 237   (slot-boundp object (dao-id-column-name (class-of object))))
 238
 239 (defclass described-db-access-class (described-class standard-db-access-class)
 240   ())
 241
 242 (defmethod initialize-instance :around ((class standard-db-access-class) &rest initargs &key name (direct-superclasses '()) direct-slots)
 243   (declare (dynamic-extent initargs))
 244   (let ((direct-slots (loop for slot in direct-slots
 245                          collect (let* ((sname (getf slot :name))
 246                                         (readers (getf slot :readers))
 247                                         (writers (getf slot :writers)))
 248                                    (setf (getf slot :readers)
 249                                          (cons (intern (format nil "~A.~A"
 250                                                                name sname)) readers))
 251                                    (setf (getf slot :writers)
 252                                          (cons `(setf ,(intern (format nil "~A.~A"
 253                                                                        name sname))) writers))
 254                                    slot))))
 255
 256
 257
 258     (if (loop for direct-superclass in direct-superclasses
 259            thereis (ignore-errors (subtypep direct-superclass 'standard-db-access-object)))
 260         (call-next-method)
 261         (apply #'call-next-method
 262                class
 263                :direct-superclasses
 264                (append direct-superclasses
 265                        (list (find-class 'standard-db-access-object)))
 266                :direct-slots direct-slots
 267                initargs))))
 268
 269 (defmethod reinitialize-instance :around ((class standard-db-access-class)
 270                                           &rest initargs
 271                                           &key (name (class-name class))
 272                                           (direct-superclasses '() direct-superclasses-p) direct-slots)
 273   (declare (dynamic-extent initargs))
 274   (let ((direct-slots (loop for slot in direct-slots
 275                          collect (let* ((sname (getf slot :name))
 276                                         (readers (getf slot :readers))
 277                                         (writers (getf slot :writers)))
 278                                    (setf (getf slot :readers)
 279                                          (cons (intern (format nil "~A.~A"
 280                                                                name sname)) readers))
 281                                    (setf (getf slot :writers)
 282                                          (cons `(setf ,(intern (format nil "~A.~A"
 283                                                                        name sname))) writers))
 284                                    slot))))
 285
 286
 287
 288     (if (loop for direct-superclass in direct-superclasses
 289            thereis (ignore-errors (subtypep direct-superclass 'standard-db-access-object)))
 290         (call-next-method)
 291         (apply #'call-next-method
 292                class
 293                :direct-superclasses
 294                (append direct-superclasses
 295                        (list (find-class 'standard-db-access-object)))
 296                :direct-slots direct-slots
 297                initargs))))
 298
 299 (defclass standard-db-access-object (standard-object)
 300   ())
 301
 302 (defun %select-objects (type select-fn query)
 303   (mapcar (curry 'make-object-from-plist type)
 304           (apply select-fn (intern (format nil "*"))
 305                  (if (string-equal (first query) :from)
 306                      query
 307                      (append `(:from ,type) query)))))
 308
 309 (defun select-objects (type &rest query)
 310   (%select-objects type #'select query))
 311
 312 (defun select-only-n-objects (n type &rest query)
 313   (let ((fields (if (eq :fields (car query))
 314                     (loop
 315                        :for cons :on (cdr query)
 316                        :if (not (keywordp (car cons)))
 317                        :collect (car cons) into fields
 318                        :else :do
 319                          (setf query cons)
 320                          (return (nreverse (print fields)))
 321                        :finally
 322                          (setf query cons)
 323                          (return (nreverse (print fields))))
 324
 325                     (list (intern "*")))))
 326     (let ((results
 327            (%query
 328             (print `(:limit (:select
 329                       ,@fields
 330                       ,@(if (string-equal (first query) :from)
 331                             (print query)
 332                             (append `(:from ,type) query)))
 333                      ,n)))))
 334     (if (eql 1 n)
 335         (make-object-from-plist type (first results))
 336         (mapcar (curry 'make-object-from-plist type) results)))))
 337
 338 (defun make-object-from-plist (type plist)
 339   (let* ((class (find-class type))
 340          (object (make-instance class))
 341          (slotds (class-slots class)))
 342
 343     (loop
 344        :for (key val) :on plist :by #'cddr
 345        :do
 346        (dolist (slotd (remove key slotds
 347                               :key #'slot-definition-column-name
 348                               :test-not #'string-equal))
 349
 350              (setf (slot-value-using-class class object slotd) val))
 351        :finally (return (reinitialize-instance object)))))
 352
 353 (defun make-object (type &rest plist)
 354   (make-object-from-plist type plist))
 355
 356 (defun insert-object (object)
 357   (let ((class (class-of object))
 358         insert-query
 359         delayed)
 360     (flet ((ins (slotd &optional (val (slot-value-using-class class object slotd)))
 361              (push (lambda ()  (push (slot-definition-column-name slotd) insert-query)
 362                            (push  val insert-query))
 363                    delayed)))
 364     (loop :for slotd in (class-slots class)
 365           :do (cond ((slot-boundp-using-class class object slotd)
 366                      (cond ((or (slot-definition-foreign-relation slotd)
 367                                 )
 368                             )
 369                            ((slot-definition-foreign-type slotd)
 370                             (set-fkey-from-slotd
 371                              (slot-value-using-class class object slotd)
 372                              object slotd
 373 )
 374                             )
 375                            (t
 376                             (ins slotd)) ))
 377                     ((slot-definition-primary-key-p slotd)
 378                      (setf (slot-value-using-class class object slotd) (get-default-value (class-table-name class)
 379                                                   (slot-definition-column-name slotd)))
 380                      (ins slotd ))))
 381     (map nil #'funcall delayed)
 382     (apply #'insert-into (class-table-name class) (nreverse insert-query))))
 383   object)
 384
 385
 386 (defun update-object (object)
 387   (let ((class (class-of object))
 388         update-query
 389         delayed)
 390     (flet ((ins (slotd &optional (val (slot-value-using-class class object slotd)))
 391              (push (lambda ()  (push (slot-definition-column-name slotd) update-query)
 392                            (push  val update-query))
 393                    delayed)))
 394     (loop :for slotd in (class-slots class)
 395           :do (cond ((slot-boundp-using-class class object slotd)
 396                      (cond ((or (slot-definition-foreign-relation slotd)
 397                                 )
 398                             )
 399                            ((slot-definition-foreign-type slotd)
 400                             (set-fkey-from-slotd
 401                              (slot-value-using-class class object slotd)
 402                              object slotd
 403 )
 404                             )
 405                            (t
 406                             (ins slotd)) ))
 407                     ((slot-definition-primary-key-p slotd)
 408                      (setf (slot-value-using-class class object slotd) (get-default-value (class-table-name class)
 409                                                   (slot-definition-column-name slotd)))
 410                      (ins slotd ))))
 411     (map nil #'funcall delayed)
 412     (apply #'update (class-table-name class) :set (nconc  (nreverse update-query)
 413                                                      (list  :where `(:= ,(dao-id-column-name class)
 414                                                                      ,(slot-value object (dao-id-column-name class))
 415                                                                      ))))))
 416   object)
 417
 418 (defun select-using-object (object &key (combinator :and))
 419   (let ((class (class-of object))
 420         select-query)
 421     (flet ((sel (slotd &optional (val (slot-value-using-class class object slotd)))
 422              (push `(:ilike ,(slot-definition-column-name slotd) ,(if (stringp val)
 423                                                                       (format nil "~A%" val) val)) select-query)))
 424     (loop :for slotd in (class-slots class)
 425           :do (cond ((slot-boundp-using-class class object slotd)
 426                      (unless (or (slot-definition-foreign-relation slotd)
 427                                  (slot-definition-foreign-type  slotd))
 428                        (sel slotd)))))
 429     (if select-query
 430            (select-objects (class-table-name class)
 431              :where (print `(,combinator ,@(nreverse select-query))))
 432            nil))))
 433
 434
 435 (defun get-default-value-query (table column)
 436   (format nil "select ~A "
 437           (second (select-only 1 ':adsrc
 438                                :from 'pg_attribute 'pg_attrdef
 439                                :where `(:and (:= adnum attnum)
 440                                         (:= attname ,(s-sql::to-sql-name column))
 441                                         (:= adrelid attrelid)
 442                                         (:= attrelid
 443                                          (:select oid
 444                                           :from pg_class
 445                                           :where (:= relname ,(s-sql::to-sql-name table)))))))))
 446
 447 (defun get-default-value (table column)
 448   (caar (query (get-default-value-query table column))))
 449
 450 (defun find-dao (type id
 451                  &key (table (class-table-name (find-class type)))
 452                       id-column-name)
 453
 454   "Get the dao corresponding to the given primary key,
 455 or return nil if it does not exist."
 456   (let ((plist
 457               (select-only 1 '*
 458                :from table
 459                :where (list ':= id (or id-column-name
 460                                  (dao-id-column-name
 461                                   (find-class type)))))))
 462     (make-object-from-plist type plist)))
 463
 464 (defmethod shared-initialize :after ((dao standard-db-access-object)
 465                                      slots &rest initargs)
 466   (let ((class (class-of dao))
 467         (foreign-key))
 468     (dolist (slotd (class-slots class))
 469       (with-slots (foreign-type) slotd
 470         (when foreign-type
 471           (when (consp foreign-type)
 472             (setf foreign-key (cdr foreign-type)
 473                   foreign-type (car foreign-type)))
 474           (if (slot-boundp-using-class class dao slotd)
 475               (let ((value (slot-value-using-class class dao slotd)))                           (unless (typep value foreign-type)
 476                   (if (connected-p *database*)
 477                       (setf (slot-value-using-class class dao slotd)
 478                             (find-dao foreign-type value))
 479                       (let ((obj (make-instance foreign-type)))
 480                         (break "here")
 481                         (setf (slot-value-using-class
 482                                (class-of obj)
 483                                obj
 484                                (class-id-slot-definition (class-of obj)))
 485                               value)))))))))))
 486
 487 (defgeneric dao-id (dao)
 488   (:method ((dao standard-db-access-object))
 489     (let ((class (class-of dao)))
 490
 491       (slot-value-using-class class dao (class-id-slot-definition class)))))
 492
 493 (defun make-dao-from-row (type row &key slots)
 494   (let* ((class (find-class type))
 495          (dao (make-instance class))
 496          (slotds (class-slots class)))
 497     (loop
 498          :for val :in row
 499          :for slotd
 500        :in (or
 501             (loop
 502                :for slot :in slots
 503                :collect (find slot slotds
 504                               :key #'slot-definition-name))
 505             slotds)
 506          :do (setf (slot-value-using-class class dao slotd) val)
 507          :finally (return (reinitialize-instance dao)))))
 508
 509 ;(defgeneric make-dao (type &rest initargs)
 510 #+nil(defun make-dao (type initargs)
 511   "Create a DAO of the given `TYPE' and initialize it according
 512   to the values of the alist `INITARGS'. `Initargs' may contain
 513   additional values, not used in the initialization proccess."
 514   (let ((instance (make-instance type)))
 515     (iter (for slot in (slots-of instance))
 516           (setf (slot-value instance (slot-definition-name slot))
 517                 (let ((the-value (cdr (assoc (intern (symbol-name (slot-definition-name slot)) 'keyword) initargs))))
 518                   (if (foreign-type-p slot)
 519                       (make-instance (sb-pcl:slot-definition-type slot) :id the-value)
 520                       the-value))))
 521     instance))
 522
 523
 524
 525
 526