[bknr-cvs] r2484 - in branches/trunk-reorg/projects/bos: m2 web
ksprotte at common-lisp.net
ksprotte at common-lisp.net
Tue Feb 12 16:58:36 UTC 2008
Author: ksprotte
Date: Tue Feb 12 11:58:31 2008
New Revision: 2484
Modified:
branches/trunk-reorg/projects/bos/m2/m2.lisp
branches/trunk-reorg/projects/bos/m2/mail-generator.lisp
branches/trunk-reorg/projects/bos/m2/utils.lisp
branches/trunk-reorg/projects/bos/web/allocation-area-handlers.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/news-tags.lisp
branches/trunk-reorg/projects/bos/web/poi-handlers.lisp
branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp
branches/trunk-reorg/projects/bos/web/startup.lisp
branches/trunk-reorg/projects/bos/web/tags.lisp
branches/trunk-reorg/projects/bos/web/web-utils.lisp
branches/trunk-reorg/projects/bos/web/webserver.lisp
Log:
more changes for bos trunk-reorg
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 Tue Feb 12 11:58:31 2008
@@ -446,12 +446,10 @@
(incf retval (length (contract-m2s contract))))
retval))
-;; trunk-reorg adaption
-;; (defun string-safe (string)
-;; (if string
-;; (escape-nl (with-output-to-string (s)
-;; (net.html.generator::emit-safe s string)))
-;; ""))
+(defun string-safe (string)
+ (if string
+ (escape-nl (arnesi:escape-as-html 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 Tue Feb 12 11:58:31 2008
@@ -275,7 +275,7 @@
email
country
language))
- (make-contract-xml-part (store-object-id contract) (all-request-params req))
+ (make-contract-xml-part (store-object-id contract) (all-request-params))
(make-vcard-part (store-object-id contract)
(make-vcard :sponsor-id (store-object-id (contract-sponsor contract))
:note (format nil "Paid-by: Back office
@@ -293,7 +293,7 @@
:email email)))))
(mail-contract-data contract "Manually entered sponsor" parts))))
-(defun mail-manual-sponsor-data (req)
+(defun mail-manual-sponsor-data ()
(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)))
@@ -327,7 +327,7 @@
(if want-print "yes" "no")
(if donationcert-yearly "yes" "no")
*website-url* contract-id email))
- (make-contract-xml-part contract-id (all-request-params req))
+ (make-contract-xml-part contract-id (all-request-params))
(make-vcard-part contract-id (make-vcard :sponsor-id sponsor-id
:note (format nil "Paid-by: Manual money transfer
Contract ID: ~A
@@ -362,7 +362,7 @@
(remhash contract-id *worldpay-params-hash*))
(error "cannot find WorldPay callback params for contract ~A~%" contract-id)))
-(defun mail-worldpay-sponsor-data (req)
+(defun mail-worldpay-sponsor-data ()
(with-query-params (contract-id)
(let* ((contract (store-object-with-id (parse-integer contract-id)))
(params (get-worldpay-params contract-id))
Modified: branches/trunk-reorg/projects/bos/m2/utils.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/m2/utils.lisp (original)
+++ branches/trunk-reorg/projects/bos/m2/utils.lisp Tue Feb 12 11:58:31 2008
@@ -5,4 +5,8 @@
(defun escape-nl (string)
(if string
(regex-replace-all #?r"[\n\r]+" string #?"<br />")
- ""))
\ No newline at end of file
+ ""))
+
+(defun random-elt (choices)
+ (when choices
+ (elt choices (random (length choices)))))
\ No newline at end of file
Modified: branches/trunk-reorg/projects/bos/web/allocation-area-handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/allocation-area-handlers.lisp (original)
+++ branches/trunk-reorg/projects/bos/web/allocation-area-handlers.lisp Tue Feb 12 11:58:31 2008
@@ -145,7 +145,7 @@
x y
(uriencode-string "Choose lower right point of allocation area")
(uriencode-string (format nil "~A?left=~A&top=~A&"
- (uri-path (hunchentoot:request-uri))
+ (hunchentoot:request-uri)
x y)))))
(t
(with-bos-cms-page (:title "Create allocation area")
@@ -166,7 +166,7 @@
(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 (hunchentoot:request-uri))))))))
+ (uriencode-string (format nil "~A?" (hunchentoot:request-uri)))))))
(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))))
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 Tue Feb 12 11:58:31 2008
@@ -41,15 +41,15 @@
(defmethod handle ((handler map-browser-handler))
(with-query-params (chosen-url)
(when chosen-url
- (setf (session-variable :chosen-url) chosen-url)))
+ (setf (hunchentoot:session-value :chosen-url) chosen-url)))
(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)
+ (if (hunchentoot:session-value :chosen-url)
(redirect (format nil "~Ax=~D&y=~D"
- (session-variable :chosen-url)
+ (hunchentoot:session-value :chosen-url)
point-x
point-y))
(with-bos-cms-page (:title "Map Point Chooser")
@@ -130,7 +130,7 @@
((:div :id "cursor"
:style #?"position:absolute; left:$(cursor-x)px; top:$(cursor-y)px; visibility:visible")
((:img :src "/images/map-cursor.png")))))))
- (map-navigator req point-x point-y "/map-browser/" :formcheck "return updateCoords();")))
+ (map-navigator point-x point-y "/map-browser/" :formcheck "return updateCoords();")))
(t
(with-bos-cms-page (:title "Map Point Chooser")
(html
Modified: branches/trunk-reorg/projects/bos/web/map-handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/map-handlers.lisp (original)
+++ branches/trunk-reorg/projects/bos/web/map-handlers.lisp Tue Feb 12 11:58:31 2008
@@ -2,7 +2,7 @@
(enable-interpol-syntax)
-(defun map-navigator (req x y base-url &key formcheck)
+(defun map-navigator (x y base-url &key formcheck)
(labels ((pfeil-image (name)
(html ((:img :border "0" :width "16" :height "16" :src (format nil "/images/~:[trans.gif~;~:*pfeil-~A.gif~]" name)))))
(td-link-to (x y name &optional (link-format (concatenate 'string base-url "~D/~D")))
@@ -69,27 +69,27 @@
operation-strings))
;; 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 image :png
-;; :date changed-time
-;; :max-age 60)
-;; (cl-gd:destroy-image image))
-;; (with-http-response (*ent*)
-;; (with-http-body ()
-;; ; do nothing
-;; ))))))
+(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 (hunchentoot:header-in :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 image :png
+ :date changed-time
+ :max-age 60)
+ (cl-gd:destroy-image image))
+ (with-http-response ()
+ (with-http-body ()
+ ;; do nothing
+ ))))))
(defclass enlarge-tile-handler (image-tile-handler)
())
@@ -107,22 +107,21 @@
x y
(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)
+ (let ((ismap-coords (decode-ismap-query-string))
+ (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 (hunchentoot:request-uri))
+ ((:img :width "360" :ismap "ismap" :height "360" :border "0" :src (tile-url tile tile-x tile-y)))))
+ (map-navigator tile-x tile-y "/enlarge-overview/")))))
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 Tue Feb 12 11:58:31 2008
@@ -10,7 +10,7 @@
())
(defmethod handle-object-form ((handler edit-news-handler) action (news-item (eql nil)))
- (let ((language (session-variable :language)))
+ (let ((language (hunchentoot:session-value :language)))
(with-bos-cms-page (:title "Edit news items")
(content-language-chooser)
(:h2 "Create new item")
@@ -33,7 +33,7 @@
(redirect (format nil "/edit-news/~D" (store-object-id (make-news-item)))))
(defmethod handle-object-form ((handler edit-news-handler) action news-item)
- (let ((language (session-variable :language)))
+ (let ((language (hunchentoot:session-value :language)))
(with-bos-cms-page (:title "Edit news item")
(content-language-chooser)
((:script :type "text/javascript")
@@ -49,7 +49,7 @@
(: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)
- (let ((language (session-variable :language)))
+ (let ((language (hunchentoot:session-value :language)))
(with-query-params (title text)
(update-news-item news-item language :title title :text text)
(with-bos-cms-page (:title "News item updated")
Modified: branches/trunk-reorg/projects/bos/web/news-tags.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/news-tags.lisp (original)
+++ branches/trunk-reorg/projects/bos/web/news-tags.lisp Tue Feb 12 11:58:31 2008
@@ -7,17 +7,17 @@
do (html (:princ-safe line) :br)))
(define-bknr-tag news-headlines (&key archive)
- (let ((language (session-variable :language)))
+ (let ((language (hunchentoot:session-value :language)))
(let* ((now (get-universal-time))
- (news-items (subseq
- (sort (if archive
- (all-news-items language)
- (remove-if #'(lambda (news-item)
- (> (- now (news-item-time news-item)) *maximum-news-item-age*))
- (all-news-items language)))
- #'>
- :key #'news-item-time)
- 0 (unless archive 3))))
+ (news-items (if archive
+ (all-news-items language)
+ (let ((items (sort (remove-if
+ #'(lambda (news-item)
+ (> (- now (news-item-time news-item)) *maximum-news-item-age*))
+ (all-news-items language))
+ #'>
+ :key #'news-item-time)))
+ (subseq items 0 (min (length items) 3))))))
(labels ((show-news-entry (news-item)
(html ((:a :href (format nil "javascript:window_news('news/~a')" (store-object-id news-item))
:class "more")
@@ -25,16 +25,16 @@
:br
(:princ-safe (news-item-title news-item language)))))))
(loop for news-item in news-items
- for index from 1
- do (if archive
- (html (show-news-entry news-item)
- :br :br)
- (html ((:div :id (format nil "newsbox~a" index))
- (show-news-entry news-item)))))))))
+ for index from 1
+ do (if archive
+ (html (show-news-entry news-item)
+ :br :br)
+ (html ((:div :id (format nil "newsbox~a" index))
+ (show-news-entry news-item)))))))))
(define-bknr-tag news-item ()
(let ((news-item (find-store-object (parse-integer (nth-value 1 (parse-url (get-template-var :request))))))
- (language (session-variable :language)))
+ (language (hunchentoot:session-value :language)))
(html ((:h1 :class "extra")
(:princ-safe (format-date-time (news-item-time news-item) :show-time nil))
", "
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 Tue Feb 12 11:58:31 2008
@@ -18,7 +18,7 @@
(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)))))))
+ (redirect (edit-object-url (make-poi (hunchentoot:session-value :language) name)))))))
(defclass edit-poi-handler (editor-only-handler edit-object-handler)
()
@@ -34,7 +34,7 @@
do (html (:li (cmslink (edit-object-url poi)
(:princ-safe (poi-name poi))
" - "
- (:princ-safe (slot-string poi 'title (session-variable :language)))))))))
+ (:princ-safe (slot-string poi 'title (hunchentoot:session-value :language)))))))))
(html (:h2 "No POIs created yet")))
((:form :method "post" :action "/make-poi")
"Make new POI named "
@@ -52,7 +52,7 @@
(defmethod handle-object-form ((handler edit-poi-handler)
action (poi poi))
(with-query-params (language shift shift-by)
- (unless language (setq language (session-variable :language)))
+ (unless language (setq language (hunchentoot:session-value :language)))
(when shift
;; change image order
(setq shift (find-store-object (parse-integer shift)))
@@ -65,7 +65,7 @@
(setf (nth old-position new-images) (nth (+ shift-by old-position) new-images))
(setf (nth (+ shift-by old-position) new-images) tmp)
(change-slot-values poi 'bos.m2::images new-images)))
- (setf (session-variable :language) language)
+ (setf (hunchentoot:session-value :language) language)
(with-bos-cms-page (:title "Edit POI")
(content-language-chooser)
(unless (poi-complete poi language)
@@ -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 (hunchentoot:request-uri)))))
+ (uriencode-string (format nil "~A?action=save&" (hunchentoot:request-uri))))
"[relocate]"))
(t
(cmslink (format nil "map-browser/?chosen-url=~A"
- (uriencode-string (format nil "~A?action=save&" (uri-path (hunchentoot:request-uri)))))
+ (uriencode-string (format nil "~A?action=save&" (hunchentoot:request-uri))))
"[choose]")))))
(:tr (:td "icon")
(:td (icon-chooser "icon" (poi-icon poi))))
@@ -169,7 +169,7 @@
(defmethod handle-object-form ((handler edit-poi-handler)
(action (eql :save)) (poi poi))
(with-query-params (published title subtitle description language x y icon movie)
- (unless language (setq language (session-variable :language)))
+ (unless language (setq language (hunchentoot:session-value :language)))
(let ((args (list :title title
:published published
:subtitle subtitle
@@ -301,7 +301,7 @@
(defmethod handle-object-form ((handler edit-poi-image-handler) action poi-image)
(with-query-params (language poi)
- (unless language (setq language (session-variable :language)))
+ (unless language (setq language (hunchentoot:session-value :language)))
(with-bos-cms-page (:title "Edit POI Image")
(html
(cmslink (edit-object-url (poi-image-poi poi-image)) "Back to POI")
@@ -331,7 +331,7 @@
(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)))
+ (unless language (setq language (hunchentoot:session-value :language)))
(update-poi-image poi-image language
:title title
:subtitle subtitle
@@ -366,7 +366,7 @@
(with-http-body ()
(let ((*standard-output* *html-stream*))
(princ "<script language=\"JavaScript\">") (terpri)
- (princ (make-poi-javascript (or (session-variable :language) *default-language*))) (terpri)
+ (princ (make-poi-javascript (or (hunchentoot:session-value :language) *default-language*))) (terpri)
(princ "parent.poi_fertig(pois, anzahlSponsoren, anzahlVerkauft);") (terpri)
(format t "parent.last_sponsors([~{~A~^,~%~}]);" (mapcar #'contract-js (last-paid-contracts)))
(princ "</script>") (terpri)))))
Modified: branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp (original)
+++ branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp Tue Feb 12 11:58:31 2008
@@ -192,7 +192,7 @@
(html (:p "Changed contract status to \"paid\""))))
(unless changed
(html (:p "No changes have been made")))
- (html (cmslink (uri-path (hunchentoot:request-uri))
+ (html (cmslink (hunchentoot:request-uri)
"Return to sponsor profile")))))
(defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :delete)) sponsor)
Modified: branches/trunk-reorg/projects/bos/web/startup.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/startup.lisp (original)
+++ branches/trunk-reorg/projects/bos/web/startup.lisp Tue Feb 12 11:58:31 2008
@@ -36,12 +36,15 @@
(defun reinit (&key debug)
(format t "~&; Publishing BOS handlers.~%")
- (unpublish :all t)
+ (unpublish)
(bos.web::publish-website :website-directory *website-directory*
:vhosts *vhosts*
:website-url *website-url*
:worldpay-test-mode *worldpay-test-mode*)
- (format t "~&; Starting aserve~@[ in debug mode~].~%" debug)
+ (format t "~&; Starting hunchentoot~@[ in debug mode~].~%" debug)
(force-output)
(setq hunchentoot:*catch-errors-p* (not debug))
- (hunchentoot:start-server :port *port*))
+ (when *webserver*
+ (hunchentoot:stop-server *webserver*))
+ (setf *hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf))
+ (setq *webserver* (hunchentoot:start-server :port *port*)))
Modified: branches/trunk-reorg/projects/bos/web/tags.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/tags.lisp (original)
+++ branches/trunk-reorg/projects/bos/web/tags.lisp Tue Feb 12 11:58:31 2008
@@ -41,7 +41,7 @@
(let ((contract (find-store-object (parse-integer (get-template-var :contract-id)))))
(when (equal want-print "no")
(contract-set-download-only-p contract t))
- (contract-issue-cert contract name :address address :language (session-variable :language))
+ (contract-issue-cert contract name :address address :language (hunchentoot:session-value :language))
(mail-worldpay-sponsor-data (get-template-var :request))
(bknr.web::redirect-request :target (if gift "index"
(format nil "profil_setup?name=~A&email=~A&sponsor-id=~A"
@@ -78,7 +78,7 @@
(manual-transfer (or (scan #?r"rweisen" action)
(scan #?r"rweisung" action)
(scan #?r"verf" action)))
- (language (session-variable :language))
+ (language (hunchentoot:session-value :language))
(sponsor (make-sponsor :language language))
(contract (make-contract sponsor numsqm
:download-only download-only
@@ -120,8 +120,7 @@
(bknr.web::redirect-request :target "allocation-areas-exhausted"))))
(define-bknr-tag mail-transfer ()
- (with-query-params ((get-template-var :request)
- country
+ (with-query-params (country
contract-id
name vorname strasse plz ort)
(let* ((contract (store-object-with-id (parse-integer contract-id)))
@@ -134,7 +133,7 @@
vorname name
strasse
plz ort)
- :language (session-variable :language))
+ :language (hunchentoot:session-value :language))
(mail-manual-sponsor-data (get-template-var :request)))))
(define-bknr-tag when-certificate (&key children)
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 Tue Feb 12 11:58:31 2008
@@ -42,9 +42,9 @@
(cadr (assoc language-short-name (website-languages) :test #'equal)))
(defun current-website-language ()
- (unless (session-variable :language)
- (setf (session-variable :language) *default-language*))
- (session-variable :language))
+ (unless (hunchentoot:session-value :language)
+ (setf (hunchentoot:session-value :language) *default-language*))
+ (hunchentoot:session-value :language))
(defun content-language-chooser ()
(html
@@ -52,9 +52,9 @@
"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 (hunchentoot:request-uri)) language-symbol)
+ (html (cmslink (format nil "~A?language=~A" (hunchentoot:request-uri) language-symbol)
(:princ-safe language-name)))))
- (if (equal (session-variable :language) language-symbol)
+ (if (equal (hunchentoot:session-value :language) language-symbol)
(html "[" (show-language-link) "]")
(html (show-language-link)))
(html " "))))))
Modified: branches/trunk-reorg/projects/bos/web/webserver.lisp
==============================================================================
--- branches/trunk-reorg/projects/bos/web/webserver.lisp (original)
+++ branches/trunk-reorg/projects/bos/web/webserver.lisp Tue Feb 12 11:58:31 2008
@@ -46,8 +46,8 @@
(setf template-name (if (and MC_gift (equal MC_gift "1")) #?"/$(lang)/versand_geschenk" #?"/$(lang)/versand_info")))))))
((and (not (scan "/" template-name))
(not (probe-file (merge-pathnames (make-pathname :name template-name :type "xml")
- (template-handler-destination handler)))))
- (setf template-name (format nil "~A/~A" (or (find-browser-prefered-language request)
+ (bknr.web::template-expander-destination handler)))))
+ (setf template-name (format nil "~A/~A" (or (find-browser-prefered-language)
*default-language*)
(if (equal "" template-name)
"index" template-name)))))
@@ -78,7 +78,7 @@
"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."
- (let ((accept-language (header-slot-value req :accept-language)))
+ (let ((accept-language (hunchentoot:header-in :accept-language)))
(dolist (language (mapcar #'car
(sort (mapcar #'(lambda (language-spec-string)
(if (find #\; language-spec-string)
@@ -102,7 +102,7 @@
(defmethod handle ((handler index-handler))
(redirect (format nil "/~A/index" (or (find-browser-prefered-language)
*default-language*))
- :permanently *response-moved-permanently*))
+ :permanently t))
(defclass infosystem-handler (page-handler)
())
@@ -112,7 +112,7 @@
(with-query-params (logout)
(when logout
(bknr.web::drop-session *session*)))
- (let ((language (session-variable :language)))
+ (let ((language (hunchentoot:session-value :language)))
(redirect #?"/infosystem/$(language)/satellitenkarte.htm")))
(defclass certificate-handler (object-handler)
@@ -172,7 +172,7 @@
;; (defmethod authorize :after ((authorizer bos-authorizer)
;; (req http-request)
;; (ent net.aserve::entity))
-;; (let ((new-language (or (language-from-url (uri-path (hunchentoot:request-uri)))
+;; (let ((new-language (or (language-from-url (hunchentoot:request-uri))
;; (query-param "language")))
;; (current-language (gethash :language (bknr-session-variables *session*))))
;; (when (or (not current-language)
@@ -180,9 +180,13 @@
;; (not (equal new-language current-language))))
;; (setf (gethash :language (bknr-session-variables *session*))
;; (or new-language
-;; (find-browser-prefered-language req)
+;; (find-browser-prefered-language)
;; *default-language*)))))
+;;; TODOreorg
+(defun publish-directory (&key prefix destination)
+ (push (hunchentoot:create-folder-dispatcher-and-handler prefix destination) hunchentoot:*dispatch-table*))
+
(defun publish-website (&key website-directory website-url (worldpay-test-mode t) (vhosts :wild))
(setf *website-directory* website-directory)
@@ -231,8 +235,8 @@
("/index" index-handler)
("/" worldpay-template-handler
:destination ,(namestring (merge-pathnames #p"templates/" website-directory))
- :command-packages ((:bos . :bos.web)
- (:bknr . :bknr.web))))
+ :command-packages (("http://headcraft.de/bos" . :bos.web)
+ ("http://bknr.net" . :bknr.web))))
:modules '(user images stats)
:navigation '(("sponsor" . "edit-sponsor/")
("statistics" . "statistics/")
@@ -256,4 +260,4 @@
(publish-directory :prefix "/infosystem/"
:destination (namestring (merge-pathnames "infosystem/" website-directory)))
(publish-directory :prefix "/certificates/"
- :destination (namestring *cert-download-directory*)))
+ :destination (namestring *cert-download-directory*)))
\ No newline at end of file
More information about the Bknr-cvs
mailing list