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.
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
#:site-dao-class
14 #:item-dao-class
#:taxonomy-value-mixin
15 #:taxonomy-cl-store-value-mixin
#:valued-taxonomy
16 #:cl-store-valued-taxonomy
#:deftaxonomy
#:ensure-taxonomy
17 #:ensure-term
#:term
#:term-text
18 #:slug
#:term-site-id
#:term-taxonomy-name
19 #:description
#:parent-id
#:term-taxonomy
#:term-site
20 #:id
#:find-terms
#:new-term
#:apply-term
21 #:term-value
#:item-terms
#:order-item-terms
22 #:unbind-term
:term-item-ids
#:term-items
23 #:setup-taxonomy-sql
))
25 (in-package #:trane-taxonomy
)
27 (defvar *taxonomies
* nil
28 "A list of defined taxonomies."
29 ;; It is supposed to be just a few of them, hash table overhead
34 ((name :initarg
:name
:reader taxonomy-name
)
35 (site-dao-class :initarg
:site-dao-class
:reader site-dao-class
)
36 (item-dao-class :initarg
:item-dao-class
:reader item-dao-class
))
37 (:documentation
"Base taxonomy class.
39 Taxonomy has a name (symbol or string, which is transformed to a
40 keyword by DEFTAXONOMY), and refers to DAO classes of taxonomy's
41 SITE and ITEM. DAO classes are required to have an integer
42 primary key, accessible by reader named ID."))
44 (defmethod print-object ((taxonomy taxonomy
) stream
)
45 (print-unreadable-object (taxonomy stream
:type t
:identity t
)
46 (princ (taxonomy-name taxonomy
) stream
)))
48 (defun taxonomy-slug (taxonomy)
49 "Return name of taxonomy for database or URL (lowercased string).
51 Applicable to taxonomy objects, symbols and strings."
52 (string-downcase (string (if (or (stringp taxonomy
)
55 (taxonomy-name taxonomy
)))))
57 (defclass valued-taxonomy
(taxonomy)
58 ((value-encoder-function :initarg
:encoder
:reader value-encoder-function
:initform
#'identity
)
59 (value-decoder-function :initarg
:decoder
:reader value-decoder-function
:initform
#'identity
))
60 (:documentation
"Taxonomy where items applied to terms may have values.
62 Defines encoder and decoder function slots, which are responsible
63 for translating value from a Lisp value to DB-safe string. By
64 default it is identity function, which means values need to be
67 (defun encode-value (taxonomy value
)
68 "Encode VALUE for database, as TAXONOMY specifies.
70 TAXONOMY should be a VALUED-TAXONOMY instance, and VALUE should
71 be any value supported by the taxonomy. When VALUE is NIL, it is
72 encoded as database NULL."
74 (funcall (value-encoder-function taxonomy
)
78 (defun decode-value (taxonomy value
)
79 "Decode VALUE from database, as TAXONOMY specifies.
81 TAXONOMY should be a VALUED-TAXONOMY instance."
82 (unless (eq :null value
)
83 (funcall (value-decoder-function taxonomy
) value
)))
85 (defmacro deftaxonomy
(name (&optional
(class 'taxonomy
)) &rest args
)
86 "Defines taxonomy named NAME, with class CLASS and initargs ARGS, and remembers it in *TAXONOMIES*.
88 NAME is symbol or string, which will be transformed to a keyword anyway."
90 (cons (make-instance ',class
91 :name
,(make-keyword name
)
93 (delete ,(make-keyword name
) *taxonomies
*
94 :key
#'taxonomy-name
))))
96 (defun ensure-taxonomy (taxonomy)
97 "If TAXONOMY is a taxonomy object, return it, otherwise find and return taxonomy named TAXONOMY."
98 (if (subtypep (class-of taxonomy
) (find-class 'taxonomy
))
100 (find (make-keyword taxonomy
) *taxonomies
*
101 :key
#'taxonomy-name
)))
104 ((term-id :col-type serial
:reader id
)
105 (term-text :col-type
(varchar 255) :initarg
:text
:accessor term-text
:documentation
"Full text of term")
106 (term-slug :col-type
(varchar 255) :accessor slug
:documentation
"URL-friendly version of term text, initially chosen by database")
107 (site-id :col-type integer
:reader term-site-id
:initarg
:site-id
:documentation
"ID of term's site")
108 (term-taxonomy :col-type
(varchar 32) :col-default
"" :reader term-taxonomy-name
:initarg
:taxonomy-name
:documentation
"Name of term's taxonomy")
109 (term-description :col-type
(or db-null text
) :accessor description
:initarg
:description
:documentation
"Textual description of a term"))
110 (:metaclass dao-class
)
112 (:documentation
"Class for a term associated with taxonomy and a site."))
114 ;;; TODO: pathnames (relative and absolute) as EXECUTE* parameters.
115 (defun setup-taxonomy-sql (&key site item
)
116 "List of SQL statements, suitable for TRANE-COMMON:EXECUTE*, to initialize database for Trane Taxonomy module.
118 SITE and ITEM are optional arguments that, if given, specify foreign
119 key reference on term's site and associated item_id columns. Any of
120 those can be a DAO class or a symbol naming one, or a list literally
121 specifying S-SQL's foreign key (as for :CREATE-TABLE
122 sql-op :REFERENCES constraint)."
123 (list (dao-table-definition 'term
)
124 `(:alter-table
,(dao-table-name 'term
) :add
:unique term-text site-id term-taxonomy
)
125 `(:alter-table
,(dao-table-name 'term
) :add
:unique term-slug site-id term-taxonomy
)
126 `(:alter-table
,(dao-table-name 'term
) :add
:check
(:raw
"(term_slug SIMILAR TO '[a-z0-9-]+')"))
128 `(:alter-table
,(dao-table-name 'term
) :add
:foreign-key
(site-id)
131 (list (dao-table-name site
)))
135 item-term
; FIXME:name
136 ((item-id :type int
,@ (etypecase item
139 `(:references
(,(dao-table-name item
))))
140 (list (cons :references item
))))
141 (term-id :type int
:references
(term))
142 (item-term-value :type
(or db-null text
))
143 (item-term-order :type
(or db-null int
)))
144 (:primary-key item-id term-id
))
146 ;; Create new term. Signals error if term exists.
147 ;; FIXME: count existing slugs starting with new slug
148 "CREATE OR REPLACE FUNCTION new_term(
149 the_text VARCHAR, the_slug VARCHAR, the_site_id INTEGER, the_taxonomy VARCHAR)
157 INSERT INTO term(term_text, term_slug, site_id, term_taxonomy)
158 VALUES (the_text, the_slug, the_site_id, the_taxonomy);
160 WHEN unique_violation THEN
161 SELECT count(*) FROM term WHERE term_slug LIKE the_slug||'%' INTO i;
164 IF i > 999 THEN RAISE EXCEPTION 'Afraid of infinite loop.';
167 INSERT INTO term(term_text, term_slug, site_id, term_taxonomy)
168 VALUES (the_text, the_slug||'-'||i, the_site_id, the_taxonomy);
169 EXCEPTION WHEN unique_violation THEN
170 IF POSITION('_slug_' IN SQLERRM) <> 0 THEN CONTINUE; END IF;
171 RAISE EXCEPTION 'Duplicate term. How to re-raise from PL/PgSQL?';
173 EXIT; -- Exit loop when no unique_violation.
176 SELECT INTO res * FROM term WHERE term_id=CURRVAL('term_term_id_seq');
179 $body$ LANGUAGE plpgsql;"
181 ;; Selects or inserts term named `the_text' for site `the_site_id' in
182 ;; taxonomy `the_taxonomy'. Returns found/new term. No support for
183 ;; description or parent for new term, this function is intended to
184 ;; work with simple terms only (e.g. tags).
185 "CREATE OR REPLACE FUNCTION ensure_term(
187 suggested_slug VARCHAR,
188 the_site_id INTEGER, -- CUSTOMIZE? function with the_site
189 -- VARCHAR which selects id by slug
190 -- and calls this one
191 the_taxonomy VARCHAR)
197 SELECT INTO res * FROM term
198 WHERE term_text=the_text
199 AND site_id=the_site_id
200 AND term_taxonomy=the_taxonomy;
202 THEN res = new_term(the_text, suggested_slug, the_site_id, the_taxonomy);
206 $body$ LANGUAGE plpgsql;"
208 ;; Sets term value for item (UPDATE or INSERT if needed). When value
209 ;; is NULL, just ensures that an association is established.
210 "CREATE OR REPLACE FUNCTION set_item_term_value(
218 SET item_term_value=the_new_value
219 WHERE item_id=the_item_id AND term_id=the_term_id;
221 INSERT INTO item_term(item_id, term_id, item_term_value)
222 VALUES(the_item_id, the_term_id, the_new_value);
225 $body$ LANGUAGE PLPGSQL;"))
227 (defmethod print-object ((term term
) stream
)
228 (print-unreadable-object (term stream
:type t
:identity t
)
229 (princ (slug term
) stream
)))
231 (defun taxonomy (term)
232 "TERM's taxonomy object"
233 (ensure-taxonomy (term-taxonomy-name term
)))
235 (defun term-site (term)
236 "TERM's site object, if TERM is associated with a SITE."
237 (let ((id (term-site-id term
)))
239 (get-dao (site-dao-class (taxonomy term
)) id
))))
241 (defun ensure-term (taxonomy site
&key text slug create-p
)
242 "Find or create term in taxonomy TAXONOMY for site SITE.
244 TEXT is a full text of term; if TEXT is given, CREATE-P is
245 non-NIL and term is not found, new term is inserted into
248 If SLUG is given instead of TEXT, only search is possible, not
250 #+b0rken
(assert (and (or text slug
)
251 (not (and text slug
)))
253 "Either TEXT or SLUG should be given, but not both.")
257 (query-dao 'term
(:select
'* :from
(:ensure-term text
(or slug
(slugify text
)) (id site
) (taxonomy-slug taxonomy
))))
258 (select-dao 'term
(:and
(:= 'term-text text
)
259 (:= 'site-id
(id site
))
260 (:= 'term-taxonomy
(taxonomy-slug taxonomy
)))))
263 (warn "CREATE-P is meaningful only with TEXT defined."))
264 (select-dao 'term
(:and
(:= 'term-slug slug
)
265 (:= 'site-id
(id site
))
266 (:= 'term-taxonomy
(taxonomy-slug taxonomy
))))))))
268 (defun new-term (taxonomy site text
&optional parent
)
269 "Create new term in SITE for TAXONOMY, with full name TEXT."
270 (first (query-dao 'term
272 (:new-term text
(id site
) (taxonomy-slug taxonomy
) (if parent
(slug parent
) :null
))))))
274 (defun find-terms-where-clause (&key taxonomy site text slug
277 (push (list := 'term-taxonomy
(taxonomy-slug taxonomy
))
281 (push (list := 'site-id
(id site
))
285 (push (list := 'term-text text
) query
))
288 (push (list := 'term-slug slug
) query
))
290 (if (> (length query
) 1)
292 (setf query
(first query
)))
296 (defun find-terms (&key taxonomy site text slug
)
297 "Find list of terms satisfying given keywords."
299 (sql-compile `(:order-by
(select '* :from
'term
300 :where
,(find-terms-where-clause :taxonomy taxonomy
306 (defun apply-term (item term
&key value order
)
307 "Apply TERM to ITEM, optionally setting its value to VALUE."
308 (query (:insert-into
'item-term
:set
311 'item-term-value
(encode-value (taxonomy term
) value
)
312 'item-term-order
(null-or order
))))
314 (defun term-value (item term
315 &aux
(encoded (query (:select
'item-term-value
:from
'item-term
316 :where
(:and
(:= 'item-id
(id item
))
317 (:= 'term-id
(id term
))))
319 "Returns value that association of ITEM and TERM is set to.
321 As a second value returns T if an association was found at all,
322 NIL otherwise. This makes it possible to tell between an
323 association with a NIL value and no association at all."
325 (values (decode-value (taxonomy term
) encoded
) t
)
328 (defun (setf term-value
) (new-value item term
)
329 "Set new value for association of ITEM and TERM.
331 New association between ITEM and TERM is established if it was
333 (query (:select
(:set-item-term-value
(id item
) (id term
)
334 (encode-value (taxonomy term
) new-value
)))
337 (defun unbind-term (item term
)
338 "Deletes association between ITEM and TERM.
340 If PURGE-EMPTY is non-NIL (default), deletes also from TERM table if
341 no more items refer to this term."
342 (execute (:delete-from
'item-term
:where
343 (:and
(:= 'item-id
(id item
))
344 (:= 'term-id
(id term
)))))
345 (execute (:delete-from
'term
:where
(:and
(:= 'term-id
(id term
))
346 (:not
(:exists
(:select
'* :from
'item-term
347 :where
(:= 'term-id
(id term
)))))))))
349 (defun item-terms (item &optional taxonomy
)
350 "List TERMs associated with ITEM in given TAXONOMY.
352 If TAXONOMY is not given, returns terms in all taxonomies."
356 (:select
'term.
* :from
'term
'item-term
:where
357 (:and
,@(when taxonomy
360 (taxonomy-slug taxonomy
))))
361 (:= 'item-term.item-id
,(id item
))
362 (:= 'term.term-id
'item-term.term-id
)))
363 'item-term.item-term-order
))))
365 (defun order-case-ssql (column values
)
370 collect
`((:= ,column
,v
) ,i
))
373 (defun order-item-terms (item terms
&key taxonomy null-other-terms
374 &aux
(term-ids (mapcar #'id terms
)))
375 "Set TERMS (a list of terms or term IDs), associated with ITEM, in given order.
377 If NULL-OTHER-TERMS is not NIL, terms not listed in TERMS get their
378 order column set to NULL. If TAXONOMY is given, restrict changes to
379 terms of given taxonomy."
383 :set item-term-order
,(if terms
384 (order-case-ssql 'term-id term-ids
)
386 :where
(:and
(:= 'item-id
,(id item
))
387 ,@(if null-other-terms
389 `((:exists
(:select t
391 :where
(:and
(:= 'term-id
'item-term.term-id
)
393 ,(taxonomy-slug taxonomy
)))))))
394 `((:in
'term-id
(:set
,@term-ids
)))))))))
396 (defun term-item-ids (term)
397 "IDs of items associated with given TERM."
398 (query (:select
'item-id
:from
'item-term
:where
(:= 'term-id
(id term
)))
401 (defun term-items (term &aux
(class (item-dao-class (taxonomy (if (integerp term
) ; FIXME
404 "Items associated with given TERM."
405 (mapcar #'(lambda (id)
407 (term-item-ids term
)))
409 #+cl-trane.taxonomy.use-cl-store
411 (defun store-to-base64 (obj)
412 (base64:usb8-array-to-base64-string
413 (flex:with-output-to-sequence
(s)
414 (cl-store:store obj s
))))
416 (defun restore-from-base64 (b64)
417 (flex:with-input-from-sequence
(s (base64:base64-string-to-usb8-array b64
))
418 (cl-store:restore s
)))
420 (defclass cl-store-valued-taxonomy
(valued-taxonomy)
422 (:default-initargs
:encoder
#'store-to-base64
:decoder
#'restore-from-base64
)
423 (:documentation
"Valued taxonomy that by default encodes/decodes almost any Lisp object with CL-STORE as BASE64 string.")))