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 (defpackage #:trane-taxonomy
   9   (:use #:common-lisp #:trane-common #:iterate #:postmodern)
  10   (:export #:taxonomy #:taxonomy-name #:taxonomy-slug #:site-dao-class
  11            #:item-dao-class #:taxonomy-value-mixin
  12            #:taxonomy-cl-store-value-mixin #:valued-taxonomy
  13            #:cl-store-valued-taxonomy #:deftaxonomy #:ensure-taxonomy
  14            #:ensure-term #:term #:term-text
  15            #:slug #:term-site-id #:term-taxonomy-name
  16            #:description #:parent-id #:term-taxonomy #:term-site
  17            #:id #:find-terms #:new-term #:apply-term
  18            #:term-value #:item-terms
  19            #:unbind-term :term-item-ids #:term-items
  20            #:slugify))
  21
  22 (in-package #:trane-taxonomy)
  23
  24 (defvar *taxonomies* nil
  25   "A list of defined taxonomies."
  26   ;; It is supposed to be just a few of them, hash table overhead
  27   ;; would be too big.
  28   )
  29
  30 (defclass taxonomy ()
  31   ((name :initarg :name :reader taxonomy-name)
  32    (site-dao-class :initarg :site-dao-class :reader site-dao-class)
  33    (item-dao-class :initarg :item-dao-class :reader item-dao-class))
  34   (:documentation "Base taxonomy class.
  35
  36 Taxonomy has a name (symbol or string, which is transformed to a
  37 keyword by DEFTAXONOMY), and refers to DAO classes of taxonomy's
  38 SITE and ITEM.  DAO classes are required to have an integer
  39 primary key, accessible by reader named ID."))
  40
  41 (defmethod print-object ((taxonomy taxonomy) stream)
  42   (print-unreadable-object (taxonomy stream :type t :identity t)
  43     (princ (taxonomy-name taxonomy) stream)))
  44
  45 (defun taxonomy-slug (taxonomy)
  46   "Return name of taxonomy for database or URL (lowercased string).
  47
  48 Applicable to taxonomy objects, symbols and strings."
  49   (string-downcase (string (if (or (stringp taxonomy)
  50                                    (symbolp taxonomy))
  51                                taxonomy
  52                                (taxonomy-name taxonomy)))))
  53
  54 (defclass valued-taxonomy (taxonomy)
  55   ((value-encoder-function :initarg :encoder :reader value-encoder-function :initform #'identity)
  56    (value-decoder-function :initarg :decoder :reader value-decoder-function :initform #'identity))
  57   (:documentation "Taxonomy where items applied to terms may have values.
  58
  59 Defines encoder and decoder function slots, which are responsible
  60 for translating value from a Lisp value to DB-safe string.  By
  61 default it is identity function, which means values need to be
  62 strings."))
  63
  64 #| FIXME:base64/cl-store/flex
  65 (defclass cl-store-valued-taxonomy (valued-taxonomy)
  66   ()
  67   (:default-initargs :encoder #'store-to-base64 :decoder #'restore-from-base64)
  68   (:documentation "Valued taxonomy that by default encodes/decodes almost any Lisp object with CL-STORE as BASE64 string."))
  69 |#
  70
  71 (defun encode-value (taxonomy value)
  72   "Encode VALUE for database, as TAXONOMY specifies.
  73
  74 TAXONOMY should be a VALUED-TAXONOMY instance, and VALUE should
  75 be any value supported by the taxonomy.  When VALUE is NIL, it is
  76 encoded as database NULL."
  77   (if value
  78       (funcall (value-encoder-function taxonomy)
  79                value)
  80       :null))
  81
  82 (defun decode-value (taxonomy value)
  83   "Decode VALUE from database, as TAXONOMY specifies.
  84
  85 TAXONOMY should be a VALUED-TAXONOMY instance."
  86   (unless (eq :null value)
  87     (funcall (value-decoder-function taxonomy) value)))
  88
  89 (defmacro deftaxonomy (name (&optional (class 'taxonomy)) &rest args)
  90   "Defines taxonomy named NAME, with class CLASS and initargs ARGS, and remembers it in *TAXONOMIES*.
  91
  92 NAME is symbol or string, which will be transformed to a keyword anyway."
  93   `(setf *taxonomies*
  94          (cons (make-instance ',class
  95                               :name ,(make-keyword name)
  96                               ,@args)
  97                (delete ,(make-keyword name) *taxonomies*
  98                        :key #'taxonomy-name))))
  99
 100 (defun ensure-taxonomy (taxonomy)
 101   "If TAXONOMY is a taxonomy object, return it, otherwise find and return taxonomy named TAXONOMY."
 102   (if (subtypep (class-of taxonomy) (find-class 'taxonomy))
 103       taxonomy
 104       (find (make-keyword taxonomy) *taxonomies*
 105             :key #'taxonomy-name)))
 106
 107 (defclass term ()
 108   ((term-id :col-type integer :reader id)
 109    (term-text :col-type varchar :initarg :text :accessor term-text :documentation "Full text of term")
 110    (term-slug :col-type varchar :accessor slug :documentation "URL-friendly version of term text, initially chosen by database")
 111    (site-id :col-type integer :reader term-site-id :initarg :site-id :documentation "ID of term's site")
 112    (term-taxonomy :col-type (varchar 32) :reader term-taxonomy-name :initarg :taxonomy-name :documentation "Name of term's taxonomy")
 113    (term-description :col-type text :accessor description :initarg :description :documentation "Textual description of a term"))
 114   (:metaclass dao-class)
 115   (:keys term-id)
 116   (:documentation "Class for a term associated with taxonomy and a site."))
 117
 118 (defmethod print-object ((term term) stream)
 119   (print-unreadable-object (term stream :type t :identity t)
 120     (princ (slug term) stream)))
 121
 122 (defun taxonomy (term)
 123   "TERM's taxonomy object"
 124   (ensure-taxonomy (term-taxonomy-name term)))
 125
 126 (defun term-site (term)
 127   "TERM's site object, if TERM is associated with a SITE."
 128   (let ((id (term-site-id term)))
 129     (when id
 130       (get-dao (site-dao-class (taxonomy term)) id))))
 131
 132 ;;; FIXME:flatten characters, unicode and so on
 133 (defun slugify (str)
 134   (iterate (for cs in-string str)
 135            (for c = (char-downcase cs))
 136            (for safe-p = (find c "abcdefghijklmnopqrstuvwxyz"))
 137            (for previous-safe-p previous safe-p initially t)
 138            (when safe-p
 139              (unless previous-safe-p
 140                (collect #\- result-type string))
 141              (collect c result-type string))))
 142
 143 (defun ensure-term (taxonomy site &key text slug create-p)
 144   "Find or create term in taxonomy TAXONOMY for site SITE.
 145
 146 TEXT is a full text of term; if TEXT is given, CREATE-P is
 147 non-NIL and term is not found, new term is inserted into
 148 database.
 149
 150 If SLUG is given instead of TEXT, only search is possible, not
 151 creation."
 152   #+b0rken (assert (and (or text slug)
 153                         (not (and text slug)))
 154                    ()
 155                    "Either TEXT or SLUG should be given, but not both.")
 156   (first
 157    (if text
 158        (if create-p
 159            (query-dao 'term (:select '* :from (:ensure-term text (or slug (slugify text)) (id site) (taxonomy-slug taxonomy))))
 160            (select-dao 'term (:and (:= 'term-text text)
 161                                    (:= 'site-id (id site))
 162                                    (:= 'term-taxonomy (taxonomy-slug taxonomy)))))
 163        (progn
 164          (when create-p
 165            (warn "CREATE-P is meaningful only with TEXT defined."))
 166          (select-dao 'term (:and (:= 'term-slug slug)
 167                                  (:= 'site-id (id site))
 168                                  (:= 'term-taxonomy (taxonomy-slug taxonomy))))))))
 169
 170 (defun new-term (taxonomy site text &optional parent)
 171   "Create new term in SITE for TAXONOMY, with full name TEXT."
 172   (first (query-dao 'term
 173                     (:select '* :from
 174                              (:new-term text (id site) (taxonomy-slug taxonomy) (if parent (slug parent) :null))))))
 175
 176 (defun find-terms-where-clause (&key taxonomy site text slug
 177                                 &aux (query ()))
 178   (when taxonomy
 179     (push (list := 'term-taxonomy (taxonomy-slug taxonomy))
 180           query))
 181
 182   (when site
 183     (push (list := 'site-id (id site))
 184           query))
 185
 186   (when text
 187     (push (list := 'term-text text) query))
 188
 189   (when slug
 190     (push (list := 'term-slug slug) query))
 191
 192   (if (> (length query) 1)
 193       (push :and query)
 194       (setf query (first query)))
 195
 196   query)
 197
 198 (defun find-terms (&key taxonomy site text slug)
 199   "Find list of terms satisfying given keywords."
 200   (query-dao 'term
 201              (sql-compile `(:order-by (select '* :from 'term
 202                                               :where ,(find-terms-where-clause :taxonomy taxonomy
 203                                                                                :site site
 204                                                                                :text text
 205                                                                                :slug slug))
 206                                       'term-text))))
 207
 208 (defun apply-term (item term &optional value)
 209   "Apply TERM to ITEM, optionally setting its value to VALUE."
 210   (query (:insert-into 'item-term :set
 211                        'item-id (id item)
 212                        'term-id (id term)
 213                        'item-term-value (encode-value (taxonomy term) value))))
 214
 215 (defun term-value (item term
 216                    &aux (encoded (query (:select 'item-term-value :from 'item-term
 217                                                  :where (:and (:= 'item-id (id item))
 218                                                               (:= 'term-id (id term))))
 219                                         :single)))
 220   "Returns value that association of ITEM and TERM is set to.
 221
 222 As a second value returns T if an association was found at all,
 223 NIL otherwise.  This makes it possible to tell between an
 224 association with a NIL value and no association at all."
 225   (if encoded
 226       (values (decode-value (taxonomy term) encoded) t)
 227       (values nil nil)))
 228
 229 (defun (setf term-value) (new-value item term)
 230   "Set new value for association of ITEM and TERM.
 231
 232 New association between ITEM and TERM is established if it was
 233 not present before."
 234   (query (:select (:set-item-term-value (id item) (id term)
 235                                         (encode-value  (taxonomy term) new-value)))
 236          :none))
 237
 238 (defun unbind-term (item term)
 239   "Deletes association between ITEM and TERM."
 240   (query (:delete-from 'item-term :where
 241                        (:and (:= 'item-id (id item))
 242                              (:= 'term-id (id term))))))
 243
 244 (defun item-terms (item &optional taxonomy)
 245   "List TERMs associated with ITEM in given TAXONOMY.
 246
 247 If TAXONOMY is not given, returns terms in all taxonomies."
 248   (query-dao 'term
 249              (sql-compile
 250               `(:select 'term.* :from 'term 'item-term :where
 251                         (:and ,@(when taxonomy
 252                                       (list (list :=
 253                                                   ''term.term-taxonomy
 254                                                   (taxonomy-slug taxonomy))))
 255                               (:= 'item-term.item-id ,(id item))
 256                               (:= 'term.term-id 'item-term.term-id))))))
 257
 258 (defun term-item-ids (term)
 259   "IDs of items associated with given TERM."
 260   (query (:select 'item-id :from 'item-term :where (:= 'term-id (id term)))
 261          :column))
 262
 263 (defun term-items (term &aux (class (item-dao-class (taxonomy (if (integerp term) ; FIXME
 264                                                                   (get-dao 'term term)
 265                                                                   term)))) )
 266   "Items associated with given TERM."
 267   (mapcar #'(lambda (id)
 268               (get-dao class id))
 269           (term-item-ids term)))
 270
 271 #+cl-trane.taxonomy.use-cl-store
 272 (progn
 273   (defun store-to-base64 (obj)
 274     (base64:usb8-array-to-base64-string
 275      (flex:with-output-to-sequence (s)
 276        (cl-store:store obj s))))
 277
 278   (defun restore-from-base64 (b64)
 279     (flex:with-input-from-sequence (s (base64:base64-string-to-usb8-array b64))
 280       (cl-store:restore  s)))
 281
 282   (defclass cl-store-valued-taxonomy (valued-taxonomy)
 283     ()
 284     (:default-initargs :encoder #'store-to-base64 :decoder #'restore-from-base64)
 285     (:documentation "Valued taxonomy that by default encodes/decodes almost any Lisp object with CL-STORE as BASE64 string.")))