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