dao.lisp 12.9 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; -*-

(in-package :submarine)

;;
;; DAO
;;
;;

(defclass dao ()
  ((id :type integer :accessor get-id :initarg :id))
  (:indices)
  (:metaclass db-class)
  (:documentation "Base class for any PostgreSQL aware classes."))


(defgeneric save-dao (object)
  (:documentation "Save a dao: update it when it already exists, insert it otherwise.")
  (:method ((dao  dao))
    (if (dao-exists-p dao)
        (update-dao dao)
        (insert-dao dao))))

(defgeneric dao-exists-p (dao)
25
  (:documentation "Return a boolean indicating whether the given DAO
26
27
exists in the database.")
  (:method ((dao dao))
ryszard.szopa's avatar
ryszard.szopa committed
28
    (with-object-connection (dao)
29
30
31
32
        (and (slot-boundp dao 'id)
             (postmodern::query (:select (:exists (:select 1 :from (class-name-of dao) :where (:= 'id (get-id dao)))))
                                :single)))))

ryszard.szopa's avatar
ryszard.szopa committed
33
34
35
36
37
38
39
40
41
(defun slot-value-or-id-if-foreign (object slot)
  "SLOT-VALUE if SLOT in OBJECT is not foreign, the ID of the object
in the slot otherwise. If the object is not saved, save it."
  (let ((value (slot-value object slot)))
    (cond ((and (typep value 'dao) (dao-exists-p value))
           (get-id value))
          ((typep value 'dao) (get-id (save-dao value)))
          (t value))))

42
(defun set-fields (object)
43
  (iter (for field in (mapcar #'slot-definition-name (db-slots-of object)))
44
        (appending `(,field ,(slot-value-or-id-if-foreign object field)))))
45
46
47
48
49

(defun id-seq-name (class)
  (intern (format nil "~A-ID-SEQ" (class-name class)) :keyword))

(defgeneric insert-dao (dao)
50
  (:documentation "Insert the given DAO into the database.")
51
  (:method ((dao dao))
ryszard.szopa's avatar
ryszard.szopa committed
52
    (with-object-connection (dao)
53
54
      (unless (slot-boundp dao 'id)
        (setf  (slot-value dao 'id) (postmodern::sequence-next (id-seq-name (class-of dao)))))
55
56
      (postmodern::execute (sql-compile `(:insert-into ,(class-name-of dao) :set ,@(set-fields dao)))))
    dao))
57
58

(defgeneric update-dao (dao)
59
  (:documentation "Update the DAO's representation in the database
60
with the values in the given object and return it."))
61
62

(defmethod update-dao ((dao dao))
ryszard.szopa's avatar
ryszard.szopa committed
63
  (with-object-connection (dao)
64
65
    (postmodern::execute (sql-compile 
                          `(:update ,(class-name-of dao) :set ,@(set-fields dao)
ryszard.szopa's avatar
ryszard.szopa committed
66
                            :where (:= id ,(get-id dao))))))
67
  dao)
68

69
70
71
72
(defmethod shared-initialize :before ((dao dao) slot-names &rest initargs &key &allow-other-keys)
  (declare (ignore slot-names initargs))
  (let ((class (class-of  dao)))
    (when (member class (db-class-unfinished-classes class))
73
      (error 'unresolved-foreign-key :format-control "You are trying to create an instance of a class with a foreign, non-existing reference. Create the class you are refering to." :type (class-name class)))))
74

75
76
77
(defmethod shared-initialize :after ((dao dao) slot-names &rest initargs &key  &allow-other-keys)
  "If :ID is provided, set the values of the slots according to the
database. If other initargs where provided, assert they are consistent
ryszard.szopa's avatar
ryszard.szopa committed
78
79
80
with the database. A NIL value in a slot is considered consistent with
everything and is overwritten with the value from the database (if
any)."
81
  (declare (ignore initargs))
82
83
84
85
  (labels ((ensure-not-db-null (x)
             (unless (equal x :NULL)
               x)))
    (when (slot-boundp dao 'id)
86
87
88
89
90
      (with-object-connection (dao)
        (let ((query-result (postmodern::query 
                             (:select '*
                                      :from (class-name-of  dao)
                                      :where (:= 'id (get-id dao))) :alist)))
91
92
          (unless query-result
            (error (make-condition 
ryszard.szopa's avatar
ryszard.szopa committed
93
                    'dao-nonexistent-id
94
                    :format-control "You tried to create a DAO with a non-existant ID."
ryszard.szopa's avatar
ryszard.szopa committed
95
                    :id (get-id dao) :type (class-name-of  dao))))
96
          (iter
97
            (for slot in  (db-slots-of  dao))
98
        
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
            (let ((slot-name (slot-definition-name slot)))
              (unless (equal 'id slot-name)
                (let ((value-from-db (ensure-not-db-null
                                      (cdr (assoc (intern (symbol-name slot-name) 'keyword) query-result)))))
                  (when (slot-boundp dao slot-name)
                    (let* ((slot-value (slot-value dao slot-name))
                           (value-from-init (if (and slot-value (foreign-type-p slot))
                                                (get-id slot-value)
                                                slot-value)))
                      (assert 
                       (or (null value-from-init) (equal value-from-init value-from-db))
                       (value-from-init value-from-db)
                       "Values inconsistent with the database for slot ~A. ~%Value from init: ~A, value from database: ~A~%" 
                       slot-name  value-from-init value-from-db)))
                  (setf (slot-value dao slot-name) 
                        (if (foreign-type-p slot)
                            (make-instance (slot-definition-type slot) :id value-from-db) 
                            value-from-db)))))))))))
117

ryszard.szopa's avatar
ryszard.szopa committed
118
119
120
121
122
123
124
125
126
(defun select-dao-fun (type test)
  "Functional interface for SELECT-DAO."
  (with-class-connection ((find-class type))
    (mapcar (lambda (x) (make-instance type :id (car x)))
            (postmodern:query (:select 'id :from type :where (:raw (if (stringp test)
                                                                       test
                                                                       (sql-compile test))))))))

(defmacro select-dao (type &optional (test t))
ryszard.szopa's avatar
ryszard.szopa committed
127
  "Select daos of TYPE for the rows in its table for which the given TEST
ryszard.szopa's avatar
ryszard.szopa committed
128
129
130
holds."
  `(select-dao-fun ,type ',test))

131
(defgeneric delete-dao (dao)
ryszard.szopa's avatar
ryszard.szopa committed
132
133
134
135
  (:documentation "Delete the given dao from the database.")
  (:method ((dao dao))
    (with-object-connection (dao)
      (postmodern:execute (:delete-from (class-name-of dao) :where (:= 'id (get-id dao)))))))
136

ryszard.szopa's avatar
get-dao    
ryszard.szopa committed
137
138
139
140
141
142
(defun get-dao (type id)
  "Get the dao corresponding to the given primary key,
or return nil if it does not exist."
 (let ((dao (make-instance type :id id)))
   (when (dao-exists-p dao)
     dao)))
143

144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171


(defgeneric get-all (type object)
  (:documentation "Get all objects of TYPE that stand in a many-to-one
relation with OBJECT.")
  (:method (type (object t))
    (let ((name-of-column
           (iter (for slot in (class-slots (find-class type)))
                 (finding (slot-definition-name slot) 
                          such-that (equal (slot-definition-type slot) (type-of object))))))                    
    (select-dao-fun type `(:= ,name-of-column ,(get-id object))))))

;; acache documentation for def-many-to-many:
;;   "Defines many-to-many mapping between two persistent classes.

;; CLASS*-NAME can be either (unquoted) symbol with class name, or
;; list (CLASS*-METHOD CLASS*-NAME).  When method name is not given,
;; other class' name is taken for method.

;; Defines additional mapping persistent class `CLASS1-NAME-CLASS2-NAME'
;; and for each of classes, a method that retrieves list of instances of
;; second class, and SETF method of the same name that updates the
;; mapping.  Mapping class has two slots, named `CLASS1-NAME' and
;; `CLASS2-NAME' that hold instances of first and second class.

;; User is responsible for SETFing relation pseudo-accessor to NIL or
;; periodically cleaning up relation class with slots of value NIL."

ryszard.szopa's avatar
ryszard.szopa committed
172
173
174
175
176
(defmacro def-many-to-many (class1-name class2-name &key connection-spec name)
  "Defines a possibly named many-to-many mapping between two
persistent classes. There can be only one unnamed mapping between any
two classes, and any number of named mappings.  CLASS*-NAME should be
an \(unquoted\) symbol with class name.
177

ryszard.szopa's avatar
ryszard.szopa committed
178
179
180
181
182
183
184
185
Defines additional mapping persistent class `NAME' \(if `NAME' is
not provided, `CLASS1-NAME-CLASS2-NAME' is used\), and for each of
classes, a method that retrieves list of instances of second class
\(named like that class or, if the relation is named,
CLASS-NAME-IN-NAME. Mapping class has three slots, `CLASS1-NAME' and
`CLASS2-NAME' that hold instances of first and second class, and
`WEIGHT' that holds an integer representing the strength of the
relationship. The following functions are available:
186

ryszard.szopa's avatar
ryszard.szopa committed
187
188
189
190
 * A predicate `RELATEDP', taking a keyword argument `RELATION', which
tells whether two objects are in a relation \(if `RELATION' is not
provided, the unnamed relation is assumed\). It returns a `NAME' or
`CLASS1-NAME-CLASS2-NAME' object. It has an accessor `WEIGHT'.
191

ryszard.szopa's avatar
ryszard.szopa committed
192
193
194
195
196
197
 * A function `RELATE' \(`RELATE-IN-NAME'\) that establishes a
relationship between its two arguments. It takes a key-argument,
`WEIGHT', by default 1. The order in which the object arguments are
provided is irrelevant.  `CONNECTION-SPEC' specifies the connection to
be used to create the link table."
  (let ((table-name (or name (intern (format nil "~A-~A" class1-name class2-name))))
198
199
200
201
        (class1-method-name class2-name)
        (class2-method-name class1-name))
    `(progn 
      (defclass ,table-name (dao)
202
        ((,class1-name :type ,class1-name :accessor ,class1-name :foreign t :on-delete :cascade)
ryszard.szopa's avatar
ryszard.szopa committed
203
204
         (,class2-name :type ,class2-name :accessor ,class2-name :foreign t :on-delete :cascade)
         (weight :type integer :accessor weight-of :initform 1 :initarg :weight))
205
        ;; A unique constraint here
ryszard.szopa's avatar
ryszard.szopa committed
206
        ;; or better no: thing of tags.
ryszard.szopa's avatar
ryszard.szopa committed
207
        (:unique (,class1-name ,class2-name))
208
        (:connection-spec ,@connection-spec)
209
210
211
212
        (:metaclass db-class))
      (defmethod ,class1-method-name ((object ,class1-name))
        (mapcar #',class2-name (select-dao-fun ',table-name (list := ',class1-name (get-id object)))))
      (defmethod ,class2-method-name ((object ,class2-name))
ryszard.szopa's avatar
ryszard.szopa committed
213
        (mapcar #',class1-name (select-dao-fun ',table-name (list := ',class2-name (get-id object)))))
ryszard.szopa's avatar
ryszard.szopa committed
214
      (defmethod relatedp-method ((object1 ,class1-name) (object2 ,class2-name) (relation ,(if name '(eql name) 'null)))
ryszard.szopa's avatar
ryszard.szopa committed
215
216
217
        (select-dao-fun ',table-name `(and
                                       (:= ,',class1-name ,(get-id object1))
                                       (:= ,',class2-name ,(get-id object2)))))
ryszard.szopa's avatar
ryszard.szopa committed
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
      (defmethod relate-method
          ((object1 ,class1-name) (object2 ,class2-name) (relation ,(if name '(eql name) 'null)) weight)
        (let ((instance (make-instance ',table-name :weight weight)))
          (setf (slot-value instance ',class1-name) object1)
          (setf (slot-value instance ',class2-name) object2)
          (save-dao instance)))

      (defmethod relate-method ((object1 ,class2-name) (object2 ,class1-name) relation weight)
        (relate-method object2 object1 relation weight))
      
      (defmethod unrelate-method ((object1 ,class1-name) (object2 ,class2-name) (relation ,(if name '(eql name) 'null)))
        (delete-dao (car (relatedp object1 object2))))
      (defmethod unrelate-method ((object2 ,class2-name) (object1 ,class1-name) relation)
        (unrelate-method object1 object2 relation)))))

(defgeneric relate-method (object1 object2 relation weight)
  (:documentation "Relate `OBJECT1' with `OBJECT2' in `RELATION'."))
(defgeneric relatedp-method (object1 object2 relation)
  (:documentation "Tell if `OBJECT1' is related to `OBJECT2' in `RELATION'."))
(defgeneric unrelate-method (object1 object2 relation)
  (:documentation "`OBJECT1' stops being with `OBJECT2' in `RELATION'."))

(defun relate (object1 object2 &key relation (weight 1))
  "Make OBJECT1 and OBJECT2 enter into the many-to-many relation
`RELATION'. If `RELATION' is not provided, the unnamed relation is
assumed."
  (relate-method object1 object2 relation weight))

(defun relatedp (object1 object2 &key relation)
  "Tell whether `OBJECT1' and `OBJECT2' are in the many-to-many relation
`RELATION' \(or the unnamed relation if `RELATION' is not provided\)."
  (relatedp-method object1 object2 relation))

(defun unrelate (object1 object2 &key relation)
  "`OBJECT1' stops being with `OBJECT2' in `RELATION'."
  (unrelate-method object1 object2 relation))
ryszard.szopa's avatar
ryszard.szopa committed
254

ryszard.szopa's avatar
ryszard.szopa committed
255
(defmacro make-and-save (type &rest rest)
ryszard.szopa's avatar
ryszard.szopa committed
256
257
  "Make a DAO and immediately save it. Takes the same arguments as
\(make-instance \(\(dao dao\)\)\)."
ryszard.szopa's avatar
ryszard.szopa committed
258
  `(save-dao (make-instance ,type ,@rest)))
ryszard.szopa's avatar
ryszard.szopa committed
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
;;; Copyright (C) 2007
;;; Ryszard Szopa <ryszard.szopa@gmail.com> & 
;;; Streamtech http://streamtech.nl/
;;;
;;; This software is provided 'as-is', without any express or implied
;;; warranty. In no event will the authors be held liable for any
;;; damages arising from the use of this software.
;;;
;;; Permission is granted to anyone to use this software for any
;;; purpose, including commercial applications, and to alter it and
;;; redistribute it freely, subject to the following restrictions:
;;;
;;; 1. The origin of this software must not be misrepresented; you must
;;;    not claim that you wrote the original software. If you use this
;;;    software in a product, an acknowledgment in the product
;;;    documentation would be appreciated but is not required.
;;;
;;; 2. Altered source versions must be plainly marked as such, and must
;;;    not be misrepresented as being the original software.
;;;
;;; 3. This notice may not be removed or altered from any source
;;;    distribution.