mail-generator.lisp

Revision 4082, 18.8 kB (checked in by hans, 1 week ago)
Fix sponsor XML problems.
Property svn:eol-style set to `native` Property svn:keywords set to `author date id revision`

Line
1	(in-package :bos.m2)
2
3	(enable-interpol-syntax)
4
5	(defvar postmaster-queue-lock (bt:make-lock "Postmaster Queue Lock"))
6
7	(defvar postmaster-queue (make-queue))
8
9	(defvar postmaster nil)
10
11	(defun postmaster-loop ()
12	(loop
13	(sleep 2)
14	(loop
15	(let ((entry (bt:with-lock-held (postmaster-queue-lock)
16	(peek-queue postmaster-queue))))
17	(when (or (null entry)
18	(not (contract-certificates-generated-p (second entry))))
19	(return)))
20	(let ((entry (bt:with-lock-held (postmaster-queue-lock)
21	(dequeue postmaster-queue))))
22	(handler-case
23	(destructuring-bind (function contract args) entry
24	(apply function contract args))
25	(error (e)
26	(warn "; could not send mail ~S: ~A" entry e)))))))
27
28	(defun postmaster-running-p ()
29	(and postmaster
30	(bt:thread-alive-p postmaster)))
31
32	(defun start-postmaster ()
33	(unless (postmaster-running-p)
34	(setq postmaster
35	(bt:make-thread #'postmaster-loop
36	:name "postmaster"))))
37
38	(defun send-to-postmaster (function contract &rest args)
39	(bt:with-lock-held (postmaster-queue-lock)
40	(enqueue (list function contract args) postmaster-queue)))
41
42	(defvar country->office-email '(("DK" . "bosdanmark.regnskov@gmail.com")
43	("SE" . "bosdanmark.regnskov@gmail.com")))
44
45	(defun country->office-email (country)
46	(or (cdr (assoc country country->office-email :test #'string-equal))
47	office-mail-address))
48
49	(defun contract-office-email (contract)
50	"Return the email address of the MXM office responsible for handling a contract"
51	(country->office-email (sponsor-country (contract-sponsor contract))))
52
53	(defun send-system-mail (&key (to office-mail-address) (subject "(no subject") (text "(no text)") (content-type "text/plain; charset=UTF-8") more-headers)
54	(setf to (alexandria:ensure-list to))
55	(if enable-mails
56	(cl-smtp:with-smtp-mail (smtp "localhost" mail-sender to)
57	(format smtp "X-Mailer: BKNR-BOS-mailer
58	Date: ~A
59	From: ~A
60	To: ~{~A~^, ~}
61	Subject: ~A
62	~@[Content-Type: ~A
63	~]~@[~*~%~]~A"
64	(format-date-time (get-universal-time) :mail-style t)
65	mail-sender
66	to
67	subject
68	content-type
69	(not more-headers)
70	text))
71	(format t "Mail with subject ~S to ~A not sent~%" subject to)))
72
73	(defun mail-info-request (email country)
74	(send-system-mail :subject "Mailing list request"
75	:to (country->office-email country)
76	:text #?"Please enter into the mailing list:
77
78
79	$(email)
80	"))
81
82	(defun mail-fiscal-certificate-to-office (contract name address country)
83	#+(or) (format t "mail-fiscal-certificate-to-office: ~a name: ~a address: ~a country: ~a~%" contract name address country))
84
85	(defun mail-template-directory (language)
86	"Return the directory where the mail templates are stored"
87	(merge-pathnames (make-pathname :directory `(:relative "templates" ,(string-downcase language)))
88	(symbol-value (find-symbol "WEBSITE-DIRECTORY" "BOS.WEB"))))
89
90	(defun rest-of-file (file)
91	(let ((result (make-array (- (file-length file)
92	(file-position file))
93	:element-type 'character)))
94	(read-sequence result file)
95	result))
96
97	(defun make-welcome-mail (sponsor)
98	"Return a plist containing the :subject and :text options to generate an email with send-system-mail"
99	(let ((vars (list :sponsor-id (sponsor-id sponsor)
100	:master-code (sponsor-master-code sponsor))))
101	(labels
102	((get-var (var-name) (getf vars var-name)))
103	(with-open-file (template (merge-pathnames #p"welcome-email.template"
104	(mail-template-directory (sponsor-language sponsor))))
105	(let ((subject (bknr.web:expand-variables (read-line template) #'get-var))
106	(text (bknr.web:expand-variables (rest-of-file template) #'get-var)))
107	(list :subject subject :text text))))))
108
109	(defun mail-instructions-to-sponsor (contract email)
110	(apply #'send-system-mail
111	:to email
112	(make-welcome-mail (contract-sponsor contract))))
113
114	(defun format-vcard (field-list)
115	(with-output-to-string (s)
116	(labels
117	((ensure-list (thing)
118	(if (listp thing) thing (list thing)))
119	(vcard-field (field-spec &rest values)
120	(let* ((values (mapcar (lambda (value) (or value "")) (ensure-list values)))
121	(encoded-values (mapcar (lambda (string) (cl-qprint:encode (or string "") :encode-newlines t)) values)))
122	(format s "~{~A~^;~}:~{~@[~A~]~^;~}~%"
123	(append (ensure-list field-spec)
124	(unless (equal values encoded-values)
125	'("CHARSET=ISO-8859-1" "ENCODING=QUOTED-PRINTABLE")))
126	encoded-values))))
127	(dolist (field field-list)
128	(when field
129	(apply #'vcard-field field))))))
130
131	(defun make-vcard (&key sponsor-id
132	note
133	vorname nachname
134	name
135	address postcode country
136	strasse ort
137	email tel)
138	(format-vcard
139	`((BEGIN "VCARD")
140	(VERSION "2.1")
141	(REV ,(format-date-time (get-universal-time) :xml-style t))
142	(FN ,(if name name (format nil "~A ~A" vorname nachname)))
143	,(when vorname
144	`(N ,nachname ,vorname nil nil nil))
145	,(when address
146	`((ADR DOM HOME) nil nil ,address nil nil ,postcode ,country))
147	,(when strasse
148	`((ADR DOM HOME) nil nil ,strasse ,ort nil ,postcode ,country))
149	,(when tel
150	`((TEL WORK HOME) ,tel))
151	((EMAIL PREF INTERNET) ,email)
152	((URL WORK) ,(format nil "~A/edit-sponsor/~A" website-url sponsor-id))
153	(NOTE ,note)
154	(END "VCARD"))))
155
156	(defun worldpay-callback-params-to-vcard (params)
157	(labels ((param (name)
158	(cdr (assoc name params :test #'string-equal))))
159	(let ((contract (store-object-with-id (parse-integer (param 'cartId)))))
160	(make-vcard :sponsor-id (param 'MC_sponsorid)
161	:note (format nil "Paid-by: Worldpay
162	Contract ID: ~A
163	Sponsor ID: ~A
164	Number of sqms: ~A
165	Amount: ~A
166	Payment type: ~A
167	WorldPay Transaction ID: ~A
168	Donationcert yearly: ~A
169	Gift: ~A
170	"
171	(param 'cartId)
172	(store-object-id (contract-sponsor contract))
173	(length (contract-m2s contract))
174	(param 'authAmountString)
175	(param 'cardType)
176	(param 'transId)
177	(if (param 'MC_donationcert-yearly) "Yes" "No")
178	(if (param 'MC_gift) "Yes" "No"))
179	:name (param 'name)
180	:address (param 'address)
181	:postcode (param 'postcode)
182	:country (param 'country)
183	:email (param 'email)
184	:tel (param 'tel)))))
185
186	(defun make-html-part (string)
187	(make-instance 'text-mime
188	:type "text"
189	:subtype "html"
190	:charset "utf-8"
191	:encoding :quoted-printable
192	:content string))
193
194	(defparameter common-element-names
195	'(("MC_donationcert-yearly" . "donationcert-yearly")
196	("MC_sponsorid" . "sponsor-id")
197	("countryString" . "country")
198	("postcode" . "plz")
199	("MC_gift" . "gift")
200	("cartId" . "contract-id")))
201
202	(defun lookup-element-name (element-name)
203	"Given an ELEMENT-NAME (which may be either a form field name or a name of a post parameter from
204	worldpay), return the common XML element name"
205	(cl-ppcre:regex-replace-all "(?i)[^-a-z0-9]"
206	(or (cdr (find element-name common-element-names :key #'car :test #'equal))
207	element-name)
208	""))
209
210	(defun make-contract-xml-part (id params)
211	(make-instance 'text-mime
212	:type "text"
213	:subtype (format nil "xml; name=\"contract-~A.xml\"" id)
214	:charset "utf-8"
215	:encoding :quoted-printable
216	:content (format nil "
217	<sponsor>
218	<date>~A</date>
219	~{<~A>~A</~A>~}
220	</sponsor>
221	"
222	(format-date-time (get-universal-time) :xml-style t)
223	(apply #'append
224	(mapcar #'(lambda (cons)
225	(destructuring-bind (element-name . content) cons
226	(setf element-name (lookup-element-name element-name))
227	(list element-name
228	(if (find #\Newline content)
229	(format nil "<![CDATA[~A]]>" content)
230	content)
231	element-name)))
232	params)))))
233
234	(defun make-vcard-part (id vcard)
235	(make-instance 'text-mime
236	:type "text"
237	:subtype (format nil "x-vcard; name=\"contract-~A.vcf\"" id)
238	:charset "utf-8"
239	:content vcard))
240
241	(defun mail-contract-data (contract type mime-parts)
242	(let ((parts mime-parts))
243	(when (probe-file (contract-pdf-pathname contract :print t))
244	(setf parts (append parts
245	(list (make-instance 'mime
246	:type "application"
247	:subtype (format nil "pdf; name=\"contract-~A.pdf\"" (store-object-id contract))
248	:encoding :base64
249	:content (file-contents (contract-pdf-pathname contract :print t)))))))
250	(send-system-mail :to (contract-office-email contract)
251	:subject (format nil "~A-Sponsor data - Sponsor-ID ~D Contract-ID ~D"
252	type
253	(store-object-id (contract-sponsor contract))
254	(store-object-id contract))
255	:content-type nil
256	:more-headers t
257	:text (with-output-to-string (s)
258	(format s "X-BOS-Sponsor-Country: ~A~%" (sponsor-country (contract-sponsor contract)))
259	(print-mime s
260	(make-instance 'multipart-mime
261	:subtype "mixed"
262	:content parts)
263	t t))))
264	(ignore-errors
265	(delete-file (contract-pdf-pathname contract :print t))))
266
267	(defun mail-print-pdf (contract)
268	(send-system-mail
269	:to (contract-office-email contract)
270	:subject (format nil "PDF certificate (regenerated) - Sponsor-ID ~D Contract-ID ~D"
271	(store-object-id (contract-sponsor contract))
272	(store-object-id contract))
273	:content-type nil
274	:more-headers t
275	:text (with-output-to-string (s)
276	(format s "X-BOS-Sponsor-Country: ~A~%" (sponsor-country (contract-sponsor contract)))
277	(print-mime s
278	(make-instance
279	'multipart-mime
280	:subtype "mixed"
281	:content (list
282	(make-instance
283	'mime
284	:type "application"
285	:subtype (format nil "pdf; name=\"contract-~A.pdf\""
286	(store-object-id contract))
287	:encoding :base64
288	:content (file-contents (contract-pdf-pathname contract :print t)))))
289	t t)))
290	(ignore-errors
291	(delete-file (contract-pdf-pathname contract :print t))))
292
293	(defun mail-backoffice-sponsor-data (contract numsqm country email name address language request-params)
294	(let* ((contract-id (store-object-id contract))
295	(numsqm (if (stringp numsqm) (parse-integer numsqm) numsqm))
296	(parts (list (make-html-part (format nil "
297	<html>
298	<body>
299	<h1>Manually entered sponsor data:</h1>
300	<table border=\"1\">
301	<tr><td>Contract-ID</td><td>~@[~A~]</td></tr>
302	<tr><td>Number of sqm</td><td>~A</td></tr>
303	<tr><td>Name</td><td>~@[~A~]</td></tr>
304	<tr><td>Adress</td><td>~@[~A~]</td></tr>
305	<tr><td>Email</td><td>~@[~A~]</td></tr>
306	<tr><td>Country</td><td>~@[~A~]</td></tr>
307	<tr><td>Language</td><td>~@[~A~]</td></tr>
308	</table>
309	</body>
310	</html>"
311	contract-id
312	numsqm
313	name
314	address
315	email
316	country
317	language))
318	(make-contract-xml-part (store-object-id contract) request-params)
319	(make-vcard-part (store-object-id contract)
320	(make-vcard :sponsor-id (store-object-id (contract-sponsor contract))
321	:note (format nil "Paid-by: Back office
322	Contract ID: ~A
323	Sponsor ID: ~A
324	Number of sqms: ~A
325	Amount: EUR~A.00
326	"
327	(store-object-id contract)
328	(store-object-id (contract-sponsor contract))
329	numsqm
330	(* 3 numsqm))
331	:name name
332	:address address
333	:email email)))))
334	(mail-contract-data contract "Manually entered sponsor" parts)))
335
336	(defun mail-manual-sponsor-data (contract vorname name strasse plz ort email telefon want-print donationcert-yearly request-params)
337	(let* ((sponsor-id (store-object-id (contract-sponsor contract)))
338	(contract-id (store-object-id contract))
339	(parts (list (make-html-part (format nil "
340	<html>
341	<body>
342	<h1>Sponsor data as entered by the sponsor:</h1>
343	<table border=\"1\">
344	<tr><td>Contract-ID</td><td>~@[~A~]</td></tr>
345	<tr><td>Number of sqm</td><td>~A</td></tr>
346	<tr><td>Amount</td><td>EUR~A</td></tr>
347	<tr><td>First name</td><td>~@[~A~]</td></tr>
348	<tr><td>Last name</td><td>~@[~A~]</td></tr>
349	<tr><td>Street</td><td>~@[~A~]</td></tr>
350	<tr><td>Postcode</td><td>~@[~A~]</td></tr>
351	<tr><td>City</td><td>~@[~A~]</td></tr>
352	<tr><td>Email</td><td>~@[~A~]</td></tr>
353	<tr><td>Phone</td><td>~@[~A~]</td></tr>
354	<tr><td></td></tr>
355	<tr><td>Printed certificate</td><td>~A</td></tr>
356	<tr><td>Donation receipt at year's end</td><td>~A</td></tr>
357	</table>
358	<p><a href=\"~A/complete-transfer/~A?email=~A\">Acknowledge receipt of payment</a></p>
359	</body>
360	</html>
361	"
362	(store-object-id contract)
363	(length (contract-m2s contract))
364	(* 3.0 (length (contract-m2s contract)))
365	vorname name strasse plz ort email telefon
366	(if want-print "yes" "no")
367	(if donationcert-yearly "yes" "no")
368	website-url contract-id (or email "")))
369	(make-contract-xml-part contract-id request-params)
370	(make-vcard-part contract-id (make-vcard :sponsor-id sponsor-id
371	:note (format nil "Paid-by: Manual money transfer
372	Contract ID: ~A
373	Sponsor ID: ~A
374	Number of sqms: ~A
375	Amount: EUR~A.00
376	Donationcert yearly: ~A
377	"
378	contract-id
379	sponsor-id
380	(length (contract-m2s contract))
381	(* 3 (length (contract-m2s contract)))
382	(if donationcert-yearly "Yes" "No"))
383	:vorname vorname
384	:nachname name
385	:strasse strasse
386	:postcode plz
387	:ort ort
388	:email email
389	:tel telefon)))))
390	(mail-contract-data contract "Ueberweisungsformular" parts)))
391
392	(defvar worldpay-params-hash (make-hash-table :test #'equal))
393
394	(defun remember-worldpay-params (contract-id params)
395	"Remember the parameters sent in a callback request from Worldpay so that they can be mailed to the BOS office later on"
396	(setf (gethash contract-id worldpay-params-hash) params))
397
398	(defun get-worldpay-params (contract)
399	(or (prog1
400	(gethash contract worldpay-params-hash)
401	(remhash contract worldpay-params-hash))
402	(error "cannot find WorldPay callback params for contract ~A~%" contract)))
403
404	(defun mail-worldpay-sponsor-data (contract)
405	(let* ((contract-id (store-object-id contract))
406	(params (get-worldpay-params contract))
407	(parts (list (make-html-part (format nil "
408	<table border=\"1\">
409	<tr>
410	<th>Parameter</th>
411	<th>Wert</th></tr>
412	</tr>
413	~{<tr><td>~A</td><td>~A</td></tr>~}
414	</table>
415	"
416	(apply #'append (mapcar #'(lambda (cons) (list (car cons) (cdr cons)))
417	(sort (copy-list params)
418	#'string-lessp
419	:key #'car)))))
420	(make-contract-xml-part contract-id params)
421	(make-vcard-part contract-id (worldpay-callback-params-to-vcard params)))))
422	(mail-contract-data contract "WorldPay" parts)))

Note: See TracBrowser for help on using the browser.

Download in other formats:

Original Format