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))