[bknr-cvs] r2048 - in trunk/projects/bos: m2 worldpay-test
bknr at bknr.net
bknr at bknr.net
Thu Oct 26 04:12:16 UTC 2006
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))))
More information about the Bknr-cvs
mailing list