[bknr-cvs] r2040 - branches/xml-class-rework/projects/bos/m2

[bknr at bknr.net]

Author: hhubner
Date: 2006-10-24 06:06:58 -0400 (Tue, 24 Oct 2006)
New Revision: 2040

Modified:
   branches/xml-class-rework/projects/bos/m2/mail-generator.lisp
Log:
vcard creation sanitized


Modified: branches/xml-class-rework/projects/bos/m2/mail-generator.lisp
===================================================================
--- branches/xml-class-rework/projects/bos/m2/mail-generator.lisp	2006-10-24 09:56:56 UTC (rev 2039)
+++ branches/xml-class-rework/projects/bos/m2/mail-generator.lisp	2006-10-24 10:06:58 UTC (rev 2040)
@@ -81,6 +81,9 @@
 
 Das Team von BOS Deutschland e.V.")))
 
+(defun ensure-list (thing)
+  (if (listp thing) thing (list thing)))
+
 (defun make-vcard (&key contract-id sponsor-id worldpay-transaction-id
 		   donationcert-yearly gift
 		   vorname nachname
@@ -89,39 +92,40 @@
 		   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~%"
+    (labels
+	((vcard-field (field-spec values)
+	   (let* ((values (mapcar (lambda (value) (or value "")) (ensure-list values)))
+		  (encoded-values (mapcar (lambda (string) (cl-qprint:encode (iconv:iconv "UTF-8" "ISO-8859-1" (or string ""))
+									     :encode-newlines t)) values)))
+	     (format s "~{~A~^;~}:~{~@[~A~]~^;~}~%"
+		     (append (ensure-list field-spec)
+			     (unless (equal values encoded-values)
+			       '("CHARSET=ISO-8859-1" "ENCODING=QUOTED-PRINTABLE")))
+		     encoded-values))))
+      (vcard-field 'begin "VCARD")
+      (vcard-field 'version "2.1")
+      (vcard-field 'rev (format-date-time (get-universal-time) :xml-style t))
+      (vcard-field 'fn (if name name (format nil "~A ~A" vorname nachname)))
+      (when vorname
+	(vcard-field 'n (list nachname vorname nil nil nil)))
+      (when address
+	(vcard-field '(adr dom home)
+		     (list nil nil address nil nil postcode country)))
+      (when strasse
+	(vcard-field '(adr dom home)
+		     (list nil nil strasse ort nil postcode country)))
+      (when tel
+	(vcard-field '(tel work home)
+		     tel))
+      (vcard-field '(email pref internet) email)
+      (vcard-field '(url work) (format nil "~A/edit-sponsor/~A" *website-url* sponsor-id))
+      (vcard-field 'note (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~%")))
+				      (if gift "Yes" "No")))
+      (vcard-field 'end "VCARD"))))
 
 (defun worldpay-callback-request-to-vcard (request)
   (with-query-params (request cartId