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