[bknr-cvs] r2479 - in branches/trunk-reorg/projects/bos: m2 web
Author: ksprotte Date: Mon Feb 11 12:24:41 2008 New Revision: 2479 Modified: branches/trunk-reorg/projects/bos/m2/m2.lisp branches/trunk-reorg/projects/bos/m2/mail-generator.lisp branches/trunk-reorg/projects/bos/m2/packages.lisp branches/trunk-reorg/projects/bos/web/allocation-area-handlers.lisp branches/trunk-reorg/projects/bos/web/allocation-cache-handlers.lisp branches/trunk-reorg/projects/bos/web/boi-handlers.lisp branches/trunk-reorg/projects/bos/web/bos.web.asd branches/trunk-reorg/projects/bos/web/contract-handlers.lisp branches/trunk-reorg/projects/bos/web/contract-image-handler.lisp branches/trunk-reorg/projects/bos/web/kml-handlers.lisp branches/trunk-reorg/projects/bos/web/languages-handler.lisp branches/trunk-reorg/projects/bos/web/map-browser-handler.lisp branches/trunk-reorg/projects/bos/web/map-handlers.lisp branches/trunk-reorg/projects/bos/web/news-handlers.lisp branches/trunk-reorg/projects/bos/web/packages.lisp branches/trunk-reorg/projects/bos/web/poi-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/web-macros.lisp branches/trunk-reorg/projects/bos/web/web-utils.lisp branches/trunk-reorg/projects/bos/web/webserver.lisp Log: bos changes for trunk-reorg; unfinished, committed for backup Modified: branches/trunk-reorg/projects/bos/m2/m2.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/m2/m2.lisp (original) +++ branches/trunk-reorg/projects/bos/m2/m2.lisp Mon Feb 11 12:24:41 2008 @@ -189,8 +189,8 @@ (defclass editor-only-handler () ()) -(defmethod bknr.web:authorized-p ((handler editor-only-handler) req) - (editor-p (bknr-request-user req))) +(defmethod bknr.web:authorized-p ((handler editor-only-handler)) + (editor-p bknr.web:*user*)) ;;;; CONTRACT @@ -446,11 +446,12 @@ (incf retval (length (contract-m2s contract)))) retval)) -(defun string-safe (string) - (if string - (escape-nl (with-output-to-string (s) - (net.html.generator::emit-safe s string))) - "")) +;; trunk-reorg adaption +;; (defun string-safe (string) +;; (if string +;; (escape-nl (with-output-to-string (s) +;; (net.html.generator::emit-safe s string))) +;; "")) (defun make-m2-javascript (sponsor) "Erzeugt das Quadratmeter-Javascript für die angegebenen Contracts" Modified: branches/trunk-reorg/projects/bos/m2/mail-generator.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/m2/mail-generator.lisp (original) +++ branches/trunk-reorg/projects/bos/m2/mail-generator.lisp Mon Feb 11 12:24:41 2008 @@ -251,8 +251,8 @@ (ignore-errors (delete-file (contract-pdf-pathname contract :print t)))) -(defun mail-backoffice-sponsor-data (contract req) - (with-query-params (req numsqm country email name address date language) +(defun mail-backoffice-sponsor-data (contract) + (with-query-params (numsqm country email name address date language) (let ((parts (list (make-html-part (format nil " <html> <body> @@ -294,7 +294,7 @@ (mail-contract-data contract "Manually entered sponsor" parts)))) (defun mail-manual-sponsor-data (req) - (with-query-params (req contract-id vorname name strasse plz ort email telefon want-print donationcert-yearly) + (with-query-params (contract-id vorname name strasse plz ort email telefon want-print donationcert-yearly) (let* ((contract (store-object-with-id (parse-integer contract-id))) (sponsor-id (store-object-id (contract-sponsor contract))) (parts (list (make-html-part (format nil " @@ -363,7 +363,7 @@ (error "cannot find WorldPay callback params for contract ~A~%" contract-id))) (defun mail-worldpay-sponsor-data (req) - (with-query-params (req contract-id) + (with-query-params (contract-id) (let* ((contract (store-object-with-id (parse-integer contract-id))) (params (get-worldpay-params contract-id)) (parts (list (make-html-part (format nil " Modified: branches/trunk-reorg/projects/bos/m2/packages.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/m2/packages.lisp (original) +++ branches/trunk-reorg/projects/bos/m2/packages.lisp Mon Feb 11 12:24:41 2008 @@ -54,7 +54,7 @@ :bknr.statistics :bknr.rss :bos.m2.config - :net.post-office + :cl-smtp :kmrcl :cxml :cl-mime 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 Mon Feb 11 12:24:41 2008 @@ -6,8 +6,8 @@ (defclass allocation-area-handler (admin-only-handler edit-object-handler) ()) -(defmethod handle-object-form ((handler allocation-area-handler) action (allocation-area (eql nil)) req) - (with-bos-cms-page (req :title "Allocation Areas") +(defmethod handle-object-form ((handler allocation-area-handler) action (allocation-area (eql nil))) + (with-bos-cms-page (:title "Allocation Areas") (html (:h2 "Defined allocation areas") ((:table :border "1") @@ -27,8 +27,8 @@ (:td (:princ-safe (round (allocation-area-percent-used allocation-area))) "%"))))) (:p (cmslink "create-allocation-area" "Create new allocation area"))))) -(defmethod handle-object-form ((handler allocation-area-handler) action allocation-area req) - (with-bos-cms-page (req :title "Allocation Area") +(defmethod handle-object-form ((handler allocation-area-handler) action allocation-area) + (with-bos-cms-page (:title "Allocation Area") (with-slots (active-p left top width height) allocation-area (html ((:table :border "1") @@ -75,15 +75,15 @@ do (html (:td ((:a :href #?"/enlarge-overview/$(tile-x)/$(tile-y)") ((:img :width "90" :height "90" :border "0" :src #?"/overview/$(tile-x)/$(tile-y)")))))))))))))) -(defmethod handle-object-form ((handler allocation-area-handler) (action (eql :delete)) allocation-area req) +(defmethod handle-object-form ((handler allocation-area-handler) (action (eql :delete)) allocation-area) (delete-object allocation-area) - (with-bos-cms-page (req :title "Allocation area has been deleted") + (with-bos-cms-page (:title "Allocation area has been deleted") (:h2 "The allocation area has been deleted"))) (defclass allocation-area-gfx-handler (editor-only-handler object-handler) ()) -(defmethod handle-object ((handler allocation-area-gfx-handler) allocation-area req) +(defmethod handle-object ((handler allocation-area-gfx-handler) allocation-area) (cl-gd:with-image* ((allocation-area-width allocation-area) (allocation-area-height allocation-area) t) (with-slots (left top width height) allocation-area @@ -128,29 +128,27 @@ (defclass create-allocation-area-handler (admin-only-handler form-handler) ()) -(defmethod handle-form ((handler create-allocation-area-handler) action req) - (with-query-params (req x y left top) +(defmethod handle-form ((handler create-allocation-area-handler) action) + (with-query-params (x y left top) (cond ((and x y left top) (destructuring-bind (x y left top) (mapcar #'parse-integer (list x y left top)) (if (or (some (complement #'plusp) (list x y left top)) (<= x left) (<= y top)) - (with-bos-cms-page (req :title "Invalid area selected") + (with-bos-cms-page (:title "Invalid area selected") (:h2 "Choose upper left corner first, then lower-right corner")) (redirect (format nil "/allocation-area/~D" (store-object-id - (make-allocation-rectangle left top (- x left) (- y top)))) - req)))) + (make-allocation-rectangle left top (- x left) (- y top)))))))) ((and x y) (redirect (format nil "/map-browser/~A/~A?heading=~A&chosen-url=~A&" x y (uriencode-string "Choose lower right point of allocation area") (uriencode-string (format nil "~A?left=~A&top=~A&" - (uri-path (request-uri req)) - x y))) - req)) + (uri-path (hunchentoot:request-uri)) + x y))))) (t - (with-bos-cms-page (req :title "Create allocation area") + (with-bos-cms-page (:title "Create allocation area") ((:form :method "POST" :enctype "multipart/form-data")) ((:table :border "0") (:tr ((:td :colspan "2") @@ -163,23 +161,22 @@ (:tr (:td "Start-Y") (:td (text-field "start-y" :value 0 :size 5))) (:tr (:td (submit-button "rectangle" "rectangle"))))))))) -(defmethod handle-form ((handler create-allocation-area-handler) (action (eql :rectangle)) req) - (with-query-params (req start-x start-y) +(defmethod handle-form ((handler create-allocation-area-handler) (action (eql :rectangle))) + (with-query-params (start-x start-y) (redirect (format nil "/map-browser/~A/~A?heading=~A&chosen-url=~A&" start-x start-y (uriencode-string "Choose upper left point of allocation area") - (uriencode-string (format nil "~A?" (uri-path (request-uri req))))) - req))) + (uriencode-string (format nil "~A?" (uri-path (hunchentoot:request-uri)))))))) -(defmethod handle-form ((handler create-allocation-area-handler) (action (eql :upload)) req) - (let ((uploaded-text-file (cdr (find "text-file" (request-uploaded-files req) :test #'equal :key #'car)))) +(defmethod handle-form ((handler create-allocation-area-handler) (action (eql :upload))) + (let ((uploaded-text-file (cdr (find "text-file" (request-uploaded-files) :test #'equal :key #'car)))) (cond ((not uploaded-text-file) - (with-bos-cms-page (req :title "No Text file uploaded") + (with-bos-cms-page (:title "No Text file uploaded") (:h2 "File not uploaded") (:p "Please upload your text file containing the allocation polygon UTM coordinates"))) (t - (with-bos-cms-page (req :title #?"Importing allocation polygons from text file $(uploaded-text-file)") + (with-bos-cms-page (:title #?"Importing allocation polygons from text file $(uploaded-text-file)") (handler-case (let* ((vertices (polygon-from-text-file uploaded-text-file)) (existing-area (find (coerce vertices 'list) Modified: branches/trunk-reorg/projects/bos/web/allocation-cache-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/web/allocation-cache-handlers.lisp (original) +++ branches/trunk-reorg/projects/bos/web/allocation-cache-handlers.lisp Mon Feb 11 12:24:41 2008 @@ -5,8 +5,8 @@ (defclass allocation-cache-handler (admin-only-handler page-handler) ()) -(defmethod handle ((handler allocation-cache-handler) req) - (with-bos-cms-page (req :title "Allocation Cache") +(defmethod handle ((handler allocation-cache-handler)) + (with-bos-cms-page (:title "Allocation Cache") (html (:pre (:princ (with-output-to-string (*standard-output*) Modified: branches/trunk-reorg/projects/bos/web/boi-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/web/boi-handlers.lisp (original) +++ branches/trunk-reorg/projects/bos/web/boi-handlers.lisp Mon Feb 11 12:24:41 2008 @@ -6,8 +6,8 @@ (defclass boi-handler (page-handler) ()) -(defmethod authorized-p ((handler boi-handler) req) - (bos.m2:editor-p (bknr-request-user req))) +(defmethod authorized-p ((handler boi-handler)) + (bos.m2:editor-p bknr.web:*user*)) (defclass create-contract-handler (boi-handler) ()) @@ -20,9 +20,9 @@ (error "Invalid sponsor ID (wrong type)")) sponsor)) -(defmethod handle ((handler create-contract-handler) req) - (with-xml-error-handler (req) - (with-query-params (req num-sqm country sponsor-id name paid expires) +(defmethod handle ((handler create-contract-handler)) + (with-xml-error-handler () + (with-query-params (num-sqm country sponsor-id name paid expires) (setf num-sqm (ignore-errors (parse-integer num-sqm :junk-allowed t))) (unless num-sqm (error "missing or invalid num-sqm parameter")) @@ -53,9 +53,9 @@ (defclass pay-contract-handler (boi-handler) ()) -(defmethod handle ((handler pay-contract-handler) req) - (with-xml-error-handler (req) - (with-query-params (req contract-id name) +(defmethod handle ((handler pay-contract-handler)) + (with-xml-error-handler () + (with-query-params (contract-id name) (unless contract-id (error "missing contract-id parameter")) (let ((contract (get-contract (or (ignore-errors (parse-integer contract-id)) @@ -65,7 +65,7 @@ (with-transaction (:contract-paid) (contract-set-paidp contract (format nil "~A: manually set paid by ~A" (format-date-time) - (user-login (bknr-request-user req)))) + (user-login bknr.web:*user*))) (when name (setf (user-full-name (contract-sponsor contract)) name)))) (with-xml-response () @@ -77,9 +77,9 @@ (defclass cancel-contract-handler (boi-handler) ()) -(defmethod handle ((handler cancel-contract-handler) req) - (with-xml-error-handler (req) - (with-query-params (req contract-id) +(defmethod handle ((handler cancel-contract-handler)) + (with-xml-error-handler () + (with-query-params (contract-id) (unless contract-id (error "missing contract-id parameter")) (let ((contract (get-contract (or (ignore-errors (parse-integer contract-id)) Modified: branches/trunk-reorg/projects/bos/web/bos.web.asd ============================================================================== --- branches/trunk-reorg/projects/bos/web/bos.web.asd (original) +++ branches/trunk-reorg/projects/bos/web/bos.web.asd Mon Feb 11 12:24:41 2008 @@ -16,7 +16,7 @@ :description "worldpay test web server" :long-description "" - :depends-on (:bknr-web :bknr-modules :bos.m2 :cxml) + :depends-on (:bknr-web :bknr-modules :bos.m2 :cxml :acl-compat) :components ((:file "packages") (:file "utf-8" :depends-on ("packages")) Modified: branches/trunk-reorg/projects/bos/web/contract-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/web/contract-handlers.lisp (original) +++ branches/trunk-reorg/projects/bos/web/contract-handlers.lisp Mon Feb 11 12:24:41 2008 @@ -9,8 +9,8 @@ (defparameter *show-m2s* 5) -(defmethod handle-object ((handler contract-handler) contract req) - (with-bos-cms-page (req :title "Displaying contract details") +(defmethod handle-object ((handler contract-handler) contract) + (with-bos-cms-page (:title "Displaying contract details") ((:table :border "0") (:tr (:td "sponsor") (:td (html-edit-link (contract-sponsor contract)))) 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 Mon Feb 11 12:24:41 2008 @@ -17,7 +17,7 @@ ;; We manipulate pixels in a temporary array which is copied to the GD image as ;; a whole for performance reasons. The FFI is way too slow to manipulate individual pixels. (let ((work-array (make-array (list width height) :element-type 'fixnum :initial-element 0)) - (color (parse-color (or (second (decoded-handler-path handler req)) "ffff00")))) + (color (parse-color (or (second (decoded-handler-path handler)) "ffff00")))) (flet ((set-pixel (x y) (decf x left) (decf y top) Modified: branches/trunk-reorg/projects/bos/web/kml-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/web/kml-handlers.lisp (original) +++ branches/trunk-reorg/projects/bos/web/kml-handlers.lisp Mon Feb 11 12:24:41 2008 @@ -40,7 +40,7 @@ (defclass contract-kml-handler (object-handler) ()) -(defmethod handle-object ((handler contract-kml-handler) (contract contract) req) +(defmethod handle-object ((handler contract-kml-handler) (contract contract)) (with-xml-response (:content-type "application/vnd.google-earth.kml+xml" :root-element "kml") ;; when name is xmlns, the attribute does not show up - why (?) ;; (attribute "xmlns" "http://earth.google.com/kml/2.2") @@ -77,5 +77,5 @@ (with-element "coordinates" (text (kml-format-points (list (contract-center-lon-lat c))))))))))))) -(defmethod handle-object ((handle-object contract-kml-handler) (object null) req) +(defmethod handle-object ((handle-object contract-kml-handler) (object null)) (error "Contract not found.")) Modified: branches/trunk-reorg/projects/bos/web/languages-handler.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/web/languages-handler.lisp (original) +++ branches/trunk-reorg/projects/bos/web/languages-handler.lisp Mon Feb 11 12:24:41 2008 @@ -5,11 +5,11 @@ (defclass languages-handler (admin-only-handler form-handler) ()) -(defmethod handle-form ((handler languages-handler) action req) - (with-bos-cms-page (req :title "Languages") +(defmethod handle-form ((handler languages-handler) action) + (with-bos-cms-page (:title "Languages") (case action (:add (handler-case - (with-query-params (req code name) + (with-query-params (code name) (when (and code name) (make-object 'website-language :code code :name name) (html (:h2 "Language " (:princ-safe code) " (" (:princ-safe name) ") created")))) @@ -17,7 +17,7 @@ (html (:h2 "Error creating language") (:pre (:princ-safe e)))))) (:delete (handler-case - (with-query-params (req delete-code) + (with-query-params (delete-code) (when delete-code (delete-object (language-with-code delete-code)) (html (:h2 "Language " (:princ-safe delete-code) " deleted")))) Modified: branches/trunk-reorg/projects/bos/web/map-browser-handler.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/web/map-browser-handler.lisp (original) +++ branches/trunk-reorg/projects/bos/web/map-browser-handler.lisp Mon Feb 11 12:24:41 2008 @@ -18,7 +18,7 @@ (defclass map-browser-handler (prefix-handler) ()) -(defun decode-coords-in-handler-path (handler req) +(defun decode-coords-in-handler-path (handler) (labels ((ensure-valid-coordinates (x y) (setq x (parse-integer x)) (setq y (parse-integer y)) @@ -30,30 +30,29 @@ (<= 0 y 10800)) (error "invalid coordinates ~A/~A" x y)) (list x y))) - (with-query-params (req xcoord ycoord) + (with-query-params (xcoord ycoord) (when (and xcoord ycoord) (return-from decode-coords-in-handler-path (ensure-valid-coordinates xcoord ycoord)))) - (let ((handler-arguments (decoded-handler-path handler req))) + (let ((handler-arguments (decoded-handler-path handler))) (when (and handler-arguments (< 1 (length handler-arguments))) (apply #'ensure-valid-coordinates handler-arguments))))) -(defmethod handle ((handler map-browser-handler) req) - (with-query-params (req chosen-url) +(defmethod handle ((handler map-browser-handler)) + (with-query-params (chosen-url) (when chosen-url (setf (session-variable :chosen-url) chosen-url))) - (with-query-params (req view-x view-y) - (destructuring-bind (&optional click-x click-y) (decode-ismap-query-string req) - (destructuring-bind (&optional point-x point-y) (decode-coords-in-handler-path handler req) - (with-query-params (req action) + (with-query-params (view-x view-y) + (destructuring-bind (&optional click-x click-y) (decode-ismap-query-string) + (destructuring-bind (&optional point-x point-y) (decode-coords-in-handler-path handler) + (with-query-params (action) (when (equal action "save") (if (session-variable :chosen-url) (redirect (format nil "~Ax=~D&y=~D" (session-variable :chosen-url) point-x - point-y) - req) - (with-bos-cms-page (req :title "Map Point Chooser") + point-y)) + (with-bos-cms-page (:title "Map Point Chooser") (html (:princ-safe "You chose " point-x " / " point-y)))) (return-from handle t))) (cond @@ -71,14 +70,14 @@ (click-coord-y (+ (tile-nw-y start-tile) click-y))) (setq point-x click-coord-x point-y click-coord-y) - (redirect (format nil "/map-browser/~D/~D" click-coord-x click-coord-y) req) + (redirect (format nil "/map-browser/~D/~D" click-coord-x click-coord-y)) (return-from handle t))) (cond ((and click-y (not point-y)) - (redirect (format nil "/map-browser/~D/~D" (* 30 click-x) (* 30 click-y)) req)) + (redirect (format nil "/map-browser/~D/~D" (* 30 click-x) (* 30 click-y)))) (point-y - (with-bos-cms-page (req :title "Map Point Chooser") - (with-query-params (req heading) + (with-bos-cms-page (:title "Map Point Chooser") + (with-query-params (heading) (when heading (html (:h2 (:princ-safe heading))))) (html @@ -133,7 +132,7 @@ ((:img :src "/images/map-cursor.png"))))))) (map-navigator req point-x point-y "/map-browser/" :formcheck "return updateCoords();"))) (t - (with-bos-cms-page (req :title "Map Point Chooser") + (with-bos-cms-page (:title "Map Point Chooser") (html ((:a :href "/map-browser/") ((:img :ismap "ismap" :src "/image/sl_all")))))))))))) \ 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 Mon Feb 11 12:24:41 2008 @@ -34,7 +34,7 @@ (:tr (:td "Y:") (:td (text-field "ycoord" :size "5" :value y))) (:tr ))) (:td - (with-query-params (req background areas contracts) + (with-query-params (background areas contracts) ;; xxx should use tile-layers (unless (or background areas contracts) (setq background t @@ -52,15 +52,15 @@ (defclass image-tile-handler (object-handler) ()) -(defmethod object-handler-get-object ((handler image-tile-handler) req) - (destructuring-bind (x y &rest operations) (decoded-handler-path handler req) +(defmethod object-handler-get-object ((handler image-tile-handler)) + (destructuring-bind (x y &rest operations) (decoded-handler-path handler) (declare (ignore operations)) (setf x (parse-integer x)) (setf y (parse-integer y)) (ensure-map-tile x y))) -(defmethod handle-object ((handler image-tile-handler) (tile (eql nil)) req) - (error-404 req)) +(defmethod handle-object ((handler image-tile-handler) (tile (eql nil))) + (error-404)) (defun parse-operations (&rest operation-strings) (mapcar #'(lambda (operation-string) @@ -68,32 +68,33 @@ (apply #'list (make-keyword-from-string operation) arguments))) operation-strings)) -(defmethod handle-object ((handler image-tile-handler) tile req) - ;; xxx parse url another time - the parse result of - ;; object-handler-get-object should really be kept in the request - (destructuring-bind (x y &rest operation-strings) (decoded-handler-path handler req) - (declare (ignore x y)) - (let ((changed-time (image-tile-changed-time tile)) - (ims (header-slot-value req :if-modified-since))) - (setf (net.aserve::last-modified *ent*) changed-time) - #+(or) - (format t "; image-tile-handler handle-object: changed-time: ~A if-modified-since: ~A~%" (format-date-time changed-time) ims) - (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 - :date changed-time - :max-age 60) - (cl-gd:destroy-image image)) - (with-http-response (req *ent*) - (with-http-body (req *ent*) - ; do nothing - )))))) +;; trunk-reorg adaption +;; (defmethod handle-object ((handler image-tile-handler) tile) +;; ;; xxx parse url another time - the parse result of +;; ;; object-handler-get-object should really be kept in the request +;; (destructuring-bind (x y &rest operation-strings) (decoded-handler-path handler) +;; (declare (ignore x y)) +;; (let ((changed-time (image-tile-changed-time tile)) +;; (ims (header-slot-value req :if-modified-since))) +;; (format t "Warning: not setting last-modified of *ent* to changed-time") +;; #+(or) +;; (format t "; image-tile-handler handle-object: changed-time: ~A if-modified-since: ~A~%" (format-date-time changed-time) ims) +;; (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 +;; :date changed-time +;; :max-age 60) +;; (cl-gd:destroy-image image)) +;; (with-http-response (*ent*) +;; (with-http-body () +;; ; do nothing +;; )))))) (defclass enlarge-tile-handler (image-tile-handler) ()) -(defun tile-active-layers-from-request-params (tile req) +(defun tile-active-layers-from-request-params (tile) (let (active-layers (all-layer-names (mapcar #'symbol-name (image-tile-layers tile)))) (dolist (layer-name all-layer-names) @@ -101,25 +102,27 @@ (push layer-name active-layers))) (or (reverse active-layers) all-layer-names))) -(defun tile-url (tile x y req) +(defun tile-url (tile x y) (format nil "/overview/~D/~D~(~{/~A~}~)" x y - (tile-active-layers-from-request-params tile req))) + (tile-active-layers-from-request-params tile))) + +;; trunk-reorg adaption +;; (defmethod handle-object ((handler enlarge-tile-handler) tile) +;; (let ((ismap-coords (decode-ismap-query-string req)) +;; (tile-x (tile-nw-x tile)) +;; (tile-y (tile-nw-y tile))) +;; (if ismap-coords +;; (let* ((x (+ (floor (first ismap-coords) 4) tile-x)) +;; (y (+ (floor (second ismap-coords) 4) tile-y)) +;; (m2 (get-m2 x y)) +;; (contract-id (and m2 (m2-contract m2) (store-object-id (m2-contract m2))))) +;; (if contract-id +;; (redirect #?"/contract/$(contract-id)") +;; (with-bos-cms-page (:title "Not sold") +;; (html (:h2 "this square meter has not been sold yet"))))) +;; (with-bos-cms-page (:title "Browsing tile") +;; (:a ((:a :href (uri-path (hunchentoot:request-uri))) +;; ((:img :width "360" :ismap "ismap" :height "360" :border "0" :src (tile-url tile tile-x tile-y req))))) +;; (map-navigator req tile-x tile-y "/enlarge-overview/"))))) -(defmethod handle-object ((handler enlarge-tile-handler) tile req) - (let ((ismap-coords (decode-ismap-query-string req)) - (tile-x (tile-nw-x tile)) - (tile-y (tile-nw-y tile))) - (if ismap-coords - (let* ((x (+ (floor (first ismap-coords) 4) tile-x)) - (y (+ (floor (second ismap-coords) 4) tile-y)) - (m2 (get-m2 x y)) - (contract-id (and m2 (m2-contract m2) (store-object-id (m2-contract m2))))) - (if contract-id - (redirect #?"/contract/$(contract-id)" req) - (with-bos-cms-page (req :title "Not sold") - (html (:h2 "this square meter has not been sold yet"))))) - (with-bos-cms-page (req :title "Browsing tile") - (:a ((:a :href (uri-path (request-uri req))) - ((:img :width "360" :ismap "ismap" :height "360" :border "0" :src (tile-url tile tile-x tile-y req))))) - (map-navigator req tile-x tile-y "/enlarge-overview/"))))) \ No newline at end of file Modified: branches/trunk-reorg/projects/bos/web/news-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/web/news-handlers.lisp (original) +++ branches/trunk-reorg/projects/bos/web/news-handlers.lisp Mon Feb 11 12:24:41 2008 @@ -9,10 +9,10 @@ (defclass edit-news-handler (editor-only-handler edit-object-handler) ()) -(defmethod handle-object-form ((handler edit-news-handler) action (news-item (eql nil)) req) +(defmethod handle-object-form ((handler edit-news-handler) action (news-item (eql nil))) (let ((language (session-variable :language))) - (with-bos-cms-page (req :title "Edit news items") - (content-language-chooser req) + (with-bos-cms-page (:title "Edit news items") + (content-language-chooser) (:h2 "Create new item") ((:form :method "post") (submit-button "new" "new")) @@ -29,13 +29,13 @@ (html (:h2 "No news items created yet")))))) -(defmethod handle-object-form ((handler edit-news-handler) (action (eql :new)) (news-item (eql nil)) req) - (redirect (format nil "/edit-news/~D" (store-object-id (make-news-item))) req)) +(defmethod handle-object-form ((handler edit-news-handler) (action (eql :new)) (news-item (eql nil))) + (redirect (format nil "/edit-news/~D" (store-object-id (make-news-item))))) -(defmethod handle-object-form ((handler edit-news-handler) action news-item req) +(defmethod handle-object-form ((handler edit-news-handler) action news-item) (let ((language (session-variable :language))) - (with-bos-cms-page (req :title "Edit news item") - (content-language-chooser req) + (with-bos-cms-page (:title "Edit news item") + (content-language-chooser) ((:script :type "text/javascript") "tinyMCE.init({ mode : 'textareas', theme : 'advanced' });") ((:form :method "post") @@ -48,15 +48,15 @@ :value (news-item-text news-item language)))) (:tr (:td (submit-button "save" "save") (submit-button "delete" "delete" :confirm "Really delete the news item?")))))))) -(defmethod handle-object-form ((handler edit-news-handler) (action (eql :save)) news-item req) +(defmethod handle-object-form ((handler edit-news-handler) (action (eql :save)) news-item) (let ((language (session-variable :language))) - (with-query-params (req title text) + (with-query-params (title text) (update-news-item news-item language :title title :text text) - (with-bos-cms-page (req :title "News item updated") + (with-bos-cms-page (:title "News item updated") (:h2 "Your changes have been saved") "You may " (cmslink (edit-object-url news-item) "continue editing the news item"))))) -(defmethod handle-object-form ((handler edit-news-handler) (action (eql :delete)) news-item req) +(defmethod handle-object-form ((handler edit-news-handler) (action (eql :delete)) news-item) (delete-object news-item) - (with-bos-cms-page (req :title "News item has been deleted") + (with-bos-cms-page (:title "News item has been deleted") (:h2 "The news item has been deleted"))) \ No newline at end of file Modified: branches/trunk-reorg/projects/bos/web/packages.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/web/packages.lisp (original) +++ branches/trunk-reorg/projects/bos/web/packages.lisp Mon Feb 11 12:24:41 2008 @@ -8,8 +8,6 @@ :cl-user :cl-interpol :cl-ppcre - :net.aserve - :net.aserve.client :xhtml-generator :cxml :puri @@ -27,6 +25,5 @@ :bos.m2.config) (:nicknames :web :worldpay-test) (:shadowing-import-from :cl-interpol #:quote-meta-chars) - (:shadowing-import-from :acl-compat.mp #:process-kill #:process-wait) - (:import-from :net.html.generator #:*html-stream*) + (:shadowing-import-from :acl-compat.mp #:process-kill #:process-wait) (:export)) Modified: branches/trunk-reorg/projects/bos/web/poi-handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/web/poi-handlers.lisp (original) +++ branches/trunk-reorg/projects/bos/web/poi-handlers.lisp Mon Feb 11 12:24:41 2008 @@ -6,26 +6,26 @@ (defclass make-poi-handler (page-handler) ()) -(defmethod handle ((handler make-poi-handler) req) - (with-query-params (req name) +(defmethod handle ((handler make-poi-handler)) + (with-query-params (name) (cond ((find-store-object name :class 'poi) - (with-bos-cms-page (req :title "Duplicate POI name") + (with-bos-cms-page (:title "Duplicate POI name") (html (:h2 "Duplicate POI name") "A POI with that name exists already, please choose a unique name"))) ((not (scan #?r"(?i)^[a-z][-a-z0-9_]+$" name)) - (with-bos-cms-page (req :title "Bad technical name") + (with-bos-cms-page (:title "Bad technical name") (html (:h2 "Bad technical name") "Please use only alphanumerical characters, - and _ for technical POI names"))) (t - (redirect (edit-object-url (make-poi (session-variable :language) name)) req))))) + (redirect (edit-object-url (make-poi (session-variable :language) name))))))) (defclass edit-poi-handler (editor-only-handler edit-object-handler) () (:default-initargs :object-class 'poi :query-function #'find-poi)) -(defmethod handle-object-form ((handler edit-poi-handler) action (object (eql nil)) req) - (with-bos-cms-page (req :title "Choose POI") +(defmethod handle-object-form ((handler edit-poi-handler) action (object (eql nil))) + (with-bos-cms-page (:title "Choose POI") (if (store-objects-with-class 'poi) (html (:h2 "Choose a POI to edit") @@ -50,8 +50,8 @@ (html ((:img :src #?"/images/$(icon).gif"))))) (defmethod handle-object-form ((handler edit-poi-handler) - action (poi poi) req) - (with-query-params (req language shift shift-by) + action (poi poi)) + (with-query-params (language shift shift-by) (unless language (setq language (session-variable :language))) (when shift ;; change image order @@ -66,8 +66,8 @@ (setf (nth (+ shift-by old-position) new-images) tmp) (change-slot-values poi 'bos.m2::images new-images))) (setf (session-variable :language) language) - (with-bos-cms-page (req :title "Edit POI") - (content-language-chooser req) + (with-bos-cms-page (:title "Edit POI") + (content-language-chooser) (unless (poi-complete poi language) (html (:h2 "This POI is not complete in the current language - Please check that " "the location and all text fields are set and that at least one image " @@ -95,11 +95,11 @@ (html (:princ-safe (format nil "~D/~D " (first (poi-area poi)) (second (poi-area poi))))) (cmslink (format nil "map-browser/~A/~A?chosen-url=~A" (first (poi-area poi)) (second (poi-area poi)) - (uriencode-string (format nil "~A?action=save&" (uri-path (request-uri req))))) + (uriencode-string (format nil "~A?action=save&" (uri-path (hunchentoot:request-uri))))) "[relocate]")) (t (cmslink (format nil "map-browser/?chosen-url=~A" - (uriencode-string (format nil "~A?action=save&" (uri-path (request-uri req))))) + (uriencode-string (format nil "~A?action=save&" (uri-path (hunchentoot:request-uri))))) "[choose]"))))) (:tr (:td "icon") (:td (icon-chooser "icon" (poi-icon poi)))) @@ -167,8 +167,8 @@ (submit-button "delete" "delete" :confirm "Really delete the POI?")))))))) (defmethod handle-object-form ((handler edit-poi-handler) - (action (eql :save)) (poi poi) req) - (with-query-params (req published title subtitle description language x y icon movie) + (action (eql :save)) (poi poi)) + (with-query-params (published title subtitle description language x y icon movie) (unless language (setq language (session-variable :language))) (let ((args (list :title title :published published @@ -180,21 +180,20 @@ (when movie (setq args (append args (list :movies (list movie))))) (apply #'update-poi poi language args)) - (with-bos-cms-page (req :title "POI has been updated") + (with-bos-cms-page (:title "POI has been updated") (html (:h2 "Your changes have been saved") "You may " (cmslink (edit-object-url poi) "continue editing the POI") ".")))) (defmethod handle-object-form ((handler edit-poi-handler) (action (eql :upload-airal)) - (poi poi) - req) - (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files req) :test #'equal :key #'car)))) + (poi poi)) + (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files) :test #'equal :key #'car)))) (unless uploaded-file (error "no file uploaded in upload handler")) (cl-gd:with-image-from-file* (uploaded-file) (unless (and (eql (cl-gd:image-width) *poi-image-width*) (eql (cl-gd:image-height) *poi-image-height*)) - (with-bos-cms-page (req :title "Invalid image size") + (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 " @@ -207,30 +206,27 @@ (change-slot-values poi 'airals (list (import-image uploaded-file :class-name 'store-image)))) (redirect (format nil "/edit-poi/~D" - (store-object-id poi)) req)) + (store-object-id poi)))) (defmethod handle-object-form ((handler edit-poi-handler) (action (eql :delete-airal)) - (poi poi) - req) + (poi poi)) (let ((airals (poi-airals poi))) (change-slot-values poi 'airals nil) (mapc #'delete-object airals)) (redirect (format nil "/edit-poi/~D" - (store-object-id poi)) req)) + (store-object-id poi)))) (defmethod handle-object-form ((handler edit-poi-handler) (action (eql :delete-movie)) - (poi poi) - req) + (poi poi)) (change-slot-values poi 'movies nil) - (redirect (format nil "/edit-poi/~D" (store-object-id poi)) req)) + (redirect (format nil "/edit-poi/~D" (store-object-id poi)))) (defmethod handle-object-form ((handler edit-poi-handler) (action (eql :upload-panorama)) - (poi poi) - req) - (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files req) :test #'equal :key #'car)))) + (poi poi)) + (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files) :test #'equal :key #'car)))) (unless uploaded-file (error "no file uploaded in upload handler")) (cl-gd:with-image-from-file* (uploaded-file) @@ -240,23 +236,22 @@ :class-name 'store-image) (poi-panoramas poi)))) (redirect (format nil "/edit-poi/~D" - (store-object-id poi)) req)) + (store-object-id poi)))) (defmethod handle-object-form ((handler edit-poi-handler) (action (eql :delete-panorama)) - (poi poi) - req) - (with-query-params (req panorama-id) + (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))) (redirect (format nil "/edit-poi/~D" - (store-object-id poi)) req)) + (store-object-id poi)))) (defmethod handle-object-form ((handler edit-poi-handler) - (action (eql :delete)) (poi poi) req) + (action (eql :delete)) (poi poi)) (delete-object poi) - (with-bos-cms-page (req :title "POI has been deleted") + (with-bos-cms-page (:title "POI has been deleted") (html (:h2 "POI has been deleted") "The POI has been deleted"))) @@ -266,9 +261,9 @@ () (:default-initargs :object-class 'poi-image)) -(defmethod handle-object-form ((handler edit-poi-image-handler) action (object (eql nil)) req) - (with-query-params (req poi) - (with-bos-cms-page (req :title "Upload new POI image") +(defmethod handle-object-form ((handler edit-poi-image-handler) action (object (eql nil))) + (with-query-params (poi) + (with-bos-cms-page (:title "Upload new POI image") (html (:h2 "Upload new image") ((:form :method "POST" :enctype "multipart/form-data")) @@ -276,16 +271,16 @@ (:p "Choose a file: " ((:input :type "file" :name "image-file"))) (:p (submit-button "upload" "upload")))))) -(defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :upload)) poi-image req) - (with-query-params (req poi) +(defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :upload)) poi-image) + (with-query-params (poi) (setq poi (find-store-object (parse-integer poi) :class 'poi)) - (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files req) :test #'equal :key #'car)))) + (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files) :test #'equal :key #'car)))) (unless uploaded-file (error "no file uploaded in upload handler")) (cl-gd:with-image-from-file* (uploaded-file) (unless (and (eql (cl-gd:image-width) *poi-image-width*) (eql (cl-gd:image-height) *poi-image-height*)) - (with-bos-cms-page (req :title "Invalid image size") + (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 " @@ -302,15 +297,15 @@ :initargs `(:poi ,poi)))) (redirect (format nil "/edit-poi-image/~D?poi=~D" (store-object-id poi-image) - (store-object-id poi)) req)))) + (store-object-id poi)))))) -(defmethod handle-object-form ((handler edit-poi-image-handler) action poi-image req) - (with-query-params (req language poi) +(defmethod handle-object-form ((handler edit-poi-image-handler) action poi-image) + (with-query-params (language poi) (unless language (setq language (session-variable :language))) - (with-bos-cms-page (req :title "Edit POI Image") + (with-bos-cms-page (:title "Edit POI Image") (html (cmslink (edit-object-url (poi-image-poi poi-image)) "Back to POI") - (content-language-chooser req) + (content-language-chooser) ((:form :method "post" :enctype "multipart/form-data") ((:input :type "hidden" :name "poi" :value poi)) (:table (:tr (:td "thumbnail") @@ -334,21 +329,21 @@ :cols 40))) (:tr (:td (submit-button "save" "save") (submit-button "delete" "delete" :confirm "Really delete the image?"))))))))) -(defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :save)) poi-image req) - (with-query-params (req title subtitle description language) +(defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :save)) poi-image) + (with-query-params (title subtitle description language) (unless language (setq language (session-variable :language))) (update-poi-image poi-image language :title title :subtitle subtitle :description description) - (with-bos-cms-page (req :title "POI image has been updated") + (with-bos-cms-page (:title "POI image has been updated") (:h2 "The POI image information has been updated") "You may " (cmslink (edit-object-url poi-image) "continue editing the POI image")))) -(defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :delete)) poi-image req) +(defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :delete)) poi-image) (let ((poi (poi-image-poi poi-image))) (delete-object poi-image) - (with-bos-cms-page (req :title "POI image has been deleted") + (with-bos-cms-page (:title "POI image has been deleted") (:h2 "The POI image has been deleted") "You may " (cmslink (edit-object-url poi) "continue editing the POI")))) @@ -363,12 +358,12 @@ (sponsor-country (contract-sponsor contract)) (length (contract-m2s contract)))) -(defmethod handle ((handler poi-javascript-handler) req) - (with-bknr-http-response (req :content-type "text/html; charset=UTF-8") - (setf (reply-header-slot-value req :cache-control) "no-cache") - (setf (reply-header-slot-value req :pragma) "no-cache") - (setf (reply-header-slot-value req :expires) "-1") - (with-http-body (req *ent*) +(defmethod handle ((handler poi-javascript-handler)) + (with-http-response (:content-type "text/html; charset=UTF-8") + (setf (hunchentoot:header-out :cache-control) "no-cache") + (setf (hunchentoot:header-out :pragma) "no-cache") + (setf (hunchentoot:header-out :expires) "-1") + (with-http-body () (let ((*standard-output* *html-stream*)) (princ "<script language=\"JavaScript\">") (terpri) (princ (make-poi-javascript (or (session-variable :language) *default-language*))) (terpri) @@ -380,18 +375,17 @@ () (:default-initargs :object-class 'poi :query-function #'find-poi)) -(defmethod handle-object ((handler poi-image-handler) (poi (eql nil)) req) +(defmethod handle-object ((handler poi-image-handler) (poi (eql nil))) (error "poi not found")) -(defmethod handle-object ((handler poi-image-handler) poi req) - (destructuring-bind (poi-name image-index-string &rest imageproc-arguments) (multiple-value-list (parse-handler-url handler req)) +(defmethod handle-object ((handler poi-image-handler) poi) + (destructuring-bind (poi-name image-index-string &rest imageproc-arguments) (multiple-value-list (parse-handler-url handler)) (declare (ignore poi-name)) (let ((image-index (1- (parse-integer image-index-string)))) (if (and (not (minusp image-index)) (< image-index (length (poi-images poi)))) (redirect (format nil "/image/~D~@[~{/~a~}~]" (store-object-id (nth image-index (poi-images poi))) - imageproc-arguments) - req) + imageproc-arguments)) (error "image index ~a out of bounds for poi ~a" image-index poi))))) 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 Mon Feb 11 12:24:41 2008 @@ -21,7 +21,7 @@ (defmethod handle ((handler reports-xml-handler) req) (with-xml-response () - (destructuring-bind (name &optional *year* &rest arguments) (decoded-handler-path handler req) + (destructuring-bind (name &optional *year* &rest arguments) (decoded-handler-path handler) (setf *year* (and *year* (parse-integer *year*))) (let ((*contracts-to-process* (sort (remove-if (lambda (contract) (or (not (contract-paidp contract)) 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 Mon Feb 11 12:24:41 2008 @@ -6,14 +6,14 @@ (defclass search-sponsors-handler (editor-only-handler form-handler) ()) -(defmethod handle-form ((handler search-sponsors-handler) action req) - (with-bos-cms-page (req :title "Search for sponsor"))) +(defmethod handle-form ((handler search-sponsors-handler) action) + (with-bos-cms-page (:title "Search for sponsor"))) (defclass edit-sponsor-handler (editor-only-handler edit-object-handler) ()) -(defmethod object-handler-get-object ((handler edit-sponsor-handler) req) - (let ((object (ignore-errors (find-store-object (parse-integer (first (decoded-handler-path handler req))))))) +(defmethod object-handler-get-object ((handler edit-sponsor-handler)) + (let ((object (ignore-errors (find-store-object (parse-integer (first (decoded-handler-path handler))))))) (typecase object (sponsor object) (contract (contract-sponsor object)) @@ -36,17 +36,17 @@ (defmethod language-selector ((contract contract)) (language-selector (contract-sponsor contract))) -(defmethod handle-object-form ((handler edit-sponsor-handler) action (sponsor (eql nil)) req) - (with-query-params (req id key count) +(defmethod handle-object-form ((handler edit-sponsor-handler) action (sponsor (eql nil))) + (with-query-params (id key count) (when id - (redirect #?"/edit-sponsor/$(id)" req) + (redirect #?"/edit-sponsor/$(id)") (return-from handle-object-form)) (when (or key count) (let ((regex (format nil "(?i)~A" key)) (found 0)) (when count (setf count (parse-integer count))) - (with-bos-cms-page (req :title "Sponsor search results") + (with-bos-cms-page (:title "Sponsor search results") ((:table :border "1") (:tr (:th "ID") (:th "Date") (:th "Email") (:th "Name") (:th "SQM") (:th "Country") (:th "Cert-Type") (:th "Paid by")) (dolist (sponsor (sort (remove-if-not #'sponsor-contracts (class-instances 'sponsor)) @@ -67,7 +67,7 @@ (return)))) (:tr ((:th :colspan "7") (:princ-safe (format nil "~A sponsor~:p ~A" found (if count "shown" "found")))))))) (return-from handle-object-form))) - (with-bos-cms-page (req :title "Find or Create Sponsor") + (with-bos-cms-page (:title "Find or Create Sponsor") (html ((:form :name "form") ((:table) @@ -106,23 +106,23 @@ (defun date-to-universal (date-string) (apply #'encode-universal-time 0 0 0 (mapcar #'parse-integer (split #?r"\." date-string)))) -(defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :create)) (sponsor (eql nil)) req) - (with-query-params (req numsqm country email name address date language) +(defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :create)) (sponsor (eql nil))) + (with-query-params (numsqm country email name address date language) (let* ((sponsor (make-sponsor :email email :country country :language language)) (contract (make-contract sponsor (parse-integer numsqm) :paidp (format nil "~A: manually created by ~A" (format-date-time (get-universal-time)) - (user-login (bknr-request-user req))) + (user-login bknr.web:*user*)) :date (date-to-universal date)))) (contract-issue-cert contract name :address address :language language) - (mail-backoffice-sponsor-data contract req) - (redirect (format nil "/edit-sponsor/~D" (store-object-id sponsor)) req)))) + (mail-backoffice-sponsor-data contract) + (redirect (format nil "/edit-sponsor/~D" (store-object-id sponsor)))))) (defun contract-checkbox-name (contract) (format nil "contract-~D-paid" (store-object-id contract))) -(defmethod handle-object-form ((handler edit-sponsor-handler) action sponsor req) - (with-bos-cms-page (req :title "Edit Sponsor") +(defmethod handle-object-form ((handler edit-sponsor-handler) action sponsor) + (with-bos-cms-page (:title "Edit Sponsor") (html ((:form :method "post") (:h2 "Sponsor Data") @@ -174,9 +174,9 @@ (:p (submit-button "save" "save") (submit-button "delete" "delete" :confirm "Really delete this sponsor?")))))) -(defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :save)) sponsor req) +(defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :save)) sponsor) (let (changed) - (with-bos-cms-page (req :title "Saving sponsor data") + (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))))) (when (and field-value @@ -192,11 +192,11 @@ (html (:p "Changed contract status to \"paid\"")))) (unless changed (html (:p "No changes have been made"))) - (html (cmslink (uri-path (request-uri req)) + (html (cmslink (uri-path (hunchentoot:request-uri)) "Return to sponsor profile"))))) -(defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :delete)) sponsor req) - (with-bos-cms-page (req :title "Sponsor deleted") +(defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :delete)) sponsor) + (with-bos-cms-page (:title "Sponsor deleted") (delete-object sponsor) (html (:p "The sponsor has been deleted")))) @@ -204,17 +204,16 @@ () (:default-initargs :object-class 'contract)) -(defmethod handle-object-form ((handler complete-transfer-handler) action (contract (eql nil)) req) - (with-bos-cms-page (req :title "Invalid contract ID") +(defmethod handle-object-form ((handler complete-transfer-handler) action (contract (eql nil))) + (with-bos-cms-page (:title "Invalid contract ID") (html "Invalid contract ID, maybe the sponsor or the contract has been deleted"))) -(defmethod handle-object-form ((handler complete-transfer-handler) action contract req) +(defmethod handle-object-form ((handler complete-transfer-handler) action contract) (if (contract-paidp contract) - (redirect (format nil "/edit-sponsor/~D" (store-object-id (contract-sponsor contract))) - req) + (redirect (format nil "/edit-sponsor/~D" (store-object-id (contract-sponsor contract)))) (let ((numsqm (length (contract-m2s contract)))) - (with-query-params (req email) - (with-bos-cms-page (req :title "Complete square meter sale with wire transfer payment") + (with-query-params (email) + (with-bos-cms-page (:title "Complete square meter sale with wire transfer payment") (html ((:form :name "form") ((:input :type "hidden" :name "numsqm" :value #?"$(numsqm)")) @@ -231,16 +230,16 @@ (:td (text-field "email" :size 20 :value email))) (:tr (:td (submit-button "process" "process" :formcheck "javascript:return check_complete_sale()"))))))))))) -(defmethod handle-object-form ((handler complete-transfer-handler) (action (eql :process)) contract req) - (with-query-params (req email country) - (with-bos-cms-page (req :title "Square meter sale completion") +(defmethod handle-object-form ((handler complete-transfer-handler) (action (eql :process)) contract) + (with-query-params (email country) + (with-bos-cms-page (:title "Square meter sale completion") (if (contract-paidp contract) (html (:h2 "This sale has already been completed")) (progn (html (:h2 "Completing square meter sale")) (sponsor-set-country (contract-sponsor contract) country) (contract-set-paidp contract (format nil "~A: wire transfer processed by ~A" - (format-date-time) (user-login (bknr-request-user req)))) + (format-date-time) (user-login bknr.web:*user*))) (when email (html (:p "Sending instruction email to " (:princ-safe email))) (mail-instructions-to-sponsor contract email)))) @@ -260,10 +259,10 @@ (sponsor-id-or-x (find-store-object (parse-integer sponsor-id-or-x) :class 'sponsor)) (t - (when (eq (find-class 'sponsor) (class-of (bknr-request-user req))) - (bknr-request-user req)))))) - (with-bknr-http-response (req :content-type "text/html; charset=UTF-8") - (with-http-body (req *ent*) + (when (eq (find-class 'sponsor) (class-of bknr.web:*user*)) + bknr.web:*user*))))) + (with-http-response (:content-type "text/html; charset=UTF-8") + (with-http-body () (let ((*standard-output* *html-stream*)) (princ "<script language=\"JavaScript\">") (terpri) (princ "var profil;") (terpri) @@ -275,16 +274,16 @@ (defclass sponsor-login-handler (page-handler) ()) -(defmethod handle ((handler sponsor-login-handler) req) - (with-query-params (req __sponsorid) - (with-bknr-http-response (req :content-type "text/html") - (setf (reply-header-slot-value req :cache-control) "no-cache") - (setf (reply-header-slot-value req :pragma) "no-cache") - (setf (reply-header-slot-value req :expires) "-1") - (with-http-body (req *ent*) +(defmethod handle ((handler sponsor-login-handler)) + (with-query-params (__sponsorid) + (with-http-response (:content-type "text/html") + (setf (hunchentoot:header-out :cache-control) "no-cache") + (setf (hunchentoot:header-out :pragma) "no-cache") + (setf (hunchentoot:header-out :expires) "-1") + (with-http-body () (format *html-stream* "<script>~%parent.set_loginstatus('~A');~%</script>~%" (cond - ((eq (find-class 'sponsor) (class-of (bknr-request-user req))) + ((eq (find-class 'sponsor) (class-of bknr.web:*user*)) "logged-in") (__sponsorid "login-failed") @@ -295,8 +294,8 @@ () (:default-initargs :class 'contract)) -(defmethod object-handler-get-object ((handler cert-regen-handler) req) - (let* ((object-id-string (first (decoded-handler-path handler req))) +(defmethod object-handler-get-object ((handler cert-regen-handler)) + (let* ((object-id-string (first (decoded-handler-path handler))) (object (store-object-with-id (parse-integer object-id-string)))) (cond ((contract-p object) @@ -305,8 +304,8 @@ (first (sponsor-contracts object))) (t (error "invalid sponsor or contract id ~A" object-id-string))))) -(defmethod handle-object-form ((handler cert-regen-handler) action (contract contract) req) - (with-bos-cms-page (req :title (format nil "Re-generate Certificate~@[~*s~]" +(defmethod handle-object-form ((handler cert-regen-handler) action (contract contract)) + (with-bos-cms-page (:title (format nil "Re-generate Certificate~@[~*s~]" (not (contract-download-only-p contract)))) (html ((:form :name "form") @@ -322,10 +321,10 @@ (html (:tr (:td (submit-button "regenerate" "regenerate"))))))))) -(defmethod handle-object-form ((handler cert-regen-handler) (action (eql :regenerate)) (contract contract) req) - (with-query-params (req name address language) +(defmethod handle-object-form ((handler cert-regen-handler) (action (eql :regenerate)) (contract contract)) + (with-query-params (name address language) (contract-issue-cert contract name :address address :language language)) - (with-bos-cms-page (req :title "Certificate has been recreated") + (with-bos-cms-page (:title "Certificate has been recreated") (html "The certificates for the sponsor have been re-generated." :br) (unless (contract-download-only-p contract) (mail-print-pdf contract) Modified: branches/trunk-reorg/projects/bos/web/web-macros.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/web/web-macros.lisp (original) +++ branches/trunk-reorg/projects/bos/web/web-macros.lisp Mon Feb 11 12:24:41 2008 @@ -2,26 +2,25 @@ (enable-interpol-syntax) -(defmacro with-bos-cms-page ((req &key title response) &rest body) - `(with-bknr-page (,req :title ,title :response ,response) +(defmacro with-bos-cms-page ((&key title response) &rest body) + `(with-bknr-page (:title ,title :response ,response) ,@body)) (defvar *xml-sink*) (defmacro with-xml-response ((&key (content-type "text/xml") (root-element "response")) &body body) - `(with-http-response (*req* *ent* :content-type ,content-type) - (with-query-params (*req* download) + `(with-http-response (:content-type ,content-type) + (with-query-params (download) (when download - (setf (reply-header-slot-value *req* :content-disposition) - (format nil "attachment; filename=~A" download)))) - (with-http-body (*req* *ent*) - (let ((*xml-sink* (make-character-stream-sink net.html.generator:*html-stream* :canonical nil))) + (setf (hunchentoot:header-out :content-disposition) + (format nil "attachment; filename=~A" download)))) + (with-http-body () + (let ((*xml-sink* (make-character-stream-sink xhtml-generator:*html-sink* :canonical nil))) (with-xml-output *xml-sink* (with-element ,root-element ,@body)))))) -(defmacro with-xml-error-handler (req &body body) - (declare (ignore req)) +(defmacro with-xml-error-handler (() &body body) `(handler-case (progn ,@body) (error (e) @@ -29,3 +28,5 @@ (with-element "status" (attribute "failure" 1) (text (princ-to-string e))))))) + + Modified: branches/trunk-reorg/projects/bos/web/web-utils.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/web/web-utils.lisp (original) +++ branches/trunk-reorg/projects/bos/web/web-utils.lisp Mon Feb 11 12:24:41 2008 @@ -46,20 +46,20 @@ (setf (session-variable :language) *default-language*)) (session-variable :language)) -(defun content-language-chooser (req) +(defun content-language-chooser () (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" (uri-path (request-uri req)) language-symbol) + (html (cmslink (format nil "~A?language=~A" (uri-path (hunchentoot:request-uri)) language-symbol) (:princ-safe language-name))))) (if (equal (session-variable :language) language-symbol) (html "[" (show-language-link) "]") (html (show-language-link))) (html " ")))))) -(defun decode-ismap-query-string (req) +(defun decode-ismap-query-string () (let ((coord-string (caar (request-query req)))) (when (and coord-string (scan #?r"^\d*,\d*$" coord-string)) (mapcar #'parse-integer (split "," coord-string))))) 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 Mon Feb 11 12:24:41 2008 @@ -53,7 +53,7 @@ "index" template-name))))) (call-next-method handler template-name)) -(defmethod initial-template-environment ((expander worldpay-template-handler) req) +(defmethod initial-template-environment ((expander worldpay-template-handler)) (append (list (cons :website-url *website-url*)) (call-next-method))) @@ -74,7 +74,7 @@ (when (website-supports-language language) language))) -(defun find-browser-prefered-language (req) +(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." @@ -99,42 +99,41 @@ (defclass index-handler (page-handler) ()) -(defmethod handle ((handler index-handler) req) - (redirect (format nil "/~A/index" (or (find-browser-prefered-language req) +(defmethod handle ((handler index-handler)) + (redirect (format nil "/~A/index" (or (find-browser-prefered-language) *default-language*)) - req - *response-moved-permanently*)) + :permanently *response-moved-permanently*)) (defclass infosystem-handler (page-handler) ()) -(defmethod handle ((handler infosystem-handler) req) +(defmethod handle ((handler infosystem-handler)) ;; XXX hier logout-parameter implementieren - (with-query-params (req logout) + (with-query-params (logout) (when logout - (bknr.web::drop-session (bknr-request-session req)))) + (bknr.web::drop-session *session*))) (let ((language (session-variable :language))) - (redirect #?"/infosystem/$(language)/satellitenkarte.htm" req))) + (redirect #?"/infosystem/$(language)/satellitenkarte.htm"))) (defclass certificate-handler (object-handler) () (:default-initargs :class 'contract)) -(defmethod handle-object ((handler certificate-handler) contract req) +(defmethod handle-object ((handler certificate-handler) contract) (unless contract - (setf contract (find-if #'contract-pdf-pathname (sponsor-contracts (bknr-request-user req))))) - (redirect (format nil "/certificates/~D.pdf" (store-object-id contract)) req)) + (setf contract (find-if #'contract-pdf-pathname (sponsor-contracts bknr.web:*user*)))) + (redirect (format nil "/certificates/~D.pdf" (store-object-id contract)))) (defclass statistics-handler (editor-only-handler prefix-handler) ()) -(defmethod handle ((handler statistics-handler) req) +(defmethod handle ((handler statistics-handler)) (let ((stats-name (parse-url req))) (cond (stats-name - (redirect (format nil "~A.svg" stats-name) req)) + (redirect (format nil "~A.svg" stats-name))) (t - (with-bos-cms-page (req :title "Statistics browser") + (with-bos-cms-page (:title "Statistics browser") (:p ((:select :id "selector" :onchange "return statistic_selected()") (dolist (file (directory (merge-pathnames #p"images/statistics/*.svg" *website-directory*))) @@ -146,15 +145,15 @@ (defclass admin-handler (editor-only-handler page-handler) ()) -(defmethod handle ((handler admin-handler) req) - (with-bos-cms-page (req :title "CMS and Administration") +(defmethod handle ((handler admin-handler)) + (with-bos-cms-page (:title "CMS and Administration") "Please choose an administration activity from the menu above")) (defclass bos-authorizer (bknr-authorizer) ()) -(defmethod find-user-from-request-parameters ((authorizer bos-authorizer) req) - (with-query-params (req __sponsorid __password) +(defmethod find-user-from-request-parameters ((authorizer bos-authorizer)) + (with-query-params (__sponsorid __password) (if (and __sponsorid __password) (handler-case (let ((sponsor (find-store-object (parse-integer __sponsorid) :class 'sponsor))) @@ -172,13 +171,13 @@ (defmethod authorize :after ((authorizer bos-authorizer) (req http-request) (ent net.aserve::entity)) - (let ((new-language (or (language-from-url (uri-path (request-uri req))) + (let ((new-language (or (language-from-url (uri-path (hunchentoot:request-uri))) (query-param req "language"))) - (current-language (gethash :language (bknr-session-variables (bknr-request-session req))))) + (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 (bknr-request-session req))) + (setf (gethash :language (bknr-session-variables *session*)) (or new-language (find-browser-prefered-language req) *default-language*)))))
participants (1)
-
ksprotte＠common-lisp.net