Changeset 2484

Show
Ignore:
Timestamp:
02/12/08 17:58:31 (1 year ago)
Author:
ksprotte
Message:

more changes for bos trunk-reorg

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved
  • branches/trunk-reorg/projects/bos/m2/m2.lisp

    r2479 r2484  
    447447    retval)) 
    448448 
    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      "")) 
    455453 
    456454(defun make-m2-javascript (sponsor) 
  • branches/trunk-reorg/projects/bos/m2/mail-generator.lisp

    r2479 r2484  
    276276                                               country 
    277277                                               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)) 
    279279                       (make-vcard-part (store-object-id contract) 
    280280                                        (make-vcard :sponsor-id (store-object-id (contract-sponsor contract)) 
     
    294294      (mail-contract-data contract "Manually entered sponsor" parts)))) 
    295295 
    296 (defun mail-manual-sponsor-data (req
     296(defun mail-manual-sponsor-data (
    297297  (with-query-params (contract-id vorname name strasse plz ort email telefon want-print donationcert-yearly) 
    298298    (let* ((contract (store-object-with-id (parse-integer contract-id))) 
     
    328328                                                (if donationcert-yearly "yes" "no") 
    329329                                                *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)) 
    331331                        (make-vcard-part contract-id (make-vcard :sponsor-id sponsor-id 
    332332                                                                 :note (format nil "Paid-by: Manual money transfer 
     
    363363      (error "cannot find WorldPay callback params for contract ~A~%" contract-id))) 
    364364 
    365 (defun mail-worldpay-sponsor-data (req
     365(defun mail-worldpay-sponsor-data (
    366366  (with-query-params (contract-id) 
    367367    (let* ((contract (store-object-with-id (parse-integer contract-id))) 
  • branches/trunk-reorg/projects/bos/m2/utils.lisp

    r1228 r2484  
    77      (regex-replace-all #?r"[\n\r]+" string #?"<br />") 
    88      "")) 
     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  
    146146                         (uriencode-string "Choose lower right point of allocation area") 
    147147                         (uriencode-string (format nil "~A?left=~A&top=~A&" 
    148                                                    (uri-path (hunchentoot:request-uri)
     148                                                   (hunchentoot:request-uri
    149149                                                   x y))))) 
    150150      (t 
     
    167167                      start-x start-y 
    168168                      (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))))))) 
    170170 
    171171(defmethod handle-form ((handler create-allocation-area-handler) (action (eql :upload))) 
  • branches/trunk-reorg/projects/bos/web/map-browser-handler.lisp

    r2479 r2484  
    4242  (with-query-params (chosen-url) 
    4343    (when chosen-url 
    44       (setf (session-variable :chosen-url) chosen-url))) 
     44      (setf (hunchentoot:session-value :chosen-url) chosen-url))) 
    4545  (with-query-params (view-x view-y) 
    4646    (destructuring-bind (&optional click-x click-y) (decode-ismap-query-string) 
     
    4848        (with-query-params (action) 
    4949          (when (equal action "save") 
    50             (if (session-variable :chosen-url) 
     50            (if (hunchentoot:session-value :chosen-url) 
    5151                (redirect (format nil "~Ax=~D&y=~D" 
    52                                   (session-variable :chosen-url) 
     52                                  (hunchentoot:session-value :chosen-url) 
    5353                                  point-x 
    5454                                  point-y)) 
     
    131131                                :style #?"position:absolute; left:$(cursor-x)px; top:$(cursor-y)px; visibility:visible") 
    132132                          ((:img :src "/images/map-cursor.png"))))))) 
    133                (map-navigator req point-x point-y "/map-browser/" :formcheck "return updateCoords();"))) 
     133               (map-navigator point-x point-y "/map-browser/" :formcheck "return updateCoords();"))) 
    134134            (t 
    135135             (with-bos-cms-page (:title "Map Point Chooser") 
  • branches/trunk-reorg/projects/bos/web/map-handlers.lisp

    r2481 r2484  
    33(enable-interpol-syntax) 
    44 
    5 (defun map-navigator (req x y base-url &key formcheck) 
     5(defun map-navigator (x y base-url &key formcheck) 
    66  (labels ((pfeil-image (name) 
    77             (html ((:img :border "0" :width "16" :height "16" :src (format nil "/images/~:[trans.gif~;~:*pfeil-~A.gif~]" name))))) 
     
    7070 
    7171;; trunk-reorg adaption 
    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 (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 :png 
    86 ;;                               :date changed-time 
    87 ;;                               :max-age 60) 
    88 ;;        (cl-gd:destroy-image image)) 
    89 ;;       (with-http-response (*ent*
    90 ;;        (with-http-body () 
    91 ;;           ; do nothing 
    92 ;;          )))))) 
     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            )))))) 
    9393 
    9494(defclass enlarge-tile-handler (image-tile-handler) 
     
    108108          (tile-active-layers-from-request-params tile))) 
    109109 
    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/"))))) 
    128127 
  • branches/trunk-reorg/projects/bos/web/news-handlers.lisp

    r2479 r2484  
    1111 
    1212(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))) 
    1414    (with-bos-cms-page (:title "Edit news items") 
    1515      (content-language-chooser) 
     
    3434 
    3535(defmethod handle-object-form ((handler edit-news-handler) action news-item) 
    36   (let ((language (session-variable :language))) 
     36  (let ((language (hunchentoot:session-value :language))) 
    3737    (with-bos-cms-page (:title "Edit news item") 
    3838      (content-language-chooser) 
     
    5050 
    5151(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))) 
    5353    (with-query-params (title text) 
    5454      (update-news-item news-item language :title title :text text) 
  • branches/trunk-reorg/projects/bos/web/news-tags.lisp

    r2343 r2484  
    88 
    99(define-bknr-tag news-headlines (&key archive) 
    10   (let ((language (session-variable :language))) 
     10  (let ((language (hunchentoot:session-value :language)))     
    1111    (let* ((now (get-universal-time)) 
    12            (news-items (subseq 
    13                         (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)))))) 
    2121      (labels ((show-news-entry (news-item) 
    2222                 (html ((:a :href (format nil "javascript:window_news('news/~a')" (store-object-id news-item)) 
     
    2626                                 (:princ-safe (news-item-title news-item language))))))) 
    2727        (loop for news-item in news-items 
    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))))))))) 
     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))))))))) 
    3434 
    3535(define-bknr-tag news-item () 
    3636  (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))) 
    3838    (html ((:h1 :class "extra") 
    3939           (:princ-safe (format-date-time (news-item-time news-item) :show-time nil)) 
  • branches/trunk-reorg/projects/bos/web/poi-handlers.lisp

    r2479 r2484  
    1919               "Please use only alphanumerical characters, - and _ for technical POI names"))) 
    2020      (t 
    21        (redirect (edit-object-url (make-poi (session-variable :language) name))))))) 
     21       (redirect (edit-object-url (make-poi (hunchentoot:session-value :language) name))))))) 
    2222 
    2323(defclass edit-poi-handler (editor-only-handler edit-object-handler) 
     
    3535                                (:princ-safe (poi-name poi)) 
    3636                                " - " 
    37                                 (:princ-safe (slot-string poi 'title (session-variable :language))))))))) 
     37                                (:princ-safe (slot-string poi 'title (hunchentoot:session-value :language))))))))) 
    3838        (html (:h2 "No POIs created yet"))) 
    3939    ((:form :method "post" :action "/make-poi") 
     
    5353                               action (poi poi)) 
    5454  (with-query-params (language shift shift-by) 
    55     (unless language (setq language (session-variable :language))) 
     55    (unless language (setq language (hunchentoot:session-value :language))) 
    5656    (when shift 
    5757      ;; change image order 
     
    6666        (setf (nth (+ shift-by old-position) new-images) tmp) 
    6767        (change-slot-values poi 'bos.m2::images new-images))) 
    68     (setf (session-variable :language) language) 
     68    (setf (hunchentoot:session-value :language) language) 
    6969    (with-bos-cms-page (:title "Edit POI") 
    7070      (content-language-chooser) 
     
    9696                     (cmslink (format nil "map-browser/~A/~A?chosen-url=~A" 
    9797                                      (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)))) 
    9999                       "[relocate]")) 
    100100                    (t 
    101101                     (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)))) 
    103103                       "[choose]"))))) 
    104104        (:tr (:td "icon") 
     
    170170                               (action (eql :save)) (poi poi)) 
    171171  (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))) 
    173173    (let ((args (list :title title 
    174174                      :published published 
     
    302302(defmethod handle-object-form ((handler edit-poi-image-handler) action poi-image) 
    303303  (with-query-params (language poi) 
    304     (unless language (setq language (session-variable :language))) 
     304    (unless language (setq language (hunchentoot:session-value :language))) 
    305305    (with-bos-cms-page (:title "Edit POI Image") 
    306306      (html 
     
    332332(defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :save)) poi-image) 
    333333  (with-query-params (title subtitle description language) 
    334     (unless language (setq language (session-variable :language))) 
     334    (unless language (setq language (hunchentoot:session-value :language))) 
    335335    (update-poi-image poi-image language 
    336336                      :title title 
     
    367367        (let ((*standard-output* *html-stream*)) 
    368368          (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) 
    370370          (princ "parent.poi_fertig(pois, anzahlSponsoren, anzahlVerkauft);") (terpri) 
    371371          (format t "parent.last_sponsors([~{~A~^,~%~}]);" (mapcar #'contract-js (last-paid-contracts))) 
  • branches/trunk-reorg/projects/bos/web/sponsor-handlers.lisp

    r2481 r2484  
    193193      (unless changed 
    194194        (html (:p "No changes have been made"))) 
    195       (html (cmslink (uri-path (hunchentoot:request-uri)
     195      (html (cmslink (hunchentoot:request-uri
    196196              "Return to sponsor profile"))))) 
    197197 
  • branches/trunk-reorg/projects/bos/web/startup.lisp

    r2481 r2484  
    3737(defun reinit (&key debug) 
    3838  (format t "~&; Publishing BOS handlers.~%") 
    39   (unpublish :all t
     39  (unpublish
    4040  (bos.web::publish-website :website-directory *website-directory* 
    4141                            :vhosts *vhosts* 
    4242                            :website-url *website-url* 
    4343                            :worldpay-test-mode *worldpay-test-mode*) 
    44   (format t "~&; Starting aserve~@[ in debug mode~].~%" debug) 
     44  (format t "~&; Starting hunchentoot~@[ in debug mode~].~%" debug) 
    4545  (force-output)   
    4646  (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  
    4242      (when (equal want-print "no") 
    4343        (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)) 
    4545      (mail-worldpay-sponsor-data (get-template-var :request)) 
    4646      (bknr.web::redirect-request :target (if gift "index" 
     
    7979                                    (scan #?r"rweisung" action) 
    8080                                    (scan #?r"verf" action))) 
    81                (language (session-variable :language)) 
     81               (language (hunchentoot:session-value :language)) 
    8282               (sponsor (make-sponsor :language language)) 
    8383               (contract (make-contract sponsor numsqm 
     
    121121 
    122122(define-bknr-tag mail-transfer () 
    123   (with-query-params ((get-template-var :request) 
    124                       country 
     123  (with-query-params (country 
    125124                      contract-id  
    126125                      name vorname strasse plz ort) 
     
    135134                                            strasse 
    136135                                            plz ort) 
    137                            :language (session-variable :language)) 
     136                           :language (hunchentoot:session-value :language)) 
    138137      (mail-manual-sponsor-data (get-template-var :request))))) 
    139138 
  • branches/trunk-reorg/projects/bos/web/web-utils.lisp

    r2479 r2484  
    4343 
    4444(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)) 
    4848 
    4949(defun content-language-chooser () 
     
    5353    (loop for (language-symbol language-name) in (website-languages) 
    5454          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) 
    5656                                (:princ-safe language-name))))) 
    57                (if (equal (session-variable :language) language-symbol) 
     57               (if (equal (hunchentoot:session-value :language) language-symbol) 
    5858                   (html "[" (show-language-link) "]") 
    5959                   (html (show-language-link))) 
  • branches/trunk-reorg/projects/bos/web/webserver.lisp

    r2481 r2484  
    4747    ((and (not (scan "/" template-name)) 
    4848          (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
    5151                                                 *default-language*) 
    5252                                 (if (equal "" template-name) 
     
    7979present in the HTTP request.  Header decoding is done according to RFC2616, considering individual 
    8080language preference weights." 
    81   (let ((accept-language (header-slot-value req :accept-language))) 
     81  (let ((accept-language (hunchentoot:header-in :accept-language))) 
    8282    (dolist (language (mapcar #'car 
    8383                              (sort (mapcar #'(lambda (language-spec-string) 
     
    103103  (redirect (format nil "/~A/index" (or (find-browser-prefered-language) 
    104104                                        *default-language*)) 
    105             :permanently *response-moved-permanently*)) 
     105            :permanently t)) 
    106106 
    107107(defclass infosystem-handler (page-handler) 
     
    113113    (when logout 
    114114      (bknr.web::drop-session *session*))) 
    115   (let ((language (session-variable :language))) 
     115  (let ((language (hunchentoot:session-value :language))) 
    116116    (redirect #?"/infosystem/$(language)/satellitenkarte.htm"))) 
    117117 
     
    173173;;                           (req http-request) 
    174174;;                           (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)) 
    176176;;                        (query-param "language"))) 
    177177;;      (current-language (gethash :language (bknr-session-variables *session*)))) 
     
    181181;;       (setf (gethash :language (bknr-session-variables *session*)) 
    182182;;          (or new-language 
    183 ;;              (find-browser-prefered-language req
     183;;              (find-browser-prefered-language
    184184;;              *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*)) 
    185189 
    186190(defun publish-website (&key website-directory website-url (worldpay-test-mode t) (vhosts :wild)) 
     
    232236                                        ("/" worldpay-template-handler 
    233237                                         :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)))) 
    236240                 :modules '(user images stats) 
    237241                 :navigation '(("sponsor" . "edit-sponsor/")