Revision: 3398 Author: hans URL: http://bknr.net/trac/changeset/3398

Fixes to payment processing related stuff with new CXML and Hunchentoot.

U trunk/bknr/web/src/web/handlers.lisp U trunk/bknr/web/src/web/web-utils.lisp U trunk/projects/bos/m2/map.lisp U trunk/projects/bos/m2-sample.rc U trunk/projects/bos/web/tags.lisp U trunk/projects/bos/web/webserver.lisp

Modified: trunk/bknr/web/src/web/handlers.lisp =================================================================== --- trunk/bknr/web/src/web/handlers.lisp 2008-07-01 10:59:11 UTC (rev 3397) +++ trunk/bknr/web/src/web/handlers.lisp 2008-07-01 11:01:48 UTC (rev 3398) @@ -180,7 +180,10 @@

(defclass cachable-handler () - ((max-age :initform 60 :initarg :max-age :accessor handler-max-age))) + ((max-age :initform 5 + :initarg :max-age + :accessor handler-max-age + :documentation "Default value to set for the Cache-Control max-age header.")))

(defmethod initialize-instance :after ((handler cachable-handler) &rest initargs) (declare (ignore initargs))

Modified: trunk/bknr/web/src/web/web-utils.lisp =================================================================== --- trunk/bknr/web/src/web/web-utils.lisp 2008-07-01 10:59:11 UTC (rev 3397) +++ trunk/bknr/web/src/web/web-utils.lisp 2008-07-01 11:01:48 UTC (rev 3398) @@ -69,7 +69,7 @@ (when post (post-parameters*))))

(defun query-param (param-name &key (get t) (post t)) - (let ((value (cdr (assoc param-name (query-params :get get :post post) :test #'equal)))) + (let ((value (cdr (assoc param-name (query-params :get get :post post) :test #'string-equal)))) (unless (equal value "") value)))

Modified: trunk/projects/bos/m2/map.lisp =================================================================== --- trunk/projects/bos/m2/map.lisp 2008-07-01 10:59:11 UTC (rev 3397) +++ trunk/projects/bos/m2/map.lisp 2008-07-01 11:01:48 UTC (rev 3398) @@ -79,12 +79,43 @@ (setf (ldb (byte 8 0) pixel-rgb-value) blue) pixel-rgb-value))

-(defun point-in-any-allocation-area-p (x-coord y-coord) +(defvar *allocation-area-cache* nil + "Array of bits indicating whether a certain square meter is inside of an allocation area") + +(defvar *allocation-cache-x* nil + "Top left X coordinate of the allocation cache") +(defvar *allocation-cache-y* nil + "Top left Y coordinate of the allocation cache") +(defvar *allocation-cache-width* nil + "Width of the allocation cache") +(defvar *allocation-cache-height* nil + "Height of the allocation cache") + +(defun point-in-any-allocation-area-p% (x-coord y-coord) (find-if #'(lambda (allocation-area) ;; first check whether point is in bounding box, then do full polygon check (and (point-in-polygon-p x-coord y-coord (allocation-area-bounding-box allocation-area)) (point-in-polygon-p x-coord y-coord (allocation-area-vertices allocation-area)))) (store-objects-with-class 'allocation-area))) + +(defun initialize-allocation-cache () + (destructuring-bind (top-left-x top-left-y width height) (allocation-areas-bounding-box) + (setf *allocation-area-cache* (make-array (list width height) :element-type '(unsigned-byte 1)) + *allocation-cache-x* top-left-x + *allocation-cache-y* top-left-y + *allocation-cache-width* width + *allocation-cache-height* height) + (dotimes (x width) + (dotimes (y height) + (when (point-in-any-allocation-area-p (+ x top-left-x) (+ y top-left-y)) + (setf (aref *allocation-area-cache* x y) 1)))))) + +(defun point-in-any-allocation-area-p (x-coord y-coord) + (and (< -1 (- x-coord *allocation-cache-x*) *allocation-cache-width*) + (< -1 (- y-coord *allocation-cache-y*) *allocation-cache-height*) + (plusp (aref *allocation-area-cache* + (- x-coord *allocation-cache-x*) + (- y-coord *allocation-cache-y*)))))

(defclass image-tile (tile) ((original-image :documentation "Original satellite image"

Modified: trunk/projects/bos/m2-sample.rc =================================================================== --- trunk/projects/bos/m2-sample.rc 2008-07-01 10:59:11 UTC (rev 3397) +++ trunk/projects/bos/m2-sample.rc 2008-07-01 11:01:48 UTC (rev 3398) @@ -1,3 +1,3 @@ -:directory (merge-pathnames #p"datastore/" (user-homedir-pathname)) +:directory (merge-pathnames #p"bos-store/" (user-homedir-pathname)) :website-url "http://createrainforest.org" :enable-mails nil

Modified: trunk/projects/bos/web/tags.lisp =================================================================== --- trunk/projects/bos/web/tags.lisp 2008-07-01 10:59:11 UTC (rev 3397) +++ trunk/projects/bos/web/tags.lisp 2008-07-01 11:01:48 UTC (rev 3398) @@ -4,9 +4,8 @@

(defun emit-without-quoting (str) ;; das ist fuer WPDISPLAY - (let ((s (cxml::chained-handler *html-sink*))) - (cxml::maybe-close-tag s) - (map nil (lambda (c) (cxml::write-rune c s)) str))) + (cxml::maybe-close-tag *html-sink*) + (map nil (lambda (c) (cxml::sink-write-rune c *html-sink*)) str))

(defun language-options-1 (current-language) (loop for (language-symbol language-name) in (website-languages)

Modified: trunk/projects/bos/web/webserver.lisp =================================================================== --- trunk/projects/bos/web/webserver.lisp 2008-07-01 10:59:11 UTC (rev 3397) +++ trunk/projects/bos/web/webserver.lisp 2008-07-01 11:01:48 UTC (rev 3398) @@ -22,7 +22,7 @@ ;; If the requested URL is /handle-sale, we do the sales processing ;; and change the template name according to the outcome.

-(defmethod find-template-pathname ((Handler worldpay-template-handler) template-name) +(defmethod find-template-pathname ((handler worldpay-template-handler) template-name) (cond ((scan #?r"(^|.*/)handle-sale" template-name) (with-query-params (cartId name address country transStatus lang MC_gift)