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