- bknr-cvs@common-lisp.net - mailman3.common-lisp.net

[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

[bknr-cvs] hans changed trunk/projects/quickhoney/website/templates/index.xml
by BKNR Commits 05 Sep '08

05 Sep '08

Revision: 3814 Author: hans URL: http://bknr.net/trac/changeset/3814 Don't shuffle images when selecting a button on the home page. U trunk/projects/quickhoney/website/templates/index.xml Modified: trunk/projects/quickhoney/website/templates/index.xml =================================================================== --- trunk/projects/quickhoney/website/templates/index.xml 2008-09-05 15:10:56 UTC (rev 3813) +++ trunk/projects/quickhoney/website/templates/index.xml 2008-09-05 15:21:59 UTC (rev 3814) @@ -63,21 +63,21 @@ <div> <a href="#pixel" class="home_button"> <img alt="home pixel" id="home_pixel" src="/image/trans" width="318" height="318" - onclick="shuffle_button_images()" onload="reveal_image(this);" class="button-image" /> + onload="reveal_image(this);" class="button-image" /> </a> <a href="#vector" class="home_button"> <img alt="home vector" id="home_vector" src="/image/trans" width="318" height="318" - onclick="shuffle_button_images()" onload="reveal_image(this);" class="button-image" /> + onload="reveal_image(this);" class="button-image" /> </a> </div> <div> <a href="#news" class="home_button"> <img alt="home news" id="home_news" src="/image/trans" width="318" height="318" - onclick="shuffle_button_images()" onload="reveal_image(this);" class="button-image" /> + onload="reveal_image(this);" class="button-image" /> </a> <a href="#shop" class="home_button"> <img alt="home shop" id="home_shop" src="/image/trans" width="318" height="318" - onclick="shuffle_button_images()" onload="reveal_image(this);" class="button-image" /> + onload="reveal_image(this);" class="button-image" /> </a> </div> </div>

1 0

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

05 Sep '08

Revision: 3813 Author: hans URL: http://bknr.net/trac/changeset/3813 add missing paren. untested functionality. 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:04:15 UTC (rev 3812) +++ trunk/projects/bos/web/sponsor-handlers.lisp 2008-09-05 15:10:56 UTC (rev 3813) @@ -327,7 +327,7 @@ (defmethod handle-object-form ((handler cert-regen-handler) (action (eql :regenerate)) (contract contract)) (with-query-params (name address language) (contract-issue-cert contract name :address address :language language)) - (redirect #?"/cert-regen/$((store-object-id contract))?action=wait") + (redirect #?"/cert-regen/$((store-object-id contract))?action=wait")) (defmethod handle-object-form ((handler cert-regen-handler) (action (eql :wait)) (contract contract)) (if (not (and (contract-certificates-generated-p contract)

1 0

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

05 Sep '08

Revision: 3812 Author: hans URL: http://bknr.net/trac/changeset/3812 Reorganize source to match control flow. 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:03:22 UTC (rev 3811) +++ trunk/projects/bos/web/sponsor-handlers.lisp 2008-09-05 15:04:15 UTC (rev 3812) @@ -330,16 +330,16 @@ (redirect #?"/cert-regen/$((store-object-id contract))?action=wait") (defmethod handle-object-form ((handler cert-regen-handler) (action (eql :wait)) (contract contract)) - (if (and (contract-certificates-generated-p contract) - (not (contract-tree-needs-update-p))) + (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-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) (mail-print-pdf contract) (html "The print certificate has been sent to the relevant BOS office address by email." :br)) (let ((sponsor (contract-sponsor contract))) - (cmslink #?"edit-sponsor/$((store-object-id sponsor))" "return to sponsor"))) - (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..."))))) \ No newline at end of file + (cmslink #?"edit-sponsor/$((store-object-id sponsor))" "return to sponsor"))))) \ No newline at end of file

1 0

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

05 Sep '08

Revision: 3811 Author: hans URL: http://bknr.net/trac/changeset/3811 Wait for certificate generation in CMS. 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 14:23:27 UTC (rev 3810) +++ trunk/projects/bos/web/sponsor-handlers.lisp 2008-09-05 15:03:22 UTC (rev 3811) @@ -327,10 +327,19 @@ (defmethod handle-object-form ((handler cert-regen-handler) (action (eql :regenerate)) (contract contract)) (with-query-params (name address language) (contract-issue-cert contract name :address address :language language)) - (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) - (mail-print-pdf contract) - (html "The print certificate has been sent to the relevant BOS office address by email." :br)) - (let ((sponsor (contract-sponsor contract))) - (cmslink #?"edit-sponsor/$((store-object-id sponsor))" "return to sponsor")))) \ No newline at end of file + (redirect #?"/cert-regen/$((store-object-id contract))?action=wait") + +(defmethod handle-object-form ((handler cert-regen-handler) (action (eql :wait)) (contract contract)) + (if (and (contract-certificates-generated-p contract) + (not (contract-tree-needs-update-p))) + (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) + (mail-print-pdf contract) + (html "The print certificate has been sent to the relevant BOS office address by email." :br)) + (let ((sponsor (contract-sponsor contract))) + (cmslink #?"edit-sponsor/$((store-object-id sponsor))" "return to sponsor"))) + (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..."))))) \ No newline at end of file

1 0