[bknr-cvs] hans changed trunk/projects/bos/
BKNR Commits
bknr at bknr.net
Thu Jul 24 13:51:29 UTC 2008
Revision: 3619
Author: hans
URL: http://bknr.net/trac/changeset/3619
Send out contract mails asynchronously, from separate thread.
U trunk/projects/bos/build.lisp
U trunk/projects/bos/m2/mail-generator.lisp
U trunk/projects/bos/m2/packages.lisp
U trunk/projects/bos/web/sponsor-handlers.lisp
U trunk/projects/bos/web/tags.lisp
U trunk/projects/bos/web/webserver.lisp
Modified: trunk/projects/bos/build.lisp
===================================================================
--- trunk/projects/bos/build.lisp 2008-07-24 13:44:53 UTC (rev 3618)
+++ trunk/projects/bos/build.lisp 2008-07-24 13:51:29 UTC (rev 3619)
@@ -71,6 +71,7 @@
(apply #'bos.m2::reinit (read-configuration "m2.rc"))
(apply #'bos.web::init (read-configuration "web.rc"))
(bos.web::start-contract-tree-image-update-daemon)
+ (bos.m2::start-postmaster)
(bknr.cron::start-cron))
(defun start-cert-daemon ()
Modified: trunk/projects/bos/m2/mail-generator.lisp
===================================================================
--- trunk/projects/bos/m2/mail-generator.lisp 2008-07-24 13:44:53 UTC (rev 3618)
+++ trunk/projects/bos/m2/mail-generator.lisp 2008-07-24 13:51:29 UTC (rev 3619)
@@ -2,6 +2,43 @@
(enable-interpol-syntax)
+(defvar *postmaster-queue-lock* (bt:make-lock "Postmaster Queue Lock"))
+
+(defvar *postmaster-queue* (make-queue))
+
+(defvar *postmaster* nil)
+
+(defun postmaster-loop ()
+ (loop
+ (sleep 2)
+ (loop
+ (let ((entry (bt:with-lock-held (*postmaster-queue-lock*)
+ (peek-queue *postmaster-queue*))))
+ (when (or (null entry)
+ (not (contract-certificates-generated-p (second entry))))
+ (return)))
+ (let ((entry (bt:with-lock-held (*postmaster-queue-lock*)
+ (dequeue *postmaster-queue*))))
+ (handler-case
+ (destructuring-bind (function contract args) entry
+ (apply function contract args))
+ (error (e)
+ (warn "; could not send mail ~S: ~A" entry e)))))))
+
+(defun postmaster-running-p ()
+ (and *postmaster*
+ (bt:thread-alive-p *postmaster*)))
+
+(defun start-postmaster ()
+ (unless (postmaster-running-p)
+ (setq *postmaster*
+ (bt:make-thread #'postmaster-loop
+ :name "postmaster"))))
+
+(defun send-to-postmaster (function contract &rest args)
+ (bt:with-lock-held (*postmaster-queue-lock*)
+ (enqueue (list function contract args) *postmaster-queue*)))
+
(defvar *country->office-email* '(("DK" . "bosdanmark.regnskov at gmail.com")
("SE" . "bosdanmark.regnskov at gmail.com")))
@@ -251,9 +288,9 @@
(ignore-errors
(delete-file (contract-pdf-pathname contract :print t))))
-(defun mail-backoffice-sponsor-data (contract)
- (with-query-params (numsqm country email name address date language)
- (let ((parts (list (make-html-part (format nil "
+(defun mail-backoffice-sponsor-data (contract numsqm country email name address language request-params)
+ (let* ((contract-id (store-object-id contract))
+ (parts (list (make-html-part (format nil "
<html>
<body>
<h1>Manually entered sponsor data:</h1>
@@ -268,36 +305,35 @@
</table>
</body>
</html>"
- (store-object-id contract)
- numsqm
- name
- address
- email
- country
- language))
- (make-contract-xml-part (store-object-id contract) (all-request-params))
- (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
+ numsqm
+ name
+ address
+ email
+ country
+ language))
+ (make-contract-xml-part (store-object-id contract) request-params)
+ (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 "Manually entered sponsor" parts))))
+ (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 "Manually entered sponsor" parts)))
-(defun mail-manual-sponsor-data ()
- (with-query-params (contract-id vorname name strasse plz ort email telefon want-print donationcert-yearly)
- (let* ((contract (store-object-with-id (parse-integer contract-id)))
- (sponsor-id (store-object-id (contract-sponsor contract)))
- (parts (list (make-html-part (format nil "
+(defun mail-manual-sponsor-data (contract vorname name strasse plz ort email telefon want-print donationcert-yearly request-params)
+ (let* ((sponsor-id (store-object-id (contract-sponsor contract)))
+ (contract-id (store-object-id contract))
+ (parts (list (make-html-part (format nil "
<html>
<body>
<h1>Sponsor data as entered by the sponsor:</h1>
@@ -320,35 +356,35 @@
</body>
</html>
"
- contract-id
- (length (contract-m2s contract))
- (* 3.0 (length (contract-m2s contract)))
- vorname name strasse plz ort email telefon
- (if want-print "yes" "no")
- (if donationcert-yearly "yes" "no")
- *website-url* contract-id (or email "")))
- (make-contract-xml-part contract-id (all-request-params))
- (make-vcard-part contract-id (make-vcard :sponsor-id sponsor-id
- :note (format nil "Paid-by: Manual money transfer
+ (store-object-id contract)
+ (length (contract-m2s contract))
+ (* 3.0 (length (contract-m2s contract)))
+ vorname name strasse plz ort email telefon
+ (if want-print "yes" "no")
+ (if donationcert-yearly "yes" "no")
+ *website-url* contract-id (or email "")))
+ (make-contract-xml-part contract-id request-params)
+ (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)))))
- (mail-contract-data contract "Ueberweisungsformular" parts))))
+ 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))
@@ -356,17 +392,16 @@
"Remember the parameters sent in a callback request from Worldpay so that they can be mailed to the BOS office later on"
(setf (gethash contract-id *worldpay-params-hash*) params))
-(defun get-worldpay-params (contract-id)
+(defun get-worldpay-params (contract)
(or (prog1
- (gethash contract-id *worldpay-params-hash*)
- (remhash contract-id *worldpay-params-hash*))
- (error "cannot find WorldPay callback params for contract ~A~%" contract-id)))
+ (gethash contract *worldpay-params-hash*)
+ (remhash contract *worldpay-params-hash*))
+ (error "cannot find WorldPay callback params for contract ~A~%" contract)))
-(defun mail-worldpay-sponsor-data ()
- (with-query-params (contract-id)
- (let* ((contract (store-object-with-id (parse-integer contract-id)))
- (params (get-worldpay-params contract-id))
- (parts (list (make-html-part (format nil "
+(defun mail-worldpay-sponsor-data (contract)
+ (let* ((contract-id (store-object-id contract))
+ (params (get-worldpay-params contract))
+ (parts (list (make-html-part (format nil "
<table border=\"1\">
<tr>
<th>Parameter</th>
@@ -375,10 +410,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-contract-xml-part contract-id params)
- (make-vcard-part contract-id (worldpay-callback-params-to-vcard params)))))
- (mail-contract-data contract "WorldPay" parts))))
+ (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 2008-07-24 13:44:53 UTC (rev 3618)
+++ trunk/projects/bos/m2/packages.lisp 2008-07-24 13:51:29 UTC (rev 3619)
@@ -251,6 +251,7 @@
#:news-item-title
#:news-item-text
+ #:send-to-postmaster
#:mail-fiscal-certificate-to-office
#:mail-instructions-to-sponsor
#:mail-info-request
Modified: trunk/projects/bos/web/sponsor-handlers.lisp
===================================================================
--- trunk/projects/bos/web/sponsor-handlers.lisp 2008-07-24 13:44:53 UTC (rev 3618)
+++ trunk/projects/bos/web/sponsor-handlers.lisp 2008-07-24 13:51:29 UTC (rev 3619)
@@ -114,7 +114,7 @@
(user-login (bknr.web:bknr-session-user)))
:date (date-to-universal date))))
(contract-issue-cert contract name :address address :language language)
- (mail-backoffice-sponsor-data contract)
+ (send-to-postmaster #'mail-backoffice-sponsor-data contract numsqm country email name address language (all-request-params))
(redirect (format nil "/edit-sponsor/~D" (store-object-id sponsor))))))
(defun contract-checkbox-name (contract)
Modified: trunk/projects/bos/web/tags.lisp
===================================================================
--- trunk/projects/bos/web/tags.lisp 2008-07-24 13:44:53 UTC (rev 3618)
+++ trunk/projects/bos/web/tags.lisp 2008-07-24 13:51:29 UTC (rev 3619)
@@ -42,7 +42,7 @@
(when (equal want-print "no")
(contract-set-download-only-p contract t))
(contract-issue-cert contract name :address address :language (request-language))
- (mail-worldpay-sponsor-data)
+ (send-to-postmaster #'mail-worldpay-sponsor-data contract)
(bknr.web::redirect-request :target (if gift "index"
(format nil "profil_setup?name=~A&email=~A&sponsor-id=~A"
(encode-urlencoded name) (encode-urlencoded email)
@@ -122,7 +122,8 @@
(define-bknr-tag mail-transfer ()
(with-query-params (country
contract-id
- name vorname strasse plz ort)
+ name vorname strasse plz ort telefon want-print
+ email donationcert-yearly)
(let* ((contract (store-object-with-id (parse-integer contract-id)))
(download-only (< (contract-price contract) *mail-certificate-threshold*)))
(with-transaction (:prepare-before-mail)
@@ -134,7 +135,9 @@
strasse
plz ort)
:language (request-language))
- (mail-manual-sponsor-data))))
+ (send-to-postmaster #'mail-manual-sponsor-data
+ contract vorname name strasse plz ort email telefon want-print donationcert-yearly
+ (all-request-params)))))
(define-bknr-tag when-certificate ()
(let ((sponsor (bknr-session-user)))
Modified: trunk/projects/bos/web/webserver.lisp
===================================================================
--- trunk/projects/bos/web/webserver.lisp 2008-07-24 13:44:53 UTC (rev 3618)
+++ trunk/projects/bos/web/webserver.lisp 2008-07-24 13:51:29 UTC (rev 3619)
@@ -29,8 +29,8 @@
(with-query-params (cartId name address country transStatus lang MC_gift)
(unless (website-supports-language lang)
(setf lang *default-language*))
- (bos.m2::remember-worldpay-params cartId (all-request-params))
(let ((contract (get-contract (parse-integer cartId))))
+ (bos.m2::remember-worldpay-params contract (all-request-params))
(sponsor-set-language (contract-sponsor contract) lang)
(cond
((not (typep contract 'contract))
More information about the Bknr-cvs
mailing list