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
  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           (:primary-key item-id term-id))
 144
 145         ;; Create new term.  Signals error if term exists.
 146         ;; FIXME: count existing slugs starting with new slug
 147         "CREATE OR REPLACE FUNCTION new_term(
 148     the_text VARCHAR, the_slug VARCHAR, the_site_id INTEGER, the_taxonomy VARCHAR)
 149 RETURNS term
 150 AS $body$
 151 DECLARE
 152     res term;
 153     i INTEGER;
 154 BEGIN
 155     BEGIN
 156         INSERT INTO term(term_text, term_slug, site_id, term_taxonomy)
 157              VALUES (the_text, the_slug, the_site_id, the_taxonomy);
 158     EXCEPTION
 159     WHEN unique_violation THEN
 160         SELECT count(*) FROM term WHERE term_slug LIKE the_slug||'%' INTO i;
 161         LOOP
 162             i = i+1;
 163             IF i > 999 THEN RAISE EXCEPTION 'Afraid of infinite loop.';
 164             END IF;
 165             BEGIN
 166                 INSERT INTO term(term_text, term_slug, site_id, term_taxonomy)
 167                      VALUES (the_text, the_slug||'-'||i, the_site_id, the_taxonomy);
 168             EXCEPTION WHEN unique_violation THEN
 169                 IF POSITION('_slug_' IN SQLERRM) <> 0 THEN CONTINUE; END IF;
 170                 RAISE EXCEPTION 'Duplicate term.  How to re-raise from PL/PgSQL?';
 171             END;
 172             EXIT;               -- Exit loop when no unique_violation.
 173         END LOOP;
 174     END;
 175     SELECT INTO res * FROM term WHERE term_id=CURRVAL('term_term_id_seq');
 176     RETURN res;
 177 END;
 178 $body$ LANGUAGE plpgsql;"
 179
 180         ;; Selects or inserts term named `the_text' for site `the_site_id' in
 181         ;; taxonomy `the_taxonomy'.  Returns found/new term.  No support for
 182         ;; description or parent for new term, this function is intended to
 183         ;; work with simple terms only (e.g. tags).
 184         "CREATE OR REPLACE FUNCTION ensure_term(
 185     the_text VARCHAR,
 186     suggested_slug VARCHAR,
 187     the_site_id INTEGER,        -- CUSTOMIZE? function with the_site
 188                                 -- VARCHAR which selects id by slug
 189                                 -- and calls this one
 190     the_taxonomy VARCHAR)
 191 RETURNS term
 192 AS $body$
 193 DECLARE
 194     res term;
 195 BEGIN
 196     SELECT INTO res * FROM term
 197           WHERE term_text=the_text
 198             AND site_id=the_site_id
 199             AND term_taxonomy=the_taxonomy;
 200     IF NOT FOUND
 201     THEN res = new_term(the_text, suggested_slug, the_site_id, the_taxonomy);
 202     END IF;
 203     RETURN res;
 204 END;
 205 $body$ LANGUAGE plpgsql;"
 206
 207         ;; Sets term value for item (UPDATE or INSERT if needed).  When value
 208         ;; is NULL, just ensures that an association is established.
 209         "CREATE OR REPLACE FUNCTION set_item_term_value(
 210        the_item_id INTEGER,
 211        the_term_id INTEGER,
 212        the_new_value TEXT)
 213 RETURNS VOID
 214 AS $body$
 215 BEGIN
 216     UPDATE item_term
 217            SET item_term_value=the_new_value
 218            WHERE item_id=the_item_id AND term_id=the_term_id;
 219     IF NOT FOUND THEN
 220         INSERT INTO item_term(item_id, term_id, item_term_value)
 221             VALUES(the_item_id, the_term_id, the_new_value);
 222     END IF;
 223 END;
 224 $body$ LANGUAGE PLPGSQL;"))
 225
 226 (defmethod print-object ((term term) stream)
 227   (print-unreadable-object (term stream :type t :identity t)
 228     (princ (slug term) stream)))
 229
 230 (defun taxonomy (term)
 231   "TERM's taxonomy object"
 232   (ensure-taxonomy (term-taxonomy-name term)))
 233
 234 (defun term-site (term)
 235   "TERM's site object, if TERM is associated with a SITE."
 236   (let ((id (term-site-id term)))
 237     (when id
 238       (get-dao (site-dao-class (taxonomy term)) id))))
 239
 240 (defun ensure-term (taxonomy site &key text slug create-p)
 241   "Find or create term in taxonomy TAXONOMY for site SITE.
 242
 243 TEXT is a full text of term; if TEXT is given, CREATE-P is
 244 non-NIL and term is not found, new term is inserted into
 245 database.
 246
 247 If SLUG is given instead of TEXT, only search is possible, not
 248 creation."
 249   #+b0rken (assert (and (or text slug)
 250                         (not (and text slug)))
 251                    ()
 252                    "Either TEXT or SLUG should be given, but not both.")
 253   (first
 254    (if text
 255        (if create-p
 256            (query-dao 'term (:select '* :from (:ensure-term text (or slug (slugify text)) (id site) (taxonomy-slug taxonomy))))
 257            (select-dao 'term (:and (:= 'term-text text)
 258                                    (:= 'site-id (id site))
 259                                    (:= 'term-taxonomy (taxonomy-slug taxonomy)))))
 260        (progn
 261          (when create-p
 262            (warn "CREATE-P is meaningful only with TEXT defined."))
 263          (select-dao 'term (:and (:= 'term-slug slug)
 264                                  (:= 'site-id (id site))
 265                                  (:= 'term-taxonomy (taxonomy-slug taxonomy))))))))
 266
 267 (defun new-term (taxonomy site text &optional parent)
 268   "Create new term in SITE for TAXONOMY, with full name TEXT."
 269   (first (query-dao 'term
 270                     (:select '* :from
 271                              (:new-term text (id site) (taxonomy-slug taxonomy) (if parent (slug parent) :null))))))
 272
 273 (defun find-terms-where-clause (&key taxonomy site text slug
 274                                 &aux (query ()))
 275   (when taxonomy
 276     (push (list := 'term-taxonomy (taxonomy-slug taxonomy))
 277           query))
 278
 279   (when site
 280     (push (list := 'site-id (id site))
 281           query))
 282
 283   (when text
 284     (push (list := 'term-text text) query))
 285
 286   (when slug
 287     (push (list := 'term-slug slug) query))
 288
 289   (if (> (length query) 1)
 290       (push :and query)
 291       (setf query (first query)))
 292
 293   query)
 294
 295 (defun find-terms (&key taxonomy site text slug)
 296   "Find list of terms satisfying given keywords."
 297   (query-dao 'term
 298              (sql-compile `(:order-by (select '* :from 'term
 299                                               :where ,(find-terms-where-clause :taxonomy taxonomy
 300                                                                                :site site
 301                                                                                :text text
 302                                                                                :slug slug))
 303                                       'term-text))))
 304
 305 (defun apply-term (item term &optional value)
 306   "Apply TERM to ITEM, optionally setting its value to VALUE."
 307   (query (:insert-into 'item-term :set
 308                        'item-id (id item)
 309                        'term-id (id term)
 310                        'item-term-value (encode-value (taxonomy term) value))))
 311
 312 (defun term-value (item term
 313                    &aux (encoded (query (:select 'item-term-value :from 'item-term
 314                                                  :where (:and (:= 'item-id (id item))
 315                                                               (:= 'term-id (id term))))
 316                                         :single)))
 317   "Returns value that association of ITEM and TERM is set to.
 318
 319 As a second value returns T if an association was found at all,
 320 NIL otherwise.  This makes it possible to tell between an
 321 association with a NIL value and no association at all."
 322   (if encoded
 323       (values (decode-value (taxonomy term) encoded) t)
 324       (values nil nil)))
 325
 326 (defun (setf term-value) (new-value item term)
 327   "Set new value for association of ITEM and TERM.
 328
 329 New association between ITEM and TERM is established if it was
 330 not present before."
 331   (query (:select (:set-item-term-value (id item) (id term)
 332                                         (encode-value  (taxonomy term) new-value)))
 333          :none))
 334
 335 (defun unbind-term (item term)
 336   "Deletes association between ITEM and TERM."
 337   (query (:delete-from 'item-term :where
 338                        (:and (:= 'item-id (id item))
 339                              (:= 'term-id (id term))))))
 340
 341 (defun item-terms (item &optional taxonomy)
 342   "List TERMs associated with ITEM in given TAXONOMY.
 343
 344 If TAXONOMY is not given, returns terms in all taxonomies."
 345   (query-dao 'term
 346              (sql-compile
 347               `(:select 'term.* :from 'term 'item-term :where
 348                         (:and ,@(when taxonomy
 349                                       (list (list :=
 350                                                   ''term.term-taxonomy
 351                                                   (taxonomy-slug taxonomy))))
 352                               (:= 'item-term.item-id ,(id item))
 353                               (:= 'term.term-id 'item-term.term-id))))))
 354
 355 (defun term-item-ids (term)
 356   "IDs of items associated with given TERM."
 357   (query (:select 'item-id :from 'item-term :where (:= 'term-id (id term)))
 358          :column))
 359
 360 (defun term-items (term &aux (class (item-dao-class (taxonomy (if (integerp term) ; FIXME
 361                                                                   (get-dao 'term term)
 362                                                                   term)))) )
 363   "Items associated with given TERM."
 364   (mapcar #'(lambda (id)
 365               (get-dao class id))
 366           (term-item-ids term)))
 367
 368 #+cl-trane.taxonomy.use-cl-store
 369 (progn
 370   (defun store-to-base64 (obj)
 371     (base64:usb8-array-to-base64-string
 372      (flex:with-output-to-sequence (s)
 373        (cl-store:store obj s))))
 374
 375   (defun restore-from-base64 (b64)
 376     (flex:with-input-from-sequence (s (base64:base64-string-to-usb8-array b64))
 377       (cl-store:restore  s)))
 378
 379   (defclass cl-store-valued-taxonomy (valued-taxonomy)
 380     ()
 381     (:default-initargs :encoder #'store-to-base64 :decoder #'restore-from-base64)
 382     (:documentation "Valued taxonomy that by default encodes/decodes almost any Lisp object with CL-STORE as BASE64 string.")))