[bknr-cvs] r2104 - in trunk/projects/bos: m2 worldpay-test - bknr-cvs@common-lisp.net - mailman3.common-lisp.net

3 Dec 2006

Author: hhubner
Date: 2006-12-03 08:26:32 -0500 (Sun, 03 Dec 2006)
New Revision: 2104
Modified:
   trunk/projects/bos/m2/mail-generator.lisp
   trunk/projects/bos/m2/packages.lisp
   trunk/projects/bos/worldpay-test/sponsor-handlers.lisp
Log:
Send sponsor data mail for manually entered sponsors.
Modified: trunk/projects/bos/m2/mail-generator.lisp
===================================================================

--- trunk/projects/bos/m2/mail-generator.lisp	2006-12-03 12:17:00 UTC (rev 2103)
+++ trunk/projects/bos/m2/mail-generator.lisp	2006-12-03 13:26:32 UTC (rev 2104)
@@ -150,6 +150,40 @@
    	  :email (param 'email)
    	  :tel (param 'tel)))))
+(defun make-html-part (string)
+  (make-instance 'text-mime
+		 :type "text"
+		 :subtype "html"
+		 :charset "utf-8"
+		 :encoding :quoted-printable
+		 :content string))
+
+(defun make-contract-xml-part (id params)
+  (make-instance 'text-mime
+		 :type "text"
+		 :subtype (format nil "xml; name="contract-~A.xml"" 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)))
+							  params)))))
+
+(defun make-vcard-part (id vcard)
+  (make-instance 'text-mime
+		 :type "text"
+		 :subtype (format nil "x-vcard; name="contract-~A.vcf"" id)
+		 :charset "utf-8"
+		 :content vcard))
+
 (defun mail-contract-data (contract type mime-parts)
   (let ((parts mime-parts))
     (unless (contract-download-only-p contract)
@@ -175,16 +209,49 @@
   (unless (contract-download-only-p contract)
     (delete-file (contract-pdf-pathname contract :print t))))
+(defun mail-backoffice-sponsor-data (contract req)
+  (with-query-params (req numsqm country email name address date language)
+    (let ((parts (list (make-html-part (format nil "
+<html>
+ <body>
+  <h1>Manuell erfasste Sponsordate:</h1>
+  <table border="1">
+   <tr><td>Contract-ID</td><td>~@[~A~]</td></tr>
+   <tr><td>Anzahl sqm</td><td>~A</td></tr>
+   <tr><td>Name</td><td>~@[~A~]</td></tr>
+   <tr><td>Adresse</td><td>~@[~A~]</td></tr>
+   <tr><td>Email</td><td>~@[~A~]</td></tr>
+  </table>
+ </body>
+</html>"
+					       (store-object-id contract)
+					       numsqm
+					       name
+					       address
+					       email))
+		       (make-contract-xml-part (store-object-id contract) (all-request-params req))
+		       (make-vcard-part (store-object-id contract)
+					(make-vcard :sponsor-id (store-object-id (contract-sponsor contract))
+						    :note (format nil "Paid-by: Back office
+Contract ID: ~A
+Sponsor ID: ~A
+Number of sqms: ~A
+Amount: EUR~A.00
+"
+								  (store-object-id contract)
+								  (store-object-id (contract-sponsor contract))
+								  numsqm
+								  (* 3 (parse-integer numsqm)))
+						    :name name
+						    :address address
+						    :email email)))))
+      (mail-contract-data contract "Manuell erfasster Sponsor" parts))))
+
 (defun mail-manual-sponsor-data (req)
   (with-query-params (req contract-id vorname name strasse plz ort email telefon donationcert-yearly)
     (let* ((contract (store-object-with-id (parse-integer contract-id)))
       (sponsor-id (store-object-id (contract-sponsor contract)))
-	   (parts (list (make-instance 'text-mime
-				       :type "text"
-				       :subtype "html"
-				       :charset "utf-8"
-				       :encoding :quoted-printable
-				       :content (format nil "
+	   (parts (list (make-html-part (format nil "
 <html>
  <body>
    <h1>Ueberweisungsformulardaten:</h1>
@@ -205,52 +272,32 @@
  </body>
 </html>
 "
-							contract-id
-							(length (contract-m2s contract))
-							vorname name strasse plz ort email telefon
-							(if donationcert-yearly "ja" "nein")
-							*website-url* contract-id email))
-			(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 :sponsor-id sponsor-id
-							    :note (format nil "Paid-by: Manual money transfer
+						contract-id
+						(length (contract-m2s contract))
+						vorname name strasse plz ort email telefon
+						(if donationcert-yearly "ja" "nein")
+						*website-url* contract-id email))
+			(make-contract-xml-part contract-id (all-request-params req))
+			(make-vcard-part contract-id (make-vcard :sponsor-id sponsor-id
+								 :note (format nil "Paid-by: Manual money transfer
 Contract ID: ~A
 Sponsor ID: ~A
 Number of sqms: ~A
 Amount: EUR~A.00
 Donationcert yearly: ~A
 "
-									  contract-id
-									  sponsor-id
-									  (length (contract-m2s contract))
-									  (* 3 (length (contract-m2s contract)))
-									  (if donationcert-yearly "Yes" "No"))
-							    :vorname vorname
-							    :nachname name
-							    :strasse strasse
-							    :postcode plz
-							    :ort ort
-							    :email email
-							    :tel telefon)))))
+									       contract-id
+									       sponsor-id
+									       (length (contract-m2s contract))
+									       (* 3 (length (contract-m2s contract)))
+									       (if donationcert-yearly "Yes" "No"))
+								 :vorname vorname
+								 :nachname name
+								 :strasse strasse
+								 :postcode plz
+								 :ort ort
+								 :email email
+								 :tel telefon)))))
       (mail-contract-data contract "Ueberweisungsformular" parts))))
(defvar *worldpay-params-hash* (make-hash-table :test #'equal))
@@ -269,12 +316,7 @@
   (with-query-params (req contract-id)
     (let* ((contract (store-object-with-id (parse-integer contract-id)))
       (params (get-worldpay-params contract-id))
-	   (parts (list (make-instance 'text-mime
-				       :type "text"
-				       :subtype "html"
-				       :charset "utf-8"
-				       :encoding :quoted-printable
-				       :content (format nil "
+	   (parts (list (make-html-part (format nil "
 <table border="1">
  <tr>
   <th>Parameter</th>
@@ -283,30 +325,10 @@
  ~{<tr><td>~A</td><td>~A</td></tr>~}
 </table>
 "
-							(apply #'append (mapcar #'(lambda (cons) (list (car cons) (cdr cons)))
-										(sort (copy-list params)
-										      #'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)
-											  (if (find #\Newline (cdr cons))
-											      (format nil "<![CDATA[~A]]>" (cdr cons))
-											      (cdr cons))
-											  (car cons)))
-										params))))
-			(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-params-to-vcard params)))))
+						(apply #'append (mapcar #'(lambda (cons) (list (car cons) (cdr cons)))
+									(sort (copy-list params)
+									      #'string-lessp
+									      :key #'car)))))
+			(make-contract-xml-part contract-id params)
+			(make-vcard-part contract-id (worldpay-callback-params-to-vcard params)))))
       (mail-contract-data contract "WorldPay" parts))))
Modified: trunk/projects/bos/m2/packages.lisp
===================================================================
--- trunk/projects/bos/m2/packages.lisp	2006-12-03 12:17:00 UTC (rev 2103)
+++ trunk/projects/bos/m2/packages.lisp	2006-12-03 13:26:32 UTC (rev 2104)
@@ -184,6 +184,7 @@
       #:mail-instructions-to-sponsor
       #:mail-info-request
       #:mail-manual-sponsor-data
+	   #:mail-backoffice-sponsor-data
       #:mail-worldpay-sponsor-data
#:*cert-download-directory*))
Modified: trunk/projects/bos/worldpay-test/sponsor-handlers.lisp
===================================================================
--- trunk/projects/bos/worldpay-test/sponsor-handlers.lisp	2006-12-03 12:17:00 UTC (rev 2103)
+++ trunk/projects/bos/worldpay-test/sponsor-handlers.lisp	2006-12-03 13:26:32 UTC (rev 2104)
@@ -84,17 +84,18 @@
        (:tr (:td "Name for certificate")
        (:td (text-field "name" :size 20)))
        (:tr (:td "Postal address for certificate"
-		 (:td (textarea-field "postaladdress" :rows 5 :cols 40))))
+		 (:td (textarea-field "address" :rows 5 :cols 40))))
        (:tr (:td (submit-button "create" "create" :formcheck "javascript:return check_complete_sale()"))))))))
(defun date-to-universal (date-string)
   (apply #'encode-universal-time 0 0 0 (mapcar #'parse-integer (split #?r"." date-string))))
(defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :create)) (sponsor (eql nil)) req)
-  (with-query-params (req numsqm country email name postaladdress date language)
+  (with-query-params (req numsqm country email name address date language)
     (let* ((sponsor (make-sponsor :email email :country country))
       (contract (make-contract sponsor (parse-integer numsqm) :paidp t :date (date-to-universal date))))
-      (contract-issue-cert contract name :address postaladdress :language language)
+      (contract-issue-cert contract name :address address :language language)
+      (mail-backoffice-sponsor-data contract req)
       (redirect (format nil "/edit-sponsor/~D" (store-object-id sponsor)) req))))
(defun contract-checkbox-name (contract)

    