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