[bknr-cvs] r1979 - branches/xml-class-rework/projects/bos/worldpay-test
bknr at bknr.net
bknr at bknr.net
Sun Aug 13 14:09:32 UTC 2006
Author: hhubner
Date: 2006-08-13 10:09:31 -0400 (Sun, 13 Aug 2006)
New Revision: 1979
Added:
branches/xml-class-rework/projects/bos/worldpay-test/contract-rss.lisp
Modified:
branches/xml-class-rework/projects/bos/worldpay-test/boi-handlers.lisp
branches/xml-class-rework/projects/bos/worldpay-test/sponsor-handlers.lisp
branches/xml-class-rework/projects/bos/worldpay-test/tags.lisp
Log:
log payment time and method for tracing
Modified: branches/xml-class-rework/projects/bos/worldpay-test/boi-handlers.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/worldpay-test/boi-handlers.lisp 2006-08-13 13:31:52 UTC (rev 1978)
+++ branches/xml-class-rework/projects/bos/worldpay-test/boi-handlers.lisp 2006-08-13 14:09:31 UTC (rev 1979)
@@ -82,7 +82,9 @@
(when (contract-paidp contract)
(error "contract has already been paid for"))
(with-transaction (:contract-paid)
- (contract-set-paidp contract t)
+ (contract-set-paidp contract (format nil "~A: manually set paid by ~A"
+ (format-date-time)
+ (user-login (bknr-request-user req))))
(when name
(setf (user-full-name (contract-sponsor contract)) name))))
(with-xml-response ()
Added: branches/xml-class-rework/projects/bos/worldpay-test/contract-rss.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/worldpay-test/contract-rss.lisp 2006-08-13 13:31:52 UTC (rev 1978)
+++ branches/xml-class-rework/projects/bos/worldpay-test/contract-rss.lisp 2006-08-13 14:09:31 UTC (rev 1979)
@@ -0,0 +1,28 @@
+(in-package :bos.m2)
+
+(defmethod rss-item-channel ((contract contract))
+ "news")
+
+(defmethod rss-item-published ((contract contract))
+ (contract-paidp contract))
+
+(defmethod rss-item-title ((contract contract))
+ (format nil (case (intern (worldpay-test::current-website-language))
+ (de "~A Quadratmeter wurden ~@[von ~A ~]gekauft")
+ (t "~A square meters bought~@[ by ~A~]"))
+ (length (contract-m2s contract))
+ (user-full-name (contract-sponsor contract))))
+
+(defmethod rss-item-description ((contract contract))
+ (rss-item-title contract))
+
+(defmethod rss-item-link ((contract contract))
+ #+(or)
+ (format nil "http://createrainforest.org/~A/news-extern/~A" (worldpay-test::current-website-language) (store-object-id item)))
+
+(defmethod rss-item-guid ((item contract))
+ #+(or)
+ (format nil "http://createrainforest.org/~A/news-extern/~A" (worldpay-test::current-website-language) (store-object-id item)))
+
+(defmethod rss-item-pub-date ((contract contract))
+ (contract-date contract))
Modified: branches/xml-class-rework/projects/bos/worldpay-test/sponsor-handlers.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/worldpay-test/sponsor-handlers.lisp 2006-08-13 13:31:52 UTC (rev 1978)
+++ branches/xml-class-rework/projects/bos/worldpay-test/sponsor-handlers.lisp 2006-08-13 14:09:31 UTC (rev 1979)
@@ -30,20 +30,24 @@
(when count
(setf count (parse-integer count)))
(with-bos-cms-page (req :title "Sponsor search results")
- (:table
- (:tr (:th "ID") (:th "Date") (:th "Email") (:th "Name"))
+ ((:table :border "1")
+ (:tr (:th "ID") (:th "Date") (:th "Email") (:th "Name") (:th "SQM") (:th "Cert-Type") (:th "Paid by"))
(dolist (sponsor (sort (remove-if-not #'sponsor-contracts (class-instances 'sponsor))
#'> :key #'(lambda (sponsor) (contract-date (first (sponsor-contracts sponsor))))))
(when (or count
(or (ignore-errors (scan regex (user-full-name sponsor)))
(ignore-errors (scan regex (user-email sponsor)))))
- (html (:tr (:td (cmslink #?"edit-sponsor/$((store-object-id sponsor))" (:princ-safe (store-object-id sponsor))))
- (:td (:princ-safe (format-date-time (contract-date (first (sponsor-contracts sponsor))) :show-time nil)))
- (:td (:princ-safe (or (user-email sponsor) "<unknown>")))
- (:td (:princ-safe (or (user-full-name sponsor) "<unknown>")))))
+ (let ((contract (first (sponsor-contracts sponsor))))
+ (html (:tr (:td (cmslink #?"edit-sponsor/$((store-object-id sponsor))" (:princ-safe (store-object-id sponsor))))
+ (:td (:princ-safe (format-date-time (contract-date contract) :show-time nil)))
+ (:td (:princ-safe (or (user-email sponsor) "<unknown>")))
+ (:td (:princ-safe (or (user-full-name sponsor) "<unknown>")))
+ (:td (:princ-safe (length (contract-m2s contract))))
+ (:td (:princ-safe (if (contract-download-only-p contract) "Download" "Print")))
+ (:td (:princ-safe (contract-paidp contract))))))
(when (eql (incf found) count)
(return))))
- (:tr ((:th :colspan "4") (:princ-safe (format nil "~A sponsor~:p ~A" found (if count "shown" "found"))))))))
+ (:tr ((:th :colspan "7") (:princ-safe (format nil "~A sponsor~:p ~A" found (if count "shown" "found"))))))))
(return-from handle-object-form)))
(with-bos-cms-page (req :title "Find or Create Sponsor")
(html
@@ -203,7 +207,8 @@
(progn
(html (:h2 "Completing square meter sale"))
(sponsor-set-country (contract-sponsor contract) country)
- (contract-set-paidp contract t)
+ (contract-set-paidp contract (format nil "~A: wire transfer processed by ~A"
+ (format-date-time) (user-login (bknr-request-user req))))
(contract-issue-cert contract name :address postaladdress :language language)
(when email
(html (:p "Sending instruction email to " (:princ-safe email)))
Modified: branches/xml-class-rework/projects/bos/worldpay-test/tags.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/worldpay-test/tags.lisp 2006-08-13 13:31:52 UTC (rev 1978)
+++ branches/xml-class-rework/projects/bos/worldpay-test/tags.lisp 2006-08-13 14:09:31 UTC (rev 1979)
@@ -30,7 +30,7 @@
(sponsor (contract-sponsor contract)))
(change-slot-values sponsor 'bknr.web::email email)
(sponsor-set-country sponsor country)
- (contract-set-paidp contract t)
+ (contract-set-paidp contract "~A: paid via worldpay" (format-date-time))
(setf (get-template-var :master-code) (sponsor-master-code sponsor))
(setf (get-template-var :sponsor-id) (sponsor-id sponsor))))
(mapc #'emit-template-node children))
More information about the Bknr-cvs
mailing list