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