Changeset 2484
- Timestamp:
- 02/12/08 17:58:31 (1 year ago)
- Files:
-
- branches/trunk-reorg/projects/bos/m2/m2.lisp (modified) (1 diff)
- branches/trunk-reorg/projects/bos/m2/mail-generator.lisp (modified) (4 diffs)
- branches/trunk-reorg/projects/bos/m2/utils.lisp (modified) (1 diff)
- branches/trunk-reorg/projects/bos/web/allocation-area-handlers.lisp (modified) (2 diffs)
- branches/trunk-reorg/projects/bos/web/map-browser-handler.lisp (modified) (3 diffs)
- branches/trunk-reorg/projects/bos/web/map-handlers.lisp (modified) (3 diffs)
- branches/trunk-reorg/projects/bos/web/news-handlers.lisp (modified) (3 diffs)
- branches/trunk-reorg/projects/bos/web/news-tags.lisp (modified) (2 diffs)
- branches/trunk-reorg/projects/bos/web/poi-handlers.lisp (modified) (9 diffs)
- branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp (modified) (1 diff)
- branches/trunk-reorg/projects/bos/web/startup.lisp (modified) (1 diff)
- branches/trunk-reorg/projects/bos/web/tags.lisp (modified) (4 diffs)
- branches/trunk-reorg/projects/bos/web/web-utils.lisp (modified) (2 diffs)
- branches/trunk-reorg/projects/bos/web/webserver.lisp (modified) (7 diffs)
Legend:
- Unmodified
- Added
- Removed
- Modified
- Copied
- Moved
branches/trunk-reorg/projects/bos/m2/m2.lisp
r2479 r2484 447 447 retval)) 448 448 449 ;; trunk-reorg adaption 450 ;; (defun string-safe (string) 451 ;; (if string 452 ;; (escape-nl (with-output-to-string (s) 453 ;; (net.html.generator::emit-safe s string))) 454 ;; "")) 449 (defun string-safe (string) 450 (if string 451 (escape-nl (arnesi:escape-as-html string)) 452 "")) 455 453 456 454 (defun make-m2-javascript (sponsor) branches/trunk-reorg/projects/bos/m2/mail-generator.lisp
r2479 r2484 276 276 country 277 277 language)) 278 (make-contract-xml-part (store-object-id contract) (all-request-params req))278 (make-contract-xml-part (store-object-id contract) (all-request-params)) 279 279 (make-vcard-part (store-object-id contract) 280 280 (make-vcard :sponsor-id (store-object-id (contract-sponsor contract)) … … 294 294 (mail-contract-data contract "Manually entered sponsor" parts)))) 295 295 296 (defun mail-manual-sponsor-data ( req)296 (defun mail-manual-sponsor-data () 297 297 (with-query-params (contract-id vorname name strasse plz ort email telefon want-print donationcert-yearly) 298 298 (let* ((contract (store-object-with-id (parse-integer contract-id))) … … 328 328 (if donationcert-yearly "yes" "no") 329 329 *website-url* contract-id email)) 330 (make-contract-xml-part contract-id (all-request-params req))330 (make-contract-xml-part contract-id (all-request-params)) 331 331 (make-vcard-part contract-id (make-vcard :sponsor-id sponsor-id 332 332 :note (format nil "Paid-by: Manual money transfer … … 363 363 (error "cannot find WorldPay callback params for contract ~A~%" contract-id))) 364 364 365 (defun mail-worldpay-sponsor-data ( req)365 (defun mail-worldpay-sponsor-data () 366 366 (with-query-params (contract-id) 367 367 (let* ((contract (store-object-with-id (parse-integer contract-id))) branches/trunk-reorg/projects/bos/m2/utils.lisp
r1228 r2484 7 7 (regex-replace-all #?r"[\n\r]+" string #?"<br />") 8 8 "")) 9 10 (defun random-elt (choices) 11 (when choices 12 (elt choices (random (length choices))))) branches/trunk-reorg/projects/bos/web/allocation-area-handlers.lisp
r2481 r2484 146 146 (uriencode-string "Choose lower right point of allocation area") 147 147 (uriencode-string (format nil "~A?left=~A&top=~A&" 148 ( uri-path (hunchentoot:request-uri))148 (hunchentoot:request-uri) 149 149 x y))))) 150 150 (t … … 167 167 start-x start-y 168 168 (uriencode-string "Choose upper left point of allocation area") 169 (uriencode-string (format nil "~A?" ( uri-path (hunchentoot:request-uri))))))))169 (uriencode-string (format nil "~A?" (hunchentoot:request-uri))))))) 170 170 171 171 (defmethod handle-form ((handler create-allocation-area-handler) (action (eql :upload))) branches/trunk-reorg/projects/bos/web/map-browser-handler.lisp
r2479 r2484 42 42 (with-query-params (chosen-url) 43 43 (when chosen-url 44 (setf ( session-variable :chosen-url) chosen-url)))44 (setf (hunchentoot:session-value :chosen-url) chosen-url))) 45 45 (with-query-params (view-x view-y) 46 46 (destructuring-bind (&optional click-x click-y) (decode-ismap-query-string) … … 48 48 (with-query-params (action) 49 49 (when (equal action "save") 50 (if ( session-variable :chosen-url)50 (if (hunchentoot:session-value :chosen-url) 51 51 (redirect (format nil "~Ax=~D&y=~D" 52 ( session-variable :chosen-url)52 (hunchentoot:session-value :chosen-url) 53 53 point-x 54 54 point-y)) … … 131 131 :style #?"position:absolute; left:$(cursor-x)px; top:$(cursor-y)px; visibility:visible") 132 132 ((:img :src "/images/map-cursor.png"))))))) 133 (map-navigator reqpoint-x point-y "/map-browser/" :formcheck "return updateCoords();")))133 (map-navigator point-x point-y "/map-browser/" :formcheck "return updateCoords();"))) 134 134 (t 135 135 (with-bos-cms-page (:title "Map Point Chooser") branches/trunk-reorg/projects/bos/web/map-handlers.lisp
r2481 r2484 3 3 (enable-interpol-syntax) 4 4 5 (defun map-navigator ( reqx y base-url &key formcheck)5 (defun map-navigator (x y base-url &key formcheck) 6 6 (labels ((pfeil-image (name) 7 7 (html ((:img :border "0" :width "16" :height "16" :src (format nil "/images/~:[trans.gif~;~:*pfeil-~A.gif~]" name))))) … … 70 70 71 71 ;; trunk-reorg adaption 72 ;;(defmethod handle-object ((handler image-tile-handler) tile)73 ;;;; xxx parse url another time - the parse result of74 ;;;; object-handler-get-object should really be kept in the request75 ;;(destructuring-bind (x y &rest operation-strings) (decoded-handler-path handler)76 ;;(declare (ignore x y))77 ;;(let ((changed-time (image-tile-changed-time tile))78 ;; (ims (header-slot-value req:if-modified-since)))79 ;;(format t "Warning: not setting last-modified of *ent* to changed-time")80 ;;#+(or)81 ;;(format t "; image-tile-handler handle-object: changed-time: ~A if-modified-since: ~A~%" (format-date-time changed-time) ims)82 ;;(if (or (not ims)83 ;;(> changed-time (date-to-universal-time ims)))84 ;;(let ((image (image-tile-image tile (apply #'parse-operations operation-strings))))85 ;;(emit-image-to-browser image :png86 ;;:date changed-time87 ;;:max-age 60)88 ;;(cl-gd:destroy-image image))89 ;; (with-http-response (*ent*)90 ;;(with-http-body ()91 ;;; do nothing92 ;;))))))72 (defmethod handle-object ((handler image-tile-handler) tile) 73 ;; xxx parse url another time - the parse result of 74 ;; object-handler-get-object should really be kept in the request 75 (destructuring-bind (x y &rest operation-strings) (decoded-handler-path handler) 76 (declare (ignore x y)) 77 (let ((changed-time (image-tile-changed-time tile)) 78 (ims (hunchentoot:header-in :if-modified-since))) 79 (format t "Warning: not setting last-modified of *ent* to changed-time") 80 #+(or) 81 (format t "; image-tile-handler handle-object: changed-time: ~A if-modified-since: ~A~%" (format-date-time changed-time) ims) 82 (if (or (not ims) 83 (> changed-time (date-to-universal-time ims))) 84 (let ((image (image-tile-image tile (apply #'parse-operations operation-strings)))) 85 (emit-image-to-browser image :png 86 :date changed-time 87 :max-age 60) 88 (cl-gd:destroy-image image)) 89 (with-http-response () 90 (with-http-body () 91 ;; do nothing 92 )))))) 93 93 94 94 (defclass enlarge-tile-handler (image-tile-handler) … … 108 108 (tile-active-layers-from-request-params tile))) 109 109 110 ;; trunk-reorg adaption 111 ;; (defmethod handle-object ((handler enlarge-tile-handler) tile) 112 ;; (let ((ismap-coords (decode-ismap-query-string req)) 113 ;; (tile-x (tile-nw-x tile)) 114 ;; (tile-y (tile-nw-y tile))) 115 ;; (if ismap-coords 116 ;; (let* ((x (+ (floor (first ismap-coords) 4) tile-x)) 117 ;; (y (+ (floor (second ismap-coords) 4) tile-y)) 118 ;; (m2 (get-m2 x y)) 119 ;; (contract-id (and m2 (m2-contract m2) (store-object-id (m2-contract m2))))) 120 ;; (if contract-id 121 ;; (redirect #?"/contract/$(contract-id)") 122 ;; (with-bos-cms-page (:title "Not sold") 123 ;; (html (:h2 "this square meter has not been sold yet"))))) 124 ;; (with-bos-cms-page (:title "Browsing tile") 125 ;; (:a ((:a :href (uri-path (hunchentoot:request-uri))) 126 ;; ((:img :width "360" :ismap "ismap" :height "360" :border "0" :src (tile-url tile tile-x tile-y req))))) 127 ;; (map-navigator req tile-x tile-y "/enlarge-overview/"))))) 110 (defmethod handle-object ((handler enlarge-tile-handler) tile) 111 (let ((ismap-coords (decode-ismap-query-string)) 112 (tile-x (tile-nw-x tile)) 113 (tile-y (tile-nw-y tile))) 114 (if ismap-coords 115 (let* ((x (+ (floor (first ismap-coords) 4) tile-x)) 116 (y (+ (floor (second ismap-coords) 4) tile-y)) 117 (m2 (get-m2 x y)) 118 (contract-id (and m2 (m2-contract m2) (store-object-id (m2-contract m2))))) 119 (if contract-id 120 (redirect #?"/contract/$(contract-id)") 121 (with-bos-cms-page (:title "Not sold") 122 (html (:h2 "this square meter has not been sold yet"))))) 123 (with-bos-cms-page (:title "Browsing tile") 124 (:a ((:a :href (hunchentoot:request-uri)) 125 ((:img :width "360" :ismap "ismap" :height "360" :border "0" :src (tile-url tile tile-x tile-y))))) 126 (map-navigator tile-x tile-y "/enlarge-overview/"))))) 128 127 branches/trunk-reorg/projects/bos/web/news-handlers.lisp
r2479 r2484 11 11 12 12 (defmethod handle-object-form ((handler edit-news-handler) action (news-item (eql nil))) 13 (let ((language ( session-variable :language)))13 (let ((language (hunchentoot:session-value :language))) 14 14 (with-bos-cms-page (:title "Edit news items") 15 15 (content-language-chooser) … … 34 34 35 35 (defmethod handle-object-form ((handler edit-news-handler) action news-item) 36 (let ((language ( session-variable :language)))36 (let ((language (hunchentoot:session-value :language))) 37 37 (with-bos-cms-page (:title "Edit news item") 38 38 (content-language-chooser) … … 50 50 51 51 (defmethod handle-object-form ((handler edit-news-handler) (action (eql :save)) news-item) 52 (let ((language ( session-variable :language)))52 (let ((language (hunchentoot:session-value :language))) 53 53 (with-query-params (title text) 54 54 (update-news-item news-item language :title title :text text) branches/trunk-reorg/projects/bos/web/news-tags.lisp
r2343 r2484 8 8 9 9 (define-bknr-tag news-headlines (&key archive) 10 (let ((language ( session-variable :language)))10 (let ((language (hunchentoot:session-value :language))) 11 11 (let* ((now (get-universal-time)) 12 (news-items ( subseq13 (sort (if archive 14 (all-news-items language) 15 (remove-if#'(lambda (news-item)16 (> (- now (news-item-time news-item)) *maximum-news-item-age*))17 (all-news-items language)))18 #'>19 :key #'news-item-time)20 0 (unless archive 3))))12 (news-items (if archive 13 (all-news-items language) 14 (let ((items (sort (remove-if 15 #'(lambda (news-item) 16 (> (- now (news-item-time news-item)) *maximum-news-item-age*)) 17 (all-news-items language)) 18 #'> 19 :key #'news-item-time))) 20 (subseq items 0 (min (length items) 3)))))) 21 21 (labels ((show-news-entry (news-item) 22 22 (html ((:a :href (format nil "javascript:window_news('news/~a')" (store-object-id news-item)) … … 26 26 (:princ-safe (news-item-title news-item language))))))) 27 27 (loop for news-item in news-items 28 for index from 129 do (if archive30 (html (show-news-entry news-item)31 :br :br)32 (html ((:div :id (format nil "newsbox~a" index))33 (show-news-entry news-item)))))))))28 for index from 1 29 do (if archive 30 (html (show-news-entry news-item) 31 :br :br) 32 (html ((:div :id (format nil "newsbox~a" index)) 33 (show-news-entry news-item))))))))) 34 34 35 35 (define-bknr-tag news-item () 36 36 (let ((news-item (find-store-object (parse-integer (nth-value 1 (parse-url (get-template-var :request)))))) 37 (language ( session-variable :language)))37 (language (hunchentoot:session-value :language))) 38 38 (html ((:h1 :class "extra") 39 39 (:princ-safe (format-date-time (news-item-time news-item) :show-time nil)) branches/trunk-reorg/projects/bos/web/poi-handlers.lisp
r2479 r2484 19 19 "Please use only alphanumerical characters, - and _ for technical POI names"))) 20 20 (t 21 (redirect (edit-object-url (make-poi ( session-variable :language) name)))))))21 (redirect (edit-object-url (make-poi (hunchentoot:session-value :language) name))))))) 22 22 23 23 (defclass edit-poi-handler (editor-only-handler edit-object-handler) … … 35 35 (:princ-safe (poi-name poi)) 36 36 " - " 37 (:princ-safe (slot-string poi 'title ( session-variable :language)))))))))37 (:princ-safe (slot-string poi 'title (hunchentoot:session-value :language))))))))) 38 38 (html (:h2 "No POIs created yet"))) 39 39 ((:form :method "post" :action "/make-poi") … … 53 53 action (poi poi)) 54 54 (with-query-params (language shift shift-by) 55 (unless language (setq language ( session-variable :language)))55 (unless language (setq language (hunchentoot:session-value :language))) 56 56 (when shift 57 57 ;; change image order … … 66 66 (setf (nth (+ shift-by old-position) new-images) tmp) 67 67 (change-slot-values poi 'bos.m2::images new-images))) 68 (setf ( session-variable :language) language)68 (setf (hunchentoot:session-value :language) language) 69 69 (with-bos-cms-page (:title "Edit POI") 70 70 (content-language-chooser) … … 96 96 (cmslink (format nil "map-browser/~A/~A?chosen-url=~A" 97 97 (first (poi-area poi)) (second (poi-area poi)) 98 (uriencode-string (format nil "~A?action=save&" ( uri-path (hunchentoot:request-uri)))))98 (uriencode-string (format nil "~A?action=save&" (hunchentoot:request-uri)))) 99 99 "[relocate]")) 100 100 (t 101 101 (cmslink (format nil "map-browser/?chosen-url=~A" 102 (uriencode-string (format nil "~A?action=save&" ( uri-path (hunchentoot:request-uri)))))102 (uriencode-string (format nil "~A?action=save&" (hunchentoot:request-uri)))) 103 103 "[choose]"))))) 104 104 (:tr (:td "icon") … … 170 170 (action (eql :save)) (poi poi)) 171 171 (with-query-params (published title subtitle description language x y icon movie) 172 (unless language (setq language ( session-variable :language)))172 (unless language (setq language (hunchentoot:session-value :language))) 173 173 (let ((args (list :title title 174 174 :published published … … 302 302 (defmethod handle-object-form ((handler edit-poi-image-handler) action poi-image) 303 303 (with-query-params (language poi) 304 (unless language (setq language ( session-variable :language)))304 (unless language (setq language (hunchentoot:session-value :language))) 305 305 (with-bos-cms-page (:title "Edit POI Image") 306 306 (html … … 332 332 (defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :save)) poi-image) 333 333 (with-query-params (title subtitle description language) 334 (unless language (setq language ( session-variable :language)))334 (unless language (setq language (hunchentoot:session-value :language))) 335 335 (update-poi-image poi-image language 336 336 :title title … … 367 367 (let ((*standard-output* *html-stream*)) 368 368 (princ "<script language=\"JavaScript\">") (terpri) 369 (princ (make-poi-javascript (or ( session-variable :language) *default-language*))) (terpri)369 (princ (make-poi-javascript (or (hunchentoot:session-value :language) *default-language*))) (terpri) 370 370 (princ "parent.poi_fertig(pois, anzahlSponsoren, anzahlVerkauft);") (terpri) 371 371 (format t "parent.last_sponsors([~{~A~^,~%~}]);" (mapcar #'contract-js (last-paid-contracts))) branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp
r2481 r2484 193 193 (unless changed 194 194 (html (:p "No changes have been made"))) 195 (html (cmslink ( uri-path (hunchentoot:request-uri))195 (html (cmslink (hunchentoot:request-uri) 196 196 "Return to sponsor profile"))))) 197 197 branches/trunk-reorg/projects/bos/web/startup.lisp
r2481 r2484 37 37 (defun reinit (&key debug) 38 38 (format t "~&; Publishing BOS handlers.~%") 39 (unpublish :all t)39 (unpublish) 40 40 (bos.web::publish-website :website-directory *website-directory* 41 41 :vhosts *vhosts* 42 42 :website-url *website-url* 43 43 :worldpay-test-mode *worldpay-test-mode*) 44 (format t "~&; Starting aserve~@[ in debug mode~].~%" debug)44 (format t "~&; Starting hunchentoot~@[ in debug mode~].~%" debug) 45 45 (force-output) 46 46 (setq hunchentoot:*catch-errors-p* (not debug)) 47 (hunchentoot:start-server :port *port*)) 47 (when *webserver* 48 (hunchentoot:stop-server *webserver*)) 49 (setf *hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf)) 50 (setq *webserver* (hunchentoot:start-server :port *port*))) branches/trunk-reorg/projects/bos/web/tags.lisp
r2426 r2484 42 42 (when (equal want-print "no") 43 43 (contract-set-download-only-p contract t)) 44 (contract-issue-cert contract name :address address :language ( session-variable :language))44 (contract-issue-cert contract name :address address :language (hunchentoot:session-value :language)) 45 45 (mail-worldpay-sponsor-data (get-template-var :request)) 46 46 (bknr.web::redirect-request :target (if gift "index" … … 79 79 (scan #?r"rweisung" action) 80 80 (scan #?r"verf" action))) 81 (language ( session-variable :language))81 (language (hunchentoot:session-value :language)) 82 82 (sponsor (make-sponsor :language language)) 83 83 (contract (make-contract sponsor numsqm … … 121 121 122 122 (define-bknr-tag mail-transfer () 123 (with-query-params ((get-template-var :request) 124 country 123 (with-query-params (country 125 124 contract-id 126 125 name vorname strasse plz ort) … … 135 134 strasse 136 135 plz ort) 137 :language ( session-variable :language))136 :language (hunchentoot:session-value :language)) 138 137 (mail-manual-sponsor-data (get-template-var :request))))) 139 138 branches/trunk-reorg/projects/bos/web/web-utils.lisp
r2479 r2484 43 43 44 44 (defun current-website-language () 45 (unless ( session-variable :language)46 (setf ( session-variable :language) *default-language*))47 ( session-variable :language))45 (unless (hunchentoot:session-value :language) 46 (setf (hunchentoot:session-value :language) *default-language*)) 47 (hunchentoot:session-value :language)) 48 48 49 49 (defun content-language-chooser () … … 53 53 (loop for (language-symbol language-name) in (website-languages) 54 54 do (labels ((show-language-link () 55 (html (cmslink (format nil "~A?language=~A" ( uri-path (hunchentoot:request-uri)) language-symbol)55 (html (cmslink (format nil "~A?language=~A" (hunchentoot:request-uri) language-symbol) 56 56 (:princ-safe language-name))))) 57 (if (equal ( session-variable :language) language-symbol)57 (if (equal (hunchentoot:session-value :language) language-symbol) 58 58 (html "[" (show-language-link) "]") 59 59 (html (show-language-link))) branches/trunk-reorg/projects/bos/web/webserver.lisp
r2481 r2484 47 47 ((and (not (scan "/" template-name)) 48 48 (not (probe-file (merge-pathnames (make-pathname :name template-name :type "xml") 49 ( template-handler-destination handler)))))50 (setf template-name (format nil "~A/~A" (or (find-browser-prefered-language request)49 (bknr.web::template-expander-destination handler))))) 50 (setf template-name (format nil "~A/~A" (or (find-browser-prefered-language) 51 51 *default-language*) 52 52 (if (equal "" template-name) … … 79 79 present in the HTTP request. Header decoding is done according to RFC2616, considering individual 80 80 language preference weights." 81 (let ((accept-language (h eader-slot-value req:accept-language)))81 (let ((accept-language (hunchentoot:header-in :accept-language))) 82 82 (dolist (language (mapcar #'car 83 83 (sort (mapcar #'(lambda (language-spec-string) … … 103 103 (redirect (format nil "/~A/index" (or (find-browser-prefered-language) 104 104 *default-language*)) 105 :permanently *response-moved-permanently*))105 :permanently t)) 106 106 107 107 (defclass infosystem-handler (page-handler) … … 113 113 (when logout 114 114 (bknr.web::drop-session *session*))) 115 (let ((language ( session-variable :language)))115 (let ((language (hunchentoot:session-value :language))) 116 116 (redirect #?"/infosystem/$(language)/satellitenkarte.htm"))) 117 117 … … 173 173 ;; (req http-request) 174 174 ;; (ent net.aserve::entity)) 175 ;; (let ((new-language (or (language-from-url ( uri-path (hunchentoot:request-uri)))175 ;; (let ((new-language (or (language-from-url (hunchentoot:request-uri)) 176 176 ;; (query-param "language"))) 177 177 ;; (current-language (gethash :language (bknr-session-variables *session*)))) … … 181 181 ;; (setf (gethash :language (bknr-session-variables *session*)) 182 182 ;; (or new-language 183 ;; (find-browser-prefered-language req)183 ;; (find-browser-prefered-language) 184 184 ;; *default-language*))))) 185 186 ;;; TODOreorg 187 (defun publish-directory (&key prefix destination) 188 (push (hunchentoot:create-folder-dispatcher-and-handler prefix destination) hunchentoot:*dispatch-table*)) 185 189 186 190 (defun publish-website (&key website-directory website-url (worldpay-test-mode t) (vhosts :wild)) … … 232 236 ("/" worldpay-template-handler 233 237 :destination ,(namestring (merge-pathnames #p"templates/" website-directory)) 234 :command-packages (( :bos. :bos.web)235 ( :bknr. :bknr.web))))238 :command-packages (("http://headcraft.de/bos" . :bos.web) 239 ("http://bknr.net" . :bknr.web)))) 236 240 :modules '(user images stats) 237 241 :navigation '(("sponsor" . "edit-sponsor/")
