September 2008 - bknr-cvs@common-lisp.net

[bknr-cvs] hans changed trunk/projects/quickhoney/website/templates/
by BKNR Commits 06 Sep '08

06 Sep '08

Revision: 3824 Author: hans URL: http://bknr.net/trac/changeset/3824 Add GA tracking. U trunk/projects/quickhoney/website/templates/frontpage.xml U trunk/projects/quickhoney/website/templates/image-browse.xml U trunk/projects/quickhoney/website/templates/index.xml Modified: trunk/projects/quickhoney/website/templates/frontpage.xml =================================================================== --- trunk/projects/quickhoney/website/templates/frontpage.xml 2008-09-06 16:38:25 UTC (rev 3823) +++ trunk/projects/quickhoney/website/templates/frontpage.xml 2008-09-06 19:56:47 UTC (rev 3824) @@ -1,38 +1,47 @@ <?xml version="1.0" encoding="UTF-8"?> <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" - "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> <html - xmlns:xml="http://www.w3.org/XML/1998/namespace" - xmlns="http://www.w3.org/1999/xhtml" - xmlns:bknr="http://bknr.net" - xmlns:quickhoney="http://quickhoney.com/" - > - <head> - <link rel="stylesheet" href="/static/styles.css" /> - <link rel="alternate" type="application/rss+xml" title="RSS Feed" href="/rss/quickhoney" /> - <script src="/static/javascript.js" type="text/javascript"> - </script> - <title>QuickHoney - Nana Rausch + Peter Stemmler</title> - </head> + xmlns:xml="http://www.w3.org/XML/1998/namespace" + xmlns="http://www.w3.org/1999/xhtml" + xmlns:bknr="http://bknr.net" + xmlns:quickhoney="http://quickhoney.com/" + > + <head> + <link rel="stylesheet" href="/static/yui/reset-fonts/reset-fonts.css" /> + <link rel="stylesheet" href="/static/quickhoney.css" /> + <link rel="alternate" type="application/rss+xml" title="RSS Feed" href="/rss/quickhoney" /> + <script src="/static/javascript.js" type="text/javascript"> + </script> + <title>QuickHoney - Nana Rausch + Peter Stemmler</title> + </head> - <body id="frontpage"> - <p> - <img src="/image/quickhoney" id="the_logo" name="logo" border="0" width="438" height="66" /> - </p> - <div> - <h1>QuickHoney Illustrations</h1> - <p>Studio for Illustration, New York</p> - <h1>Peter Stemmler</h1> - <p>Phone: 646.270.5562<br/>Email: p(a)quickhoney.com</p> - <h1>Nana Rausch</h1> - <p>Phone 646.270.5592<br/>Email: n(a)quickhoney.com</p> - </div> - <p> - This site requires Firefox, Safari or Internet Explorer and Javascript for full viewing pleasure. - </p> - <p>Enter our <a href="/image-browse">Image gallery</a> for basic view.</p> - <script type="text/javascript"> - document.location.href = '/index'; - </script> - </body> + <body id="frontpage"> + <p> + <img src="/image/quickhoney" id="the_logo" name="logo" border="0" width="438" height="66" /> + </p> + <div> + <h1>QuickHoney Illustrations</h1> + <p>Studio for Illustration, New York</p> + <h1>Peter Stemmler</h1> + <p>Phone: 646.270.5562<br/>Email: p(a)quickhoney.com</p> + <h1>Nana Rausch</h1> + <p>Phone 646.270.5592<br/>Email: n(a)quickhoney.com</p> + </div> + <p> + This site requires Firefox, Safari or Internet Explorer and Javascript for full viewing pleasure. + </p> + <p>Enter our <a href="/image-browse">Image gallery</a> for basic view.</p> +<script type="text/javascript"> +var gaJsHost = (("https:" == document.location.protocol) ? "https://ssl." : "http://www."); +document.write(unescape("%3Cscript src='" + gaJsHost + "google-analytics.com/ga.js' type='text/javascript'%3E%3C/script%3E")); +</script> +<script type="text/javascript"> +var pageTracker = _gat._getTracker("UA-3432041-4"); +pageTracker._trackPageview(); +</script> + <script type="text/javascript"> + document.location.href = '/index'; + </script> + </body> </html> Modified: trunk/projects/quickhoney/website/templates/image-browse.xml =================================================================== --- trunk/projects/quickhoney/website/templates/image-browse.xml 2008-09-06 16:38:25 UTC (rev 3823) +++ trunk/projects/quickhoney/website/templates/image-browse.xml 2008-09-06 19:56:47 UTC (rev 3824) @@ -18,6 +18,14 @@ <div id="logo"> <img src="/image/quickhoney-black" id="the_logo" name="logo" border="0" /> </div> +<script type="text/javascript"> +var gaJsHost = (("https:" == document.location.protocol) ? "https://ssl." : "http://www."); +document.write(unescape("%3Cscript src='" + gaJsHost + "google-analytics.com/ga.js' type='text/javascript'%3E%3C/script%3E")); +</script> +<script type="text/javascript"> +var pageTracker = _gat._getTracker("UA-3432041-4"); +pageTracker._trackPageview(); +</script> <quickhoney:simple-image-browser /> <div id="footer"> ©1998-2008 QuickHoney Nana Rausch & Peter Stemmler. No part of Modified: trunk/projects/quickhoney/website/templates/index.xml =================================================================== --- trunk/projects/quickhoney/website/templates/index.xml 2008-09-06 16:38:25 UTC (rev 3823) +++ trunk/projects/quickhoney/website/templates/index.xml 2008-09-06 19:56:47 UTC (rev 3824) @@ -370,6 +370,14 @@ <iframe src="about:blank" height="0" width="0" name="edit_iframe"> </iframe> </div> +<script type="text/javascript"> +var gaJsHost = (("https:" == document.location.protocol) ? "https://ssl." : "http://www."); +document.write(unescape("%3Cscript src='" + gaJsHost + "google-analytics.com/ga.js' type='text/javascript'%3E%3C/script%3E")); +</script> +<script type="text/javascript"> +var pageTracker = _gat._getTracker("UA-3432041-4"); +pageTracker._trackPageview(); +</script> <script language="javascript" type="text/javascript"> init(); </script>

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/src/
by BKNR Commits 06 Sep '08

06 Sep '08

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"))))

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/src/
by BKNR Commits 06 Sep '08

06 Sep '08

Revision: 3822 Author: hans URL: http://bknr.net/trac/changeset/3822 Update shopping data structures, not yet a lot to see here. U trunk/projects/quickhoney/src/packages.lisp A trunk/projects/quickhoney/src/quickhoney-shop.lisp U trunk/projects/quickhoney/src/shop.lisp Modified: trunk/projects/quickhoney/src/packages.lisp =================================================================== --- trunk/projects/quickhoney/src/packages.lisp 2008-09-06 16:34:27 UTC (rev 3821) +++ trunk/projects/quickhoney/src/packages.lisp 2008-09-06 16:36:42 UTC (rev 3822) @@ -17,6 +17,12 @@ :quickhoney.config) (:export)) +(defpackage :shop + (:use :cl + :bknr.datastore + :bknr.indices + :bknr.user)) + (defpackage :quickhoney (:use :cl :cl-user @@ -40,7 +46,12 @@ #:quickhoney-image #:quickhoney-image-client #:quickhoney-image-spider-keywords - #:startup)) + #:startup + #:quickhoney-image-category + #:quickhoney-image-subcategory + #:all-categories + #:subcategories-of + #:images-in-category)) (defpackage :quickhoney.tags (:use :cl Added: trunk/projects/quickhoney/src/quickhoney-shop.lisp =================================================================== --- trunk/projects/quickhoney/src/quickhoney-shop.lisp (rev 0) +++ trunk/projects/quickhoney/src/quickhoney-shop.lisp 2008-09-06 16:36:42 UTC (rev 3822) @@ -0,0 +1,12 @@ +(in-package :quickhoney) + +(define-persistent-class quickhoney-product () + ((image + :update + :type (or quickhoney-image null) + :index-type hash-index + :index-reader products-for-image + :documentation + "Image that this product is related to, or nil for standalone products")) + (:documentation + "Mixin class for Quickhoney products, which are usually related to a QUICKHONEY-IMAGE")) \ No newline at end of file Modified: trunk/projects/quickhoney/src/shop.lisp =================================================================== --- trunk/projects/quickhoney/src/shop.lisp 2008-09-06 16:34:27 UTC (rev 3821) +++ trunk/projects/quickhoney/src/shop.lisp 2008-09-06 16:36:42 UTC (rev 3822) @@ -1,4 +1,4 @@ -(in-package :quickhoney) +(in-package :shop) ;; Shopping system. @@ -24,11 +24,18 @@ :type money :documentation "Price of the product, not including any taxes.") - (image + (name :update - :type (or quickhoney-image null) + :type string + :index-type string-unique-index + :index-reader product-with-name :documentation - "Image that this product is related to, or nil for standalone products"))) + "Short name of the product, must be unique, should be identifier") + (description + :update + :type string + :documentation + "Textual description of the product"))) (defgeneric sell (product) (:documentation @@ -47,7 +54,7 @@ address. Once paid, the system makes the product available to the customer for download.")) -(defgeneric stock-count ((product download-product)) +(defmethod stock-count ((product download-product)) nil) (define-persistent-class emailable-product (product) @@ -58,12 +65,13 @@ be supplied by the customer. Once paid, the system sends the order to the store personnel for fulfillment.")) -(defgeneric stock-count ((product download-product)) +(defmethod stock-count ((product emailable-product)) nil) (define-persistent-class mailable-product (product) ((stock-count :update :type integer + :accessor stock-count :documentation "Number of instances of this product that are available to be sold.")) (:documentation

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/upgrade-stuff/import.lisp
by BKNR Commits 06 Sep '08

06 Sep '08

Revision: 3821 Author: hans URL: http://bknr.net/trac/changeset/3821 Support db upgrade through just loading this file. U trunk/projects/quickhoney/upgrade-stuff/import.lisp Modified: trunk/projects/quickhoney/upgrade-stuff/import.lisp =================================================================== --- trunk/projects/quickhoney/upgrade-stuff/import.lisp 2008-09-06 16:33:40 UTC (rev 3820) +++ trunk/projects/quickhoney/upgrade-stuff/import.lisp 2008-09-06 16:34:27 UTC (rev 3821) @@ -1,17 +1,17 @@ (in-package :quickhoney) -(defun replace-image (pathname) +(defun replace-image (pathname &rest args) (handler-case (let ((old (store-image-with-name (pathname-name pathname)))) (when old (format t "deleting ~A~%" old) (delete-object old)) - (import-image pathname)) + (apply #'import-image pathname args)) (error (e) (format t "~&; error importing ~S: ~A~%" pathname e)))) (dolist (name '(#p"type-news.png" #p"type-pixel.png" #p"type-shop.png" #p"type-vector.png")) - (import-image name :keywords '(:type))) + (replace-image name :keywords '(:type))) (dolist (pathname '(#P"overlay-close.gif" #P"hey.gif" @@ -32,7 +32,7 @@ #P"pixelcontact.gif")) (replace-image pathname)) -(import-image #p"news-sep.gif") +(replace-image #p"news-sep.gif") (with-transaction (:update-shopping) (dolist (image (get-keywords-intersection-store-images '(:photo :shopping))) @@ -41,6 +41,30 @@ (mapc #'delete-object (get-keywords-intersection-store-images '(:upload :home :button))) (mapc #'delete-object (get-keywords-intersection-store-images '(:clients :nicejobs))) +(defparameter *category-keywords* '(:pixel :vector :news :contact)) +(defparameter *other-keywords* '(:published :upload :import :buy-file :buy-t-shirt :buy-print :explicit :hans :bw)) + +(with-transaction (:initialize-cat-sub) + (dolist (image (class-instances 'quickhoney-image)) + (let ((cat (first (intersection (store-image-keywords image) *category-keywords*))) + (sub (first (set-difference (store-image-keywords image) (append *category-keywords* *other-keywords*))))) + (when cat + (setf (quickhoney-image-cat-sub image) + (if sub + (list cat sub) + (list cat)))) + (setf (store-image-keywords image) + (set-difference (store-image-keywords image) (cons (quickhoney-image-subcategory image) + *category-keywords*)))))) + +(with-transaction (:initialize-owner) + (dolist (image (class-instances 'quickhoney-image)) + (setf (owned-object-owner image) + (case (quickhoney-image-category image) + (:vector (find-user "p")) + (:pixel (find-user "n")) + (t (find-user "hans")))))) + (with-transaction (:initialize-news) (setf (slot-value (find-rss-channel "quickhoney") 'bknr.rss::items) (sort (remove-if (lambda (image)

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/
by BKNR Commits 06 Sep '08

06 Sep '08

Revision: 3820 Author: hans URL: http://bknr.net/trac/changeset/3820 Reworked and enhanced non-JS image browser to support site indexing by search engines. U trunk/projects/quickhoney/src/tags.lisp U trunk/projects/quickhoney/website/templates/frontpage.xml U trunk/projects/quickhoney/website/templates/image-browse.xml U trunk/projects/quickhoney/website/templates/index.xml Modified: trunk/projects/quickhoney/src/tags.lisp =================================================================== --- trunk/projects/quickhoney/src/tags.lisp 2008-09-06 16:31:28 UTC (rev 3819) +++ trunk/projects/quickhoney/src/tags.lisp 2008-09-06 16:33:40 UTC (rev 3820) @@ -9,71 +9,95 @@ (format-date-time (last-image-upload-timestamp) :vms-style t :show-time nil)))))) +(defun image-url (image) + (format nil "/image-browse/~(~A/~A~)/~A" + (quickhoney-image-category image) + (quickhoney-image-subcategory image) + (bknr.images:store-image-name image))) + +(defun navigation (&key previous up next) + (html ((:div :class "nav") + (when previous + (html ((:div :class "previous") + ((:a :href previous) "<<")))) + ((:div :class "up") + ((:a :href up) + "up")) + (when next + (html ((:div :class "next") + ((:a :href next) ">>"))))))) + (define-bknr-tag simple-image-browser () (tbnl:handle-if-modified-since (last-image-upload-timestamp)) (destructuring-bind (&optional category subcategory image-name) (multiple-value-list (parse-url)) (cond (image-name - (let ((image (or (bknr.images:store-image-with-name image-name) - (error #?"image $(image-name) not found")))) - (html - (:table - (:tbody - (:tr (:td "name") (:td (:princ image-name))) - (let ((next (cadr (member image (bknr.datastore:class-instances 'quickhoney-image))))) - (when next - (html (:tr (:td "next") - (:td ((:a :href #?"/image-browse/$((bknr.images:store-image-name next))") - (:princ (bknr.images:store-image-name next)))))))) - (:tr (:td "width") (:td (:princ (bknr.images:store-image-width image)))) - (:tr (:td "height") (:td (:princ (bknr.images:store-image-height image)))) - (when (quickhoney-image-client image) - (html (:tr (:td "client") (:td (:princ (quickhoney-image-client image)))))) - (when (quickhoney-image-spider-keywords image) - (html (:tr (:td "description") (:td (:princ (quickhoney-image-spider-keywords image)))))))) - ((:img :src #?"/image/$(image-name)" - :width (bknr.images:store-image-width image) - :height (bknr.images:store-image-height image))) - ((:script :type "text/javascript") - (:princ #?"document.location.href = document.location.href.replace(/\\/image-browse.*/, '$((make-image-link image :internal t))');"))))) + (let* ((image (or (bknr.images:store-image-with-name image-name) + (error #?"image $(image-name) not found"))) + (images-in-category (images-in-category (list (quickhoney-image-category image) + (quickhoney-image-subcategory image)))) + (previous (loop for rest on images-in-category + when (equal image (cadr rest)) + do (return (car rest)))) + (next (cadr (member image images-in-category)))) + (navigation :previous (and previous (image-url previous)) + :up (format nil "/image-browse/~(~A/~A~)" + (quickhoney-image-category image) + (quickhoney-image-subcategory image)) + :next (and next (image-url next))) + (html + ((:img :src #?"/image/$(image-name)" + :class "image" + :width (bknr.images:store-image-width image) + :height (bknr.images:store-image-height image))) + ((:div :class "metadata" :style #?"height: $((bknr.images:store-image-height image))px") + (:table + (:tbody + (:tr (:th "name") + (:td (:princ image-name))) + (:tr (:th "artist") + (:td (:princ (bknr.user:user-full-name (or (bknr.user:owned-object-owner image) + (bknr.user:find-user "hans")))) + ", QuickHoney")) + (:tr (:th "date") + (:td (:princ (format-date-time (bknr.datastore:blob-timestamp image) :vms-style t :show-time nil)))) + (when (and (quickhoney-image-client image) + (not (equal "" (quickhoney-image-client image)))) + (html (:tr (:th "client") + (:td (:princ (quickhoney-image-client image)))))) + (when (quickhoney-image-spider-keywords image) + (html (:tr (:th "keywords") + (:td (:princ (quickhoney-image-spider-keywords image)))))))))))) (subcategory + (navigation :up (format nil "/image-browse/~(~A~)" category)) (html - (:h1 (:princ #?"Images with category $(category) and subcategory $(subcategory)")) + (:h1 (:princ #?"$(category) / $(subcategory)")) (:ul - (dolist (image (bknr.images:get-keywords-intersection-store-images - (mapcar #'make-keyword-from-string (list category subcategory)))) + (dolist (image (sort (copy-list (quickhoney:images-in-category (mapcar #'make-keyword-from-string (list category subcategory)))) + #'> + :key #'bknr.datastore:blob-timestamp)) (html (:li ((:a :href #?"/image-browse/$(category)/$(subcategory)/$((bknr.images:store-image-name image))") (:princ (bknr.images:store-image-name image))))))))) (category + (navigation :up "/image-browse") (html - (:h1 (:princ #?"Subcategories of $(category)")) + (:h1 (:princ category)) (:ul - (dolist (subcategory (mapcar #'car - (group-on (remove (find-class 'quickhoney::quickhoney-image) - (bknr.images:get-keyword-store-images (make-keyword-from-string category)) - :test (complement #'eq) :key #'class-of) - :key #'quickhoney::quickhoney-image-subcategory))) + (dolist (subcategory (subcategories-of (make-keyword-from-string category))) (html (:li ((:a :href (format nil "/image-browse/~A/~(~A~)" category subcategory))) (:princ subcategory))))))) (t (html - (:h1 (:princ #?"Categories")) - (:ul - (dolist (category (mapcar #'car - (group-on (bknr.datastore:class-instances 'quickhoney::quickhoney-image) - :key #'quickhoney::quickhoney-image-category))) - (when category - (html - (:li ((:a :href (format nil "/image-browse/~(~A~)" category))) - (:princ category))))))))))) + ((:a :href "/image-browse/pixel") + (:h1 "Nana Rausch")) + ((:a :href "/image-browse/vector") + (:h1 "Peter Stemmler"))))) + (html + ((:script :type "text/javascript") + (:princ #?"document.location.href = document.location.href.replace(/\\/image-browse\\//, '/index#');"))))) -(define-bknr-tag first-image-link () - (html - ((:a :href #?"/image-browse/$((bknr.images:store-image-name (first (bknr.datastore:class-instances 'quickhoney-image))))") - (emit-tag-children)))) - (define-bknr-tag login-status () (cond ((bknr.web::admin-p (bknr-session-user)) Modified: trunk/projects/quickhoney/website/templates/frontpage.xml =================================================================== --- trunk/projects/quickhoney/website/templates/frontpage.xml 2008-09-06 16:31:28 UTC (rev 3819) +++ trunk/projects/quickhoney/website/templates/frontpage.xml 2008-09-06 16:33:40 UTC (rev 3820) @@ -30,7 +30,7 @@ <p> This site requires Firefox, Safari or Internet Explorer and Javascript for full viewing pleasure. </p> - <p>Enter our <quickhoney:first-image-link>Image gallery</quickhoney:first-image-link> for basic view.</p> + <p>Enter our <a href="/image-browse">Image gallery</a> for basic view.</p> <script type="text/javascript"> document.location.href = '/index'; </script> Modified: trunk/projects/quickhoney/website/templates/image-browse.xml =================================================================== --- trunk/projects/quickhoney/website/templates/image-browse.xml 2008-09-06 16:31:28 UTC (rev 3819) +++ trunk/projects/quickhoney/website/templates/image-browse.xml 2008-09-06 16:33:40 UTC (rev 3820) @@ -1,25 +1,28 @@ <?xml version="1.0" encoding="UTF-8"?> <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" - "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> <html - xmlns="http://www.w3.org/1999/xhtml" - xmlns:bknr="http://bknr.net" - xmlns:quickhoney="http://quickhoney.com/" - > - <head> - <link rel="stylesheet" href="/static/styles.css" /> - <script src="/static/javascript.js" type="text/javascript"> - </script> - <title>QuickHoney image</title> - </head> - <body id="imagedetail"> - <div id="logo"> - <a href="javascript:window.close()"> - <img src="/image/quickhoney" id="the_logo" name="logo" border="0" /> - </a> - </div> - <div id="image"> - <quickhoney:simple-image-browser /> - </div> - </body> -</html> \ No newline at end of file + xmlns="http://www.w3.org/1999/xhtml" + xmlns:bknr="http://bknr.net" + xmlns:quickhoney="http://quickhoney.com/" + > + <head> + <link rel="stylesheet" href="/static/yui/reset-fonts/reset-fonts.css" /> + <link rel="stylesheet" href="/static/quickhoney.css" /> + <link rel="stylesheet" href="/static/image-browse.css" /> + <script src="/static/javascript.js" type="text/javascript"> + </script> + <title>QuickHoney image</title> + </head> + <body id="image-browse"> + <div id="logo"> + <img src="/image/quickhoney-black" id="the_logo" name="logo" border="0" /> + </div> + <quickhoney:simple-image-browser /> + <div id="footer"> + ©1998-2008 QuickHoney Nana Rausch & Peter Stemmler. No part of + this website may be reproduced in any manner without permission. + Programming by Hübner/Odendahl <a href="http://headcraft.de/" target="_new">headcraft</a> + </div> + </body> +</html> Modified: trunk/projects/quickhoney/website/templates/index.xml =================================================================== --- trunk/projects/quickhoney/website/templates/index.xml 2008-09-06 16:31:28 UTC (rev 3819) +++ trunk/projects/quickhoney/website/templates/index.xml 2008-09-06 16:33:40 UTC (rev 3820) @@ -9,7 +9,8 @@ > <head> <link rel="stylesheet" href="/static/yui/reset-fonts/reset-fonts.css" /> - <link rel="stylesheet" href="/static/styles.css" /> + <link rel="stylesheet" href="/static/quickhoney.css" /> + <link rel="stylesheet" href="/static/index.css" /> <link rel="stylesheet" href="/static/ydsf.css" /> <link rel="alternate" type="application/rss+xml" title="RSS Feed" href="/rss/quickhoney" /> <script src="/static/detectplugins.js" type="text/javascript"> </script>

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/website/static/
by BKNR Commits 06 Sep '08

06 Sep '08

Revision: 3819 Author: hans URL: http://bknr.net/trac/changeset/3819 Fix for images with non-URL characters in their names. Split styles for non-JS image browser into separate file. Clear previous image when entering directory in order to reduce spurious image exposures. A trunk/projects/quickhoney/website/static/image-browse.css A trunk/projects/quickhoney/website/static/index.css U trunk/projects/quickhoney/website/static/javascript.js A trunk/projects/quickhoney/website/static/quickhoney.css D trunk/projects/quickhoney/website/static/styles.css Change set too large, please see URL above

1 0

[bknr-cvs] ksprotte changed trunk/bknr/datastore/src/data/
by BKNR Commits 05 Sep '08

05 Sep '08

Revision: 3818 Author: ksprotte URL: http://bknr.net/trac/changeset/3818 whitespace / indent datastore/src/data U trunk/bknr/datastore/src/data/blob.lisp U trunk/bknr/datastore/src/data/convert.lisp U trunk/bknr/datastore/src/data/encoding-test.lisp U trunk/bknr/datastore/src/data/encoding.lisp U trunk/bknr/datastore/src/data/json.lisp U trunk/bknr/datastore/src/data/object-tests.lisp U trunk/bknr/datastore/src/data/object.lisp U trunk/bknr/datastore/src/data/package.lisp U trunk/bknr/datastore/src/data/tests.lisp U trunk/bknr/datastore/src/data/txn.lisp U trunk/bknr/datastore/src/data/xml-object.lisp U trunk/bknr/datastore/src/data/xml-tutorial.lisp Change set too large, please see URL above

1 0

[bknr-cvs] ksprotte changed trunk/bknr/datastore/src/data/object.lisp
by BKNR Commits 05 Sep '08

05 Sep '08

Revision: 3817 Author: ksprotte URL: http://bknr.net/trac/changeset/3817 (deftransaction CHANGE-SLOT-VALUES ...) had been split into (defun CHANGE-SLOT-VALUES ...) and (defun TX-CHANGE-SLOT-VALUES ...) in http://bknr.net/trac/changeset/3037 to produce a warning only when CHANGE-SLOT-VALUES is called (it is deprecated), whereas TX-CHANGE-SLOT-VALUES is properly used in (SETF SLOT-VALUE-USING-CLASS). I dont understand the reason for deprecating change-slot-values AND making it at the same time non-functional. It is still used by BOS e.g. in edit-sponsor, so I changed it to still produce a warning, but be functional again. U trunk/bknr/datastore/src/data/object.lisp Modified: trunk/bknr/datastore/src/data/object.lisp =================================================================== --- trunk/bknr/datastore/src/data/object.lisp 2008-09-05 16:25:53 UTC (rev 3816) +++ trunk/bknr/datastore/src/data/object.lisp 2008-09-05 18:10:54 UTC (rev 3817) @@ -716,12 +716,11 @@ (defun change-slot-values (object &rest slots-and-values) "This function is the deprecated way to set slots of persistent objects." - (declare (ignore slots-and-values)) (warn "CHANGE-SLOT-VALUES is deprecated - use WITH-TRANSACTION and standard accessors!") (execute (make-instance 'transaction :function-symbol 'tx-change-slot-values :timestamp (get-universal-time) - :args (list object)))) + :args (list* object slots-and-values)))) (defmethod prepare-for-snapshot (object) nil)

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/src/tags.lisp
by BKNR Commits 05 Sep '08

05 Sep '08

Revision: 3816 Author: hans URL: http://bknr.net/trac/changeset/3816 Hierarchical HTML browser. This is far too inefficient yet. U trunk/projects/quickhoney/src/tags.lisp Modified: trunk/projects/quickhoney/src/tags.lisp =================================================================== --- trunk/projects/quickhoney/src/tags.lisp 2008-09-05 16:18:22 UTC (rev 3815) +++ trunk/projects/quickhoney/src/tags.lisp 2008-09-05 16:25:53 UTC (rev 3816) @@ -10,29 +10,64 @@ :vms-style t :show-time nil)))))) (define-bknr-tag simple-image-browser () - (let* ((image-name (parse-url)) - (image (or (bknr.images:store-image-with-name image-name) - (error #?"image $(image-name) not found")))) - (html - (:table - (:tbody - (:tr (:td "name") (:td (:princ image-name))) - (let ((next (cadr (member image (bknr.datastore:class-instances 'quickhoney-image))))) - (when next - (html (:tr (:td "next") - (:td ((:a :href #?"/image-browse/$((bknr.images:store-image-name next))") - (:princ (bknr.images:store-image-name next)))))))) - (:tr (:td "width") (:td (:princ (bknr.images:store-image-width image)))) - (:tr (:td "height") (:td (:princ (bknr.images:store-image-height image)))) - (when (quickhoney-image-client image) - (html (:tr (:td "client") (:td (:princ (quickhoney-image-client image)))))) - (when (quickhoney-image-spider-keywords image) - (html (:tr (:td "description") (:td (:princ (quickhoney-image-spider-keywords image)))))))) - ((:img :src #?"/image/$(image-name)" - :width (bknr.images:store-image-width image) - :height (bknr.images:store-image-height image))) - ((:script :type "text/javascript") - (:princ #?"document.location.href = document.location.href.replace(/\\/image-browse.*/, '$((make-image-link image :internal t))');"))))) + (tbnl:handle-if-modified-since (last-image-upload-timestamp)) + (destructuring-bind (&optional category subcategory image-name) (multiple-value-list (parse-url)) + (cond + (image-name + (let ((image (or (bknr.images:store-image-with-name image-name) + (error #?"image $(image-name) not found")))) + (html + (:table + (:tbody + (:tr (:td "name") (:td (:princ image-name))) + (let ((next (cadr (member image (bknr.datastore:class-instances 'quickhoney-image))))) + (when next + (html (:tr (:td "next") + (:td ((:a :href #?"/image-browse/$((bknr.images:store-image-name next))") + (:princ (bknr.images:store-image-name next)))))))) + (:tr (:td "width") (:td (:princ (bknr.images:store-image-width image)))) + (:tr (:td "height") (:td (:princ (bknr.images:store-image-height image)))) + (when (quickhoney-image-client image) + (html (:tr (:td "client") (:td (:princ (quickhoney-image-client image)))))) + (when (quickhoney-image-spider-keywords image) + (html (:tr (:td "description") (:td (:princ (quickhoney-image-spider-keywords image)))))))) + ((:img :src #?"/image/$(image-name)" + :width (bknr.images:store-image-width image) + :height (bknr.images:store-image-height image))) + ((:script :type "text/javascript") + (:princ #?"document.location.href = document.location.href.replace(/\\/image-browse.*/, '$((make-image-link image :internal t))');"))))) + (subcategory + (html + (:h1 (:princ #?"Images with category $(category) and subcategory $(subcategory)")) + (:ul + (dolist (image (bknr.images:get-keywords-intersection-store-images + (mapcar #'make-keyword-from-string (list category subcategory)))) + (html + (:li ((:a :href #?"/image-browse/$(category)/$(subcategory)/$((bknr.images:store-image-name image))") + (:princ (bknr.images:store-image-name image))))))))) + (category + (html + (:h1 (:princ #?"Subcategories of $(category)")) + (:ul + (dolist (subcategory (mapcar #'car + (group-on (remove (find-class 'quickhoney::quickhoney-image) + (bknr.images:get-keyword-store-images (make-keyword-from-string category)) + :test (complement #'eq) :key #'class-of) + :key #'quickhoney::quickhoney-image-subcategory))) + (html + (:li ((:a :href (format nil "/image-browse/~A/~(~A~)" category subcategory))) + (:princ subcategory))))))) + (t + (html + (:h1 (:princ #?"Categories")) + (:ul + (dolist (category (mapcar #'car + (group-on (bknr.datastore:class-instances 'quickhoney::quickhoney-image) + :key #'quickhoney::quickhoney-image-category))) + (when category + (html + (:li ((:a :href (format nil "/image-browse/~(~A~)" category))) + (:princ category))))))))))) (define-bknr-tag first-image-link () (html @@ -47,4 +82,5 @@ (query-param "__username")) (html (:h1 "Login failed, please try again"))) (t - (html (:h1 "Please login"))))) \ No newline at end of file + (html (:h1 "Please login"))))) +

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/sponsor-handlers.lisp
by BKNR Commits 05 Sep '08

05 Sep '08

Revision: 3815 Author: ksprotte URL: http://bknr.net/trac/changeset/3815 small fix for CERT-REGEN-HANDLER action :WAIT (We need with-http-response and with-http-body for page with custom :head) U trunk/projects/bos/web/sponsor-handlers.lisp Modified: trunk/projects/bos/web/sponsor-handlers.lisp =================================================================== --- trunk/projects/bos/web/sponsor-handlers.lisp 2008-09-05 15:21:59 UTC (rev 3814) +++ trunk/projects/bos/web/sponsor-handlers.lisp 2008-09-05 16:18:22 UTC (rev 3815) @@ -332,10 +332,13 @@ (defmethod handle-object-form ((handler cert-regen-handler) (action (eql :wait)) (contract contract)) (if (not (and (contract-certificates-generated-p contract) (not (contract-tree-needs-update-p)))) - (html (:html - (:head ((:meta :http-equiv "refresh" - :content #?"2; url=/cert-regen/$((store-object-id contract))?action=wait"))) - (:body "waiting for certificate to be regenerated..."))) + (with-http-response (:content-type "text/html; charset=UTF-8") + (with-http-body () + (html + (:html + (:head ((:meta :http-equiv "refresh" + :content #?"2; url=/cert-regen/$((store-object-id contract))?action=wait"))) + (:body (:p "waiting for certificate to be regenerated...")))))) (with-bos-cms-page (:title "Certificate has been recreated") (html "The certificates for the sponsor have been re-generated." :br) (unless (contract-download-only-p contract)

1 0