[bknr-cvs] r2007 - in branches/xml-class-rework/projects/bos: . m2 payment-website/static tools worldpay-test
bknr at bknr.net
bknr at bknr.net
Fri Oct 20 05:06:41 UTC 2006
Author: hhubner
Date: 2006-10-20 01:06:38 -0400 (Fri, 20 Oct 2006)
New Revision: 2007
Added:
branches/xml-class-rework/projects/bos/tools/
branches/xml-class-rework/projects/bos/tools/wp-callpack-redirect.pl
Modified:
branches/xml-class-rework/projects/bos/m2/m2.lisp
branches/xml-class-rework/projects/bos/m2/mail-generator.lisp
branches/xml-class-rework/projects/bos/m2/packages.lisp
branches/xml-class-rework/projects/bos/payment-website/static/cms.js
branches/xml-class-rework/projects/bos/worldpay-test/config.lisp
branches/xml-class-rework/projects/bos/worldpay-test/sponsor-handlers.lisp
branches/xml-class-rework/projects/bos/worldpay-test/tags.lisp
branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp
Log:
Add reverse proxy for WorldPay callbacks to distribute callbacks
between test and production system depending on the testMode.
Add sponsor slot to contain the worldpay transaction id, link back
to WorldPay CMS for easier access.
Modified: branches/xml-class-rework/projects/bos/m2/m2.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/m2/m2.lisp 2006-10-16 18:30:48 UTC (rev 2006)
+++ branches/xml-class-rework/projects/bos/m2/m2.lisp 2006-10-20 05:06:38 UTC (rev 2007)
@@ -183,6 +183,7 @@
(color :read)
(download-only :read)
(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))
(:default-initargs
:m2s nil
Modified: branches/xml-class-rework/projects/bos/m2/mail-generator.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/m2/mail-generator.lisp 2006-10-16 18:30:48 UTC (rev 2006)
+++ branches/xml-class-rework/projects/bos/m2/mail-generator.lisp 2006-10-20 05:06:38 UTC (rev 2007)
@@ -125,6 +125,20 @@
email vorname name strasse plz ort
contract-id))))
+(defun worldpay-callback-request-to-vcard (request)
+ (with-query-params (request
+ cartId
+ transId
+ MC_sponsorid
+ MC_donationcert-yearly
+ MC_gift
+ address
+ postcode
+ country
+ email
+ tel)))
+
+
(defun mail-request-parameters (req subject)
(send-system-mail :subject subject
:content-type "text/html; charset=UTF-8"
Modified: branches/xml-class-rework/projects/bos/m2/packages.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/m2/packages.lisp 2006-10-16 18:30:48 UTC (rev 2006)
+++ branches/xml-class-rework/projects/bos/m2/packages.lisp 2006-10-20 05:06:38 UTC (rev 2007)
@@ -103,6 +103,7 @@
#:contract-set-paidp
#:contract-price
#:contract-issue-cert
+ #:contract-worldpay-trans-id
#:contract-pdf-pathname
#:contract-pdf-url
#:contract-download-only-p
Modified: branches/xml-class-rework/projects/bos/payment-website/static/cms.js
===================================================================
--- branches/xml-class-rework/projects/bos/payment-website/static/cms.js 2006-10-16 18:30:48 UTC (rev 2006)
+++ branches/xml-class-rework/projects/bos/payment-website/static/cms.js 2006-10-20 05:06:38 UTC (rev 2007)
@@ -52,7 +52,7 @@
var stats_name = select[select.options.selectedIndex].value;
document.getElementById('stats').innerHTML
- = '<embed src="/images/statistics/' + stats_name + '.svg" width="800" height="600" type="image/svg+xml"></embed>';
+ = '<embed src="/images/statistics/' + stats_name + '.svg" width="800" height="600" type="image/svg+xml"></embed>';
return true;
}
Added: branches/xml-class-rework/projects/bos/tools/wp-callpack-redirect.pl
===================================================================
--- branches/xml-class-rework/projects/bos/tools/wp-callpack-redirect.pl 2006-10-16 18:30:48 UTC (rev 2006)
+++ branches/xml-class-rework/projects/bos/tools/wp-callpack-redirect.pl 2006-10-20 05:06:38 UTC (rev 2007)
@@ -0,0 +1,26 @@
+#!/usr/bin/perl -w
+
+use strict;
+
+use HTTP::Daemon;
+use HTTP::Status;
+use LWP::UserAgent;
+
+my $port = "3456";
+
+my $ua = LWP::UserAgent->new;
+my $daemon = HTTP::Daemon->new(LocalPort => 3456, ReuseAddr => 1);
+
+while (my $client = $daemon->accept) {
+ my $request = $client->get_request;
+ if ($request) {
+ my $content = $request->content;
+
+ my $is_test = ($content =~ /testMode=100/);
+ my $host = $is_test ? "test.createrainforest.org" : "createrainforest.org";
+ my $response = $ua->get("http://" . $host . ":8080/handle-sale?" . $content);
+ $client->send_response($response);
+ print "Redirected request to ", ($is_test ? "TEST" : "PRODUCTION"), " system\n";
+ }
+ $client->close;
+}
Modified: branches/xml-class-rework/projects/bos/worldpay-test/config.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/worldpay-test/config.lisp 2006-10-16 18:30:48 UTC (rev 2006)
+++ branches/xml-class-rework/projects/bos/worldpay-test/config.lisp 2006-10-20 05:06:38 UTC (rev 2007)
@@ -4,6 +4,9 @@
(defparameter *worldpay-installation-id* 103530
"Installation-ID für Worldpay")
+;; Worldpay Test Mode
+(defparameter *worldpay-test-mode* t)
+
;; URL für BASE HREFs
(defparameter *website-url* "http://create-rainforest.org")
Modified: branches/xml-class-rework/projects/bos/worldpay-test/sponsor-handlers.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/worldpay-test/sponsor-handlers.lisp 2006-10-16 18:30:48 UTC (rev 2006)
+++ branches/xml-class-rework/projects/bos/worldpay-test/sponsor-handlers.lisp 2006-10-20 05:06:38 UTC (rev 2007)
@@ -134,7 +134,10 @@
(:td (:princ-safe (if (contract-paidp contract) "paid" "not paid")))
(:td (cmslink (format nil "cert-regen/~A" (store-object-id contract)) "Regenerate Certificate")
(when (probe-file (contract-pdf-pathname contract))
- (html :br (cmslink (contract-pdf-url contract) "Show Certificate"))))))))
+ (html :br (cmslink (contract-pdf-url contract) "Show Certificate")))
+ (when (contract-worldpay-trans-id contract)
+ (html :br ((:a :href (format nil "https://select.worldpay.com/wcc/admin?op-transInfo-~A=1"
+ (contract-worldpay-trans-id contract)))))))))))
(:p (submit-button "save" "save")
(submit-button "delete" "delete" :confirm "Really delete this sponsor?"))))))
Modified: branches/xml-class-rework/projects/bos/worldpay-test/tags.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/worldpay-test/tags.lisp 2006-10-16 18:30:48 UTC (rev 2006)
+++ branches/xml-class-rework/projects/bos/worldpay-test/tags.lisp 2006-10-20 05:06:38 UTC (rev 2007)
@@ -25,12 +25,13 @@
(emit-without-quoting "<WPDISPLAY ITEM=banner>"))
(define-bknr-tag process-payment (&key children)
- (with-template-vars (cartId email country)
+ (with-template-vars (cartId transId email country)
(let* ((contract (get-contract (parse-integer cartId)))
(sponsor (contract-sponsor contract)))
(change-slot-values sponsor 'bknr.web::email email)
(sponsor-set-country sponsor country)
(contract-set-paidp contract (format nil "~A: paid via worldpay" (format-date-time)))
+ (setf (contract-worldpay-trans-id contract) transId)
(setf (get-template-var :master-code) (sponsor-master-code sponsor))
(setf (get-template-var :sponsor-id) (sponsor-id sponsor))))
(mapc #'emit-template-node children))
@@ -78,23 +79,24 @@
(language (session-variable :language)))
(setf (get-template-var :worldpay-url)
(if manual-transfer
- (format nil "ueberweisung?contract-id=~a&amount=~a&numsqm=~a~@[&donationcert-yearly=1~]"
+ (format nil "ueberweisung?contract-id=~A&amount=~A&numsqm=~A~@[&donationcert-yearly=1~]"
(store-object-id contract)
price
numsqm
donationcert-yearly)
- (format nil "https://select.worldpay.com/wcc/purchase?instId=~a&cartId=~a&amount=~a¤cy=EUR&lang=~a&desc=~a&MC_sponsorid=~a&MC_password=~a&MC_donationcert-yearly=~A&MC_gift=~A" ; &testMode=100 für test
+ (format nil "https://select.worldpay.com/wcc/purchase?instId=~A&cartId=~A&amount=~A¤cy=EUR&lang=~A&desc=~A&MC_sponsorid=~A&MC_password=~A&MC_donationcert-yearly=~A&MC_gift=~A~@[~A~]"
*worldpay-installation-id*
(store-object-id contract)
price
language
- (encode-urlencoded (format nil "~a ~a in Samboja Lestari"
+ (encode-urlencoded (format nil "~A ~A in Samboja Lestari"
numsqm
(if (string-equal language "de") "qm Regenwald" "sqm rain forest")))
(store-object-id sponsor)
(sponsor-master-code sponsor)
(if donationcert-yearly "1" "0")
- (if gift "1" "0"))))))
+ (if gift "1" "0")
+ (when *worldpay-test-mode* "&testMode=100"))))))
(mapc #'emit-template-node children))
(define-bknr-tag mail-transfer ()
Modified: branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp 2006-10-16 18:30:48 UTC (rev 2006)
+++ branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp 2006-10-20 05:06:38 UTC (rev 2007)
@@ -96,7 +96,7 @@
())
(defmethod handle ((handler index-handler) req)
- (redirect (format nil "/~a/index" (or (find-browser-prefered-language req)
+ (redirect (format nil "/~A/index" (or (find-browser-prefered-language req)
*default-language*))
req))
@@ -135,8 +135,8 @@
(dolist (file (directory (merge-pathnames #p"images/statistics/*.svg" *website-directory*)))
(html ((:option :value (pathname-name file))
(:princ-safe (pathname-name file)))))))
- ((:p :id "stats")
- ((:embed :src "/images/statistics/all-contracts.svg" :width 800 :height 600 :type "image/svg+xml") "")))))))
+ ((:p :id "stats"))
+ ((:script :type "text/javascript") "statistic_selected()"))))))
(defclass print-certificate-handler (admin-only-handler object-handler)
()
@@ -191,12 +191,14 @@
(find-browser-prefered-language req)
*default-language*)))))
-(defun publish-worldpay-test (&key website-directory website-url (vhosts :wild))
+(defun publish-worldpay-test (&key website-directory website-url (worldpay-test-mode t) (vhosts :wild))
(setf *website-directory* website-directory)
(when website-url
(setf *website-url* website-url))
+ (setf *worldpay-test-mode* worldpay-test-mode)
+
(make-instance 'bos-website
:name "BOS Website"
:handler-definitions `(("/edit-poi" edit-poi-handler)
More information about the Bknr-cvs
mailing list