- Fix TERM-SYNONYMS.
[cl-trane.git] / src / taxonomy.lisp
blobf6a98acc4013fa46e98c6ccb11400b2edbd7f6f8
1 ;;; Taxonomy Library
2 ;;; Inspiration: http://svn.automattic.com/wordpress/trunk/wp-includes/taxonomy.php
4 ;;;; Copyright (c) 2008, Maciej Pasternacki <maciej@pasternacki.net>
5 ;;;; All rights reserved. This file is available on the terms
6 ;;;; detailed in COPYING file included with it.
8 ;;; TODO:
9 ;;; - Customizable dao table, support table and support function names (common prefix)
11 (defpackage #:trane-taxonomy
12 (:use #:common-lisp #:trane-common #:iterate #:postmodern)
13 (:export #:taxonomy #:taxonomy-name #:taxonomy-slug
14 #:item-dao-class #:valued-taxonomy
15 #:cl-store-valued-taxonomy #:deftaxonomy #:ensure-taxonomy
16 #:ensure-term #:term #:term-text
17 #:slug #:term-taxonomy-name
18 #:description #:term-taxonomy #:term-synonyms
19 #:id #:find-terms #:new-term #:apply-term
20 #:term-value #:item-terms #:order-item-terms
21 #:unbind-term :term-item-ids #:term-items
22 #:setup-taxonomy-sql))
24 (in-package #:trane-taxonomy)
26 (defvar *taxonomies* nil
27 "A list of defined taxonomies."
28 ;; It is supposed to be just a few of them, hash table overhead
29 ;; would be too big.
32 (defclass taxonomy ()
33 ((name :initarg :name :reader taxonomy-name)
34 (item-dao-class :initarg :item-dao-class :reader item-dao-class))
35 (:documentation "Base taxonomy class.
37 Taxonomy has a name (symbol or string, which is transformed to a
38 keyword by DEFTAXONOMY), and refers to DAO classes of taxonomy's ITEM.
39 DAO classes are required to have an integer primary key, accessible by
40 reader named ID."))
42 (defmethod print-object ((taxonomy taxonomy) stream)
43 (print-unreadable-object (taxonomy stream :type t :identity t)
44 (princ (taxonomy-name taxonomy) stream)))
46 (defun taxonomy-slug (taxonomy)
47 "Return name of taxonomy for database or URL (lowercased string).
49 Applicable to taxonomy objects, symbols and strings."
50 (string-downcase (string (if (or (stringp taxonomy)
51 (symbolp taxonomy))
52 taxonomy
53 (taxonomy-name taxonomy)))))
55 (defclass valued-taxonomy (taxonomy)
56 ((value-encoder-function :initarg :encoder :reader value-encoder-function :initform #'identity)
57 (value-decoder-function :initarg :decoder :reader value-decoder-function :initform #'identity))
58 (:documentation "Taxonomy where items applied to terms may have values.
60 Defines encoder and decoder function slots, which are responsible
61 for translating value from a Lisp value to DB-safe string. By
62 default it is identity function, which means values need to be
63 strings."))
65 (defun encode-value (taxonomy value)
66 "Encode VALUE for database, as TAXONOMY specifies.
68 TAXONOMY should be a VALUED-TAXONOMY instance, and VALUE should
69 be any value supported by the taxonomy. When VALUE is NIL, it is
70 encoded as database NULL."
71 (if value
72 (funcall (value-encoder-function taxonomy)
73 value)
74 :null))
76 (defun decode-value (taxonomy value)
77 "Decode VALUE from database, as TAXONOMY specifies.
79 TAXONOMY should be a VALUED-TAXONOMY instance."
80 (unless (eq :null value)
81 (funcall (value-decoder-function taxonomy) value)))
83 (defmacro deftaxonomy (name (&optional (class 'taxonomy)) &rest args)
84 "Defines taxonomy named NAME, with class CLASS and initargs ARGS, and remembers it in *TAXONOMIES*.
86 NAME is symbol or string, which will be transformed to a keyword anyway."
87 `(setf *taxonomies*
88 (cons (make-instance ',class
89 :name ,(make-keyword name)
90 ,@args)
91 (delete ,(make-keyword name) *taxonomies*
92 :key #'taxonomy-name))))
94 (defun ensure-taxonomy (taxonomy)
95 "If TAXONOMY is a taxonomy object, return it, otherwise find and return taxonomy named TAXONOMY."
96 (if (subtypep (class-of taxonomy) (find-class 'taxonomy))
97 taxonomy
98 (find (make-keyword taxonomy) *taxonomies*
99 :key #'taxonomy-name)))
101 (defclass term ()
102 ((term-id :col-type serial :reader id)
103 (term-text :col-type (varchar 255) :initarg :text :accessor term-text :documentation "Full text of term")
104 (term-slug :col-type (varchar 255) :accessor slug :documentation "URL-friendly version of term text, initially chosen by database")
105 (term-taxonomy :col-type (varchar 32) :col-default "" :reader term-taxonomy-name :initarg :taxonomy-name :documentation "Name of term's taxonomy")
106 (term-description :col-type (or db-null text) :accessor description :initarg :description :documentation "Textual description of a term"))
107 (:metaclass dao-class)
108 (:keys term-id)
109 (:documentation "Class for a term associated with taxonomy."))
111 ;;; TODO: pathnames (relative and absolute) as EXECUTE* parameters.
112 (defun setup-taxonomy-sql (&key item)
113 "List of SQL statements, suitable for TRANE-COMMON:EXECUTE*, to initialize database for Trane Taxonomy module.
115 ITEM is an optional arguments that, if given, specifies foreign key
116 reference on term's associated item_id columns. It can be a DAO
117 class, a symbol naming one, or a list literally specifying S-SQL's
118 foreign key (as for :CREATE-TABLE sql-op :REFERENCES constraint)."
119 (list (dao-table-definition 'term)
120 `(:alter-table ,(dao-table-name 'term) :add :unique term-text term-taxonomy)
121 `(:alter-table ,(dao-table-name 'term) :add :unique term-slug term-taxonomy)
122 `(:alter-table ,(dao-table-name 'term) :add :check (:raw "(term_slug SIMILAR TO '[a-z0-9-]+')"))
123 `(:create-table
124 item-term ; FIXME:name
125 ((item-id :type int ,@ (etypecase item
126 (null)
127 ((or symbol class)
128 `(:references (,(dao-table-name item))))
129 (list (cons :references item))))
130 (term-id :type int :references (term))
131 (item-term-value :type (or db-null text))
132 (item-term-order :type (or db-null int)))
133 (:primary-key item-id term-id))
135 ;; Create new term. Signals error if term exists.
136 ;; FIXME: count existing slugs starting with new slug
137 "CREATE OR REPLACE FUNCTION new_term(
138 the_text VARCHAR, the_slug VARCHAR, the_taxonomy VARCHAR)
139 RETURNS term
140 AS $body$
141 DECLARE
142 res term;
143 i INTEGER;
144 BEGIN
145 BEGIN
146 INSERT INTO term(term_text, term_slug, term_taxonomy)
147 VALUES (the_text, the_slug, the_taxonomy);
148 EXCEPTION
149 WHEN unique_violation THEN
150 SELECT count(*) FROM term WHERE term_slug LIKE the_slug||'%' INTO i;
151 LOOP
152 i = i+1;
153 IF i > 999 THEN RAISE EXCEPTION 'Afraid of infinite loop.';
154 END IF;
155 BEGIN
156 INSERT INTO term(term_text, term_slug, term_taxonomy)
157 VALUES (the_text, the_slug||'-'||i, the_taxonomy);
158 EXCEPTION WHEN unique_violation THEN
159 IF POSITION('_slug_' IN SQLERRM) <> 0 THEN CONTINUE; END IF;
160 RAISE EXCEPTION 'Duplicate term. How to re-raise from PL/PgSQL?';
161 END;
162 EXIT; -- Exit loop when no unique_violation.
163 END LOOP;
164 END;
165 SELECT INTO res * FROM term WHERE term_id=CURRVAL('term_term_id_seq');
166 RETURN res;
167 END;
168 $body$ LANGUAGE plpgsql;"
170 ;; Selects or inserts term named `the_text' in taxonomy
171 ;; `the_taxonomy'. Returns found/new term. No support for
172 ;; description or parent for new term, this function is
173 ;; intended to work with simple terms only (e.g. tags).
174 "CREATE OR REPLACE FUNCTION ensure_term(
175 the_text VARCHAR,
176 suggested_slug VARCHAR,
177 the_taxonomy VARCHAR)
178 RETURNS term
179 AS $body$
180 DECLARE
181 res term;
182 BEGIN
183 SELECT INTO res * FROM term
184 WHERE term_text=the_text
185 AND term_taxonomy=the_taxonomy;
186 IF NOT FOUND
187 THEN res = new_term(the_text, suggested_slug, the_taxonomy);
188 END IF;
189 RETURN res;
190 END;
191 $body$ LANGUAGE plpgsql;"
193 ;; Sets term value for item (UPDATE or INSERT if needed). When value
194 ;; is NULL, just ensures that an association is established.
195 "CREATE OR REPLACE FUNCTION set_item_term_value(
196 the_item_id INTEGER,
197 the_term_id INTEGER,
198 the_new_value TEXT)
199 RETURNS VOID
200 AS $body$
201 BEGIN
202 UPDATE item_term
203 SET item_term_value=the_new_value
204 WHERE item_id=the_item_id AND term_id=the_term_id;
205 IF NOT FOUND THEN
206 INSERT INTO item_term(item_id, term_id, item_term_value)
207 VALUES(the_item_id, the_term_id, the_new_value);
208 END IF;
209 END;
210 $body$ LANGUAGE PLPGSQL;"))
212 (defmethod print-object ((term term) stream)
213 (print-unreadable-object (term stream :type t :identity t)
214 (princ (slug term) stream)))
216 (defun term-taxonomy (term)
217 "TERM's taxonomy object"
218 (ensure-taxonomy (term-taxonomy-name term)))
220 (defun ensure-term (taxonomy &key text slug create-p)
221 "Find or create term in taxonomy TAXONOMY.
223 TEXT is a full text of term; if TEXT is given, CREATE-P is
224 non-NIL and term is not found, new term is inserted into
225 database.
227 If SLUG is given instead of TEXT, only search is possible, not
228 creation."
229 #+b0rken (assert (and (or text slug)
230 (not (and text slug)))
232 "Either TEXT or SLUG should be given, but not both.")
233 (first
234 (if text
235 (if create-p
236 (query-dao 'term (:select '* :from (:ensure-term text (or slug (slugify text)) (taxonomy-slug taxonomy))))
237 (select-dao 'term (:and (:= 'term-text text)
238 (:= 'term-taxonomy (taxonomy-slug taxonomy)))))
239 (progn
240 (when create-p
241 (warn "CREATE-P is meaningful only with TEXT defined."))
242 (select-dao 'term (:and (:= 'term-slug slug)
243 (:= 'term-taxonomy (taxonomy-slug taxonomy))))))))
245 (defun new-term (taxonomy text &optional parent)
246 "Create new term in TAXONOMY, with full name TEXT."
247 (first (query-dao 'term
248 (:select '* :from
249 (:new-term text (taxonomy-slug taxonomy) (if parent (slug parent) :null))))))
251 (defun find-terms-where-clause (&key taxonomy text slug
252 &aux (query ()))
253 (when taxonomy
254 (push (list := 'term-taxonomy (taxonomy-slug taxonomy))
255 query))
257 (when text
258 (push (list := 'term-text text) query))
260 (when slug
261 (push (list := 'term-slug slug) query))
263 (if (> (length query) 1)
264 (push :and query)
265 (setf query (first query)))
267 query)
269 (defun find-terms (&key taxonomy text slug)
270 "Find list of terms satisfying given keywords."
271 (query-dao 'term
272 (sql-compile `(:order-by (select '* :from 'term
273 :where ,(find-terms-where-clause :taxonomy taxonomy
274 :text text
275 :slug slug))
276 'term-text))))
278 (defun term-synonyms (term)
279 "Return list of terms synonymous with TERM.
281 Two terms are synonymous when they are in the same taxonomy and differ
282 only in case. More special cases for synonymity may be introduced
283 later.
285 TERM is always included in the returned list, and it is a first item.
287 TERM may be also a list, whose first element is taxonomy object or
288 name, and second element is term name. This is a case of premature
289 optimization."
290 (etypecase term
291 (term (cons term
292 (mapcar #'cache-dao
293 (query-dao 'term
294 (sql (:select '* :from 'term
295 :where (:and (:!= 'term-id (id term))
296 (:= 'term-taxonomy
297 (taxonomy-slug (term-taxonomy term)))
298 (:= (:lower 'term-text)
299 (:lower (term-text term))))))))))
300 (list (mapcar #'cache-dao
301 (query-dao 'term
302 (sql (:select '* :from 'term
303 :where (:and (:= 'term-taxonomy
304 (taxonomy-slug (first term)))
305 (:= (:lower 'term-text)
306 (:lower (string (second term))))))))))))
308 (defun apply-term (item term &key value order)
309 "Apply TERM to ITEM, optionally setting its value to VALUE."
310 (query (:insert-into 'item-term :set
311 'item-id (id item)
312 'term-id (id term)
313 'item-term-value (encode-value (taxonomy term) value)
314 'item-term-order (null-or order))))
316 (defun term-value (item term
317 &aux (encoded (query (:select 'item-term-value 'item-term-order
318 :from 'item-term
319 :where (:and (:= 'item-id (id item))
320 (:= 'term-id (id term))))
321 :row)))
322 "Returns value that association of ITEM and TERM is set to.
324 As a second value returns T if an association was found at all,
325 NIL otherwise. This makes it possible to tell between an
326 association with a NIL value and no association at all.
328 Third value is a term ordering value, if ordering is set."
329 (if encoded
330 (values (decode-value (taxonomy term) (first encoded)) t (unless-null (second encoded)))
331 (values nil nil nil)))
333 (defun (setf term-value) (new-value item term)
334 "Set new value for association of ITEM and TERM.
336 New association between ITEM and TERM is established if it was
337 not present before."
338 (query (:select (:set-item-term-value (id item) (id term)
339 (encode-value (taxonomy term) new-value)))
340 :none))
342 (defun unbind-term (item term)
343 "Deletes association between ITEM and TERM.
345 If PURGE-EMPTY is non-NIL (default), deletes also from TERM table if
346 no more items refer to this term."
347 (execute (:delete-from 'item-term :where
348 (:and (:= 'item-id (id item))
349 (:= 'term-id (id term)))))
350 (execute (:delete-from 'term :where (:and (:= 'term-id (id term))
351 (:not (:exists (:select '* :from 'item-term
352 :where (:= 'term-id (id term)))))))))
354 (defun item-terms (item &optional taxonomy)
355 "List TERMs associated with ITEM in given TAXONOMY.
357 If TAXONOMY is not given, returns terms in all taxonomies."
358 (query-dao 'term
359 (sql-compile
360 `(:order-by
361 (:select 'term.* :from 'term 'item-term :where
362 (:and ,@(when taxonomy
363 (list (list :=
364 ''term.term-taxonomy
365 (taxonomy-slug taxonomy))))
366 (:= 'item-term.item-id ,(id item))
367 (:= 'term.term-id 'item-term.term-id)))
368 'item-term.item-term-order))))
370 (defun order-case-ssql (column values)
371 `(:case
372 ,@(loop
373 for i from 1
374 for v in values
375 collect `((:= ,column ,v) ,i))
376 (t :null)))
378 (defun order-item-terms (item terms &key taxonomy null-other-terms
379 &aux (term-ids (mapcar #'id terms)))
380 "Set TERMS (a list of terms or term IDs), associated with ITEM, in given order.
382 If NULL-OTHER-TERMS is not NIL, terms not listed in TERMS get their
383 order column set to NULL. If TAXONOMY is given, restrict changes to
384 terms of given taxonomy."
385 (query
386 (sql-compile
387 `(:update item-term
388 :set item-term-order ,(if terms
389 (order-case-ssql 'term-id term-ids)
390 :null)
391 :where (:and (:= 'item-id ,(id item))
392 ,@(if null-other-terms
393 (when taxonomy
394 `((:exists (:select t
395 :from 'term
396 :where (:and (:= 'term-id 'item-term.term-id)
397 (:= 'term-taxonomy
398 ,(taxonomy-slug taxonomy)))))))
399 `((:in 'term-id (:set ,@term-ids)))))))))
401 (defun term-item-ids (term)
402 "IDs of items associated with given TERM."
403 (query (:select 'item-id :from 'item-term :where (:= 'term-id (id term)))
404 :column))
406 (defun term-items (term &aux (class (item-dao-class (taxonomy (if (integerp term) ; FIXME
407 (get-dao 'term term)
408 term)))) )
409 "Items associated with given TERM."
410 (mapcar #'(lambda (id)
411 (get-dao class id))
412 (term-item-ids term)))
414 #+cl-trane.taxonomy.use-cl-store
415 (progn
416 (defun store-to-base64 (obj)
417 (base64:usb8-array-to-base64-string
418 (flex:with-output-to-sequence (s)
419 (cl-store:store obj s))))
421 (defun restore-from-base64 (b64)
422 (flex:with-input-from-sequence (s (base64:base64-string-to-usb8-array b64))
423 (cl-store:restore s)))
425 (defclass cl-store-valued-taxonomy (valued-taxonomy)
427 (:default-initargs :encoder #'store-to-base64 :decoder #'restore-from-base64)
428 (:documentation "Valued taxonomy that by default encodes/decodes almost any Lisp object with CL-STORE as BASE64 string.")))