Changeset 2479

Show
Ignore:
Timestamp:
02/11/08 18:24:41 (1 year ago)
Author:
ksprotte
Message:

bos changes for trunk-reorg; unfinished, committed for backup

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

  • branches/trunk-reorg/projects/bos/m2/m2.lisp

    r2418 r2479  
    190190  ()) 
    191191 
    192 (defmethod bknr.web:authorized-p ((handler editor-only-handler) req) 
    193   (editor-p (bknr-request-user req))) 
     192(defmethod bknr.web:authorized-p ((handler editor-only-handler)) 
     193  (editor-p bknr.web:*user*)) 
    194194 
    195195;;;; CONTRACT 
    …… 
    447447    retval)) 
    448448 
    449 (defun string-safe (string) 
    450   (if string 
    451       (escape-nl (with-output-to-string (s) 
    452                    (net.html.generator::emit-safe s string))) 
    453       "")) 
     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;;       "")) 
    454455 
    455456(defun make-m2-javascript (sponsor) 

  • branches/trunk-reorg/projects/bos/m2/mail-generator.lisp

    r2405 r2479  
    252252    (delete-file (contract-pdf-pathname contract :print t)))) 
    253253 
    254 (defun mail-backoffice-sponsor-data (contract req) 
    255   (with-query-params (req numsqm country email name address date language) 
     254(defun mail-backoffice-sponsor-data (contract) 
     255  (with-query-params (numsqm country email name address date language) 
    256256    (let ((parts (list (make-html-part (format nil " 
    257257<html> 
    …… 
    295295 
    296296(defun mail-manual-sponsor-data (req) 
    297   (with-query-params (req contract-id vorname name strasse plz ort email telefon want-print donationcert-yearly) 
     297  (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))) 
    299299           (sponsor-id (store-object-id (contract-sponsor contract))) 
    …… 
    364364 
    365365(defun mail-worldpay-sponsor-data (req) 
    366   (with-query-params (req contract-id) 
     366  (with-query-params (contract-id) 
    367367    (let* ((contract (store-object-with-id (parse-integer contract-id))) 
    368368           (params (get-worldpay-params contract-id)) 

  • branches/trunk-reorg/projects/bos/m2/packages.lisp

    r2418 r2479  
    5555        :bknr.rss 
    5656        :bos.m2.config 
    57         :net.post-office 
     57        :cl-smtp 
    5858        :kmrcl 
    5959        :cxml 

  • branches/trunk-reorg/projects/bos/web/allocation-area-handlers.lisp

    r2401 r2479  
    77  ()) 
    88 
    9 (defmethod handle-object-form ((handler allocation-area-handler) action (allocation-area (eql nil)) req) 
    10   (with-bos-cms-page (req :title "Allocation Areas") 
     9(defmethod handle-object-form ((handler allocation-area-handler) action (allocation-area (eql nil))) 
     10  (with-bos-cms-page (:title "Allocation Areas") 
    1111    (html 
    1212     (:h2 "Defined allocation areas") 
    …… 
    2828     (:p (cmslink "create-allocation-area" "Create new allocation area"))))) 
    2929 
    30 (defmethod handle-object-form ((handler allocation-area-handler) action allocation-area req) 
    31   (with-bos-cms-page (req :title "Allocation Area") 
     30(defmethod handle-object-form ((handler allocation-area-handler) action allocation-area) 
     31  (with-bos-cms-page (:title "Allocation Area") 
    3232    (with-slots (active-p left top width height) allocation-area 
    3333      (html 
    …… 
    7676                                             ((:img :width "90" :height "90" :border "0" :src #?"/overview/$(tile-x)/$(tile-y)")))))))))))))) 
    7777 
    78 (defmethod handle-object-form ((handler allocation-area-handler) (action (eql :delete)) allocation-area req) 
     78(defmethod handle-object-form ((handler allocation-area-handler) (action (eql :delete)) allocation-area) 
    7979  (delete-object allocation-area) 
    80   (with-bos-cms-page (req :title "Allocation area has been deleted") 
     80  (with-bos-cms-page (:title "Allocation area has been deleted") 
    8181    (:h2 "The allocation area has been deleted"))) 
    8282 
    …… 
    8484  ()) 
    8585 
    86 (defmethod handle-object ((handler allocation-area-gfx-handler) allocation-area req) 
     86(defmethod handle-object ((handler allocation-area-gfx-handler) allocation-area) 
    8787  (cl-gd:with-image* ((allocation-area-width allocation-area) 
    8888                      (allocation-area-height allocation-area) t) 
    …… 
    129129  ()) 
    130130 
    131 (defmethod handle-form ((handler create-allocation-area-handler) action req) 
    132   (with-query-params (req x y left top) 
     131(defmethod handle-form ((handler create-allocation-area-handler) action) 
     132  (with-query-params (x y left top) 
    133133    (cond 
    134134      ((and x y left top) 
    …… 
    137137                   (<= x left) 
    138138                   (<= y top)) 
    139              (with-bos-cms-page (req :title "Invalid area selected") 
     139             (with-bos-cms-page (:title "Invalid area selected") 
    140140               (:h2 "Choose upper left corner first, then lower-right corner")) 
    141141             (redirect (format nil "/allocation-area/~D" (store-object-id 
    142                                                           (make-allocation-rectangle left top (- x left) (- y top)))) 
    143                    req)))) 
     142                                                          (make-allocation-rectangle left top (- x left) (- y top)))))))) 
    144143      ((and x y) 
    145144       (redirect (format nil "/map-browser/~A/~A?heading=~A&chosen-url=~A&" 
    …… 
    147146                         (uriencode-string "Choose lower right point of allocation area") 
    148147                         (uriencode-string (format nil "~A?left=~A&top=~A&" 
    149                                                    (uri-path (request-uri req)) 
    150                                                    x y))) 
    151                  req)) 
     148                                                   (uri-path (hunchentoot:request-uri)) 
     149                                                   x y))))) 
    152150      (t 
    153        (with-bos-cms-page (req :title "Create allocation area") 
     151       (with-bos-cms-page (:title "Create allocation area") 
    154152         ((:form :method "POST" :enctype "multipart/form-data")) 
    155153         ((:table :border "0") 
    …… 
    164162          (:tr (:td (submit-button "rectangle" "rectangle"))))))))) 
    165163 
    166 (defmethod handle-form ((handler create-allocation-area-handler) (action (eql :rectangle)) req) 
    167   (with-query-params (req start-x start-y) 
     164(defmethod handle-form ((handler create-allocation-area-handler) (action (eql :rectangle))) 
     165  (with-query-params (start-x start-y) 
    168166    (redirect (format nil "/map-browser/~A/~A?heading=~A&chosen-url=~A&" 
    169167                      start-x start-y 
    170168                      (uriencode-string "Choose upper left point of allocation area") 
    171                       (uriencode-string (format nil "~A?" (uri-path (request-uri req))))) 
    172               req))) 
    173  
    174 (defmethod handle-form ((handler create-allocation-area-handler) (action (eql :upload)) req) 
    175   (let ((uploaded-text-file (cdr (find "text-file" (request-uploaded-files req) :test #'equal :key #'car)))) 
     169                      (uriencode-string (format nil "~A?" (uri-path (hunchentoot:request-uri)))))))) 
     170 
     171(defmethod handle-form ((handler create-allocation-area-handler) (action (eql :upload))) 
     172  (let ((uploaded-text-file (cdr (find "text-file" (request-uploaded-files) :test #'equal :key #'car)))) 
    176173    (cond 
    177174      ((not uploaded-text-file) 
    178        (with-bos-cms-page (req :title "No Text file uploaded") 
     175       (with-bos-cms-page (:title "No Text file uploaded") 
    179176         (:h2 "File not uploaded") 
    180177         (:p "Please upload your text file containing the allocation polygon UTM coordinates"))) 
    181178      (t 
    182        (with-bos-cms-page (req :title #?"Importing allocation polygons from text file $(uploaded-text-file)") 
     179       (with-bos-cms-page (:title #?"Importing allocation polygons from text file $(uploaded-text-file)") 
    183180         (handler-case 
    184181             (let* ((vertices (polygon-from-text-file uploaded-text-file)) 

  • branches/trunk-reorg/projects/bos/web/allocation-cache-handlers.lisp

    r2383 r2479  
    66  ()) 
    77 
    8 (defmethod handle ((handler allocation-cache-handler) req) 
    9   (with-bos-cms-page (req :title "Allocation Cache") 
     8(defmethod handle ((handler allocation-cache-handler)) 
     9  (with-bos-cms-page (:title "Allocation Cache") 
    1010    (html 
    1111     (:pre (:princ 

  • branches/trunk-reorg/projects/bos/web/boi-handlers.lisp

    r2400 r2479  
    77  ()) 
    88 
    9 (defmethod authorized-p ((handler boi-handler) req) 
    10   (bos.m2:editor-p (bknr-request-user req))) 
     9(defmethod authorized-p ((handler boi-handler)) 
     10  (bos.m2:editor-p bknr.web:*user*)) 
    1111 
    1212(defclass create-contract-handler (boi-handler) 
    …… 
    2121    sponsor)) 
    2222 
    23 (defmethod handle ((handler create-contract-handler) req) 
    24   (with-xml-error-handler (req) 
    25     (with-query-params (req num-sqm country sponsor-id name paid expires) 
     23(defmethod handle ((handler create-contract-handler)) 
     24  (with-xml-error-handler () 
     25    (with-query-params (num-sqm country sponsor-id name paid expires) 
    2626      (setf num-sqm (ignore-errors (parse-integer num-sqm :junk-allowed t))) 
    2727      (unless num-sqm 
    …… 
    5454  ()) 
    5555 
    56 (defmethod handle ((handler pay-contract-handler) req) 
    57   (with-xml-error-handler (req) 
    58     (with-query-params (req contract-id name) 
     56(defmethod handle ((handler pay-contract-handler)) 
     57  (with-xml-error-handler () 
     58    (with-query-params (contract-id name) 
    5959      (unless contract-id 
    6060        (error "missing contract-id parameter")) 
    …… 
    6666          (contract-set-paidp contract (format nil "~A: manually set paid by ~A" 
    6767                                               (format-date-time) 
    68                                                (user-login (bknr-request-user req)))) 
     68                                               (user-login bknr.web:*user*))) 
    6969          (when name 
    7070            (setf (user-full-name (contract-sponsor contract)) name)))) 
    …… 
    7878  ()) 
    7979 
    80 (defmethod handle ((handler cancel-contract-handler) req) 
    81   (with-xml-error-handler (req) 
    82     (with-query-params (req contract-id) 
     80(defmethod handle ((handler cancel-contract-handler)) 
     81  (with-xml-error-handler () 
     82    (with-query-params (contract-id) 
    8383      (unless contract-id 
    8484        (error "missing contract-id parameter")) 

  • branches/trunk-reorg/projects/bos/web/bos.web.asd

    r2473 r2479  
    1717  :long-description "" 
    1818 
    19   :depends-on (:bknr-web :bknr-modules :bos.m2 :cxml) 
     19  :depends-on (:bknr-web :bknr-modules :bos.m2 :cxml :acl-compat) 
    2020 
    2121  :components ((:file "packages") 

  • branches/trunk-reorg/projects/bos/web/contract-handlers.lisp

    r2343 r2479  
    1010(defparameter *show-m2s* 5) 
    1111 
    12 (defmethod handle-object ((handler contract-handler) contract req) 
    13   (with-bos-cms-page (req :title "Displaying contract details") 
     12(defmethod handle-object ((handler contract-handler) contract) 
     13  (with-bos-cms-page (:title "Displaying contract details") 
    1414    ((:table :border "0") 
    1515     (:tr (:td "sponsor") 

  • branches/trunk-reorg/projects/bos/web/contract-image-handler.lisp

    r2343 r2479  
    1818        ;; a whole for performance reasons.  The FFI is way too slow to manipulate individual pixels. 
    1919        (let ((work-array (make-array (list width height) :element-type 'fixnum :initial-element 0)) 
    20               (color (parse-color (or (second (decoded-handler-path handler req)) "ffff00")))) 
     20              (color (parse-color (or (second (decoded-handler-path handler)) "ffff00")))) 
    2121          (flet ((set-pixel (x y) 
    2222                   (decf x left) 

  • branches/trunk-reorg/projects/bos/web/kml-handlers.lisp

    r2425 r2479  
    4141  ()) 
    4242 
    43 (defmethod handle-object ((handler contract-kml-handler) (contract contract) req) 
     43(defmethod handle-object ((handler contract-kml-handler) (contract contract)) 
    4444  (with-xml-response (:content-type "application/vnd.google-earth.kml+xml" :root-element "kml") 
    4545    ;; when name is xmlns, the attribute does not show up - why (?) 
    …… 
    7878                  (text (kml-format-points (list (contract-center-lon-lat c))))))))))))) 
    7979 
    80 (defmethod handle-object ((handle-object contract-kml-handler) (object null) req) 
     80(defmethod handle-object ((handle-object contract-kml-handler) (object null)) 
    8181  (error "Contract not found.")) 

  • branches/trunk-reorg/projects/bos/web/languages-handler.lisp

    r2343 r2479  
    66  ()) 
    77 
    8 (defmethod handle-form ((handler languages-handler) action req) 
    9   (with-bos-cms-page (req :title "Languages") 
     8(defmethod handle-form ((handler languages-handler) action) 
     9  (with-bos-cms-page (:title "Languages") 
    1010    (case action 
    1111      (:add (handler-case 
    12                 (with-query-params (req code name) 
     12                (with-query-params (code name) 
    1313                  (when (and code name) 
    1414                    (make-object 'website-language :code code :name name) 
    …… 
    1818                      (:pre (:princ-safe e)))))) 
    1919      (:delete (handler-case 
    20                    (with-query-params (req delete-code) 
     20                   (with-query-params (delete-code) 
    2121                     (when delete-code 
    2222                       (delete-object (language-with-code delete-code)) 

  • branches/trunk-reorg/projects/bos/web/map-browser-handler.lisp

    r2343 r2479  
    1919  ()) 
    2020 
    21 (defun decode-coords-in-handler-path (handler req) 
     21(defun decode-coords-in-handler-path (handler) 
    2222  (labels ((ensure-valid-coordinates (x y) 
    2323             (setq x (parse-integer x)) 
    …… 
    3131               (error "invalid coordinates ~A/~A" x y)) 
    3232             (list x y))) 
    33     (with-query-params (req xcoord ycoord) 
     33    (with-query-params (xcoord ycoord) 
    3434      (when (and xcoord ycoord) 
    3535        (return-from decode-coords-in-handler-path (ensure-valid-coordinates xcoord ycoord)))) 
    36     (let ((handler-arguments (decoded-handler-path handler req))) 
     36    (let ((handler-arguments (decoded-handler-path handler))) 
    3737      (when (and handler-arguments 
    3838                 (< 1 (length handler-arguments))) 
    3939        (apply #'ensure-valid-coordinates handler-arguments))))) 
    4040 
    41 (defmethod handle ((handler map-browser-handler) req) 
    42   (with-query-params (req chosen-url) 
     41(defmethod handle ((handler map-browser-handler)) 
     42  (with-query-params (chosen-url) 
    4343    (when chosen-url 
    4444      (setf (session-variable :chosen-url) chosen-url))) 
    45   (with-query-params (req view-x view-y) 
    46     (destructuring-bind (&optional click-x click-y) (decode-ismap-query-string req) 
    47       (destructuring-bind (&optional point-x point-y) (decode-coords-in-handler-path handler req) 
    48         (with-query-params (req action) 
     45  (with-query-params (view-x view-y) 
     46    (destructuring-bind (&optional click-x click-y) (decode-ismap-query-string) 
     47      (destructuring-bind (&optional point-x point-y) (decode-coords-in-handler-path handler) 
     48        (with-query-params (action) 
    4949          (when (equal action "save") 
    5050            (if (session-variable :chosen-url) 
    …… 
    5252                                  (session-variable :chosen-url) 
    5353                                  point-x 
    54                                   point-y) 
    55                           req) 
    56                 (with-bos-cms-page (req :title "Map Point Chooser") 
     54                                  point-y)) 
     55                (with-bos-cms-page (:title "Map Point Chooser") 
    5756                  (html (:princ-safe "You chose " point-x " / " point-y)))) 
    5857            (return-from handle t))) 
    …… 
    7271              (setq point-x click-coord-x 
    7372                    point-y click-coord-y) 
    74               (redirect (format nil "/map-browser/~D/~D" click-coord-x click-coord-y) req) 
     73              (redirect (format nil "/map-browser/~D/~D" click-coord-x click-coord-y)) 
    7574              (return-from handle t))) 
    7675          (cond 
    7776            ((and click-y (not point-y)) 
    78              (redirect (format nil "/map-browser/~D/~D" (* 30 click-x) (* 30 click-y)) req)) 
     77             (redirect (format nil "/map-browser/~D/~D" (* 30 click-x) (* 30 click-y)))) 
    7978            (point-y 
    80              (with-bos-cms-page (req :title "Map Point Chooser") 
    81                (with-query-params (req heading) 
     79             (with-bos-cms-page (:title "Map Point Chooser") 
     80               (with-query-params (heading) 
    8281                 (when heading 
    8382                   (html (:h2 (:princ-safe heading))))) 
    …… 
    134133               (map-navigator req point-x point-y "/map-browser/" :formcheck "return updateCoords();"))) 
    135134            (t 
    136              (with-bos-cms-page (req :title "Map Point Chooser") 
     135             (with-bos-cms-page (:title "Map Point Chooser") 
    137136               (html 
    138137                ((:a :href "/map-browser/") 

  • branches/trunk-reorg/projects/bos/web/map-handlers.lisp

    r2343 r2479  
    3535              (:tr ))) 
    3636            (:td 
    37              (with-query-params (req background areas contracts) 
     37             (with-query-params (background areas contracts) 
    3838               ;; xxx should use tile-layers 
    3939               (unless (or background areas contracts) 
    …… 
    5353  ()) 
    5454 
    55 (defmethod object-handler-get-object ((handler image-tile-handler) req) 
    56   (destructuring-bind (x y &rest operations) (decoded-handler-path handler req) 
     55(defmethod object-handler-get-object ((handler image-tile-handler)) 
     56  (destructuring-bind (x y &rest operations) (decoded-handler-path handler) 
    5757    (declare (ignore operations)) 
    5858    (setf x (parse-integer x)) 
    …… 
    6060    (ensure-map-tile x y))) 
    6161 
    62 (defmethod handle-object ((handler image-tile-handler) (tile (eql nil)) req) 
    63   (error-404 req)) 
     62(defmethod handle-object ((handler image-tile-handler) (tile (eql nil))) 
     63  (error-404)) 
    6464 
    6565(defun parse-operations (&rest operation-strings) 
    …… 
    6969          operation-strings)) 
    7070 
    71 (defmethod handle-object ((handler image-tile-handler) tile req) 
    72   ;; xxx parse url another time - the parse result of 
    73   ;; object-handler-get-object should really be kept in the request 
    74   (destructuring-bind (x y &rest operation-strings) (decoded-handler-path handler req) 
    75     (declare (ignore x y)) 
    76     (let ((changed-time (image-tile-changed-time tile)) 
    77           (ims (header-slot-value req :if-modified-since))) 
    78       (setf (net.aserve::last-modified *ent*) changed-time) 
    79       #+(or) 
    80       (format t "; image-tile-handler handle-object: changed-time: ~A if-modified-since: ~A~%" (format-date-time changed-time) ims) 
    81       (if (or (not ims) 
    82               (> changed-time (date-to-universal-time ims))) 
    83           (let ((image (image-tile-image tile (apply #'parse-operations operation-strings)))) 
    84             (emit-image-to-browser req image :png 
    85                                    :date changed-time 
    86                                    :max-age 60) 
    87             (cl-gd:destroy-image image)) 
    88           (with-http-response (req *ent*) 
    89             (with-http-body (req *ent*) 
    90               ; do nothing 
    91               )))))) 
     71;; 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 req 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;;            )))))) 
    9293 
    9394(defclass enlarge-tile-handler (image-tile-handler) 
    9495  ()) 
    9596 
    96 (defun tile-active-layers-from-request-params (tile req) 
     97(defun tile-active-layers-from-request-params (tile) 
    9798  (let (active-layers 
    9899        (all-layer-names (mapcar #'symbol-name (image-tile-layers tile)))) 
    …… 
    102103    (or (reverse active-layers) all-layer-names))) 
    103104 
    104 (defun tile-url (tile x y req) 
     105(defun tile-url (tile x y) 
    105106  (format nil "/overview/~D/~D~(~{/~A~}~)" 
    106107          x y 
    107           (tile-active-layers-from-request-params tile req))) 
     108          (tile-active-layers-from-request-params tile))) 
    108109 
    109 (defmethod handle-object ((handler enlarge-tile-handler) tile req) 
    110   (let ((ismap-coords (decode-ismap-query-string req)) 
    111         (tile-x (tile-nw-x tile)) 
    112         (tile-y (tile-nw-y tile))) 
    113     (if ismap-coords 
    114         (let* ((x (+ (floor (first ismap-coords) 4) tile-x)) 
    115                (y (+ (floor (second ismap-coords) 4) tile-y)) 
    116                (m2 (get-m2 x y)) 
    117                (contract-id (and m2 (m2-contract m2) (store-object-id (m2-contract m2))))) 
    118           (if contract-id 
    119               (redirect #?"/contract/$(contract-id)" req) 
    120               (with-bos-cms-page (req :title "Not sold") 
    121                 (html (:h2 "this square meter has not been sold yet"))))) 
    122         (with-bos-cms-page (req :title "Browsing tile") 
    123           (:a ((:a :href (uri-path (request-uri req))) 
    124                ((:img :width "360" :ismap "ismap" :height "360" :border "0" :src (tile-url tile tile-x tile-y req))))) 
    125           (map-navigator req tile-x tile-y "/enlarge-overview/"))))) 
     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/"))))) 
     128 

  • branches/trunk-reorg/projects/bos/web/news-handlers.lisp

    r2411 r2479  
    1010  ()) 
    1111 
    12 (defmethod handle-object-form ((handler edit-news-handler) action (news-item (eql nil)) req) 
     12(defmethod handle-object-form ((handler edit-news-handler) action (news-item (eql nil))) 
    1313  (let ((language (session-variable :language))) 
    14     (with-bos-cms-page (req :title "Edit news items") 
    15       (content-language-chooser req) 
     14    (with-bos-cms-page (:title "Edit news items") 
     15      (content-language-chooser) 
    1616      (:h2 "Create new item") 
    1717      ((:form :method "post") 
    …… 
    3030           (:h2 "No news items created yet")))))) 
    3131 
    32 (defmethod handle-object-form ((handler edit-news-handler) (action (eql :new)) (news-item (eql nil)) req) 
    33   (redirect (format nil "/edit-news/~D" (store-object-id (make-news-item))) req)) 
     32(defmethod handle-object-form ((handler edit-news-handler) (action (eql :new)) (news-item (eql nil))) 
     33  (redirect (format nil "/edit-news/~D" (store-object-id (make-news-item))))) 
    3434 
    35 (defmethod handle-object-form ((handler edit-news-handler) action news-item req) 
     35(defmethod handle-object-form ((handler edit-news-handler) action news-item) 
    3636  (let ((language (session-variable :language))) 
    37     (with-bos-cms-page (req :title "Edit news item") 
    38       (content-language-chooser req) 
     37    (with-bos-cms-page (:title "Edit news item") 
     38      (content-language-chooser) 
    3939      ((:script :type "text/javascript") 
    4040       "tinyMCE.init({ mode : 'textareas', theme : 'advanced' });") 
    …… 
    4949         (:tr (:td (submit-button "save" "save") (submit-button "delete" "delete" :confirm "Really delete the news item?")))))))) 
    5050 
    51 (defmethod handle-object-form ((handler edit-news-handler) (action (eql :save)) news-item req) 
     51(defmethod handle-object-form ((handler edit-news-handler) (action (eql :save)) news-item) 
    5252  (let ((language (session-variable :language))) 
    53     (with-query-params (req title text) 
     53    (with-query-params (title text) 
    5454      (update-news-item news-item language :title title :text text) 
    55       (with-bos-cms-page (req :title "News item updated") 
     55      (with-bos-cms-page (:title "News item updated") 
    5656        (:h2 "Your changes have been saved") 
    5757        "You may " (cmslink (edit-object-url news-item) "continue editing the news item"))))) 
    5858 
    59 (defmethod handle-object-form ((handler edit-news-handler) (action (eql :delete)) news-item req) 
     59(defmethod handle-object-form ((handler edit-news-handler) (action (eql :delete)) news-item) 
    6060  (delete-object news-item) 
    61   (with-bos-cms-page (req :title "News item has been deleted") 
     61  (with-bos-cms-page (:title "News item has been deleted") 
    6262    (:h2 "The news item has been deleted"))) 

  • branches/trunk-reorg/projects/bos/web/packages.lisp

    r2345 r2479  
    99        :cl-interpol 
    1010        :cl-ppcre 
    11         :net.aserve 
    12         :net.aserve.client 
    1311        :xhtml-generator 
    1412        :cxml 
    …… 
    2826  (:nicknames :web :worldpay-test) 
    2927  (:shadowing-import-from :cl-interpol #:quote-meta-chars) 
    30   (:shadowing-import-from :acl-compat.mp #:process-kill #:process-wait) 
    31   (:import-from :net.html.generator #:*html-stream*) 
     28  (:shadowing-import-from :acl-compat.mp #:process-kill #:process-wait)   
    3229  (:export)) 

  • branches/trunk-reorg/projects/bos/web/poi-handlers.lisp

    r2343 r2479  
    77  ()) 
    88   
    9 (defmethod handle ((handler make-poi-handler) req) 
    10   (with-query-params (req name) 
     9(defmethod handle ((handler make-poi-handler)) 
     10  (with-query-params (name) 
    1111    (cond 
    1212      ((find-store-object name :class 'poi) 
    13        (with-bos-cms-page (req :title "Duplicate POI name") 
     13       (with-bos-cms-page (:title "Duplicate POI name") 
    1414         (html (:h2 "Duplicate POI name") 
    1515               "A POI with that name exists already, please choose a unique name"))) 
    1616      ((not (scan #?r"(?i)^[a-z][-a-z0-9_]+$" name)) 
    17        (with-bos-cms-page (req :title "Bad technical name") 
     17       (with-bos-cms-page (:title "Bad technical name") 
    1818         (html (:h2 "Bad technical name") 
    1919               "Please use only alphanumerical characters, - and _ for technical POI names"))) 
    2020      (t 
    21        (redirect (edit-object-url (make-poi (session-variable :language) name)) req))))) 
     21       (redirect (edit-object-url (make-poi (session-variable :language) name))))))) 
    2222 
    2323(defclass edit-poi-handler (editor-only-handler edit-object-handler) 
    …… 
    2525  (:default-initargs :object-class 'poi :query-function #'find-poi)) 
    2626 
    27 (defmethod handle-object-form ((handler edit-poi-handler) action (object (eql nil)) req) 
    28   (with-bos-cms-page (req :title "Choose POI") 
     27(defmethod handle-object-form ((handler edit-poi-handler) action (object (eql nil))) 
     28  (with-bos-cms-page (:title "Choose POI") 
    2929    (if (store-objects-with-class 'poi) 
    3030        (html 
    …… 
    5151 
    5252(defmethod handle-object-form ((handler edit-poi-handler) 
    53                                action (poi poi) req) 
    54   (with-query-params (req language shift shift-by) 
     53                               action (poi poi)) 
     54  (with-query-params (language shift shift-by) 
    5555    (unless language (setq language (session-variable :language))) 
    5656    (when shift 
    …… 
    6767        (change-slot-values poi 'bos.m2::images new-images))) 
    6868    (setf (session-variable :language) language) 
    69     (with-bos-cms-page (req :title "Edit POI") 
    70       (content-language-chooser req) 
     69    (with-bos-cms-page (:title "Edit POI") 
     70      (content-language-chooser) 
    7171      (unless (poi-complete poi language) 
    7272        (html (:h2 "This POI is not complete in the current language - Please check that " 
    …… 
    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 (request-uri req))))) 
     98                                      (uriencode-string (format nil "~A?action=save&" (uri-path (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 (request-uri req))))) 
     102                                      (uriencode-string (format nil "~A?action=save&" (uri-path (hunchentoot:request-uri))))) 
    103103                       "[choose]"))))) 
    104104        (:tr (:td "icon") 
    …… 
    168168 
    169169(defmethod handle-object-form ((handler edit-poi-handler) 
    170                                (action (eql :save)) (poi poi) req) 
    171   (with-query-params (req published title subtitle description language x y icon movie) 
     170                               (action (eql :save)) (poi poi)) 
     171  (with-query-params (published title subtitle description language x y icon movie) 
    172172    (unless language (setq language (session-variable :language))) 
    173173    (let ((args (list :title title 
    …… 
    181181        (setq args (append args (list :movies (list movie))))) 
    182182      (apply #'update-poi poi language args)) 
    183     (with-bos-cms-page (req :title "POI has been updated") 
     183    (with-bos-cms-page (:title "POI has been updated") 
    184184      (html (:h2 "Your changes have been saved") 
    185185            "You may " (cmslink (edit-object-url poi) "continue editing the POI") ".")))) 
    …… 
    187187(defmethod handle-object-form ((handler edit-poi-handler) 
    188188                               (action (eql :upload-airal)) 
    189                                (poi poi) 
    190                                req) 
    191   (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files req) :test #'equal :key #'car)))) 
     189                               (poi poi)) 
     190  (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files) :test #'equal :key #'car)))) 
    192191    (unless uploaded-file 
    193192      (error "no file uploaded in upload handler")) 
    …… 
    195194      (unless (and (eql (cl-gd:image-width) *poi-image-width*) 
    196195                   (eql (cl-gd:image-height) *poi-image-height*)) 
    197         (with-bos-cms-page (req :title "Invalid image size") 
     196        (with-bos-cms-page (:title "Invalid image size") 
    198197          (:h2 "Invalid image size") 
    199198          (:p "The image needs to be " 
    …… 
    208207                                                        :class-name 'store-image)))) 
    209208  (redirect (format nil "/edit-poi/~D" 
    210                     (store-object-id poi)) req)) 
     209                    (store-object-id poi)))) 
    211210 
    212211(defmethod handle-object-form ((handler edit-poi-handler) 
    213212                               (action (eql :delete-airal)) 
    214                                (poi poi) 
    215                                req) 
     213                               (poi poi)) 
    216214  (let ((airals (poi-airals poi))) 
    217215    (change-slot-values poi 'airals nil) 
    218216    (mapc #'delete-object airals)) 
    219217  (redirect (format nil "/edit-poi/~D" 
    220                     (store-object-id poi)) req)) 
     218                    (store-object-id poi)))) 
    221219 
    222220(defmethod handle-object-form ((handler edit-poi-handler) 
    223221                               (action (eql :delete-movie)) 
    224                                (poi poi) 
    225                                req) 
     222                               (poi poi)) 
    226223  (change-slot-values poi 'movies nil) 
    227   (redirect (format nil "/edit-poi/~D" (store-object-id poi)) req)) 
     224  (redirect (format nil "/edit-poi/~D" (store-object-id poi)))) 
    228225 
    229226(defmethod handle-object-form ((handler edit-poi-handler) 
    230227                               (action (eql :upload-panorama)) 
    231                                (poi poi) 
    232                                req) 
    233   (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files req) :test #'equal :key #'car)))) 
     228                               (poi poi)) 
     229  (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files) :test #'equal :key #'car)))) 
    234230    (unless uploaded-file 
    235231      (error "no file uploaded in upload handler")) 
    …… 
    241237                                             (poi-panoramas poi)))) 
    242238  (redirect (format nil "/edit-poi/~D" 
    243                     (store-object-id poi)) req)) 
     239                    (store-object-id poi)))) 
    244240 
    245241(defmethod handle-object-form ((handler edit-poi-handler) 
    246242                               (action (eql :delete-panorama)) 
    247                                (poi poi) 
    248                                req) 
    249   (with-query-params (req panorama-id) 
     243                               (poi poi)) 
     244  (with-query-params (panorama-id) 
    250245    (let ((panorama (find-store-object (parse-integer panorama-id)))) 
    251246      (change-slot-values poi 'panoramas (remove panorama (poi-panoramas poi))) 
    252247      (mapc #'delete-object panorama))) 
    253248  (redirect (format nil "/edit-poi/~D" 
    254                     (store-object-id poi)) req)) 
    255  
    256 (defmethod handle-object-form ((handler edit-poi-handler) 
    257                                (action (eql :delete)) (poi poi) req) 
     249                    (store-object-id poi)))) 
     250 
     251(defmethod handle-object-form ((handler edit-poi-handler) 
     252                               (action (eql :delete)) (poi poi)) 
    258253  (delete-object poi) 
    259   (with-bos-cms-page (req :title "POI has been deleted") 
     254  (with-bos-cms-page (:title "POI has been deleted") 
    260255    (html (:h2 "POI has been deleted") 
    261256          "The POI has been deleted"))) 
    …… 
    267262  (:default-initargs :object-class 'poi-image)) 
    268263 
    269 (defmethod handle-object-form ((handler edit-poi-image-handler) action (object (eql nil)) req) 
    270   (with-query-params (req poi) 
    271     (with-bos-cms-page (req :title "Upload new POI image") 
     264(defmethod handle-object-form ((handler edit-poi-image-handler) action (object (eql nil))) 
     265  (with-query-params (poi) 
     266    (with-bos-cms-page (:title "Upload new POI image") 
    272267      (html 
    273268       (:h2 "Upload new image") 
    …… 
    277272       (:p (submit-button "upload" "upload")))))) 
    278273 
    279 (defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :upload)) poi-image req) 
    280   (with-query-params (req poi) 
     274(defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :upload)) poi-image) 
     275  (with-query-params (poi) 
    281276    (setq poi (find-store-object (parse-integer poi) :class 'poi)) 
    282     (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files req) :test #'equal :key #'car)))) 
     277    (let ((uploaded-file (cdr (find "image-file" (request-uploaded-files) :test #'equal :key #'car)))) 
    283278      (unless uploaded-file 
    284279        (error "no file uploaded in upload handler")) 
    …… 
    286281        (unless (and (eql (cl-gd:image-width) *poi-image-width*) 
    287282                     (eql (cl-gd:image-height) *poi-image-height*)) 
    288           (with-bos-cms-page (req :title "Invalid image size") 
     283          (with-bos-cms-page (:title "Invalid image size") 
    289284            (:h2 "Invalid image size") 
    290285            (:p "The image needs to be " 
    …… 
    303298      (redirect (format nil "/edit-poi-image/~D?poi=~D" 
    304299                        (store-object-id poi-image) 
    305                         (store-object-id poi)) req)))) 
    306  
    307 (defmethod handle-object-form ((handler edit-poi-image-handler) action poi-image req) 
    308   (with-query-params (req language poi) 
     300                        (store-object-id poi)))))) 
     301 
     302(defmethod handle-object-form ((handler edit-poi-image-handler) action poi-image) 
     303  (with-query-params (language poi) 
    309304    (unless language (setq language (session-variable :language))) 
    310     (with-bos-cms-page (req :title "Edit POI Image") 
     305