[bknr-cvs] r2035 - in branches/xml-class-rework/projects/bos: m2 worldpay-test
bknr at bknr.net
bknr at bknr.net
Mon Oct 23 08:14:41 UTC 2006
Author: hhubner
Date: 2006-10-23 04:14:40 -0400 (Mon, 23 Oct 2006)
New Revision: 2035
Modified:
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/worldpay-test/tags.lisp
branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp
Log:
mail vcards of manual sales
functions renamed, api enhanced
Modified: branches/xml-class-rework/projects/bos/m2/mail-generator.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/m2/mail-generator.lisp 2006-10-23 06:05:39 UTC (rev 2034)
+++ branches/xml-class-rework/projects/bos/m2/mail-generator.lisp 2006-10-23 08:14:40 UTC (rev 2035)
@@ -10,8 +10,14 @@
To: ~A
Subject: ~A
Content-Type: ~A
-~@[~%~]~A"
- (format-date-time (get-universal-time) :mail-style t) *mail-sender* to subject content-type (not more-headers) text)))
+~@[~*~%~]~A"
+ (format-date-time (get-universal-time) :mail-style t)
+ *mail-sender*
+ to
+ subject
+ content-type
+ (not more-headers)
+ text)))
(defun mail-info-request (email)
(send-system-mail :subject "Mailinglisten-Eintrag"
@@ -26,7 +32,7 @@
(send-system-mail :subject #?"Druckauftrag fuer Spender-Urkunde"
:text #?"Bitte die folgende Urkunde ausdrucken und versenden:
-http://create-rainforest.org/print-certificate/$(contract-id)
+$(*website-url*)/print-certificate/$(contract-id)
Versandadresse:
@@ -75,27 +81,100 @@
Das Team von BOS Deutschland e.V.")))
-(defun mail-transfer-indication (contract-id vorname name strasse plz ort email telefon mail-certificate donationcert-yearly)
- (let ((contract (store-object-with-id (parse-integer contract-id))))
- (send-system-mail :subject #?"Ueberweisungsformular fuer Contract-ID $(contract-id)"
- :content-type "text/html; charset=UTF-8"
- :text (format nil "
+(defun make-vcard (&key contract-id sponsor-id worldpay-transaction-id
+ donationcert-yearly gift
+ vorname nachname
+ name
+ address postcode country
+ strasse ort
+ email tel)
+ (with-output-to-string (s)
+ (format s "BEGIN:VCARD~%")
+ (format s "REV:~A~%" (format-date-time (get-universal-time) :xml-style t))
+ (format s "VERSION:2.1~%")
+ (if name
+ (format s "FN;CHARSET=ISO-8859-1;ENCODING=QUOTED-PRINTABLE:~A~%" (cl-qprint:encode (iconv:iconv "UTF-8" "ISO-8859-1" name)))
+ (format s "FN;CHARSET=ISO-8859-1;ENCODING=QUOTED-PRINTABLE:~A ~A~%"
+ (cl-qprint:encode (iconv:iconv "UTF-8" "ISO-8859-1" vorname))
+ (cl-qprint:encode (iconv:iconv "UTF-8" "ISO-8859-1" nachname))))
+ (when vorname
+ (format s "N;CHARSET=ISO-8859-1;ENCODING=QUOTED-PRINTABLE:~A;~A;;;~%"
+ (cl-qprint:encode (iconv:iconv "UTF-8" "ISO-8859-1" nachname))
+ (cl-qprint:encode (iconv:iconv "UTF-8" "ISO-8859-1" vorname))))
+ (when address
+ (format s "ADR;DOM;HOME;CHARSET=ISO-8859-1;ENCODING=QUOTED-PRINTABLE:;;~A;;;~@[~A~];~A~%"
+ (cl-qprint:encode (iconv:iconv "UTF-8" "ISO-8859-1" address) :encode-newlines t) postcode country))
+ (when strasse
+ (format s "ADR;DOM;HOME;CHARSET=ISO-8859-1;ENCODING=QUOTED-PRINTABLE:;;~A;~A;;~A;~@[~A~]~%"
+ (cl-qprint:encode (iconv:iconv "UTF-8" "ISO-8859-1" strasse))
+ (cl-qprint:encode (iconv:iconv "UTF-8" "ISO-8859-1" ort))
+ postcode country))
+ (when tel
+ (format s "TEL;WORK;HOME:~A~%" tel))
+ (format s "EMAIL;PREF;INTERNET:~A~%" email)
+ (format s "URL;WORK:~A/edit-sponsor/~A~%" *website-url* sponsor-id)
+ (format s "NOTE;ENCODING=QUOTED-PRINTABLE:~A~%"
+ (cl-qprint:encode (format nil "Contract ID: ~A~%Sponsor ID: ~A~%~@[WorldPay Transaction ID: ~A~%~]Donationcert yearly: ~A~%Gift: ~A~%"
+ contract-id
+ sponsor-id
+ worldpay-transaction-id
+ (if donationcert-yearly "Yes" "No")
+ (if gift "Yes" "No"))
+ :encode-newlines t))
+ (format s "END:VCARD~%")))
+
+(defun worldpay-callback-request-to-vcard (request)
+ (with-query-params (request cartId
+ transId
+ MC_sponsorid
+ MC_donationcert-yearly
+ MC_gift
+ name
+ address
+ postcode
+ country
+ email
+ tel)
+ (make-vcard :contract-id cartId
+ :sponsor-id MC_sponsorid
+ :worldpay-transaction-id transId
+ :donationcert-yearly MC_donationcert-yearly
+ :gift MC_gift
+ :name name
+ :address address
+ :postcode postcode
+ :country country
+ :email email
+ :tel tel)))
+
+(defun mail-manual-sponsor-data (req)
+ (with-query-params (req contract-id vorname name strasse plz ort email telefon mail-certificate donationcert-yearly)
+ (let* ((contract (store-object-with-id (parse-integer contract-id)))
+ (sponsor-id (store-object-id (contract-sponsor contract)))
+ (mime (make-instance 'multipart-mime
+ :subtype "mixed"
+ :content (list (make-instance 'text-mime
+ :type "text"
+ :subtype "html"
+ :charset "utf-8"
+ :encoding :quoted-printable
+ :content (format nil "
<html>
<body>
<h1>Ueberweisungsformulardaten:</h1>
<table border=\"1\">
- <tr><td>Contract-ID</td><td>~@[~a~]</td></tr>
- <tr><td>Anzahl sqm</td><td>~a</td></tr>
- <tr><td>Vorname</td><td>~@[~a~]</td></tr>
- <tr><td>Name</td><td>~@[~a~]</td></tr>
- <tr><td>Strasse</td><td>~@[~a~]</td></tr>
- <tr><td>PLZ</td><td>~@[~a~]</td></tr>
- <tr><td>Ort</td><td>~@[~a~]</td></tr>
- <tr><td>Email</td><td>~@[~a~]</td></tr>
- <tr><td>Telefon</td><td>~@[~a~]</td></tr>~@[
+ <tr><td>Contract-ID</td><td>~@[~A~]</td></tr>
+ <tr><td>Anzahl sqm</td><td>~A</td></tr>
+ <tr><td>Vorname</td><td>~@[~A~]</td></tr>
+ <tr><td>Name</td><td>~@[~A~]</td></tr>
+ <tr><td>Strasse</td><td>~@[~A~]</td></tr>
+ <tr><td>PLZ</td><td>~@[~A~]</td></tr>
+ <tr><td>Ort</td><td>~@[~A~]</td></tr>
+ <tr><td>Email</td><td>~@[~A~]</td></tr>
+ <tr><td>Telefon</td><td>~@[~A~]</td></tr>~@[
<tr><td></td></tr>
- <tr><td>Urkunde per Post</td><td>~a</td></tr>
- <tr><td>Spendenbescheinigung am Jahresende</td><td>~a</td></tr>~]
+ <tr><td>Urkunde per Post</td><td>~A</td></tr>
+ <tr><td>Spendenbescheinigung am Jahresende</td><td>~A</td></tr>~]
</table>
<p>Email & Adresse fuer Cut&Paste:</p>
<pre>
@@ -105,60 +184,66 @@
~A
~A ~A
</pre>
- <p><a href=\"http://create-rainforest.org/complete-transfer/~a\">Link zum Sponsor-Datensatz</a></p>
+ <p><a href=\"~A/complete-transfer/~A\">Link zum Sponsor-Datensatz</a></p>
</body>
</html>
"
- contract-id
- (length (contract-m2s contract))
- vorname name strasse plz ort email telefon
- (if mail-certificate "ja" "nein")
- (if donationcert-yearly "ja" "nein")
- email vorname name strasse plz ort
- contract-id))))
+ contract-id
+ (length (contract-m2s contract))
+ vorname name strasse plz ort email telefon
+ (if mail-certificate "ja" "nein")
+ (if donationcert-yearly "ja" "nein")
+ email vorname name
+ strasse plz ort
+ *website-url* contract-id))
+ (make-instance 'text-mime
+ :type "text"
+ :subtype (format nil "xml; name=\"contract-~A.xml\"" contract-id)
+ :charset "utf-8"
+ :encoding :quoted-printable
+ :content (format nil "
+<sponsor>
+ ~{<~A>~A</~A>~}
+</sponsor>
+"
+ (apply #'append (mapcar #'(lambda (cons)
+ (list (car cons)
+ (if (find #\Newline (cdr cons))
+ (format nil "<![CDATA[~A]]>" (cdr cons))
+ (cdr cons))
+ (car cons)))
+ (all-request-params req)))))
+ (make-instance 'text-mime
+ :type "text"
+ :subtype (format nil "x-vcard; name=\"contract-~A.vcf\"" contract-id)
+ :charset "utf-8"
+ :content (make-vcard :contract-id contract-id
+ :sponsor-id sponsor-id
+ :donationcert-yearly donationcert-yearly
+ :vorname vorname
+ :nachname name
+ :strasse strasse
+ :postcode plz
+ :ort ort
+ :email email
+ :tel telefon))))))
+ (send-system-mail :subject (format nil "Ueberweisungsformular-Spenderdaten - Sponsor-ID ~D Contract-ID ~D"
+ sponsor-id contract-id)
+ :content-type "multipart/mixed"
+ :more-headers t
+ :text (with-output-to-string (s) (print-mime s mime t t))))))
-(defun worldpay-callback-request-to-vcard (request)
- (with-query-params (request cartId
- transId
- MC_sponsorid
- MC_donationcert-yearly
- MC_gift
- name
- address
- postcode
- country
- email
- tel)
- (with-output-to-string (s)
- (format s "BEGIN:VCARD~%")
- (format s "REV:~A~%" (format-date-time (get-universal-time) :xml-style t))
- (format s "VERSION:2.1~%")
- (format s "FN;CHARSET=ISO-8859-1;ENCODING=QUOTED-PRINTABLE:~A~%" (cl-qprint:encode (iconv:iconv "UTF-8" "ISO-8859-1" name)))
- (format s "ADR;DOM;HOME;CHARSET=ISO-8859-1;ENCODING=QUOTED-PRINTABLE:;;~A;;;~@[~A~];~A~%"
- (cl-qprint:encode (iconv:iconv "UTF-8" "ISO-8859-1" address) :encode-newlines t) postcode country)
- (when tel
- (format s "TEL;WORK;HOME:~A~%" tel))
- (format s "EMAIL;PREF;INTERNET:~A~%" email)
- (format s "URL;WORK:~A/edit-sponsor/~A~%" *website-url* MC_sponsorid)
- (format s "NOTE;ENCODING=QUOTED-PRINTABLE:~A~%"
- (cl-qprint:encode (format nil "Contract ID: ~A~%Sponsor ID: ~A~%WorldPay Transaction ID: ~A~%Donationcert yearly: ~A~%Gift: ~A~%"
- cartId
- MC_sponsorid
- transId
- (if MC_donationcert-yearly "Yes" "No")
- (if MC_gift "Yes" "No"))
- :encode-newlines t))
- (format s "END:VCARD~%"))))
-
-(defun mail-request-parameters (req subject)
- (let ((mime (make-instance 'cl-mime:multipart-mime
- :subtype "mixed"
- :content (list (make-instance 'cl-mime:text-mime
- :type "text"
- :subtype "html"
- :charset "utf-8"
- :encoding :quoted-printable
- :content (format nil "
+(defun mail-worldpay-sponsor-data (req)
+ (with-query-params (req cartId)
+ (let* ((contract (store-object-with-id (parse-integer cartId)))
+ (mime (make-instance 'multipart-mime
+ :subtype "mixed"
+ :content (list (make-instance 'text-mime
+ :type "text"
+ :subtype "html"
+ :charset "utf-8"
+ :encoding :quoted-printable
+ :content (format nil "
<table border=\"1\">
<tr>
<th>Parameter</th>
@@ -167,27 +252,35 @@
~{<tr><td>~A</td><td>~A</td></tr>~}
</table>
"
- (apply #'append (mapcar #'(lambda (cons) (list (car cons) (cdr cons)))
- (all-request-params req)))))
- (make-instance 'cl-mime:text-mime
- :type "text"
- :subtype "xml; name=\"sponsor.xml\""
- :charset "utf-8"
- :encoding :quoted-printable
- :content (format nil "
+ (apply #'append (mapcar #'(lambda (cons) (list (car cons) (cdr cons)))
+ (sort (all-request-params req)
+ #'string-lessp
+ :key #'car)))))
+ (make-instance 'text-mime
+ :type "text"
+ :subtype (format nil "xml; name=\"contract-~A.xml\"" (store-object-id contract))
+ :charset "utf-8"
+ :encoding :quoted-printable
+ :content (format nil "
<sponsor>
~{<~A>~A</~A>~}
</sponsor>
"
- (apply #'append (mapcar #'(lambda (cons) (list (car cons) (cdr cons) (car cons)))
- (all-request-params req)))))
- (make-instance 'cl-mime:text-mime
- :type "text"
- :subtype "x-vcard; name=\"sponsor.vcf\""
- :charset "utf-8"
- :content (worldpay-callback-request-to-vcard req))))))
- (format t "made mame~%")
- (send-system-mail :subject subject
- :content-type "multipart/mixed"
- :more-headers t
- :text (with-output-to-string (s) (cl-mime:print-mime s mime t t)))))
+ (apply #'append (mapcar #'(lambda (cons)
+ (list (car cons)
+ (if (find #\Newline (cdr cons))
+ (format nil "<![CDATA[~A]]>" (cdr cons))
+ (cdr cons))
+ (car cons)))
+ (all-request-params req)))))
+ (make-instance 'text-mime
+ :type "text"
+ :subtype (format nil "x-vcard; name=\"contract-~A.vcf\"" (store-object-id contract))
+ :charset "utf-8"
+ :content (worldpay-callback-request-to-vcard req))))))
+ (send-system-mail :subject (format nil "Online-Spenderdaten - Sponsor-ID ~D Contract-ID ~D"
+ (store-object-id (contract-sponsor contract))
+ (store-object-id contract))
+ :content-type "multipart/mixed"
+ :more-headers t
+ :text (with-output-to-string (s) (print-mime s mime t t))))))
Modified: branches/xml-class-rework/projects/bos/m2/packages.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/m2/packages.lisp 2006-10-23 06:05:39 UTC (rev 2034)
+++ branches/xml-class-rework/projects/bos/m2/packages.lisp 2006-10-23 08:14:40 UTC (rev 2035)
@@ -38,6 +38,7 @@
:bos.m2.config
:net.post-office
:cxml
+ :cl-mime
:cl-gd)
(:shadowing-import-from :cl-interpol #:quote-meta-chars)
(:export #:m2-store
@@ -178,9 +179,9 @@
#:mail-fiscal-certificate-to-office
#:mail-instructions-to-sponsor
- #:mail-transfer-indication
#:mail-info-request
- #:mail-request-parameters
+ #:mail-manual-sponsor-data
+ #:mail-worldpay-sponsor-data
#:*cert-download-directory*))
Modified: branches/xml-class-rework/projects/bos/worldpay-test/tags.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/worldpay-test/tags.lisp 2006-10-23 06:05:39 UTC (rev 2034)
+++ branches/xml-class-rework/projects/bos/worldpay-test/tags.lisp 2006-10-23 08:14:40 UTC (rev 2035)
@@ -100,8 +100,7 @@
(mapc #'emit-template-node children))
(define-bknr-tag mail-transfer ()
- (with-query-params ((get-template-var :request) contract-id vorname name strasse plz ort email telefon mail-certificate donationcert-yearly)
- (mail-transfer-indication contract-id vorname name strasse plz ort email telefon mail-certificate donationcert-yearly)))
+ (mail-manual-sponsor-data (get-template-var :request)))
(define-bknr-tag when-certificate (&key children)
(let ((sponsor (bknr-request-user (get-template-var :request))))
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-23 06:05:39 UTC (rev 2034)
+++ branches/xml-class-rework/projects/bos/worldpay-test/worldpay-test.lisp 2006-10-23 08:14:40 UTC (rev 2035)
@@ -36,14 +36,10 @@
((equal "C" transStatus)
(setf template-name #?"/$(lang)/sponsor_canceled"))
((< (contract-price contract) *mail-certificate-threshold*)
- (mail-request-parameters request (format nil "Online-Spenderdaten - Sponsor-ID ~D Contract-ID ~D"
- (store-object-id (contract-sponsor contract))
- (store-object-id contract)))
+ (mail-worldpay-sponsor-data request)
(setf template-name #?"/$(lang)/quittung"))
(t
- (mail-request-parameters request (format nil "Online-Spenderdaten - Sponsor-ID ~D Contract-ID ~D"
- (store-object-id (contract-sponsor contract))
- (store-object-id contract)))
+ (mail-worldpay-sponsor-data request)
(when (<= *mail-fiscal-certificate-threshold* (contract-price contract))
(mail-fiscal-certificate-to-office contract name address country))
(setf template-name (if (and MC_gift (equal MC_gift "1")) #?"/$(lang)/versand_geschenk" #?"/$(lang)/versand_info")))))))
More information about the Bknr-cvs
mailing list