[bknr-cvs] hans changed trunk/

[BKNR Commits]

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)