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 #: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))
  24
  25 (in-package #:trane-taxonomy)
  26
  27 (defvar *taxonomies* nil
  28   "A list of defined taxonomies."
  29   ;; It is supposed to be just a few of them, hash table overhead
  30   ;; would be too big.
  31   )
  32
  33 (defclass taxonomy ()
  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.
  38
  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."))
  43
  44 (defmethod print-object ((taxonomy taxonomy) stream)
  45   (print-unreadable-object (taxonomy stream :type t :identity t)
  46     (princ (taxonomy-name taxonomy) stream)))
  47
  48 (defun taxonomy-slug (taxonomy)
  49   "Return name of taxonomy for database or URL (lowercased string).
  50
  51 Applicable to taxonomy objects, symbols and strings."
  52   (string-downcase (string (if (or (stringp taxonomy)
  53                                    (symbolp taxonomy))
  54                                taxonomy
  55                                (taxonomy-name taxonomy)))))
  56
  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.
  61
  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
  65 strings."))
  66
  67 (defun encode-value (taxonomy value)
  68   "Encode VALUE for database, as TAXONOMY specifies.
  69
  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."
  73   (if value
  74       (funcall (value-encoder-function taxonomy)
  75                value)
  76       :null))
  77
  78 (defun decode-value (taxonomy value)
  79   "Decode VALUE from database, as TAXONOMY specifies.
  80
  81 TAXONOMY should be a VALUED-TAXONOMY instance."
  82   (unless (eq :null value)
  83     (funcall (value-decoder-function taxonomy) value)))
  84
  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*.
  87
  88 NAME is symbol or string, which will be transformed to a keyword anyway."
  89   `(setf *taxonomies*
  90          (cons (make-instance ',class
  91                               :name ,(make-keyword name)
  92                               ,@args)
  93                (delete ,(make-keyword name) *taxonomies*
  94                        :key #'taxonomy-name))))
  95
  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))
  99       taxonomy
 100       (find (make-keyword taxonomy) *taxonomies*
 101             :key #'taxonomy-name)))
 102
 103 (defclass term ()
 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)
 111   (:keys term-id)
 112   (:documentation "Class for a term associated with taxonomy and a site."))
 113
 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.
 117
 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-]+')"))
 127         (when site
 128           `(:alter-table ,(dao-table-name 'term) :add :foreign-key (site-id)
 129                          ,@ (etypecase site
 130                               ((or symbol class)
 131                                (list (dao-table-name site)))
 132                               (list site))))
 133
 134         `(:create-table
 135           item-term       ; FIXME:name
 136           ((item-id :type int ,@ (etypecase item
 137                                    (null)
 138                                    ((or symbol class)
 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))
 145
 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)
 150 RETURNS term
 151 AS $body$
 152 DECLARE
 153     res term;
 154     i INTEGER;
 155 BEGIN
 156     BEGIN
 157         INSERT INTO term(term_text, term_slug, site_id, term_taxonomy)
 158              VALUES (the_text, the_slug, the_site_id, the_taxonomy);
 159     EXCEPTION
 160     WHEN unique_violation THEN
 161         SELECT count(*) FROM term WHERE term_slug LIKE the_slug||'%' INTO i;
 162         LOOP
 163             i = i+1;
 164             IF i > 999 THEN RAISE EXCEPTION 'Afraid of infinite loop.';
 165             END IF;
 166             BEGIN
 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?';
 172             END;
 173             EXIT;               -- Exit loop when no unique_violation.
 174         END LOOP;
 175     END;
 176     SELECT INTO res * FROM term WHERE term_id=CURRVAL('term_term_id_seq');
 177     RETURN res;
 178 END;
 179 $body$ LANGUAGE plpgsql;"
 180
 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(
 186     the_text VARCHAR,
 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)
 192 RETURNS term
 193 AS $body$
 194 DECLARE
 195     res term;
 196 BEGIN
 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;
 201     IF NOT FOUND
 202     THEN res = new_term(the_text, suggested_slug, the_site_id, the_taxonomy);
 203     END IF;
 204     RETURN res;
 205 END;
 206 $body$ LANGUAGE plpgsql;"
 207
 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(
 211        the_item_id INTEGER,
 212        the_term_id INTEGER,
 213        the_new_value TEXT)
 214 RETURNS VOID
 215 AS $body$
 216 BEGIN
 217     UPDATE item_term
 218            SET item_term_value=the_new_value
 219            WHERE item_id=the_item_id AND term_id=the_term_id;
 220     IF NOT FOUND THEN
 221         INSERT INTO item_term(item_id, term_id, item_term_value)
 222             VALUES(the_item_id, the_term_id, the_new_value);
 223     END IF;
 224 END;
 225 $body$ LANGUAGE PLPGSQL;"))
 226
 227 (defmethod print-object ((term term) stream)
 228   (print-unreadable-object (term stream :type t :identity t)
 229     (princ (slug term) stream)))
 230
 231 (defun taxonomy (term)
 232   "TERM's taxonomy object"
 233   (ensure-taxonomy (term-taxonomy-name term)))
 234
 235 (defun term-site (term)
 236   "TERM's site object, if TERM is associated with a SITE."
 237   (let ((id (term-site-id term)))
 238     (when id
 239       (get-dao (site-dao-class (taxonomy term)) id))))
 240
 241 (defun ensure-term (taxonomy site &key text slug create-p)
 242   "Find or create term in taxonomy TAXONOMY for site SITE.
 243
 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
 246 database.
 247
 248 If SLUG is given instead of TEXT, only search is possible, not
 249 creation."
 250   #+b0rken (assert (and (or text slug)
 251                         (not (and text slug)))
 252                    ()
 253                    "Either TEXT or SLUG should be given, but not both.")
 254   (first
 255    (if text
 256        (if create-p
 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)))))
 261        (progn
 262          (when create-p
 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))))))))
 267
 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
 271                     (:select '* :from
 272                              (:new-term text (id site) (taxonomy-slug taxonomy) (if parent (slug parent) :null))))))
 273
 274 (defun find-terms-where-clause (&key taxonomy site text slug
 275                                 &aux (query ()))
 276   (when taxonomy
 277     (push (list := 'term-taxonomy (taxonomy-slug taxonomy))
 278           query))
 279
 280   (when site
 281     (push (list := 'site-id (id site))
 282           query))
 283
 284   (when text
 285     (push (list := 'term-text text) query))
 286
 287   (when slug
 288     (push (list := 'term-slug slug) query))
 289
 290   (if (> (length query) 1)
 291       (push :and query)
 292       (setf query (first query)))
 293
 294   query)
 295
 296 (defun find-terms (&key taxonomy site text slug)
 297   "Find list of terms satisfying given keywords."
 298   (query-dao 'term
 299              (sql-compile `(:order-by (select '* :from 'term
 300                                               :where ,(find-terms-where-clause :taxonomy taxonomy
 301                                                                                :site site
 302                                                                                :text text
 303                                                                                :slug slug))
 304                                       'term-text))))
 305
 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
 309                        'item-id (id item)
 310                        'term-id (id term)
 311                        'item-term-value (encode-value (taxonomy term) value)
 312                        'item-term-order (null-or order))))
 313
 314 (defun term-value (item term
 315                    &aux (encoded (query (:select 'item-term-value 'item-term-order
 316                                                  :from 'item-term
 317                                                  :where (:and (:= 'item-id (id item))
 318                                                               (:= 'term-id (id term))))
 319                                         :row)))
 320   "Returns value that association of ITEM and TERM is set to.
 321
 322 As a second value returns T if an association was found at all,
 323 NIL otherwise.  This makes it possible to tell between an
 324 association with a NIL value and no association at all.
 325
 326 Third value is a term ordering value, if ordering is set."
 327   (if encoded
 328       (values (decode-value (taxonomy term) (first encoded)) t (unless-null (second encoded)))
 329       (values nil nil nil)))
 330
 331 (defun (setf term-value) (new-value item term)
 332   "Set new value for association of ITEM and TERM.
 333
 334 New association between ITEM and TERM is established if it was
 335 not present before."
 336   (query (:select (:set-item-term-value (id item) (id term)
 337                                         (encode-value  (taxonomy term) new-value)))
 338          :none))
 339
 340 (defun unbind-term (item term)
 341   "Deletes association between ITEM and TERM.
 342
 343 If PURGE-EMPTY is non-NIL (default), deletes also from TERM table if
 344 no more items refer to this term."
 345   (execute (:delete-from 'item-term :where
 346                          (:and (:= 'item-id (id item))
 347                                (:= 'term-id (id term)))))
 348   (execute (:delete-from 'term :where (:and (:= 'term-id (id term))
 349                                             (:not (:exists (:select '* :from 'item-term
 350                                                                     :where (:= 'term-id (id term)))))))))
 351
 352 (defun item-terms (item &optional taxonomy)
 353   "List TERMs associated with ITEM in given TAXONOMY.
 354
 355 If TAXONOMY is not given, returns terms in all taxonomies."
 356   (query-dao 'term
 357              (sql-compile
 358               `(:order-by
 359                 (:select 'term.* :from 'term 'item-term :where
 360                          (:and ,@(when taxonomy
 361                                        (list (list :=
 362                                                    ''term.term-taxonomy
 363                                                    (taxonomy-slug taxonomy))))
 364                                (:= 'item-term.item-id ,(id item))
 365                                (:= 'term.term-id 'item-term.term-id)))
 366                 'item-term.item-term-order))))
 367
 368 (defun order-case-ssql (column values)
 369   `(:case
 370        ,@(loop
 371             for i from 1
 372             for v in values
 373             collect `((:= ,column ,v) ,i))
 374      (t :null)))
 375
 376 (defun order-item-terms (item terms &key taxonomy null-other-terms
 377                          &aux (term-ids (mapcar #'id terms)))
 378   "Set TERMS (a list of terms or term IDs), associated with ITEM, in given order.
 379
 380 If NULL-OTHER-TERMS is not NIL, terms not listed in TERMS get their
 381 order column set to NULL.  If TAXONOMY is given, restrict changes to
 382 terms of given taxonomy."
 383   (query
 384    (sql-compile
 385     `(:update item-term
 386               :set item-term-order ,(if terms
 387                                         (order-case-ssql 'term-id term-ids)
 388                                         :null)
 389               :where (:and (:= 'item-id ,(id item))
 390                            ,@(if null-other-terms
 391                                  (when taxonomy
 392                                    `((:exists (:select t
 393                                                        :from 'term
 394                                                        :where (:and (:= 'term-id 'item-term.term-id)
 395                                                                     (:= 'term-taxonomy
 396                                                                         ,(taxonomy-slug taxonomy)))))))
 397                                  `((:in 'term-id (:set ,@term-ids)))))))))
 398
 399 (defun term-item-ids (term)
 400   "IDs of items associated with given TERM."
 401   (query (:select 'item-id :from 'item-term :where (:= 'term-id (id term)))
 402          :column))
 403
 404 (defun term-items (term &aux (class (item-dao-class (taxonomy (if (integerp term) ; FIXME
 405                                                                   (get-dao 'term term)
 406                                                                   term)))) )
 407   "Items associated with given TERM."
 408   (mapcar #'(lambda (id)
 409               (get-dao class id))
 410           (term-item-ids term)))
 411
 412 #+cl-trane.taxonomy.use-cl-store
 413 (progn
 414   (defun store-to-base64 (obj)
 415     (base64:usb8-array-to-base64-string
 416      (flex:with-output-to-sequence (s)
 417        (cl-store:store obj s))))
 418
 419   (defun restore-from-base64 (b64)
 420     (flex:with-input-from-sequence (s (base64:base64-string-to-usb8-array b64))
 421       (cl-store:restore  s)))
 422
 423   (defclass cl-store-valued-taxonomy (valued-taxonomy)
 424     ()
 425     (:default-initargs :encoder #'store-to-base64 :decoder #'restore-from-base64)
 426     (:documentation "Valued taxonomy that by default encodes/decodes almost any Lisp object with CL-STORE as BASE64 string.")))