[bknr-cvs] r2479 - in branches/trunk-reorg/projects/bos: m2 web
ksprotte at common-lisp.net
ksprotte at common-lisp.net
Mon Feb 11 17:24:44 UTC 2008
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)
, at 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
, at body))))))
-(defmacro with-xml-error-handler (req &body body)
- (declare (ignore req))
+(defmacro with-xml-error-handler (() &body body)
`(handler-case
(progn , at 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*)))))
More information about the Bknr-cvs
mailing list