5eff8ccfabeada2c409269c03371e3ed0006609f
[clinton/lisp-on-lines.git] / src / backend / clsql.lisp
1 (in-package :meta-model)
2
3 (eval-when (:compile-toplevel :load-toplevel :execute)
4 (use-package :clsql))
5
6 (export 'def-meta-model-from-table)
7 (export 'def-meta-models)
8 (export 'def-view-class/meta)
9 (export 'list-base-classes)
10
11
12
13 (defmethod sync-instance ((view clsql:standard-db-object) &key (fill-gaps-only-p nil) (database *default-database*))
14 (labels ((sym->sql (sym) (string-downcase (substitute #\_ #\- (string sym))))
15 (get-def (slot) (caar (query
16 (format nil "SELECT DISTINCT adsrc from pg_attrdef join pg_attribute on attnum = adnum where adrelid = (select oid from pg_class where relname = '~A') and attname = '~A'" (sym->sql (class-name (class-of view))) (sym->sql slot)))))
17 (get-default-value (slot)
18 (let ((def (get-def slot)))
19 (if def
20 (caar (query (format nil "SELECT ~A" def)))))))
21
22 (dolist (slot (list-slots view))
23 (when (and (primary-key-p view slot)
24 (or (not (slot-boundp view slot))
25 (equal (slot-value view slot) nil)))
26 (setf (slot-value view slot) (get-default-value slot))
27 (when (and (primary-key-p view slot)
28 (not (slot-value view slot))
29 (not fill-gaps-only-p))
30 (error "No default value for primary key : ~A" slot))))
31 (when fill-gaps-only-p
32 (update-objects-joins (list view))
33 (return-from sync-instance))
34 (update-records-from-instance view :database database)
35 (update-instance-from-records view :database database)
36 (update-objects-joins (list view)))
37
38 ;; return the modified and hopefully now persistent object
39 view)
40
41
42
43 (defparameter *clsql-base-classes* (list) )
44
45 (defmethod list-base-classes ((type (eql :clsql)))
46 *clsql-base-classes*)
47
48 (defmethod def-base-type-class-expander ((base-type (eql :clsql)) (model meta-model-class) (name t) (args t))
49 `(def-view-class ,name ()
50 ,(meta-model.metadata model)))
51
52 (defmethod def-base-type-class-expander :after ((base-type (eql :clsql)) (model meta-model-class) (name t) (args t))
53 (unless (member name *clsql-base-classes*)
54 (setf *clsql-base-classes* (cons name *clsql-base-classes*))))
55
56 (defparameter *sql-type-map* '((:INT4 integer) (:BOOL boolean) (:TEXT string) (:VARCHAR string) (:TIMESTAMP clsql-sys::wall-time) (:NUMERIC number)(:BYTEA string)))
57
58 (defun gen-type (table column)
59 (cadr (assoc
60 (cadr (assoc
61 column
62 (list-attribute-types table)
63 :test #'equalp ))
64 *sql-type-map*)))
65
66 (defun sql->sym (name &optional (package nil))
67 (flet ((xform (x)
68 (string-upcase (substitute #\- #\_ x))))
69 (if package
70 (intern (xform (string name)) package)
71 (intern (xform (string name))))))
72
73 (defun table->slots (table pkey &optional (accesor-prefix table) (prefix-all-p nil))
74 (mapcar
75 #'(lambda (col)
76 (flet ((accessor-name (col)
77 (let ((name (sql->sym col)))
78 (if (or prefix-all-p
79 (and (fboundp name)
80 (eq (type-of (symbol-function name)) 'function)))
81 (sql->sym (concatenate 'string
82 (string accesor-prefix) "-" col))
83 name))))
84
85 `(,(sql->sym col)
86 :accessor ,(accessor-name col)
87 :initarg ,(sql->sym col "KEYWORD")
88 :type ,(gen-type table col)
89 :db-kind
90 ,(if (equalp col pkey)
91 `:key
92 `:base))))
93 (list-attributes table)))
94
95 (defun view-class-definition-list ()
96 (mapcar #'(lambda (x) `(def-meta-model-from-table ,x))
97 (list-tables)))
98
99 (defmacro def-meta-models ()
100 (let ((defs (view-class-definition-list)))
101 `(progn ,@defs)))
102
103
104 (defun get-pkeys ()
105 (let ((keys '()))
106 (dolist (row (get-pkeys-query))
107 (setf keys (acons (car row) (list (cadr row)) keys)))
108 keys))
109
110 (defun get-pkeys-query()
111 (query
112 "SELECT pg_class.relname, pg_attribute.attname, pg_catalog.quote_ident(conname) AS constraint_n
113 , pg_catalog.pg_get_indexdef(d.objid) AS constraint_definition
114 , CASE
115 WHEN contype = 'p' THEN
116 'PRIMARY KEY'
117 ELSE
118 'UNIQUE'
119 END as constraint_type
120 FROM
121 pg_class, pg_attribute,
122 pg_catalog.pg_constraint AS c
123 JOIN pg_catalog.pg_depend AS d ON (d.refobjid = c.oid)
124 WHERE contype IN ('p', 'u')
125 AND deptype = 'i'
126 and conrelid = pg_class.oid
127 and pg_attribute.attnum = ANY (c.conkey)
128 and pg_attribute.attrelid = pg_class.oid"))
129
130 ;;here is how this works
131 ;;from the postgres system tables we get
132 ;;list of all the has-a relationships.
133 ;;the inverse of a has-a is an implicit has-many
134 ;;and any relation having more than one foreign key
135 ;;is a join table hosting a many-to-many relationship
136
137 (defun get-fkey-explosions ()
138 (let ((key-table (get-fkey-explosions-query))
139 (keys '()))
140 (dolist (row key-table)
141 (setf row (mapcar #'(lambda (x)
142 (sql->sym x))
143 row))
144 ;;this one does the has-a
145 (setf keys (acons (car row) (gen-has-a row)
146 keys))
147 ;;the inverse of the previous represents a has-many.
148 (setf keys
149 (acons (fourth row) (gen-has-many row)
150 keys))
151
152 ;;many-to-many
153 (dolist (mrow
154 (remove-if #'(lambda (r) (or (not (equal (car row) (car r)))
155 (equal (last row) (last r))))
156 (mapcar #'(lambda (x)
157 (mapcar #'sql->sym x))
158 key-table)))
159 (setf keys (acons (fourth row)
160 (gen-many-to-many mrow (third row) (second row))
161 keys))))
162 keys ))
163
164
165 (defun get-fkey-explosions-query ()
166 ;;these query's are a mess, i don't even know how they work :)
167 (query "
168 SELECT pg_class.relname,
169 pg_attribute.attname,
170 fa.attname ,
171 f.relname
172 FROM pg_class,
173 pg_constraint,
174 pg_attribute,
175 pg_class as f ,
176 pg_attribute as fa
177 WHERE pg_class.relname in (select tablename from pg_tables where schemaname = 'public')
178 AND pg_class.oid = pg_constraint.conrelid
179 AND pg_attribute.attnum = ANY (pg_constraint.conkey)
180 AND pg_attribute.attrelid = pg_class.oid
181 AND f.oid = confrelid
182 AND fa.attrelid = f.oid
183 AND fa.attnum = ANY (pg_constraint.confkey)"))
184
185
186 ;; i chose keyword args here so as to make the code more understandable.
187 ;; it didn't really work.
188 (defun gen-join-slot (&key name home-key foreign-key join-class (set nil))
189 `(,(intern name)
190 :accessor ,(intern name)
191 :db-kind :join
192 :db-info (:join-class ,join-class
193 :home-key ,home-key
194 :foreign-key ,foreign-key
195 :set ,set)))
196
197 (defun gen-has-a (row)
198 (gen-join-slot
199 :name
200 (format nil "~A->~A" (string (car row))(string (second row)))
201 :home-key (second row)
202 :foreign-key (third row)
203 :join-class (fourth row)))
204
205 (defun gen-has-many (row)
206 (gen-join-slot
207 :name
208 (format nil "~A->~A" (string (car row))(string (second row)))
209 :home-key (third row)
210 :foreign-key (second row)
211 :join-class (car row)
212 :set t))
213
214 (defun gen-many-to-many (row home-key foreign-key)
215 (let ((name (sql->sym (string-upcase (format nil "~A<-~A->~A" (string (car row)) (string foreign-key) (string (second row)))))))
216 (setf row (mapcar #'sql->sym row))
217 `(,name
218 :accessor ,name
219 :db-kind :join
220 :db-info (:join-class ,(car row)
221 :home-key ,home-key
222 :foreign-key ,foreign-key
223 :target-slot ,name
224 :set t))))
225
226 (defmethod update-records-from-instance :before ((view clsql::standard-db-object) &key database)
227 (declare (ignorable database))
228 (labels ((sym->sql (sym) (string-downcase (substitute #\_ #\- (string sym))))
229 (get-def (slot) (caar (query
230 (format nil "SELECT DISTINCT adsrc from pg_attrdef join pg_attribute on attnum = adnum where adrelid = (select oid from pg_class where relname = '~A') and attname = '~A'" (sym->sql (class-name (class-of view))) (sym->sql slot)))))
231 (get-default-value (slot) (caar (query (format nil "SELECT ~A" (get-def slot))))))
232
233 (dolist (slot (list-slots view))
234 (when (and (primary-key-p view slot)
235 (or (not (slot-boundp view slot))
236 (equal (slot-value view slot) nil)))
237 (setf (slot-value view slot) (get-default-value slot))))))
238
239 ;;;;
240
241 (defmacro def-view-class/meta (name supers slots &rest args)
242 "Create and instrument CLSQL view-class NAME and
243 appropriate meta-model class its default name is %NAME-meta-model."
244
245 (let ((model-name (cond ((eq :model-name (car args))
246 (pop args) ; remove keyword
247 (pop args)) ; get value
248 (t (intern (format nil "%~S-META-MODEL" name))))))
249
250 `(progn
251 (let* ((m (def-meta-model ,model-name ,supers ,slots ,args))
252 (i (make-instance m)))
253 (setf (meta-model.base-type i) :clsql)
254 (prog1 (eval (def-base-class-expander i ',name ',args))
255 (defmethod meta-model.metadata ((self ,name))
256 (meta-model.metadata i)))))))
257
258 (defmacro def-view-class/table (table &optional (name (sql->sym table)) model-name)
259 "takes the name of a table as a string and
260 creates a clsql view-class"
261 (let* ((pkey (cadr (assoc table (get-pkeys) :test #'equalp)))
262 (table-slots (table->slots table pkey name))
263 (join-slots
264 (let ((slots nil))
265 (dolist (exp (get-fkey-explosions))
266 (when (equalp (car exp) (sql->sym table))
267 (setf slots (cons (cdr exp) slots))))
268 slots)))
269 `(eval-when (:compile-toplevel :load-toplevel :execute)
270 (def-view-class/meta ,name
271 ()
272 ,(append table-slots join-slots)
273 ,@(when model-name (list :model-name model-name))))))
274
275
276 (defmethod prepare-slot-name-for-select ((i standard-db-object) slot-name)
277 (clsql:sql-expression :attribute slot-name))
278
279 (def-compare-expr standard-db-object expr-= sql-=)
280 (def-compare-expr standard-db-object expr-< sql-<)
281 (def-compare-expr standard-db-object expr-> sql->)
282 (def-compare-expr standard-db-object expr-ends-with sql-uplike :value-format "%~A")
283 (def-compare-expr standard-db-object expr-starts-with sql-uplike :value-format "~A%")
284 (def-compare-expr standard-db-object expr-contains sql-uplike :value-format "%~A%")
285
286 (def-logical-expr standard-db-object expr-and #'sql-and)
287
288 (def-logical-expr standard-db-object expr-or #'sql-or)
289
290 (def-logical-expr standard-db-object expr-not #'sql-not)
291
292 (defmethod select-instances ((instance standard-db-object) &rest query)
293 (unless (keywordp (car query))
294 (setf query (cons :where query)))
295 (apply #'select (class-name (class-of instance)) :flatp t query))