Author: hhubner Date: 2006-10-24 13:07:54 -0400 (Tue, 24 Oct 2006) New Revision: 2041 Modified: branches/xml-class-rework/projects/bos/m2/mail-generator.lisp Log: Beautified vCard generator Modified: branches/xml-class-rework/projects/bos/m2/mail-generator.lisp =================================================================== --- branches/xml-class-rework/projects/bos/m2/mail-generator.lisp 2006-10-24 10:06:58 UTC (rev 2040) +++ branches/xml-class-rework/projects/bos/m2/mail-generator.lisp 2006-10-24 17:07:54 UTC (rev 2041) @@ -81,19 +81,12 @@ 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 - name - address postcode country - strasse ort - email tel) +(defun format-vcard (field-list) (with-output-to-string (s) (labels - ((vcard-field (field-spec values) + ((ensure-list (thing) + (if (listp thing) thing (list thing))) + (vcard-field (field-spec &rest 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))) @@ -102,31 +95,40 @@ (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"))) - (vcard-field 'end "VCARD")))) + (dolist (field field-list) + (when field + (apply #'vcard-field field)))))) +(defun make-vcard (&key contract-id sponsor-id worldpay-transaction-id + donationcert-yearly gift + vorname nachname + name + address postcode country + strasse ort + email tel) + (format-vcard + `((BEGIN "VCARD") + (VERSION "2.1") + (REV ,(format-date-time (get-universal-time) :xml-style t)) + (FN ,(if name name (format nil "~A ~A" vorname nachname))) + ,(when vorname + `(N ,nachname ,vorname nil nil nil)) + ,(when address + `((ADR DOM HOME) nil nil ,address nil nil ,postcode ,country)) + ,(when strasse + `((ADR DOM HOME) nil nil ,strasse ,ort nil ,postcode ,country)) + ,(when tel + `((TEL WORK HOME) ,tel)) + ((EMAIL PREF INTERNET) ,email) + ((URL WORK) ,(format nil "~A/edit-sponsor/~A" *website-url* sponsor-id)) + (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"))) + (END "VCARD")))) + (defun worldpay-callback-request-to-vcard (request) (with-query-params (request cartId transId