[bknr-cvs] hans changed trunk/projects/quickhoney/src/
BKNR Commits
bknr at bknr.net
Sat Sep 6 16:38:25 UTC 2008
Revision: 3823
Author: hans
URL: http://bknr.net/trac/changeset/3823
Put category and subcategory into slot of quickhoney-image for better
performance.
U trunk/projects/quickhoney/src/handlers.lisp
U trunk/projects/quickhoney/src/image.lisp
U trunk/projects/quickhoney/src/money.lisp
U trunk/projects/quickhoney/src/news.lisp
U trunk/projects/quickhoney/src/quickhoney.asd
Modified: trunk/projects/quickhoney/src/handlers.lisp
===================================================================
--- trunk/projects/quickhoney/src/handlers.lisp 2008-09-06 16:36:42 UTC (rev 3822)
+++ trunk/projects/quickhoney/src/handlers.lisp 2008-09-06 16:38:25 UTC (rev 3823)
@@ -24,7 +24,7 @@
())
(defmethod object-handler-get-object ((handler random-image-handler))
- (random-elt (get-keywords-intersection-store-images (mapcar #'make-keyword-from-string (decoded-handler-path handler)))))
+ (random-elt (images-in-category (mapcar #'make-keyword-from-string (decoded-handler-path handler)))))
(defmethod handle-object ((handler random-image-handler) store-image)
(redirect (format nil "/image/~A" (store-object-id store-image))))
@@ -44,14 +44,19 @@
(defparameter *editable-keywords* '(:explicit :buy-file :buy-print :buy-t-shirt)
"List of keywords that are image keywords which can be edited through the CMS")
+(defun images-in-category-sorted-by-time (cat-sub)
+ (sort (copy-list (images-in-category cat-sub))
+ #'> :key #'blob-timestamp))
+
(defmethod object-handler-get-object ((handler json-image-query-handler))
- (sort (remove-if-not (lambda (object) (subtypep (type-of object) 'quickhoney-image))
- (get-keywords-intersection-store-images (mapcar #'make-keyword-from-string (decoded-handler-path handler))))
- #'< :key #'blob-timestamp))
+ (images-in-category-sorted-by-time (mapcar #'make-keyword-from-string (decoded-handler-path handler))))
(defmethod image-to-json ((image quickhoney-image))
(with-json-object ()
(encode-object-element "name" (store-image-name image))
+ (encode-object-element "category" (quickhoney-image-category image))
+ (when (quickhoney-image-subcategory image)
+ (encode-object-element "subcategory" (quickhoney-image-subcategory image)))
(encode-object-element "id" (store-object-id image))
(encode-object-element "type" (image-content-type (blob-mime-type image)))
(encode-object-element "width" (store-image-width image))
@@ -195,28 +200,25 @@
(defclass json-buttons-handler (prefix-handler quickhoney-image-handler)
())
-(defun images-sorted-by-time (&rest keywords)
- (sort (remove-if-not (rcurry #'subtypep 'quickhoney-image)
- (get-keywords-intersection-store-images keywords)
- :key #'type-of)
- #'>
- :key #'blob-timestamp))
-
(defun preproduced-buttons (category subcategory)
(let ((images (get-keywords-intersection-store-images (list category subcategory :button))))
(when images
(cons :buttons images))))
+(defun images-in-all-subcategories-sorted-by-time (category)
+ (sort (apply #'append (mapcar (lambda (cat-sub)
+ (when (eq category (car cat-sub))
+ (copy-list (images-in-category cat-sub))))
+ (all-categories)))
+ #'> :key #'blob-timestamp))
+
(defun newest-images (category subcategory)
- (let ((images (apply #'images-sorted-by-time
- (append (unless (eq :home category)
- (list category))
- (unless (eq :browseall subcategory)
- (list subcategory))))))
+ (let ((images (if (eq :home category)
+ (images-in-all-subcategories-sorted-by-time subcategory)
+ (images-in-category-sorted-by-time (list category subcategory)))))
(when images
(cons :images images))))
-
(defmethod handle ((handler json-buttons-handler))
(with-json-response ()
(with-object-element ("buttons")
@@ -252,9 +254,7 @@
(defmethod handle ((handler upload-image-handler))
(with-query-params (client spider-keywords)
- (let ((uploaded-file (request-uploaded-file "image-file"))
- (keywords (append (mapcar #'make-keyword-from-string (decoded-handler-path handler))
- (image-keywords-from-request-parameters))))
+ (let ((uploaded-file (request-uploaded-file "image-file")))
(handler-case
(progn
(unless uploaded-file
@@ -271,8 +271,9 @@
(cl-gd:true-color-to-palette))
(let* ((image (make-store-image :name (pathname-name (upload-original-filename uploaded-file))
:class-name 'quickhoney-image
- :keywords (cons :upload keywords)
- :initargs (list :client client
+ :keywords (cons :upload (image-keywords-from-request-parameters))
+ :initargs (list :cat-sub (mapcar #'make-keyword-from-string (decoded-handler-path handler))
+ :client client
:spider-keywords spider-keywords))))
(with-http-response ()
(with-http-body ()
@@ -321,8 +322,9 @@
(cl-gd:true-color-to-palette))
(let* ((image (make-store-image :name (pathname-name (upload-original-filename uploaded-file))
:class-name 'quickhoney-news-item
- :keywords (list :upload :news)
- :initargs (list :title title
+ :keywords (list :upload)
+ :initargs (list :cat-sub (list :news)
+ :title title
:text text))))
(with-http-response ()
(with-http-body ()
@@ -370,8 +372,10 @@
(image (make-store-image :name (pathname-name (upload-original-filename uploaded-image))
:type (make-keyword-from-string (pathname-type (upload-original-filename uploaded-image)))
:class-name 'quickhoney-animation-image
- :keywords (list :upload :pixel :animation)
- :initargs `(:client ,client :animation ,animation-blob))))
+ :keywords (list :upload)
+ :initargs (list :cat-sub (list :pixel :animation)
+ :client client
+ :animation animation-blob))))
(with-http-response ()
(with-http-body ()
(html (:html
@@ -418,9 +422,9 @@
(let* ((image (make-store-image :name (pathname-name (upload-original-filename uploaded-file))
:type (make-keyword-from-string (pathname-type (upload-original-filename uploaded-file)))
:class-name 'store-image
- :keywords (list :button
- (make-keyword-from-string directory)
- (make-keyword-from-string subdirectory)))))
+ :keywords (list :button)
+ :initargs (list :cat-sub (list (make-keyword-from-string directory)
+ (make-keyword-from-string subdirectory))))))
(with-http-response ()
(with-http-body ()
(html (:html
@@ -463,6 +467,8 @@
(encode-object-element "name" (store-image-name image)))
(:method ((image quickhoney-image))
(encode-object-element "type" "upload")
+ (encode-object-element "category" (quickhoney-image-category image))
+ (encode-object-element "subcategory" (quickhoney-image-subcategory image))
(with-object-element ("keywords")
(with-json-array ()
(dolist (keyword (store-image-keywords image))
@@ -490,10 +496,10 @@
(with-object-element ("months")
(with-json-array ()
(dolist (month (sort (rss-channel-archived-months channel)
- (lambda (a b)
- (if (= (first a) (first b))
- (> (second a) (second b))
- (> (first a) (first b))))))
+ (lambda (a b)
+ (if (= (first a) (first b))
+ (> (second a) (second b))
+ (> (first a) (first b))))))
(with-json-array ()
(encode-array-element (first month))
(encode-array-element (second month))))))))
Modified: trunk/projects/quickhoney/src/image.lisp
===================================================================
--- trunk/projects/quickhoney/src/image.lisp 2008-09-06 16:36:42 UTC (rev 3822)
+++ trunk/projects/quickhoney/src/image.lisp 2008-09-06 16:38:25 UTC (rev 3823)
@@ -1,12 +1,22 @@
(in-package :quickhoney)
(define-persistent-class quickhoney-image (store-image rss-item)
- ((client :update :initform nil
- :index-type hash-index :index-initargs (:test #'equal)
- :index-reader images-for-client
- :index-keys all-clients)
- (spider-keywords :update :initform nil)
- (products :update :initform nil)))
+ ((client :update
+ :initform nil
+ :index-type hash-index :index-initargs (:test #'equal)
+ :index-reader images-for-client
+ :index-keys all-clients)
+ (cat-sub :update
+ :initform nil
+ :index-type hash-index :index-initargs (:test #'equal)
+ :index-reader images-in-category
+ :index-keys all-categories
+ :documentation
+ "Category this image belongs to, as a list of one or two keywords")
+ (spider-keywords :update
+ :initform nil)
+ (products :update
+ :initform nil)))
(defvar *last-image-upload-timestamp* 0)
@@ -23,11 +33,18 @@
(get-keywords-intersection-store-images '(:import))))
(defmethod quickhoney-image-category ((image quickhoney-image))
- (first (intersection (store-image-keywords image) '(:pixel :vector :news :contact))))
+ (car (quickhoney-image-cat-sub image)))
(defmethod quickhoney-image-subcategory ((image quickhoney-image))
- (first (set-difference (store-image-keywords image) '(:pixel :vector :news :button :contact :published :upload))))
+ (cadr (quickhoney-image-cat-sub image)))
+(defun subcategories-of (category)
+ (loop
+ for cat-sub in (all-categories)
+ when (and (eq category (car cat-sub))
+ (cadr cat-sub))
+ collect (cadr cat-sub)))
+
(defmethod make-image-link ((image quickhoney-image) &key internal)
(format nil "~@[~A~]/index#~(~A~@[/~A~]~)/~A"
(unless internal
Modified: trunk/projects/quickhoney/src/money.lisp
===================================================================
--- trunk/projects/quickhoney/src/money.lisp 2008-09-06 16:36:42 UTC (rev 3822)
+++ trunk/projects/quickhoney/src/money.lisp 2008-09-06 16:38:25 UTC (rev 3823)
@@ -1,4 +1,4 @@
-(in-package :quickhoney)
+(in-package :shop)
(defclass money ()
((currency :initarg :currency
Modified: trunk/projects/quickhoney/src/news.lisp
===================================================================
--- trunk/projects/quickhoney/src/news.lisp 2008-09-06 16:36:42 UTC (rev 3822)
+++ trunk/projects/quickhoney/src/news.lisp 2008-09-06 16:38:25 UTC (rev 3823)
@@ -7,12 +7,11 @@
(member :explicit (store-image-keywords image)))
(defmethod rss-item-encoded-content ((image quickhoney-image))
- (let* ((category (first (intersection (store-image-keywords image) '(:vector :pixel))))
- (is-vector (eq category :vector)))
+ (let ((is-vector (eq (quickhoney-image-category image) :vector)))
(with-output-to-string (s)
(html-stream
s
- ((:div :class (format nil "newsentry news_~(~A~)" category))
+ ((:div :class (format nil "newsentry news_~(~A~)" (quickhoney-image-category image)))
((:img :src (format nil "http://~A/image/~A"
(website-host)
(store-object-id image)))
Modified: trunk/projects/quickhoney/src/quickhoney.asd
===================================================================
--- trunk/projects/quickhoney/src/quickhoney.asd 2008-09-06 16:36:42 UTC (rev 3822)
+++ trunk/projects/quickhoney/src/quickhoney.asd 2008-09-06 16:38:25 UTC (rev 3823)
@@ -37,4 +37,9 @@
(:file "tags" :depends-on ("image"))
(:file "webserver" :depends-on ("handlers"))
(:file "daily" :depends-on ("config"))
+
+ (:file "money" :depends-on ("packages"))
+ (:file "shop" :depends-on ("money"))
+ (:file "quickhoney-shop" :depends-on ("shop"))
+
(:file "init" :depends-on ("webserver" "daily"))))
More information about the Bknr-cvs
mailing list