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)