Author: hhubner Date: 2006-10-26 00:12:15 -0400 (Thu, 26 Oct 2006) New Revision: 2048 Modified: trunk/projects/bos/m2/m2.lisp trunk/projects/bos/m2/packages.lisp trunk/projects/bos/m2/poi.lisp trunk/projects/bos/worldpay-test/poi-handlers.lisp trunk/projects/bos/worldpay-test/sponsor-handlers.lisp trunk/projects/bos/worldpay-test/tags.lisp Log: New panoramas API for sat application. Fixed dowload-only certificates with manual money transfer. Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2006-10-26 04:11:11 UTC (rev 2047) +++ trunk/projects/bos/m2/m2.lisp 2006-10-26 04:12:15 UTC (rev 2048) @@ -181,7 +181,7 @@ (paidp :update) (m2s :read) (color :read) - (download-only :read) + (download-only :update) (cert-issued :read) (worldpay-trans-id :update :initform nil) (expires :read :documentation "universal time which specifies the time the contract expires (is deleted) when it has not been paid for" :initform nil)) @@ -235,6 +235,9 @@ (or (contract-download-only contract) (< (contract-price contract) *mail-amount*))) +(deftransaction contract-set-download-only-p (contract newval) + (setf (contract-download-only contract) newval)) + (defmethod contract-fdf-pathname ((contract contract) language) (merge-pathnames (make-pathname :name (format nil "~D-~(~A~)" (store-object-id contract) Modified: trunk/projects/bos/m2/packages.lisp =================================================================== --- trunk/projects/bos/m2/packages.lisp 2006-10-26 04:11:11 UTC (rev 2047) +++ trunk/projects/bos/m2/packages.lisp 2006-10-26 04:12:15 UTC (rev 2048) @@ -102,6 +102,7 @@ #:contract-color #:contract-cert-issued #:contract-set-paidp + #:contract-set-download-only-p #:contract-price #:contract-issue-cert #:contract-worldpay-trans-id Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2006-10-26 04:11:11 UTC (rev 2047) +++ trunk/projects/bos/m2/poi.lisp 2006-10-26 04:12:15 UTC (rev 2048) @@ -129,26 +129,38 @@ (not (poi-published poi)))) (store-objects-with-class 'poi)) #'(lambda (poi-1 poi-2) (string-lessp (slot-string poi-1 'title language) (slot-string poi-2 'title language))))) - (format t "var poi = [];~%") - (format t "poi['symbol'] = ~S;~%" (poi-name poi)) - (format t "poi['icon'] = ~S;~%" (poi-icon poi)) - (format t "poi['name'] = ~S;~%" (slot-string poi 'title language)) - (format t "poi['untertitel'] = ~S;~%" (slot-string poi 'subtitle language)) - (format t "poi['text'] = ~S;~%" (escape-nl (slot-string poi 'description language))) - (format t "poi['x'] = ~D;~%" (poi-center-x poi)) - (format t "poi['y'] = ~D;~%" (poi-center-y poi)) - (format t "poi['thumbnail'] = ~D;~%" (length (poi-images poi))) + (format t " +var poi = { symbol: ~S, + icon: ~S, + name: ~S, + untertitel: ~S, + text: ~S, + x: ~D, + y: ~D, + thumbnail: ~D +}; +" + (poi-name poi) + (poi-icon poi) + (slot-string poi 'title language) + (slot-string poi 'subtitle language) + (escape-nl (slot-string poi 'description language)) + (poi-center-x poi) + (poi-center-y poi) + (length (poi-images poi))) + (format t "poi.thumbnail = ~D;~%" (length (poi-images poi))) (when (poi-airals poi) - (format t "poi['luftbild'] = ~D;~%" (store-object-id (first (poi-airals poi))))) + (format t "poi.luftbild = ~D;~%" (store-object-id (first (poi-airals poi))))) (when (poi-panoramas poi) - (format t "poi['panorama'] = ~D;~%" (store-object-id (first (poi-panoramas poi))))) + (let ((panorama-ids (mapcar #'store-object-id (poi-panoramas poi)))) + (format t "poi.panoramas = [ ~D~{, ~D~} ];~%" (first panorama-ids) (rest panorama-ids)))) (loop for slot-name in '(title subtitle description) for javascript-name in '("imageueberschrift" "imageuntertitel" "imagetext") for slot-values = (mapcar #'(lambda (image) (escape-nl (slot-string image slot-name language))) (poi-images poi)) when slot-values - do (format t "poi[~S] = [~S~{, ~S~}];~%" javascript-name (car slot-values) (cdr slot-values))) + do (format t "poi.~A = [ ~S~{, ~S~} ];~%" javascript-name (car slot-values) (cdr slot-values))) (format t "pois.push(poi);~%")) (dolist (allocation-area (remove-if (complement #'allocation-area-active-p) (class-instances 'allocation-area))) (destructuring-bind (x y) (allocation-area-center allocation-area) Modified: trunk/projects/bos/worldpay-test/poi-handlers.lisp =================================================================== --- trunk/projects/bos/worldpay-test/poi-handlers.lisp 2006-10-26 04:11:11 UTC (rev 2047) +++ trunk/projects/bos/worldpay-test/poi-handlers.lisp 2006-10-26 04:12:15 UTC (rev 2048) @@ -140,15 +140,16 @@ :br (submit-button "upload-airal" "upload-airal"))))) (:tr (:td "panorama view") - (:td (if (poi-panoramas poi) - (html ((:a :href (format nil "/image/~D" (store-object-id (first (poi-panoramas poi)))) - :target "_new") - " view ") - (submit-button "delete-panorama" "delete-panorama" :confirm "Really delete the panorama image?")) - (html "Upload new panorama view" - ((:input :type "file" :name "image-file")) - :br - (submit-button "upload-panorama" "upload-panorama"))))) + (:td (dolist (panorama (poi-panoramas poi)) + (html (:princ-safe (format-date-time (blob-timestamp panorama))) + ((:a :href (format nil "/image/~D" (store-object-id panorama)) :target "_new" :class "cmslink") + " view ") + (submit-button "delete-panorama" "delete-panorama" :confirm "Really delete this panorama image?") + :br)) + (html "Upload new panorama view" + ((:input :type "file" :name "image-file")) + :br + (submit-button "upload-panorama" "upload-panorama")))) (:tr (:td (submit-button "save" "save") (submit-button "delete" "delete" :confirm "Really delete the POI?")))))))) (defmethod handle-object-form ((handler edit-poi-handler) @@ -212,8 +213,9 @@ (cl-gd:with-image-from-file* (uploaded-file) ; just open the image to make sure that gd can process it ) - (change-slot-values poi 'panoramas (list (import-image uploaded-file - :class-name 'store-image)))) + (change-slot-values poi 'panoramas (cons (import-image uploaded-file + :class-name 'store-image) + (poi-panoramas poi)))) (redirect (format nil "/edit-poi/~D" (store-object-id poi)) req)) @@ -221,9 +223,10 @@ (action (eql :delete-panorama)) (poi poi) req) - (let ((panoramas (poi-panoramas poi))) - (change-slot-values poi 'panoramas nil) - (mapc #'delete-object panoramas)) + (with-query-params (req panorama-id) + (let ((panorama (find-store-object (parse-integer panorama-id)))) + (change-slot-values poi 'panoramas (remove panorama (poi-panoramas poi))) + (mapc #'delete-object panorama))) (redirect (format nil "/edit-poi/~D" (store-object-id poi)) req)) Modified: trunk/projects/bos/worldpay-test/sponsor-handlers.lisp =================================================================== --- trunk/projects/bos/worldpay-test/sponsor-handlers.lisp 2006-10-26 04:11:11 UTC (rev 2047) +++ trunk/projects/bos/worldpay-test/sponsor-handlers.lisp 2006-10-26 04:12:15 UTC (rev 2048) @@ -205,8 +205,10 @@ (:td (text-field "name" :size 50))) (:tr (:td "Email-Address") (:td (text-field "email" :size 20))) - (:tr (:td "Postal address for certificate" - (:td (textarea-field "postaladdress" :rows 5 :cols 40)))) + (unless (contract-download-only-p contract) + (html + (:tr (:td "Postal address for certificate" + (:td (textarea-field "postaladdress" :rows 5 :cols 40)))))) (:tr (:td (submit-button "process" "process" :formcheck "javascript:return check_complete_sale()")))))))))) (defmethod handle-object-form ((handler complete-transfer-handler) (action (eql :process)) contract req) Modified: trunk/projects/bos/worldpay-test/tags.lisp =================================================================== --- trunk/projects/bos/worldpay-test/tags.lisp 2006-10-26 04:11:11 UTC (rev 2047) +++ trunk/projects/bos/worldpay-test/tags.lisp 2006-10-26 04:12:15 UTC (rev 2048) @@ -100,7 +100,12 @@ (mapc #'emit-template-node children)) (define-bknr-tag mail-transfer () - (mail-manual-sponsor-data (get-template-var :request))) + (with-query-params ((get-template-var :request) contract-id mail-certificate) + (let* ((contract (store-object-with-id (parse-integer contract-id))) + (download-only (or (< (contract-price contract) *mail-certificate-threshold*) + (not mail-certificate)))) + (contract-set-download-only-p contract download-only) + (mail-manual-sponsor-data (get-template-var :request))))) (define-bknr-tag when-certificate (&key children) (let ((sponsor (bknr-request-user (get-template-var :request))))