[bknr-cvs] r2481 - branches/trunk-reorg/projects/bos/web
ksprotte at common-lisp.net
ksprotte at common-lisp.net
Tue Feb 12 12:19:26 UTC 2008
Author: ksprotte
Date: Tue Feb 12 07:19:24 2008
New Revision: 2481
Modified:
branches/trunk-reorg/projects/bos/web/allocation-area-handlers.lisp
branches/trunk-reorg/projects/bos/web/contract-image-handler.lisp
branches/trunk-reorg/projects/bos/web/map-handlers.lisp
branches/trunk-reorg/projects/bos/web/reports-xml-handler.lisp
branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp
branches/trunk-reorg/projects/bos/web/startup.lisp
branches/trunk-reorg/projects/bos/web/webserver.lisp
Log:
bos trunk-reorg compiles for the first time
Modified: branches/trunk-reorg/projects/bos/web/allocation-area-handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/allocation-area-handlers.lisp (original)
+++ branches/trunk-reorg/projects/bos/web/allocation-area-handlers.lisp Tue Feb 12 07:19:24 2008
@@ -123,7 +123,7 @@
do (incf dest-x copy-width))
do (incf dest-y copy-height))
(cl-gd:draw-polygon vertices :color (elt colors 1))
- (emit-image-to-browser req cl-gd:*default-image* :png)))))
+ (emit-image-to-browser cl-gd:*default-image* :png)))))
(defclass create-allocation-area-handler (admin-only-handler form-handler)
())
Modified: branches/trunk-reorg/projects/bos/web/contract-image-handler.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/contract-image-handler.lisp (original)
+++ branches/trunk-reorg/projects/bos/web/contract-image-handler.lisp Tue Feb 12 07:19:24 2008
@@ -7,7 +7,7 @@
()
(:default-initargs :class 'contract))
-(defmethod handle-object ((handler contract-image-handler) contract req)
+(defmethod handle-object ((handler contract-image-handler) contract)
"Create and return a GD image of the contract. The returned
rectangular image will have the size of the contracts' bounding box.
All square meters will have yellow color, the background will be transparent."
@@ -27,4 +27,4 @@
(cl-gd:do-rows (y)
(cl-gd:do-pixels-in-row (x)
(setf (cl-gd:raw-pixel) (aref work-array x y)))))
- (emit-image-to-browser req cl-gd:*default-image* :png :cache-sticky t))))
\ No newline at end of file
+ (emit-image-to-browser cl-gd:*default-image* :png :cache-sticky t))))
\ No newline at end of file
Modified: branches/trunk-reorg/projects/bos/web/map-handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/map-handlers.lisp (original)
+++ branches/trunk-reorg/projects/bos/web/map-handlers.lisp Tue Feb 12 07:19:24 2008
@@ -82,7 +82,7 @@
;; (if (or (not ims)
;; (> changed-time (date-to-universal-time ims)))
;; (let ((image (image-tile-image tile (apply #'parse-operations operation-strings))))
-;; (emit-image-to-browser req image :png
+;; (emit-image-to-browser image :png
;; :date changed-time
;; :max-age 60)
;; (cl-gd:destroy-image image))
@@ -98,7 +98,7 @@
(let (active-layers
(all-layer-names (mapcar #'symbol-name (image-tile-layers tile))))
(dolist (layer-name all-layer-names)
- (when (query-param req layer-name)
+ (when (query-param layer-name)
(push layer-name active-layers)))
(or (reverse active-layers) all-layer-names)))
Modified: branches/trunk-reorg/projects/bos/web/reports-xml-handler.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/reports-xml-handler.lisp (original)
+++ branches/trunk-reorg/projects/bos/web/reports-xml-handler.lisp Tue Feb 12 07:19:24 2008
@@ -19,7 +19,7 @@
(declare (ignore second minute hour date month day-of-week is-dst tz))
year))
-(defmethod handle ((handler reports-xml-handler) req)
+(defmethod handle ((handler reports-xml-handler))
(with-xml-response ()
(destructuring-bind (name &optional *year* &rest arguments) (decoded-handler-path handler)
(setf *year* (and *year* (parse-integer *year*)))
Modified: branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp (original)
+++ branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp Tue Feb 12 07:19:24 2008
@@ -178,14 +178,14 @@
(let (changed)
(with-bos-cms-page (:title "Saving sponsor data")
(dolist (field-name '(full-name email password country language info-text))
- (let ((field-value (query-param req (string-downcase (symbol-name field-name)))))
+ (let ((field-value (query-param (string-downcase (symbol-name field-name)))))
(when (and field-value
(not (equal field-value (slot-value sponsor field-name))))
(change-slot-values sponsor field-name field-value)
(setf changed t)
(html (:p "Changed " (:princ-safe (string-downcase (symbol-name field-name))))))))
(dolist (contract (sponsor-contracts sponsor))
- (when (and (query-param req (contract-checkbox-name contract))
+ (when (and (query-param (contract-checkbox-name contract))
(not (contract-paidp contract)))
(change-slot-values contract 'paidp t)
(setf changed t)
@@ -249,8 +249,8 @@
(defclass m2-javascript-handler (prefix-handler)
())
-(defmethod handle ((handler m2-javascript-handler) req)
- (multiple-value-bind (sponsor-id-or-x y) (parse-url req)
+(defmethod handle ((handler m2-javascript-handler))
+ (multiple-value-bind (sponsor-id-or-x y) (parse-url)
(let ((sponsor (cond
(y
(let ((m2 (get-m2 (parse-integer sponsor-id-or-x) (parse-integer y))))
Modified: branches/trunk-reorg/projects/bos/web/startup.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/startup.lisp (original)
+++ branches/trunk-reorg/projects/bos/web/startup.lisp Tue Feb 12 07:19:24 2008
@@ -42,10 +42,6 @@
:website-url *website-url*
:worldpay-test-mode *worldpay-test-mode*)
(format t "~&; Starting aserve~@[ in debug mode~].~%" debug)
- (force-output)
- (setq *webserver*
- (if debug
- (progn (net.aserve::debug-on :notrap)
- (net.aserve:start :port *port* :listeners 0))
- (progn (net.aserve::debug-off :all)
- (net.aserve:start :port *port* :listeners *listeners*)))))
+ (force-output)
+ (setq hunchentoot:*catch-errors-p* (not debug))
+ (hunchentoot:start-server :port *port*))
Modified: branches/trunk-reorg/projects/bos/web/webserver.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/webserver.lisp (original)
+++ branches/trunk-reorg/projects/bos/web/webserver.lisp Tue Feb 12 07:19:24 2008
@@ -22,13 +22,13 @@
;; 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 &key request)
+(defmethod find-template-pathname ((Handler worldpay-template-handler) template-name)
(cond
((scan #?r"(^|.*/)handle-sale" template-name)
- (with-query-params (request cartId name address country transStatus lang MC_gift)
+ (with-query-params (cartId name address country transStatus lang MC_gift)
(unless (website-supports-language lang)
(setf lang *default-language*))
- (bos.m2::remember-worldpay-params cartId (all-request-params request))
+ (bos.m2::remember-worldpay-params cartId (all-request-params))
(let ((contract (get-contract (parse-integer cartId))))
(sponsor-set-language (contract-sponsor contract) lang)
(cond
@@ -128,7 +128,7 @@
())
(defmethod handle ((handler statistics-handler))
- (let ((stats-name (parse-url req)))
+ (let ((stats-name (parse-url)))
(cond
(stats-name
(redirect (format nil "~A.svg" stats-name)))
@@ -168,19 +168,20 @@
(call-next-method)))
(call-next-method))))
-(defmethod authorize :after ((authorizer bos-authorizer)
- (req http-request)
- (ent net.aserve::entity))
- (let ((new-language (or (language-from-url (uri-path (hunchentoot:request-uri)))
- (query-param req "language")))
- (current-language (gethash :language (bknr-session-variables *session*))))
- (when (or (not current-language)
- (and new-language
- (not (equal new-language current-language))))
- (setf (gethash :language (bknr-session-variables *session*))
- (or new-language
- (find-browser-prefered-language req)
- *default-language*)))))
+;; trunk-reorg adaption
+;; (defmethod authorize :after ((authorizer bos-authorizer)
+;; (req http-request)
+;; (ent net.aserve::entity))
+;; (let ((new-language (or (language-from-url (uri-path (hunchentoot:request-uri)))
+;; (query-param "language")))
+;; (current-language (gethash :language (bknr-session-variables *session*))))
+;; (when (or (not current-language)
+;; (and new-language
+;; (not (equal new-language current-language))))
+;; (setf (gethash :language (bknr-session-variables *session*))
+;; (or new-language
+;; (find-browser-prefered-language req)
+;; *default-language*)))))
(defun publish-website (&key website-directory website-url (worldpay-test-mode t) (vhosts :wild))
(setf *website-directory* website-directory)
More information about the Bknr-cvs
mailing list