src/taxonomy.lisp

   1 ;;; Taxonomy Library
   2 ;;; Inspiration: http://svn.automattic.com/wordpress/trunk/wp-includes/taxonomy.php
   3
   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.
   7
   8 ;;; TODO:
   9 ;;;  - Customizable dao table, support table and support function names (common prefix)
  10
  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))
  23
  24 (in-package #:trane-taxonomy)
  25
  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.
  30   )
  31
  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.
  36
  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."))
  41
  42 (defmethod print-object ((taxonomy taxonomy) stream)
  43   (print-unreadable-object (taxonomy stream :type t :identity t)
  44     (princ (taxonomy-name taxonomy) stream)))
  45
  46 (defun taxonomy-slug (taxonomy)
  47   "Return name of taxonomy for database or URL (lowercased string).
  48
  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)))))
  54
  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.
  59
  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."))
  64
  65 (defun encode-value (taxonomy value)
  66   "Encode VALUE for database, as TAXONOMY specifies.
  67
  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))
  75
  76 (defun decode-value (taxonomy value)
  77   "Decode VALUE from database, as TAXONOMY specifies.
  78
  79 TAXONOMY should be a VALUED-TAXONOMY instance."
  80   (unless (eq :null value)
  81     (funcall (value-decoder-function taxonomy) value)))
  82
  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*.
  85
  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))))
  93
  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)))
 100
 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."))
 110
 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.
 114
 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))
 134
 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;"
 169
 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;"
 192
 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;"))
 211
 212 (defmethod print-object ((term term) stream)
 213   (print-unreadable-object (term stream :type t :identity t)
 214     (princ (slug term) stream)))
 215
 216 (defun term-taxonomy (term)
 217   "TERM's taxonomy object"
 218   (ensure-taxonomy (term-taxonomy-name term)))
 219
 220 (defun ensure-term (taxonomy &key text slug create-p)
 221   "Find or create term in taxonomy TAXONOMY.
 222
 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.
 226
 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)))
 231                    ()
 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))))))))
 244
 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))))))
 250
 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))
 256
 257   (when text
 258     (push (list := 'term-text text) query))
 259
 260   (when slug
 261     (push (list := 'term-slug slug) query))
 262
 263   (if (> (length query) 1)
 264       (push :and query)
 265       (setf query (first query)))
 266
 267   query)
 268
 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))))
 277
 278 (defun term-synonyms (term)
 279   "Return list of terms synonymous with TERM.
 280
 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.
 284
 285 TERM is always included in the returned list, and it is a first item.
 286
 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))))))))))))
 307
 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 (term-taxonomy term) value)
 314                        'item-term-order (null-or order))))
 315
 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.
 323
 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.
 327
 328 Third value is a term ordering value, if ordering is set."
 329   (if encoded
 330       (values (decode-value (term-taxonomy term) (first encoded)) t (unless-null (second encoded)))
 331       (values nil nil nil)))
 332
 333 (defun (setf term-value) (new-value item term)
 334   "Set new value for association of ITEM and TERM.
 335
 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  (term-taxonomy term) new-value)))
 340          :none))
 341
 342 (defun unbind-term (item term)
 343   "Deletes association between ITEM and TERM.
 344
 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)))))))))
 353
 354 (defun item-terms (item &optional taxonomy)
 355   "List TERMs associated with ITEM in given TAXONOMY.
 356
 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))))
 369
 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)))
 377
 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.
 381
 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)))))))))
 400
 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))
 405
 406 (defun term-items (term &aux (class (item-dao-class (term-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)))
 413
 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))))
 420
 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)))
 424
 425   (defclass cl-store-valued-taxonomy (valued-taxonomy)
 426     ()
 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.")))