dao.lisp 9.96 KB
Newer Older
1
2
3
4
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; -*-

(in-package :submarine)

ryszard.szopa's avatar
ryszard.szopa committed
5
6
7
8
9
10
11
12
13
14
15
;; DAO conditions

(define-condition dao-error (simple-error)
  ((type :initarg :type :reader table-name))
  (:documentation "Base class for DAO related errors."))

(define-condition dao-nonexistent-id (dao-error)
  ((id :initarg :id :reader id))
  (:documentation "Condition signaling the attempt to initialize a dao
with a non-existant ID."))

16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
;;
;; 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 save-all-foreign-daos (dao)
36
  (:documentation "Saves recursively all foreign daos in the slots of DAO")
37
  (:method ((dao dao))
38
    (iter (for slot in (mapcar #'slot-definition-name (db-slots-of dao)))
39
40
41
42
43
          (let ((s-value (slot-value dao slot)))
            (when (typep s-value 'dao)
              (save-dao s-value))))))

(defgeneric dao-exists-p (dao)
44
  (:documentation "Return a boolean indicating whether the given DAO
45
46
exists in the database.")
  (:method ((dao dao))
ryszard.szopa's avatar
ryszard.szopa committed
47
    (with-object-connection (dao)
48
49
50
51
52
        (and (slot-boundp dao 'id)
             (postmodern::query (:select (:exists (:select 1 :from (class-name-of dao) :where (:= 'id (get-id dao)))))
                                :single)))))

(defun set-fields (object)
53
  (iter (for field in (mapcar #'slot-definition-name (db-slots-of object)))
54
        (appending `(,field ,(slot-value-or-id-if-foreign object field)))))
55
56
57
58
59

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

(defgeneric insert-dao (dao)
60
  (:documentation "Insert the given DAO into the database.")
61
  (:method ((dao dao))
ryszard.szopa's avatar
ryszard.szopa committed
62
    (with-object-connection (dao)
63
64
      (unless (slot-boundp dao 'id)
        (setf  (slot-value dao 'id) (postmodern::sequence-next (id-seq-name (class-of dao)))))
65
66
      (postmodern::execute (sql-compile `(:insert-into ,(class-name-of dao) :set ,@(set-fields dao)))))
    dao))
67
68

(defgeneric update-dao (dao)
69
  (:documentation "Update the DAO's representation in the database
70
with the values in the given object and return it."))
71
72

(defmethod update-dao ((dao dao))
ryszard.szopa's avatar
ryszard.szopa committed
73
  (with-object-connection (dao)
74
75
    (postmodern::execute (sql-compile 
                          `(:update ,(class-name-of dao) :set ,@(set-fields dao)
76
77
                            :where (:= 'id (get-id dao))))))
  dao)
78
79


80
81
82
(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
83
84
85
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)."
86
  (declare (ignore initargs))
87
88
89
90
  (labels ((ensure-not-db-null (x)
             (unless (equal x :NULL)
               x)))
    (when (slot-boundp dao 'id)
91
92
93
94
95
      (with-object-connection (dao)
        (let ((query-result (postmodern::query 
                             (:select '*
                                      :from (class-name-of  dao)
                                      :where (:= 'id (get-id dao))) :alist)))
96
97
          (unless query-result
            (error (make-condition 
ryszard.szopa's avatar
ryszard.szopa committed
98
                    'dao-nonexistent-id
99
                    :format-control "You tried to create a DAO with a non-existant ID."
ryszard.szopa's avatar
ryszard.szopa committed
100
                    :id (get-id dao) :type (class-name-of  dao))))
101
          (iter
102
            (for slot in  (db-slots-of  dao))
103
        
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
            (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)))))))))))
122

ryszard.szopa's avatar
ryszard.szopa committed
123
124
125
126
127
128
129
130
131
(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
132
  "Select daos of TYPE for the rows in its table for which the given TEST
ryszard.szopa's avatar
ryszard.szopa committed
133
134
135
holds."
  `(select-dao-fun ,type ',test))

136
(defgeneric delete-dao (dao)
ryszard.szopa's avatar
ryszard.szopa committed
137
138
139
140
  (: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)))))))
141

ryszard.szopa's avatar
get-dao    
ryszard.szopa committed
142
143
144
145
146
147
(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)))
148

149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176


(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."

177
(defmacro def-many-to-many (class1-name class2-name connection-spec)
178
179
180
181
182
183
184
185
186
  "Defines many-to-many mapping between two persistent classes.

CLASS*-NAME should be an (unquoted) symbol with class name.

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

ryszard.szopa's avatar
ryszard.szopa committed
187
The connection-spec specifies the connection to be used with the link table."
188
189
190
191
192
193
194
195
  (let ((table-name (intern (format nil "~A-~A" class1-name class2-name)))
        (class1-method-name class2-name)
        (class2-method-name class1-name))
    `(progn 
      (defclass ,table-name (dao)
        ((,class1-name :type ,class1-name :accessor ,class1-name)
         (,class2-name :type ,class2-name :accessor ,class2-name))
        ;; A unique constraint here
ryszard.szopa's avatar
ryszard.szopa committed
196
        ;; or better no: thing of tags.
197
        (:connection-spec ,@connection-spec)
198
199
200
201
202
203
204
        (: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))
        (mapcar #',class1-name (select-dao-fun ',table-name (list := ',class2-name (get-id object))))))))

(defgeneric relate (object1 object2)
205
  (:documentation "Make OBJECT1 and OBJECT2 enter into a many to many relation.")
206
207
208
209
  (:method ((object1 dao) (object2 dao))
    ;; Catch unique constraint violation
    (let* ((type1 (type-of object1))
           (type2 (type-of object2))
210
211
212
213
214
215
           (link  (intern (format nil "~A-~A" type1 type2)))
           (instance (make-instance link)))
      (progn 
        (setf (slot-value instance type1) object1)
        (setf (slot-value instance type2) object2)
        (save-dao instance)))))
ryszard.szopa's avatar
ryszard.szopa committed
216

ryszard.szopa's avatar
ryszard.szopa committed
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
;;; 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.