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

[bknr-cvs] ksprotte changed trunk/projects/bos/
by BKNR Commits 28 Jul '08

28 Jul '08

Revision: 3653 Author: ksprotte URL: http://bknr.net/trac/changeset/3653 poi-handlers changed to get them up-to-date with hunchentoot - all the old functionality is working now again A trunk/projects/bos/payment-website/static/MochiKit U trunk/projects/bos/payment-website/static/cms.js U trunk/projects/bos/web/poi-handlers.lisp U trunk/projects/bos/web/webserver.lisp Added: trunk/projects/bos/payment-website/static/MochiKit =================================================================== --- trunk/projects/bos/payment-website/static/MochiKit (rev 0) +++ trunk/projects/bos/payment-website/static/MochiKit 2008-07-28 10:48:50 UTC (rev 3653) @@ -0,0 +1 @@ +link ../../../../thirdparty/MochiKit/MochiKit \ No newline at end of file Property changes on: trunk/projects/bos/payment-website/static/MochiKit ___________________________________________________________________ Name: svn:special + * Modified: trunk/projects/bos/payment-website/static/cms.js =================================================================== --- trunk/projects/bos/payment-website/static/cms.js 2008-07-28 08:48:19 UTC (rev 3652) +++ trunk/projects/bos/payment-website/static/cms.js 2008-07-28 10:48:50 UTC (rev 3653) @@ -92,3 +92,9 @@ return true; } } + +function confirm_delete(field_name, value, confirm_string) +{ + $(field_name).value = value; + return confirm(confirm_string); +} \ No newline at end of file Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-07-28 08:48:19 UTC (rev 3652) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-07-28 10:48:50 UTC (rev 3653) @@ -1,11 +1,10 @@ - (in-package :bos.web) (enable-interpol-syntax) (defclass make-poi-handler (page-handler) ()) - + (defmethod handle ((handler make-poi-handler)) (with-query-params (name) (cond @@ -64,7 +63,8 @@ (< -1 (+ shift-by old-position) (length new-images)))) (setf (nth old-position new-images) (nth (+ shift-by old-position) new-images)) (setf (nth (+ shift-by old-position) new-images) tmp) - (change-slot-values poi 'bos.m2::images new-images))) + (with-transaction ("setf poi-images") + (setf (poi-images poi) new-images)))) (with-bos-cms-page (:title "Edit POI") (content-language-chooser) (unless (poi-complete poi language) @@ -111,19 +111,19 @@ for index from 1 by 1 do (html (:td ((:a :href (format nil "/edit-poi-image/~a?poi=~A" (store-object-id image) (store-object-id poi))) ((:img :border "0" :src (format nil "/image/~a/thumbnail,,55,55" (store-object-id image))))) - :br - (if (eql index 1) - (html ((:img :src "/images/trans.gif" :width "16"))) - (html ((:a :href (format nil "/edit-poi/~A?shift=~A&shift-by=-1" - (store-object-id poi) - (store-object-id image))) - ((:img :border "0" :src "/images/pfeil-l.gif"))))) - ((:img :src "/images/trans.gif" :width "23")) - (unless (eql index (length (poi-images poi))) - (html ((:a :href (format nil "/edit-poi/~A?shift=~A&shift-by=1" - (store-object-id poi) - (store-object-id image))) - ((:img :border "0" :src "/images/pfeil-r.gif")))))))))) + :br + (if (eql index 1) + (html ((:img :src "/images/trans.gif" :width "16"))) + (html ((:a :href (format nil "/edit-poi/~A?shift=~A&shift-by=-1" + (store-object-id poi) + (store-object-id image))) + ((:img :border "0" :src "/images/pfeil-l.gif"))))) + ((:img :src "/images/trans.gif" :width "23")) + (unless (eql index (length (poi-images poi))) + (html ((:a :href (format nil "/edit-poi/~A?shift=~A&shift-by=1" + (store-object-id poi) + (store-object-id image))) + ((:img :border "0" :src "/images/pfeil-r.gif")))))))))) (unless (eql 6 (length (poi-images poi))) (html :br @@ -139,12 +139,14 @@ ((:input :type "file" :name "image-file")) :br (submit-button "upload-airal" "upload-airal"))))) - (:tr (:td "panorama view") + (:tr (:td "panorama view" + ((:input :id "panorama-id" :type "hidden" :name "panorama-id"))) (:td (dolist (panorama (poi-panoramas poi)) (html (:princ-safe (format-date-time (blob-timestamp panorama))) ((:a :href (format nil "/image/~D" (store-object-id panorama)) :target "_new" :class "cmslink") " view ") - (submit-button "delete-panorama" "delete-panorama" :confirm "Really delete this panorama image?") + (submit-button "delete-panorama" "delete-panorama" + :formcheck #?"javascript:confirm_delete('panorama-id', $((store-object-id panorama)), 'Really delete this panorama image?')") :br)) (html "Upload new panorama view" ((:input :type "file" :name "image-file")) @@ -191,28 +193,30 @@ (unless uploaded-file (error "no file uploaded in upload handler")) (with-image-from-upload* (uploaded-file) - (unless (and (eql (cl-gd:image-width) *poi-image-width*) - (eql (cl-gd:image-height) *poi-image-height*)) - (with-bos-cms-page (:title "Invalid image size") - (:h2 "Invalid image size") - (:p "The image needs to be " - (:princ-safe *poi-image-width*) " pixels wide and " - (:princ-safe *poi-image-height*) " pixels high. Your uploaded image is " - (:princ-safe (cl-gd:image-width)) " pixels wide and " - (:princ-safe (cl-gd:image-height)) " pixels high. Please use an image editor " - "to resize the image and upload it again.") - (:p (cmslink (edit-object-url poi) "Back to POI"))) - (return-from handle-object-form t))) - (change-slot-values poi 'airals (list (import-image (upload-pathname uploaded-file) - :class-name 'store-image)))) - (redirect (format nil "/edit-poi/~D" - (store-object-id poi)))) + (cond + ((and (eql (cl-gd:image-width) *poi-image-width*) + (eql (cl-gd:image-height) *poi-image-height*)) + (with-transaction ("set airals") + (setf (poi-airals poi) (print (list (import-image uploaded-file :class-name 'store-image))))) + (redirect (format nil "/edit-poi/~D" + (store-object-id poi)))) + (t + (with-bos-cms-page (:title "Invalid image size") + (:h2 "Invalid image size") + (:p "The image needs to be " + (:princ-safe *poi-image-width*) " pixels wide and " + (:princ-safe *poi-image-height*) " pixels high. Your uploaded image is " + (:princ-safe (cl-gd:image-width)) " pixels wide and " + (:princ-safe (cl-gd:image-height)) " pixels high. Please use an image editor " + "to resize the image and upload it again.") + (:p (cmslink (edit-object-url poi) "Back to POI")))))))) (defmethod handle-object-form ((handler edit-poi-handler) (action (eql :delete-airal)) (poi poi)) (let ((airals (poi-airals poi))) - (change-slot-values poi 'airals nil) + (with-transaction ("setf poi-airals nil") + (setf (poi-airals poi) nil)) (mapc #'delete-object airals)) (redirect (format nil "/edit-poi/~D" (store-object-id poi)))) @@ -220,7 +224,8 @@ (defmethod handle-object-form ((handler edit-poi-handler) (action (eql :delete-movie)) (poi poi)) - (change-slot-values poi 'movies nil) + (with-transaction ("setf poi-movies nil") + (setf (poi-movies poi) nil)) (redirect (format nil "/edit-poi/~D" (store-object-id poi)))) (defmethod handle-object-form ((handler edit-poi-handler) @@ -229,12 +234,10 @@ (let ((uploaded-file (request-uploaded-file "image-file"))) (unless uploaded-file (error "no file uploaded in upload handler")) - (with-image-from-upload* (uploaded-file) - ; just open the image to make sure that gd can process it - ) - (change-slot-values poi 'panoramas (cons (import-image (upload-pathname uploaded-file) - :class-name 'store-image) - (poi-panoramas poi)))) + ;; just open the image to make sure that gd can process it + (with-image-from-upload* (uploaded-file)) + (with-transaction ("add poi-panorama") + (push (import-image uploaded-file :class-name 'store-image) (poi-panoramas poi)))) (redirect (format nil "/edit-poi/~D" (store-object-id poi)))) @@ -243,8 +246,9 @@ (poi poi)) (with-query-params (panorama-id) (let ((panorama (find-store-object (parse-integer panorama-id)))) - (change-slot-values poi 'panoramas (remove panorama (poi-panoramas poi))) - (mapc #'delete-object panorama))) + (with-transaction ("delete poi-panorama") + (alexandria:deletef (poi-panoramas poi) panorama)) + (delete-object panorama))) (redirect (format nil "/edit-poi/~D" (store-object-id poi)))) @@ -292,7 +296,7 @@ (return-from handle-object-form t))) (if poi-image (blob-from-file poi-image uploaded-file) - (setq poi-image (import-image (upload-pathname uploaded-file) + (setq poi-image (import-image uploaded-file :class-name 'poi-image :initargs `(:poi ,poi)))) (redirect (format nil "/edit-poi-image/~D?poi=~D" @@ -314,8 +318,8 @@ (:td ((:img :src (format nil "/image/~A" (store-object-id poi-image)))))) (:tr (:td "upload new image") (:td ((:input :type "file" :name "image-file")) - :br - (submit-button "upload" "upload"))) + :br + (submit-button "upload" "upload"))) (:tr (:td "title") (:td (text-field "title" :value (slot-string poi-image 'title language)))) @@ -364,10 +368,10 @@ :key (lambda (poi) (store-object-last-change poi 1))) (reduce #'max last-paid-contracts :key (lambda (contract) (store-object-last-change contract 0)))))) - (hunchentoot:handle-if-modified-since timestamp) + (hunchentoot:handle-if-modified-since timestamp) (setf (hunchentoot:header-out :last-modified) (hunchentoot:rfc-1123-date timestamp)) - (with-http-response (:content-type "text/html; charset=UTF-8") + (with-http-response (:content-type "text/html; charset=UTF-8") (with-http-body () (html ((:script :language "JavaScript") @@ -409,12 +413,12 @@ (format-image (image) (with-element "image" (attribute "id" (princ-to-string (store-object-id image))) - (when (typep image 'poi-image) + (when (typep image 'poi-image) (attribute "title" (slot-string image 'title language)) - (attribute "subtitle" (slot-string image 'subtitle language)) + (attribute "subtitle" (slot-string image 'subtitle language)) (with-element "description" (text (slot-string image 'description language)))) (with-element "url" (text (format nil "http://createrainforest.org/image/~D" - (store-object-id image)))) + (store-object-id image)))) (with-element "width" (text (princ-to-string (store-image-width image)))) (with-element "height" (text (princ-to-string (store-image-height image))))))) (with-accessors ((id store-object-id) @@ -480,19 +484,19 @@ ;; images (with-element "tr" (dolist (image images) - (img-td image))) + (img-td image))) ;; titles (with-element "tr" (dolist (image images) (img-td-title image))))) (handler-case (with-xml-output (make-string-sink) - (with-element "html" + (with-element "html" (with-element "head") (with-element "body" (with-element "table" (attribute "cellspacing" "0") (attribute "width" "500") (attribute "cellpadding" "5") (attribute "border" "0") - (attribute "style" "background-color: rgb(186, 186, 186);") + (attribute "style" "background-color: rgb(186, 186, 186);") (with-element "tbody" (with-element "tr" (with-element "td" @@ -566,7 +570,7 @@ (defmethod handle-object ((handler poi-xml-handler) poi) (let ((timestamp (store-object-last-change poi 1))) - (hunchentoot:handle-if-modified-since timestamp) + (hunchentoot:handle-if-modified-since timestamp) (setf (hunchentoot:header-out :last-modified) (hunchentoot:rfc-1123-date timestamp)) (with-query-params ((lang "en")) @@ -580,7 +584,7 @@ (defmethod handle-object ((handler poi-kml-handler) poi) (with-query-params ((lang "en")) - (with-xml-response () + (with-xml-response () (with-namespace (nil "http://earth.google.com/kml/2.1") (with-element "kml" (write-poi-kml poi lang)))))) @@ -610,5 +614,3 @@ (with-element "href" (text (format nil "http://~a/static/Orang_weiss.png" (website-host))))))) (kml-region (make-rectangle2 (list 0 0 +width+ +width+)) '(:min 600 :max -1)) (mapc #'(lambda (poi) (write-poi-kml poi lang)) relevant-pois)))))))) - - Modified: trunk/projects/bos/web/webserver.lisp =================================================================== --- trunk/projects/bos/web/webserver.lisp 2008-07-28 08:48:19 UTC (rev 3652) +++ trunk/projects/bos/web/webserver.lisp 2008-07-28 10:48:50 UTC (rev 3653) @@ -225,7 +225,7 @@ :authorizer (make-instance 'bos-authorizer) :site-logo-url "/images/bos-logo.gif" :style-sheet-urls '("/static/cms.css") - :javascript-urls '("/static/cms.js" "/static/tiny_mce/tiny_mce.js")) + :javascript-urls '("/static/cms.js" "/static/tiny_mce/tiny_mce.js" "/static/MochiKit/MochiKit.js")) (publish-directory :prefix "/static/" :destination (merge-pathnames "static/" website-directory))

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/poi-handlers.lisp
by BKNR Commits 28 Jul '08

28 Jul '08

Revision: 3652 Author: ksprotte URL: http://bknr.net/trac/changeset/3652 edit-poi-handler added link to poi microsite U trunk/projects/bos/web/poi-handlers.lisp Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-07-28 08:47:01 UTC (rev 3651) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-07-28 08:48:19 UTC (rev 3652) @@ -74,7 +74,8 @@ ((:form :method "POST" :enctype "multipart/form-data") ((:table :border "1") (:tr (:td "name") - (:td (:princ-safe (poi-name poi)))) + (:td (:princ-safe (poi-name poi)) + (cmslink (format nil "/poi-xml/~D?lang=~A" (store-object-id poi) language) "view"))) (:tr (:td "published") (:td (checkbox-field "published" "published" :checked (poi-published poi)))) (:tr (:td "title")

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/web-utils.lisp
by BKNR Commits 28 Jul '08

28 Jul '08

Revision: 3651 Author: ksprotte URL: http://bknr.net/trac/changeset/3651 fixed content-language-chooser to use script-name instead of request-uri U trunk/projects/bos/web/web-utils.lisp Modified: trunk/projects/bos/web/web-utils.lisp =================================================================== --- trunk/projects/bos/web/web-utils.lisp 2008-07-27 10:07:06 UTC (rev 3650) +++ trunk/projects/bos/web/web-utils.lisp 2008-07-28 08:47:01 UTC (rev 3651) @@ -39,17 +39,19 @@ (cadr (assoc language-short-name (website-languages) :test #'equal))) (defun content-language-chooser () + "Note that in the current implementation other GET parameters than + language will be lost (not appended to script-name)." (html ((:p :class "languages") "Content languages: " (loop for (language-symbol language-name) in (website-languages) - do (labels ((show-language-link () - (html (cmslink (format nil "~A?language=~A" (hunchentoot:request-uri*) language-symbol) - (:princ-safe language-name))))) - (if (equal (request-language) language-symbol) - (html "[" (show-language-link) "]") - (html (show-language-link))) - (html " ")))))) + do (labels ((show-language-link () + (html (cmslink (format nil "~A?language=~A" (hunchentoot:script-name*) language-symbol) + (:princ-safe language-name))))) + (if (equal (request-language) language-symbol) + (html "[" (show-language-link) "]") + (html (show-language-link))) + (html " ")))))) (defun decode-ismap-query-string () (let ((coord-string (caar (query-params))))

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/src/pa
by BKNR Commits 27 Jul '08

27 Jul '08

Revision: 3650 Author: hans URL: http://bknr.net/trac/changeset/3650 Add beginnings of round-trip test environment for Paypal Express Checkout. U trunk/projects/quickhoney/src/packages.lisp A trunk/projects/quickhoney/src/paypal-test.lisp U trunk/projects/quickhoney/src/paypal.lisp Modified: trunk/projects/quickhoney/src/packages.lisp =================================================================== --- trunk/projects/quickhoney/src/packages.lisp 2008-07-26 22:06:44 UTC (rev 3649) +++ trunk/projects/quickhoney/src/packages.lisp 2008-07-27 10:07:06 UTC (rev 3650) @@ -54,4 +54,9 @@ (:export #:client-selectbox)) (defpackage :paypal + (:use :cl) + (:export #:request + #:make-express-checkout-url)) + +(defpackage :paypal-test (:use :cl)) \ No newline at end of file Added: trunk/projects/quickhoney/src/paypal-test.lisp =================================================================== --- trunk/projects/quickhoney/src/paypal-test.lisp (rev 0) +++ trunk/projects/quickhoney/src/paypal-test.lisp 2008-07-27 10:07:06 UTC (rev 3650) @@ -0,0 +1,43 @@ +(in-package :paypal-test) + +(defgeneric dispatch-request (request-type request) + (:documentation "dispatch incoming http request")) + +(defmethod no-applicable-method ((function (eql #'dispatch-request)) &rest args) + (declare (ignore args)) + nil) + +(defmacro define-handler (type (request) &body body) + (let ((request-type-var (gensym))) + `(defmethod dispatch-request ((,request-type-var (eql ,type)) ,request) + (declare (ignore ,request-type-var)) + (lambda () ,@body)))) + +(defvar *response-host* nil) +(defvar *response-port* nil) + +(define-handler :checkout (request) + (tbnl:redirect (paypal:make-express-checkout-url 10 :eur + :returnurl (format nil "http://~A:~A/return-paypal" response-host response-port) + :cancelurl (format nil "http://~A:~A/cancel-paypal" response-host response-port)))) + +(define-handler :stop (request) + (throw 'stop-server nil)) + +(define-handler :return-paypal (request) + "Returned from paypal") + +(define-handler :cancel-paypal (request) + "Cancelled") + +(defun dispatch-request% (request) + (let* ((type-string (cl-ppcre:scan-to-strings "[^/]+" (tbnl:script-name request))) + (request-type (and type-string (find-symbol (string-upcase type-string) :keyword)))) + (dispatch-request request-type request))) + +(defun test-express-checkout (&key (response-port 2993) (response-host "127.0.0.1")) + (setf *response-host* response-host + *response-port* response-port) + (catch 'stop-server + (tbnl:start-server :port response-port + :dispatch-table (list #'dispatch-request%)))) Modified: trunk/projects/quickhoney/src/paypal.lisp =================================================================== --- trunk/projects/quickhoney/src/paypal.lisp 2008-07-26 22:06:44 UTC (rev 3649) +++ trunk/projects/quickhoney/src/paypal.lisp 2008-07-27 10:07:06 UTC (rev 3650) @@ -57,21 +57,20 @@ (error 'request-error :response response)) response))) -(defun test-express-checkout () - (let* ((amt "50.00") - (currencycode "EUR") - (returnurl "http://test.createrainforest.org/return-paypal") - (cancelurl "http://test.createrainforest.org/cancel-paypal") +(defun make-express-checkout-url (amount currencycode returnurl cancelurl) + (let* ((amt (format nil "~,2F" amount)) + (currencycode (symbol-name currencycode)) (token (getf (request "SetExpressCheckout" - :amt amt - :currencycode currencycode - :returnurl returnurl - :cancelurl cancelurl - :paymentaction "Sale") - :token))) - (format *trace-output* "url: https://www.sandbox.paypal.com/webscr?cmd=_express-checkout&token=~A~ - &AMT=~A&CURRENCYCODE=~A&RETURNURL=~A&CANCELURL=~A" + :amt amt + :currencycode currencycode + :returnurl returnurl + :cancelurl cancelurl + :paymentaction "Sale") + :token))) + (format nil "https://www.sandbox.paypal.com/webscr?cmd=_express-checkout&token=~A~ + &AMT=~A&CURRENCYCODE=~A&RETURNURL=~A&CANCELURL=~A" (hunchentoot:url-encode token) amt currencycode (hunchentoot:url-encode returnurl) - (hunchentoot:url-encode cancelurl)))) \ No newline at end of file + (hunchentoot:url-encode cancelurl)))) +

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/website/
by BKNR Commits 26 Jul '08

26 Jul '08

Revision: 3649 Author: hans URL: http://bknr.net/trac/changeset/3649 Work on shopping cart page, fix shop page a little U trunk/projects/quickhoney/website/static/javascript.js U trunk/projects/quickhoney/website/static/styles.css U trunk/projects/quickhoney/website/templates/index.xml Modified: trunk/projects/quickhoney/website/static/javascript.js =================================================================== --- trunk/projects/quickhoney/website/static/javascript.js 2008-07-26 22:06:02 UTC (rev 3648) +++ trunk/projects/quickhoney/website/static/javascript.js 2008-07-26 22:06:44 UTC (rev 3649) @@ -432,12 +432,20 @@ }); pages['shop'] - = new Page(['shop_page'], + = new Page(['results'], ['000000', 'ffffff', '0054ff'], function() { footer_hide(); }); +pages['cart'] + = new Page(['cart_page'], + ['000000', 'ffffff', '0054ff'], + function() { + show_shopping_cart(); + footer_hide(); + }); + pages['contact'] = new Page(['contact_page'], ['000000', 'ffffff', 'ffa200'], @@ -1302,6 +1310,12 @@ } } +function show_shopping_cart () +{ + $('menu').className = 'shop'; + document.body.className = 'shop'; +} + function recolored_image_path(name) { return '/image/' + name + '/color,ff00ff,' + pages[current_directory].colors[2]; Modified: trunk/projects/quickhoney/website/static/styles.css =================================================================== --- trunk/projects/quickhoney/website/static/styles.css 2008-07-26 22:06:02 UTC (rev 3648) +++ trunk/projects/quickhoney/website/static/styles.css 2008-07-26 22:06:44 UTC (rev 3649) @@ -25,6 +25,8 @@ margin: 0px; } +a img { border-width: 0px; } + .cmslink { background-color: #bfbfbf; color: #000000; @@ -617,7 +619,7 @@ padding-top: 16px; } -img#checkout { +a#checkout { position: absolute; top: 0px; left: 585px; Modified: trunk/projects/quickhoney/website/templates/index.xml =================================================================== --- trunk/projects/quickhoney/website/templates/index.xml 2008-07-26 22:06:02 UTC (rev 3648) +++ trunk/projects/quickhoney/website/templates/index.xml 2008-07-26 22:06:44 UTC (rev 3649) @@ -23,7 +23,7 @@ <div id="overlay"> </div> - <img id="checkout" src="/image/checkout" width="112" height="24"/> + <a id="checkout" href="#cart" onclick="show_page('cart');"><img src="/image/checkout" width="112" height="24"/></a> <div id="menu"> <a onclick="show_page('home')" href="#home" id="m_home"> @@ -150,11 +150,8 @@ </div> </p> </div> - - <div id="shop_page"> - <img id="shop-type" src="/image/type-shop" /> - <p id="shop_content"> - </p> + + <div id="cart_page"> </div> <div id="contact_page">

1 0

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

26 Jul '08

Revision: 3648 Author: hans URL: http://bknr.net/trac/changeset/3648 Add beginnings of a Paypal payment module U trunk/projects/quickhoney/src/packages.lisp A trunk/projects/quickhoney/src/paypal.lisp U trunk/projects/quickhoney/src/quickhoney.asd Modified: trunk/projects/quickhoney/src/packages.lisp =================================================================== --- trunk/projects/quickhoney/src/packages.lisp 2008-07-26 12:19:43 UTC (rev 3647) +++ trunk/projects/quickhoney/src/packages.lisp 2008-07-26 22:06:02 UTC (rev 3648) @@ -52,3 +52,6 @@ :quickhoney.config) (:shadowing-import-from :cl-interpol #:quote-meta-chars) (:export #:client-selectbox)) + +(defpackage :paypal + (:use :cl)) \ No newline at end of file Added: trunk/projects/quickhoney/src/paypal.lisp =================================================================== --- trunk/projects/quickhoney/src/paypal.lisp (rev 0) +++ trunk/projects/quickhoney/src/paypal.lisp 2008-07-26 22:06:02 UTC (rev 3648) @@ -0,0 +1,77 @@ +(in-package :paypal) + +(defparameter *paypal-url* "https://api-3t.sandbox.paypal.com/nvp" + "NVP URL of the Paypal server") +(defparameter *paypal-user* "sdk-three_api1.sdk.com" + "Username to use to authenticate at the Paypal server") +(defparameter *paypal-password* "QFZCWN5HZM8VBG7Q" + "Password to use to authenticate at the Paypal server") +(defparameter *paypal-signature* "A-IzJhZZjhg29XQ2qnhapuwxIDzyAZQ92FRP5dqBzVesOkzbdUONzmOU" + "Signature to use to authenticate at the Paypal server") + +(define-condition request-error (error) + ((response :initarg :response))) + +(define-condition http-request-error (error) + ((http-status :initarg :http-status) + (response-string :initarg :response-string))) + +(defun decode-response (response) + "Decode a paypal response string, which is URL encoded and follow + list encoding rules. Returns the parameters as a plist." + (let ((hash (make-hash-table))) + (dolist (entry (cl-ppcre:split "&" response)) + (destructuring-bind (parameter-string value) (cl-ppcre:split "=" entry :limit 2) + (multiple-value-bind (match registers) (cl-ppcre:scan-to-strings "^L_(.*?)([0-9]+)$" parameter-string) + (if match + (let* ((parameter (intern (aref registers 0) :keyword)) + (index (parse-integer (aref registers 1))) + (previous-value (gethash parameter hash))) + (unless (= (length previous-value) index) + (error "unexpected list value ~A in Paypal response ~S" parameter-string response)) + (setf (gethash parameter hash) (append previous-value (list (hunchentoot:url-decode value))))) + (setf (gethash (intern parameter-string :keyword) hash) (hunchentoot:url-decode value)))))) + (loop for key being the hash-keys of hash + collect key + collect (gethash key hash)))) + +(defun request (method &rest args &key &allow-other-keys) + "Perform a request to the Paypal NVP API. METHOD is the method to + use, additional keyword arguments are passed as parameters to the + API. Returns " + (multiple-value-bind (response-string http-status) + (drakma:http-request *paypal-url* + :method :post + :parameters (append (list (cons "METHOD" method) + (cons "VERSION" "52.0") + (cons "USER" *paypal-user*) + (cons "PWD" *paypal-password*) + (cons "SIGNATURE" *paypal-signature*)) + (loop for (param value) on args by #'cddr + collect (cons (symbol-name param) + (if (stringp value) value (princ-to-string value)))))) + (unless (= 200 http-status) + (error 'http-request-error :http-status http-status :response-string response-string)) + (let ((response (decode-response response-string))) + (unless (string-equal "Success" (getf response :ack)) + (error 'request-error :response response)) + response))) + +(defun test-express-checkout () + (let* ((amt "50.00") + (currencycode "EUR") + (returnurl "http://test.createrainforest.org/return-paypal") + (cancelurl "http://test.createrainforest.org/cancel-paypal") + (token (getf (request "SetExpressCheckout" + :amt amt + :currencycode currencycode + :returnurl returnurl + :cancelurl cancelurl + :paymentaction "Sale") + :token))) + (format *trace-output* "url: https://www.sandbox.paypal.com/webscr?cmd=_express-checkout&token=~A~ + &AMT=~A&CURRENCYCODE=~A&RETURNURL=~A&CANCELURL=~A" + (hunchentoot:url-encode token) + amt currencycode + (hunchentoot:url-encode returnurl) + (hunchentoot:url-encode cancelurl)))) \ No newline at end of file Modified: trunk/projects/quickhoney/src/quickhoney.asd =================================================================== --- trunk/projects/quickhoney/src/quickhoney.asd 2008-07-26 12:19:43 UTC (rev 3647) +++ trunk/projects/quickhoney/src/quickhoney.asd 2008-07-26 22:06:02 UTC (rev 3648) @@ -20,6 +20,7 @@ :cl-ppcre :cxml :cl-mime + :drakma :bknr.web :bknr.datastore :bknr.modules

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/website/
by BKNR Commits 26 Jul '08

26 Jul '08

Revision: 3647 Author: hans URL: http://bknr.net/trac/changeset/3647 Add shopping cart skeleton U trunk/projects/quickhoney/website/static/javascript.js U trunk/projects/quickhoney/website/static/styles.css U trunk/projects/quickhoney/website/templates/index.xml Modified: trunk/projects/quickhoney/website/static/javascript.js =================================================================== --- trunk/projects/quickhoney/website/static/javascript.js 2008-07-26 10:17:52 UTC (rev 3646) +++ trunk/projects/quickhoney/website/static/javascript.js 2008-07-26 12:19:43 UTC (rev 3647) @@ -207,6 +207,16 @@ $("edit_client_select").innerHTML = make_clients_selector('edit_client'); } +/* shopping cart */ + +var cart = { + products: [], + add: function (product) { + this.products.push(product); + $('checkout').style.visibility = 'visible'; + } +} + /* news */ function loadXMLDoc(fname) @@ -441,27 +451,6 @@ current_directory = 'contact'; }); -function preload_menu_images() { - var colors = []; - - for (var i in pages) { - var page = pages[i]; - for (var j in page.colors) { - colors[page.colors[j]] = true; - } - } - - var images = []; - - for (var color in colors) { - for (page in pages) { - var button = new Image; - button.src = '/image/' + page + '/color,000000,' + color; - push(images, new Image); - } - } -} - function change_colors(pagename, colors) { foreground_color = colors[0]; @@ -509,6 +498,7 @@ // Activate the menu by coloring the buttons correctly change_colors(pagename, page.colors); $('menu').className = pagename; + document.body.className = pagename; // Update globals current_directory = pagename; @@ -520,23 +510,12 @@ display_path(); // Make all elements of this page visible - var elements = $("elements").childNodes; + map(function (element) { + if (element.id && element.style) { + element.style.visibility = (findValue(page.elements, element.id) != -1) ? 'visible' : 'hidden'; + } + }, $("elements").childNodes); - for (var i = 0; i < elements.length; i++) { - if (elements[i].id) { - var element_name = elements[i].id; - var show = false; - for (var j in page.elements) { - if (element_name == page.elements[j]) { - show = true; - } - } - if (elements[i].style) { - elements[i].style.visibility = show ? "visible" : "hidden"; - } - } - } - page.action(); display_cms_window(); @@ -625,20 +604,14 @@ $("contactimage").src = button_images['contact/contact']; } - debug('checking jump_to: ' + document.jump_to); if (document.jump_to) { - debug('got jump_to: ' + document.jump_to); var components = document.jump_to.split("/"); document.jump_to = null; - debug('before show_page'); show_page(components[0]); - debug('after show_page'); if (components[1]) { subdirectory(components[1]); - debug('after subdirectory'); } document.show_picture = components[2]; - debug('show_picture set'); } } @@ -1126,8 +1099,6 @@ } debug('init - done'); - - // setTimeout("preload_menu_images();", 100); } /* old cms support */ @@ -1200,10 +1171,45 @@ SPACER = partial(DIV, { 'class': 'spacer' }); ARTWORK_NAME = partial(SPAN, { 'class': 'artwork-name' }); +function remove_overlay() +{ + $('overlay').style.visibility = 'hidden'; + replaceChildNodes('overlay'); +} + +function buy_file() +{ + cart.add([ 'file', current_image.name ]); + return "File added to shopping cart"; +} + +function buy_print() +{ + cart.add([ 'print', current_image.name ]); + return "Print added to shopping cart"; +} + +function buy_t_shirt() +{ + cart.add([ 't-shirt', current_image.name ]); + return "T-Shirt added to shopping cart"; +} + +function buy_product_button (buy_function) { + var button = BUTTON(null, IMG({ src: '/image/add-to-cart', width: 102, height: 40 })); + button.onclick = function () { + var confirmation = buy_function(); + replaceChildNodes('overlay', H1(null, confirmation)); + callLater(1, remove_overlay); + return false; + } + return button; +} + var make_buy_forms = { 'buy-file' : function () { make_overlay('buy-file', 'Buy Art as Vector PDF File', 426, - FORM({ method: 'POST', action: '#' }, + FORM({ action: '#', onsubmit: 'return false' }, SPACER("Download Artwork ", ARTWORK_NAME(current_image.name), " for one-time private use only. ", "Please read our ", A({ href: '/static/user-agreement.html', target: 'user-agreement' }, "User Agreement"), @@ -1215,13 +1221,13 @@ PRICE('45 €'), NOTICE(' (inside EU, incl. tax)*'), BR(), PRICE('37.82 €'), NOTICE(' (outside EU, tax free)*'), BR(), BR(), - BUTTON(null, IMG({ src: '/image/add-to-cart', width: 102, height: 40 })), + buy_product_button(buy_file), BR(), BR(), NOTICE("Please note: Our shop is operating from Germany, that's why there is a sales tax within Europe and none outside")))); }, 'buy-print' : function () { make_overlay('buy-print', 'Buy Art Floating Gallery Plexiglas', 426, - FORM({ method: 'POST', action: '#' }, + FORM({ action: '#', onsubmit: 'return false' }, SPACER("Fineart print mounted behind plexiglas on aluminium board with a 3/4'' wood brace. ", NOTICE('Please allow 4-6 days for production in addition to the shipping time')), IMG({ src: '/image/print-sample', width: 426, height: 428 }), @@ -1241,13 +1247,13 @@ PRICE('190 €'), NOTICE('(inside EU, incl. tax)*'), BR(), PRICE('159.66 €'), NOTICE('(outside EU, tax free)*'), BR())))), BR(), - BUTTON(null, IMG({ src: '/image/add-to-cart', width: 102, height: 40 })), + buy_product_button(buy_print), BR(), BR(), NOTICE("Please note: We are shipping from Germany, that's why there is a sales tax within Europe and none outside")))); }, 'buy-t-shirt' : function () { make_overlay('buy-t-shirt', 'Buy Art on T-Shirt', 426, - FORM({ method: 'POST', action: '#' }, + FORM({ action: '#', onsubmit: 'return false' }, SPACER("Artwork ", ARTWORK_NAME(current_image.name), " in colored flocked foil ", "hot pressed on an American Apparel T-Shirt. ", NOTICE('These Tees are custom made, so please allow 4-6 days for production in addition to the shipping time')), @@ -1279,7 +1285,7 @@ INPUT({ name: 'quantity', size: 1, maxlength: 1 }), BR(), BR(), - BUTTON(null, IMG({ src: '/image/add-to-cart', width: 102, height: 40 })))))), + buy_product_button(buy_t_shirt))))), BR(), BR(), NOTICE("Please note: We are shipping from Germany, that's why there is a sales tax within Europe and none outside")))) } Modified: trunk/projects/quickhoney/website/static/styles.css =================================================================== --- trunk/projects/quickhoney/website/static/styles.css 2008-07-26 10:17:52 UTC (rev 3646) +++ trunk/projects/quickhoney/website/static/styles.css 2008-07-26 12:19:43 UTC (rev 3647) @@ -83,22 +83,27 @@ #menu.home a img { background-color: #953cfd; } #menu.pixel a img { background-color: #ff00ff; } +.pixel a { color: #ff00ff; } #menu.pixel a#m_pixel img.selected { visibility: visible } #menu.pixel a#m_pixel img.unselected { visibility: hidden } #menu.vector a img { background-color: #00ccff; } +.vector a { color: #00ccff; } #menu.vector a#m_vector img.selected { visibility: visible } #menu.vector a#m_vector img.unselected { visibility: hidden } #menu.news a img { background-color: #30be01; } +.news a { color: #30be01; } #menu.news a#m_news img.selected { visibility: visible } #menu.news a#m_news img.unselected { visibility: hidden } #menu.shop a img { background-color: #0054ff; } +.shop a { color: #0054ff; } #menu.shop a#m_shop img.selected { visibility: visible } #menu.shop a#m_shop img.unselected { visibility: hidden } #menu.contact a img { background-color: #ffa200; } +.contact a { color: #ffa200; } #menu.contact a#m_contact img.selected { visibility: visible } #menu.contact a#m_contact img.unselected { visibility: hidden } @@ -576,7 +581,6 @@ top: 0px; } - #overlay #hey { padding: 10px 15px 10px 10px; } @@ -617,4 +621,5 @@ position: absolute; top: 0px; left: 585px; + visibility: hidden; } \ No newline at end of file Modified: trunk/projects/quickhoney/website/templates/index.xml =================================================================== --- trunk/projects/quickhoney/website/templates/index.xml 2008-07-26 10:17:52 UTC (rev 3646) +++ trunk/projects/quickhoney/website/templates/index.xml 2008-07-26 12:19:43 UTC (rev 3647) @@ -139,7 +139,7 @@ description </div> </div> - <div class="news_sep" /> + <div class="news_sep"> </div> <br/> <div class="newsentry news_pixel"> <img src="/image/TSG_Platforms_web/cutout-button,,00ccff,98,4"/>

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/website/
by BKNR Commits 26 Jul '08

26 Jul '08

Revision: 3646 Author: hans URL: http://bknr.net/trac/changeset/3646 Menu completely revamped, now CSS based. U trunk/projects/quickhoney/website/static/javascript.js U trunk/projects/quickhoney/website/static/styles.css U trunk/projects/quickhoney/website/templates/index.xml Modified: trunk/projects/quickhoney/website/static/javascript.js =================================================================== --- trunk/projects/quickhoney/website/static/javascript.js 2008-07-26 09:09:11 UTC (rev 3645) +++ trunk/projects/quickhoney/website/static/javascript.js 2008-07-26 10:17:52 UTC (rev 3646) @@ -422,7 +422,7 @@ }); pages['shop'] - = new Page(['clients_page'], + = new Page(['shop_page'], ['000000', 'ffffff', '0054ff'], function() { footer_hide(); @@ -471,23 +471,6 @@ // change text colors $("body").style.backgroundColor = "#" + background_color; $("body").style.color = "#" + foreground_color; - - for (var i = 0; i < document.styleSheets.length; i++) { - var rules = document.styleSheets[i][document.all ? 'rules' : 'cssRules']; - for (var j = 0; j < rules.length; j++) { - var rule = rules[j]; - var selectorText = rule.selectorText.toLowerCase(); - if (selectorText == 'a') { - rule.style['color'] = '#' + link_color; - rule.style['backgroundColor'] = '#' + background_color; - } else if (selectorText == '.text') { - rule.style['color'] = '#' + foreground_color; - rule.style['backgroundColor'] = '#' + background_color; - } else if (selectorText == 'img.menu') { - rule.style['backgroundColor'] = '#' + link_color; - } - } - } } function display_cms_window() { @@ -525,6 +508,7 @@ // Activate the menu by coloring the buttons correctly change_colors(pagename, page.colors); + $('menu').className = pagename; // Update globals current_directory = pagename; @@ -734,7 +718,7 @@ return false; } -function goto_page(page) { +function goto_results_page(page) { query_position = 0; for (var page_index = 0; page_index < page; page_index++) { for (var row_index = 0; row_index < query_result_pages[page_index].length; row_index++) { @@ -788,14 +772,14 @@ if (current_page > 0) { push(result_links, '<a href="#' + current_directory + '/' + current_subdirectory + '/' + (current_page - 1) + - '" onclick="goto_page(' + (current_page - 1) + ');"><<</a>'); + '" onclick="goto_results_page(' + (current_page - 1) + ');"><<</a>'); } else { push(result_links, '<<'); } var last_page = position_to_page(query_result.length - 1); if (current_page < last_page) { push(result_links, '<a href="#' + current_directory + '/' + current_subdirectory + '/' + (current_page + 1).toString() + - '" onclick="goto_page(' + (current_page + 1).toString() + ');">>></a>'); + '" onclick="goto_results_page(' + (current_page + 1).toString() + ');">>></a>'); } else { push(result_links, '>>'); } @@ -820,7 +804,7 @@ push(result_links, (page_number + 1).toString()); } else { push(result_links, '<a href="#' + current_directory + '/' + current_subdirectory + '/' + (current_page + 1).toString() + - '" onclick="goto_page(' + page_number + ');">' + (page_number + 1) + '</a>'); + '" onclick="goto_results_page(' + page_number + ');">' + (page_number + 1) + '</a>'); } } Modified: trunk/projects/quickhoney/website/static/styles.css =================================================================== --- trunk/projects/quickhoney/website/static/styles.css 2008-07-26 09:09:11 UTC (rev 3645) +++ trunk/projects/quickhoney/website/static/styles.css 2008-07-26 10:17:52 UTC (rev 3646) @@ -80,24 +80,57 @@ /* menu */ -img.menu { +#menu.home a img { background-color: #953cfd; } + +#menu.pixel a img { background-color: #ff00ff; } +#menu.pixel a#m_pixel img.selected { visibility: visible } +#menu.pixel a#m_pixel img.unselected { visibility: hidden } + +#menu.vector a img { background-color: #00ccff; } +#menu.vector a#m_vector img.selected { visibility: visible } +#menu.vector a#m_vector img.unselected { visibility: hidden } + +#menu.news a img { background-color: #30be01; } +#menu.news a#m_news img.selected { visibility: visible } +#menu.news a#m_news img.unselected { visibility: hidden } + +#menu.shop a img { background-color: #0054ff; } +#menu.shop a#m_shop img.selected { visibility: visible } +#menu.shop a#m_shop img.unselected { visibility: hidden } + +#menu.contact a img { background-color: #ffa200; } +#menu.contact a#m_contact img.selected { visibility: visible } +#menu.contact a#m_contact img.unselected { visibility: hidden } + +#menu img.selected { + visibility: hidden; + z-index: 110; +} + +#menu a { position: absolute; padding: 0px; top: 36px; border-width: 0px; - background-color: white; } -img#m_quickhoney { +#menu a img { + position: absolute; + top: 0px; + left: 0px; + border-width: 0px; +} + +#m_quickhoney { top: 28px; left: 36px; } -img#m_pixel { left: 262px; } -img#m_vector { left: 334px; } -img#m_news { left: 416px; } -img#m_shop { left: 494px; } -img#m_contact { left: 594px; } +#m_pixel { left: 262px; } +#m_vector { left: 334px; } +#m_news { left: 416px; } +#m_shop { left: 494px; } +#m_contact { left: 594px; } /* path / version */ Modified: trunk/projects/quickhoney/website/templates/index.xml =================================================================== --- trunk/projects/quickhoney/website/templates/index.xml 2008-07-26 09:09:11 UTC (rev 3645) +++ trunk/projects/quickhoney/website/templates/index.xml 2008-07-26 10:17:52 UTC (rev 3646) @@ -26,23 +26,28 @@ <img id="checkout" src="/image/checkout" width="112" height="24"/> <div id="menu"> - <a onclick="show_page('home')" href="#home"> - <img alt="home" class="menu" id="m_home" src="/image/quickhoney" /> + <a onclick="show_page('home')" href="#home" id="m_home"> + <img alt="home" class="menu" src="/image/quickhoney" /> </a> - <a onclick="show_page('pixel')" href="#pixel" id="a_pixel" class="menu"> - <img alt="pixel" class="menu" id="m_pixel" src="/image/pixel-unselected" /> + <a onclick="show_page('pixel')" href="#pixel" id="m_pixel"> + <img alt="pixel" class="unselected" src="/image/pixel-unselected" /> + <img alt="pixel" class="selected" src="/image/pixel-selected" /> </a> - <a onclick="show_page('vector')" href="#vector"> - <img alt="vector" class="menu" id="m_vector" src="/image/vector-unselected" /> + <a onclick="show_page('vector')" href="#vector" id="m_vector"> + <img alt="vector" class="unselected" src="/image/vector-unselected" /> + <img alt="vector" class="selected" src="/image/vector-selected" /> </a> - <a onclick="show_page('news')" href="#news"> - <img alt="news" class="menu" id="m_news" src="/image/news-unselected" /> + <a onclick="show_page('news')" href="#news" id="m_news"> + <img alt="news" class="unselected" src="/image/news-unselected" /> + <img alt="news" class="selected" src="/image/news-selected" /> </a> - <a onclick="show_page('shop')" href="#shop"> - <img alt="shop" class="menu" id="m_shop" src="/image/shop-unselected" /> + <a onclick="show_page('shop')" href="#shop" id="m_shop"> + <img alt="shop" class="unselected" src="/image/shop-unselected" /> + <img alt="shop" class="selected" src="/image/shop-selected" /> </a> - <a onclick="show_page('contact')" href="#contact"> - <img alt="contact" class="menu" id="m_contact" src="/image/contact-unselected" /> + <a onclick="show_page('contact')" href="#contact" id="m_contact"> + <img alt="contact" class="unselected" src="/image/contact-unselected" /> + <img alt="contact" class="selected" src="/image/contact-selected" /> </a> </div>

1 0

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

26 Jul '08

Revision: 3645 Author: hans URL: http://bknr.net/trac/changeset/3645 Snapshot, product overlays finished. A trunk/projects/quickhoney/upgrade-stuff/buy-top.gif U trunk/projects/quickhoney/upgrade-stuff/buy.gif U trunk/projects/quickhoney/upgrade-stuff/import.lisp A trunk/projects/quickhoney/upgrade-stuff/t-shirt-sample-background.gif U trunk/projects/quickhoney/website/static/javascript.js U trunk/projects/quickhoney/website/static/styles.css U trunk/projects/quickhoney/website/templates/index.xml Added: trunk/projects/quickhoney/upgrade-stuff/buy-top.gif =================================================================== (Binary files differ) Property changes on: trunk/projects/quickhoney/upgrade-stuff/buy-top.gif ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Modified: trunk/projects/quickhoney/upgrade-stuff/buy.gif =================================================================== (Binary files differ) Modified: trunk/projects/quickhoney/upgrade-stuff/import.lisp =================================================================== --- trunk/projects/quickhoney/upgrade-stuff/import.lisp 2008-07-25 16:46:19 UTC (rev 3644) +++ trunk/projects/quickhoney/upgrade-stuff/import.lisp 2008-07-26 09:09:11 UTC (rev 3645) @@ -5,10 +5,12 @@ (dolist (name '(#P"overlay-close.gif" #P"hey.gif" - #P"buy.gif" #P"buy-print.gif" #P"buy-file.gif" #P"buy-t-shirt.gif" + #P"buy.gif" #P"buy-top.gif" #P"buy-print.gif" #P"buy-file.gif" #P"buy-t-shirt.gif" #P"buy-right-line.gif" + #P"t-shirt-sample-background.gif" #P"print-sample.jpg" - #P"button-bottom.gif" #P"add-to-cart.gif" #P"checkout.gif")) + #P"button-bottom.gif" + #P"add-to-cart.gif" #P"checkout.gif")) (handler-case (import-image name) (error (e) Added: trunk/projects/quickhoney/upgrade-stuff/t-shirt-sample-background.gif =================================================================== (Binary files differ) Property changes on: trunk/projects/quickhoney/upgrade-stuff/t-shirt-sample-background.gif ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Modified: trunk/projects/quickhoney/website/static/javascript.js =================================================================== --- trunk/projects/quickhoney/website/static/javascript.js 2008-07-25 16:46:19 UTC (rev 3644) +++ trunk/projects/quickhoney/website/static/javascript.js 2008-07-26 09:09:11 UTC (rev 3645) @@ -1211,10 +1211,10 @@ $('hey_send').onclick = hey_send; } -NOTICE = partial(SPAN, { class: 'notice' }); -PRICE = partial(SPAN, { class: 'price' }); -SPACER = partial(DIV, { class: 'spacer' }); -ARTWORK_NAME = partial(SPAN, { class: 'artwork-name' }); +NOTICE = partial(SPAN, { 'class': 'notice' }); +PRICE = partial(SPAN, { 'class': 'price' }); +SPACER = partial(DIV, { 'class': 'spacer' }); +ARTWORK_NAME = partial(SPAN, { 'class': 'artwork-name' }); var make_buy_forms = { 'buy-file' : function () { @@ -1230,6 +1230,7 @@ BR(), BR(), PRICE('45 €'), NOTICE(' (inside EU, incl. tax)*'), BR(), PRICE('37.82 €'), NOTICE(' (outside EU, tax free)*'), BR(), + BR(), BUTTON(null, IMG({ src: '/image/add-to-cart', width: 102, height: 40 })), BR(), BR(), NOTICE("Please note: Our shop is operating from Germany, that's why there is a sales tax within Europe and none outside")))); @@ -1237,7 +1238,7 @@ 'buy-print' : function () { make_overlay('buy-print', 'Buy Art Floating Gallery Plexiglas', 426, FORM({ method: 'POST', action: '#' }, - SPACER("Fineart print mounted behind plexiglas on aluminium board with a 3/4'' wood brace.", + SPACER("Fineart print mounted behind plexiglas on aluminium board with a 3/4'' wood brace. ", NOTICE('Please allow 4-6 days for production in addition to the shipping time')), IMG({ src: '/image/print-sample', width: 426, height: 428 }), SPACER(ARTWORK_NAME(current_image.name), @@ -1255,6 +1256,7 @@ "Small 33cm x 50cm (13'' x 19.7'')", BR(), PRICE('190 €'), NOTICE('(inside EU, incl. tax)*'), BR(), PRICE('159.66 €'), NOTICE('(outside EU, tax free)*'), BR())))), + BR(), BUTTON(null, IMG({ src: '/image/add-to-cart', width: 102, height: 40 })), BR(), BR(), NOTICE("Please note: We are shipping from Germany, that's why there is a sales tax within Europe and none outside")))); @@ -1263,17 +1265,37 @@ make_overlay('buy-t-shirt', 'Buy Art on T-Shirt', 426, FORM({ method: 'POST', action: '#' }, SPACER("Artwork ", ARTWORK_NAME(current_image.name), " in colored flocked foil ", - "hot pressed on an American Apparel T-Shirt." + "hot pressed on an American Apparel T-Shirt. ", NOTICE('These Tees are custom made, so please allow 4-6 days for production in addition to the shipping time')), SPACER(TABLE(null, TBODY(null, TR(null, - TD({ id: 't-shirt-sample' }, INPUT({ type: "radio", name: "size", value: "small"})), + TD({ 'class': 't-shirt-sample', valign: 'top' }, + IMG({ id: 't-shirt-sample', src: '/image/' + current_image.name + '/cell,ffffff,100,100,10'})), TD(null, - "Small 20cm x 30cm (7.8'' x 11.8'')", BR(), - PRICE('150 €'), NOTICE(' (inside EU, incl. tax)*'), BR(), - PRICE('128.32 €'), NOTICE(' (outside EU, tax free)*'), BR())),)), - BUTTON(null, IMG({ src: '/image/add-to-cart', width: 102, height: 40 })), + "Color:", BR(), + "Tee - white", BR(), + "Art - as in original", BR(), + BR(), + "Price:", BR(), + PRICE('35.00 €'), NOTICE(' (inside EU, incl. tax)*'), BR(), + PRICE('29.41 €'), NOTICE(' (outside EU, tax free)*'), BR(), + BR(), + "Size:", BR(), + SELECT({ name: 'size' }, + OPTION({ value: "" }, "Choose Size"), + OPTION({ value: "XS" }, "XS"), + OPTION({ value: "S" }, "S"), + OPTION({ value: "M" }, "M"), + OPTION({ value: "L" }, "L"), + OPTION({ value: "XL" }, "XL")), + BR(), + BR(), + "Quantity:", BR(), + INPUT({ name: 'quantity', size: 1, maxlength: 1 }), + BR(), + BR(), + BUTTON(null, IMG({ src: '/image/add-to-cart', width: 102, height: 40 })))))), BR(), BR(), NOTICE("Please note: We are shipping from Germany, that's why there is a sales tax within Europe and none outside")))) } @@ -1317,7 +1339,8 @@ buttons.push(make_image_action_button('hey', make_hey_form, 23)); replaceChildNodes('image_action_buttons', buttons); if (buyable) { - appendChildNodes('image_action_buttons', IMG({ id: 'buy', src: recolored_image_path('buy'), width: 127, height: 22})); + appendChildNodes('image_action_buttons', IMG({ id: 'buy', src: recolored_image_path('buy'), width: 37, height: 22})); + appendChildNodes('image_action_buttons', IMG({ id: 'buy-top', src: recolored_image_path('buy-top'), width: 90, height: 1})); } appendChildNodes('image_action_buttons', IMG({ id: 'buy-right-line', src: recolored_image_path('buy-right-line'), width: 1, height: height})); var animator = new YAHOO.util.Anim('image_action_buttons', {}, .3, Modified: trunk/projects/quickhoney/website/static/styles.css =================================================================== --- trunk/projects/quickhoney/website/static/styles.css 2008-07-25 16:46:19 UTC (rev 3644) +++ trunk/projects/quickhoney/website/static/styles.css 2008-07-26 09:09:11 UTC (rev 3645) @@ -81,11 +81,11 @@ /* menu */ img.menu { - position: absolute; - padding: 0px; - top: 36px; - border-width: 0px; - background-color: white; + position: absolute; + padding: 0px; + top: 36px; + border-width: 0px; + background-color: white; } img#m_quickhoney { @@ -388,25 +388,25 @@ } .newsentry { - width: 428px; - height: 108px; - position: relative; - } + width: 428px; + height: 108px; + position: relative; + } .newsentry img { - position: absolute; - top: 5px; left: 5px; - } + position: absolute; + top: 5px; left: 5px; + } .newsentry div { - position: absolute; - top: 5px; left: 118px; - } + position: absolute; + top: 5px; left: 118px; + } .newsentry h1 { - margin: 0px 0px 2px 0px; - font-size: 120%; - color: white; - font-weight: normal; - } + margin: 0px 0px 2px 0px; + font-size: 120%; + color: white; + font-weight: normal; + } .news_vector { background-color: #00ccff; } .news_pixel { background-color: #ff00ff; } @@ -471,92 +471,117 @@ } .error { - margin: 2em; - padding: 1em; - border: 1pt solid #aa0000; + margin: 2em; + padding: 1em; + border: 1pt solid #aa0000; color:#f00; font-size: 110%; } #frontpage p { - margin: 1em; + margin: 1em; } #frontpage div p { - margin: 2em; + margin: 2em; } #overlay { - z-index: 100; - top: 144px; - left: 36px; - position: absolute; - background: white; - border: 1px solid #000000; - margin: 0px; - padding: 0px; + z-index: 100; + top: 144px; + left: 36px; + position: absolute; + background: white; + border: 1px solid #000000; + margin: 0px; + padding: 0px; } #overlay #close { - position: absolute; - top: 12px; + position: absolute; + top: 12px; } #overlay h1 { - margin-left: 10px; + margin-left: 10px; } -#overlay.pixel h1, #overlay.pixel h2 { - color: #ff00ff; +#overlay.pixel h1, #overlay.pixel h2, #overlay.pixel .artwork-name { + color: #ff00ff; } -#overlay.vector h1, #overlay.vector h2 { - color: #00ccff; +#overlay.vector h1, #overlay.vector h2, #overlay.vector .artwork-name { + color: #00ccff; } #image_action_buttons { position: absolute; - left: 584px; - top: 28px; - width: 60px; - overflow: hidden; - z-index: 100; + left: 584px; + top: 28px; + width: 60px; + overflow: hidden; + z-index: 100; } #image_action_buttons #buy { - z-index: 110; - position: absolute; - left: 0px; - top: 0px; + z-index: 110; + position: absolute; + left: 0px; + top: 0px; } +#image_action_buttons #buy-top { + z-index: 110; + position: absolute; + left: 37px; + top: 0px; +} + #image_action_buttons #buy-right-line { - z-index: 100; - position: absolute; - right: 0px; - top: 0px; + z-index: 100; + position: absolute; + right: 0px; + top: 0px; } #overlay #hey { - padding: 10px 15px 10px 10px; + padding: 10px 15px 10px 10px; } #overlay #hey #hey_from, #overlay #hey textarea { - width: 100%; + width: 100%; } #overlay #hey #hey_send { - margin-top: 5px; + margin-top: 5px; } #overlay span.notice { - color: #999999; + color: #999999; } #overlay span.price { - color: #33cc00; + color: #33cc00; } #overlay div.spacer { - padding: 12px; + padding: 12px; +} + +#overlay td.t-shirt-sample { + width: 188px; + height: 132px; + background-image: url(/image/t-shirt-sample-background); + background-repeat: no-repeat; +} + +#overlay img#t-shirt-sample { + padding-left: 43px; + padding-top: 16px; +} + +img#checkout { + position: absolute; + top: 0px; + left: 585px; } \ No newline at end of file Modified: trunk/projects/quickhoney/website/templates/index.xml =================================================================== --- trunk/projects/quickhoney/website/templates/index.xml 2008-07-25 16:46:19 UTC (rev 3644) +++ trunk/projects/quickhoney/website/templates/index.xml 2008-07-26 09:09:11 UTC (rev 3645) @@ -23,6 +23,8 @@ <div id="overlay"> </div> + <img id="checkout" src="/image/checkout" width="112" height="24"/> + <div id="menu"> <a onclick="show_page('home')" href="#home"> <img alt="home" class="menu" id="m_home" src="/image/quickhoney" />

1 0

[bknr-cvs] hans changed trunk/
by BKNR Commits 25 Jul '08

25 Jul '08

Revision: 3644 Author: hans URL: http://bknr.net/trac/changeset/3644 Revive cmucl support for BOS. U trunk/bknr/datastore/src/utils/acl-mp-compat.lisp U trunk/bknr/datastore/src/utils/package.lisp U trunk/clean.lisp A trunk/projects/bos/Makefile.cmucl U trunk/projects/bos/build.lisp U trunk/projects/bos/m2/m2-pdf.lisp U trunk/projects/bos/m2/packages.lisp U trunk/projects/bos/web/bos.web.asd U trunk/projects/bos/web/packages.lisp U trunk/projects/bos/web/webserver.lisp A trunk/projects/bos/web/website-language.lisp U trunk/thirdparty/bordeaux-threads_0.4.0/src/cmu.lisp Modified: trunk/bknr/datastore/src/utils/acl-mp-compat.lisp =================================================================== --- trunk/bknr/datastore/src/utils/acl-mp-compat.lisp 2008-07-25 16:24:06 UTC (rev 3643) +++ trunk/bknr/datastore/src/utils/acl-mp-compat.lisp 2008-07-25 16:46:19 UTC (rev 3644) @@ -55,17 +55,17 @@ (error "missing port for this compiler, please provide for multiprocessing primitives for this compiler in ~A" *load-pathname*) (defun make-process (function &key name) - #+sbcl(sb-thread:make-thread function :name name) - #+openmcl(ccl:process-run-function name function) - #+cmu(mp:make-process function :name name)) + #+sbcl (sb-thread:make-thread function :name name) + #+openmcl (ccl:process-run-function name function) + #+cmu (mp:make-process function :name name)) (defun destroy-process (process) - #+sbcl(sb-thread:destroy-thread process) - #+openmcl(ccl:process-kill process) - #+cmu(mp:destroy-process process)) + #+sbcl (sb-thread:destroy-thread process) + #+openmcl (ccl:process-kill process) + #+cmu (mp:destroy-process process)) (defun process-active-p (process) - #+sbcl(sb-thread:thread-alive-p process) - #+openmcl(ccl::process-active-p process) - #+cmu(mp:process-active-p process)) + #+sbcl (sb-thread:thread-alive-p process) + #+openmcl (ccl::process-active-p process) + #+cmu (mp:process-active-p process)) Modified: trunk/bknr/datastore/src/utils/package.lisp =================================================================== --- trunk/bknr/datastore/src/utils/package.lisp 2008-07-25 16:24:06 UTC (rev 3643) +++ trunk/bknr/datastore/src/utils/package.lisp 2008-07-25 16:46:19 UTC (rev 3644) @@ -6,7 +6,6 @@ :cl-interpol :md5 #+sbcl :sb-ext - #+cmu :mp #+openmcl :ccl) #+openmcl (:shadow :ccl #:copy-file #:make-process) Modified: trunk/clean.lisp =================================================================== --- trunk/clean.lisp 2008-07-25 16:24:06 UTC (rev 3643) +++ trunk/clean.lisp 2008-07-25 16:46:19 UTC (rev 3644) @@ -3,6 +3,11 @@ ;; BKNR build script - Called by buildbot to clean up fasls (format t "; cleaning fasls in ~A~%" (probe-file *default-pathname-defaults*)) -(mapc #'delete-file (directory (compile-file-pathname #P"**/*.lisp"))) +(mapc #'delete-file + (directory + (merge-pathnames (make-pathname :name :wild + :directory '(:relative :wild-inferiors) + :type (pathname-type (compile-file-pathname ""))) + (probe-file *default-pathname-defaults*)))) Added: trunk/projects/bos/Makefile.cmucl =================================================================== --- trunk/projects/bos/Makefile.cmucl (rev 0) +++ trunk/projects/bos/Makefile.cmucl 2008-07-25 16:46:19 UTC (rev 3644) @@ -0,0 +1,29 @@ +LISP=lisp -noinit +all: bos.core +.PHONY: all + +bos.core: build.lisp + $(LISP) -load build.lisp -eval '(ext:save-lisp "bos.core")' + +# various cleaning stuff +.PHONY: cleancore +cleancore: + rm -f bos.core + +.PHONY: cleanfasl +cleanfasl: + (cd ../.. && $(LISP) -load clean.lisp -eval '(quit)') + +.PHONY: cleanall +cleanall: cleancore cleanfasl + +.PHONY: clean +clean: cleancore + +.PHONY: start +start: bos.core + $(LISP) -dynamic-space-size 800 -core bos.core -eval '(start)' + +# TAGS +TAGS: + find . -name '*.lisp' | xargs etags -a Modified: trunk/projects/bos/build.lisp =================================================================== --- trunk/projects/bos/build.lisp 2008-07-25 16:24:06 UTC (rev 3643) +++ trunk/projects/bos/build.lisp 2008-07-25 16:46:19 UTC (rev 3644) @@ -1,18 +1,22 @@ ;;; a quick startup script that can be loaded with all supported lisps (in-package :cl-user) -#+cmu(load (compile-file "../../bknr/patches/patch-around-mop-cmucl19a.lisp")) +#+sbcl (require 'asdf) +#+sbcl (require 'sb-posix) -#+sbcl(require 'asdf) -#+sbcl(require 'sb-posix) +#+sbcl (assert (eql sb-impl::*default-external-format* :utf-8)) +#+cmu +(setf stream:*default-external-format* :utf-8 + ext:*gc-verbose* nil + *compile-print* nil + ext:*bytes-consed-between-gcs* (* 64 1024 1024) + *default-pathname-defaults* (pathname (format nil "~A/" (nth-value 1 (unix:unix-current-directory))))) -#+sbcl(assert (eql sb-impl::*default-external-format* :utf-8)) - (load (compile-file "../../thirdparty/asdf/asdf.lisp")) ;; cl-gd glue -#+darwin(assert (zerop (asdf:run-shell-command "cd ../../thirdparty/cl-gd-0.5.6; make cl-gd-glue.dylib"))) -#-darwin(assert (zerop (asdf:run-shell-command "cd ../../thirdparty/cl-gd-0.5.6; make"))) +#+darwin (assert (zerop (asdf:run-shell-command "cd ../../thirdparty/cl-gd-0.5.6; make cl-gd-glue.dylib"))) +#-darwin (assert (zerop (asdf:run-shell-command "cd ../../thirdparty/cl-gd-0.5.6; make"))) ;;; some helpers (defun setup-registry () @@ -22,7 +26,7 @@ (pushnew (make-pathname :directory (pathname-directory asd-pathname)) asdf:*central-registry* :test #'equal)) - (directory #p"../../**/*.asd"))) + (directory (merge-pathnames #p"**/*.asd" (truename "../../"))))) (defun read-configuration (pathname) (with-open-file (s pathname) @@ -37,23 +41,26 @@ ;;; load bos project (asdf:oos 'asdf:load-op :bos.web) +#+sbcl (defvar *sbcl-home* (sb-int:sbcl-homedir-pathname)) +#+sbcl (defun ensure-sbcl-home () (sb-posix:putenv (format nil "SBCL_HOME=~a" *sbcl-home*))) (defun env-ascii-check () - #+sbcl(assert (block top - (dolist (string (posix-environ) t) - (loop for ch across string - unless (< 0 (char-code ch) 128) - do (return-from top nil)))) - nil - "We will have a problem if your environment contains anything else than ASCII characters.~ + #+sbcl + (assert (block top + (dolist (string (posix-environ) t) + (loop for ch across string + unless (< 0 (char-code ch) 128) + do (return-from top nil)))) + nil + "We will have a problem if your environment contains anything else than ASCII characters.~ ~%So I'd like to enforce this here.")) (defun start (&key (swank-port 4005)) - (ensure-sbcl-home) + #+sbcl (ensure-sbcl-home) (env-ascii-check) ;; check for changes that are not yet in the core (asdf:oos 'asdf:load-op :bos.web) @@ -72,7 +79,9 @@ (apply #'bos.web::init (read-configuration "web.rc")) (bos.web::start-contract-tree-image-update-daemon) (bos.m2::start-postmaster) - (bknr.cron::start-cron)) + (bknr.cron::start-cron) + #+(and cmu mp) + (mp::startup-idle-and-top-level-loops)) (defun start-cert-daemon () (ensure-sbcl-home) Modified: trunk/projects/bos/m2/m2-pdf.lisp =================================================================== --- trunk/projects/bos/m2/m2-pdf.lisp 2008-07-25 16:24:06 UTC (rev 3643) +++ trunk/projects/bos/m2/m2-pdf.lisp 2008-07-25 16:46:19 UTC (rev 3644) @@ -65,7 +65,7 @@ ;; cl-pdf does not really handle non-ascii characters in a very ;; usable manner. In order to avoid having to deal with ;; embedding fonts and encoding, just work around the issue: - (princ (remove #\Latin_Capital_Letter_A_With_Circumflex + (princ (remove (code-char 194) (with-output-to-string (s) (let ((pdf:*compress-streams* nil)) (pdf:write-document s)))) Modified: trunk/projects/bos/m2/packages.lisp =================================================================== --- trunk/projects/bos/m2/packages.lisp 2008-07-25 16:24:06 UTC (rev 3643) +++ trunk/projects/bos/m2/packages.lisp 2008-07-25 16:46:19 UTC (rev 3644) @@ -272,8 +272,6 @@ (defpackage :bos.m2.cert-generator (:use :cl - #+cmu :extensions - #+sbcl :sb-ext :bos.m2.config :bknr.utils :cl-ppcre Modified: trunk/projects/bos/web/bos.web.asd =================================================================== --- trunk/projects/bos/web/bos.web.asd 2008-07-25 16:24:06 UTC (rev 3643) +++ trunk/projects/bos/web/bos.web.asd 2008-07-25 16:46:19 UTC (rev 3644) @@ -37,7 +37,9 @@ (:file "contract-tree" :depends-on ("quad-tree")) (:file "sat-tree" :depends-on ("quad-tree" "contract-tree")) (:file "countries" :depends-on ("packages")) + (:file "website-language" :depends-on ("packages")) (:file "kml-handlers" :depends-on ("packages" + "website-language" "web-macros" "countries" "dictionary")) @@ -52,6 +54,7 @@ (:file "contract-rss" :depends-on ("web-utils")) (:file "webserver" :depends-on ("news-tags" "tags" + "website-language" "map-handlers" "map-browser-handler" "poi-handlers" Modified: trunk/projects/bos/web/packages.lisp =================================================================== --- trunk/projects/bos/web/packages.lisp 2008-07-25 16:24:06 UTC (rev 3643) +++ trunk/projects/bos/web/packages.lisp 2008-07-25 16:46:19 UTC (rev 3644) @@ -4,15 +4,12 @@ (:nicknames :web :worldpay-test) (:use :cl :date-calc - #+cmu :extensions - #+sbcl :sb-ext :cl-user :cl-interpol :cl-ppcre :xhtml-generator :cxml :puri - #+(or) :mime :bknr.web :bknr.web.frontend :bknr.datastore Modified: trunk/projects/bos/web/webserver.lisp =================================================================== --- trunk/projects/bos/web/webserver.lisp 2008-07-25 16:24:06 UTC (rev 3643) +++ trunk/projects/bos/web/webserver.lisp 2008-07-25 16:46:19 UTC (rev 3644) @@ -57,45 +57,6 @@ (cons :language (request-language))) (call-next-method))) -(define-persistent-class website-language () - ((code :read :index-type string-unique-index :index-reader language-with-code) - (name :read :index-type string-unique-index))) - -(defun website-languages () - (mapcar #'(lambda (language) (list (website-language-code language) - (website-language-name language))) - (class-instances 'website-language))) - -(defun website-supports-language (language) - (find language (website-languages) :test #'string-equal :key #'car)) - -(defun language-from-url (path) - (register-groups-bind (language) (#?r"^/(..)/" path) - (when (website-supports-language language) - language))) - -(defun find-browser-prefered-language () - "Determine the language prefered by the user, as determined by the Accept-Language header -present in the HTTP request. Header decoding is done according to RFC2616, considering individual -language preference weights." - (let ((accept-language (hunchentoot:header-in* :accept-language))) - (dolist (language (mapcar #'car - (sort (mapcar #'(lambda (language-spec-string) - (if (find #\; language-spec-string) - (destructuring-bind (language preference-string) - (split #?r" *; *q=" language-spec-string) - (cons language (read-from-string preference-string))) - (cons language-spec-string 1))) - (split #?r" *, *" accept-language)) - #'> :key #'cdr))) - (when (website-supports-language language) - (return-from find-browser-prefered-language language)) - (register-groups-bind (language variant) (#?r"^(.*)-(.*)$" language) - (declare (ignore variant)) - (when (website-supports-language language) - (return-from find-browser-prefered-language language))))) - nil) - (defclass index-handler (page-handler) ()) Added: trunk/projects/bos/web/website-language.lisp =================================================================== --- trunk/projects/bos/web/website-language.lisp (rev 0) +++ trunk/projects/bos/web/website-language.lisp 2008-07-25 16:46:19 UTC (rev 3644) @@ -0,0 +1,43 @@ + +(in-package :bos.web) + +(enable-interpol-syntax) + +(define-persistent-class website-language () + ((code :read :index-type string-unique-index :index-reader language-with-code) + (name :read :index-type string-unique-index))) + +(defun website-languages () + (mapcar #'(lambda (language) (list (website-language-code language) + (website-language-name language))) + (class-instances 'website-language))) + +(defun website-supports-language (language) + (find language (website-languages) :test #'string-equal :key #'car)) + +(defun language-from-url (path) + (register-groups-bind (language) (#?r"^/(..)/" path) + (when (website-supports-language language) + language))) + +(defun find-browser-prefered-language () + "Determine the language prefered by the user, as determined by the Accept-Language header +present in the HTTP request. Header decoding is done according to RFC2616, considering individual +language preference weights." + (let ((accept-language (hunchentoot:header-in* :accept-language))) + (dolist (language (mapcar #'car + (sort (mapcar #'(lambda (language-spec-string) + (if (find #\; language-spec-string) + (destructuring-bind (language preference-string) + (split #?r" *; *q=" language-spec-string) + (cons language (read-from-string preference-string))) + (cons language-spec-string 1))) + (split #?r" *, *" accept-language)) + #'> :key #'cdr))) + (when (website-supports-language language) + (return-from find-browser-prefered-language language)) + (register-groups-bind (language variant) (#?r"^(.*)-(.*)$" language) + (declare (ignore variant)) + (when (website-supports-language language) + (return-from find-browser-prefered-language language))))) + nil) \ No newline at end of file Modified: trunk/thirdparty/bordeaux-threads_0.4.0/src/cmu.lisp =================================================================== --- trunk/thirdparty/bordeaux-threads_0.4.0/src/cmu.lisp 2008-07-25 16:24:06 UTC (rev 3643) +++ trunk/thirdparty/bordeaux-threads_0.4.0/src/cmu.lisp 2008-07-25 16:46:19 UTC (rev 3644) @@ -8,7 +8,7 @@ ;;; Thread Creation -(defun make-thread (function &key name) +(defun make-thread (function &key (name "Anonymous")) (mp:make-process function :name name)) (defun current-thread ()

1 0