[bknr-cvs] r2331 - in branches/bos/projects/bos: . m2 payment-website/images worldpay-test
bknr at bknr.net
bknr at bknr.net
Thu Jan 17 15:24:21 UTC 2008
Author: hhubner
Date: 2008-01-17 10:24:19 -0500 (Thu, 17 Jan 2008)
New Revision: 2331
Modified:
branches/bos/projects/bos/README
branches/bos/projects/bos/m2/m2.lisp
branches/bos/projects/bos/m2/mail-generator.lisp
branches/bos/projects/bos/m2/packages.lisp
branches/bos/projects/bos/payment-website/images/header_ganzneu.gif
branches/bos/projects/bos/worldpay-test/sponsor-handlers.lisp
Log:
Send out re-generated print certificate by email.
Tag mails by sponsor country for filtering.
Modified: branches/bos/projects/bos/README
===================================================================
--- branches/bos/projects/bos/README 2008-01-17 15:23:49 UTC (rev 2330)
+++ branches/bos/projects/bos/README 2008-01-17 15:24:19 UTC (rev 2331)
@@ -4,7 +4,7 @@
Vorbereitung
------------
- - CMUCL 19a installieren, so dass "lisp" im Pfad ist
+ - CMUCL 19c installieren, so dass "lisp" im Pfad ist
- Komplettes cvs auschecken:
$ cvs -d :ext:bknr.net:/home/bknr/cvs co -d bknr.net .
Modified: branches/bos/projects/bos/m2/m2.lisp
===================================================================
--- branches/bos/projects/bos/m2/m2.lisp 2008-01-17 15:23:49 UTC (rev 2330)
+++ branches/bos/projects/bos/m2/m2.lisp 2008-01-17 15:24:19 UTC (rev 2331)
@@ -286,20 +286,34 @@
(defmethod contract-pdf-url ((contract contract))
(format nil "/certificate/~A" (store-object-id contract)))
+(defmethod contract-certificates-generated-p (contract)
+ (and (probe-file (contract-pdf-pathname contract))
+ (or (contract-download-only-p contract)
+ (probe-file (contract-pdf-pathname contract :print t)))))
+
+(defmethod contract-delete-certificate-files (contract)
+ (ignore-errors
+ (delete-file (contract-pdf-pathname contract))
+ (delete-file (contract-pdf-pathname contract :print t))))
+
+(defun wait-for-certificates (contract)
+ "Wait until the PDF generating process has generated the certificates"
+ (dotimes (i 10)
+ (when (contract-certificates-generated-p contract)
+ (return))
+ (sleep 1))
+ (unless (contract-certificates-generated-p contract)
+ (error "Cannot generate certificate")))
+
(defmethod contract-issue-cert ((contract contract) name &key address language)
- (if (contract-cert-issued contract)
- (warn "can't re-issue cert for ~A" contract)
- (progn
- (make-certificate contract name :address address :language language)
- (unless (contract-download-only-p contract)
- (make-certificate contract name :address address :language language :print t))
- (dotimes (i 10)
- (when (probe-file (contract-pdf-pathname contract))
- (return))
- (sleep 1))
- (if (probe-file (contract-pdf-pathname contract))
- (change-slot-values contract 'cert-issued t)
- (error "Cannot generate certificate")))))
+ (when (contract-cert-issued contract)
+ (warn "re-issuing cert for ~A" contract))
+ (contract-delete-certificate-files contract)
+ (make-certificate contract name :address address :language language)
+ (unless (contract-download-only-p contract)
+ (make-certificate contract name :address address :language language :print t))
+ (wait-for-certificates contract)
+ (change-slot-values contract 'cert-issued t))
(defmethod contract-image-tiles ((contract contract))
(let (image-tiles)
Modified: branches/bos/projects/bos/m2/mail-generator.lisp
===================================================================
--- branches/bos/projects/bos/m2/mail-generator.lisp 2008-01-17 15:23:49 UTC (rev 2330)
+++ branches/bos/projects/bos/m2/mail-generator.lisp 2008-01-17 15:24:19 UTC (rev 2331)
@@ -214,14 +214,40 @@
:content-type nil
:more-headers t
:text (with-output-to-string (s)
+ (format s "X-BOS-Sponsor-Country: ~A~%" (sponsor-country (contract-sponsor contract)))
(print-mime s
(make-instance 'multipart-mime
:subtype "mixed"
:content parts)
t t))))
- (unless (contract-download-only-p contract)
+ (when (contract-pdf-pathname contract :print t)
(delete-file (contract-pdf-pathname contract :print t))))
+(defun mail-print-pdf (contract)
+ (send-system-mail
+ :to (contract-office-email contract)
+ :subject (format nil "PDF certificate (regenerated) - Sponsor-ID ~D Contract-ID ~D"
+ (store-object-id (contract-sponsor contract))
+ (store-object-id contract))
+ :content-type nil
+ :more-headers t
+ :text (with-output-to-string (s)
+ (format s "X-BOS-Sponsor-Country: ~A~%" (sponsor-country (contract-sponsor contract)))
+ (print-mime s
+ (make-instance
+ 'multipart-mime
+ :subtype "mixed"
+ :content (list
+ (make-instance
+ 'mime
+ :type "application"
+ :subtype (format nil "pdf; name=\"contract-~A.pdf\""
+ (store-object-id contract))
+ :encoding :base64
+ :content (file-contents (contract-pdf-pathname contract :print t)))))
+ t t)))
+ (delete-file (contract-pdf-pathname contract :print t)))
+
(defun mail-backoffice-sponsor-data (contract req)
(with-query-params (req numsqm country email name address date language)
(let ((parts (list (make-html-part (format nil "
Modified: branches/bos/projects/bos/m2/packages.lisp
===================================================================
--- branches/bos/projects/bos/m2/packages.lisp 2008-01-17 15:23:49 UTC (rev 2330)
+++ branches/bos/projects/bos/m2/packages.lisp 2008-01-17 15:24:19 UTC (rev 2331)
@@ -195,6 +195,7 @@
#:mail-manual-sponsor-data
#:mail-backoffice-sponsor-data
#:mail-worldpay-sponsor-data
+ #:mail-print-pdf
#:*cert-download-directory*))
Modified: branches/bos/projects/bos/payment-website/images/header_ganzneu.gif
===================================================================
(Binary files differ)
Modified: branches/bos/projects/bos/worldpay-test/sponsor-handlers.lisp
===================================================================
--- branches/bos/projects/bos/worldpay-test/sponsor-handlers.lisp 2008-01-17 15:23:49 UTC (rev 2330)
+++ branches/bos/projects/bos/worldpay-test/sponsor-handlers.lisp 2008-01-17 15:24:19 UTC (rev 2331)
@@ -304,7 +304,8 @@
(t (error "invalid sponsor or contract id ~A" object-id-string)))))
(defmethod handle-object-form ((handler cert-regen-handler) action (contract contract) req)
- (with-bos-cms-page (req :title "Re-generate Certificate")
+ (with-bos-cms-page (req :title (format nil "Re-generate Certificate~@[~*s~]"
+ (not (contract-download-only-p contract))))
(html
((:form :name "form")
((:table)
@@ -319,12 +320,14 @@
(html
(:tr (:td (submit-button "regenerate" "regenerate")))))))))
-(defun confirm-cert-regen (req)
- (with-bos-cms-page (req :title "Certificate generation request has been created")
- (html
- "Your certificate generation request has been created, please wait a few seconds before checking the PDF file")))
-
(defmethod handle-object-form ((handler cert-regen-handler) (action (eql :regenerate)) (contract contract) req)
(with-query-params (req name address language)
- (bos.m2::make-certificate contract name :address address :language language))
- (confirm-cert-regen req))
\ No newline at end of file
+ (contract-issue-cert contract name :address address :language language))
+ (with-bos-cms-page (req :title "Certificate has been recreated")
+ (html "The certificates for the sponsor have been re-generated.")
+ (unless (contract-download-only-p contract)
+ (mail-print-pdf contract)
+ (let ((sponsor (contract-sponsor contract)))
+ (html "The print certificate has been sent to the relevant BOS office address by email."
+ :br
+ (cmslink #?"edit-sponsor/$((store-object-id sponsor))" "return to sponsor"))))))
\ No newline at end of file
More information about the Bknr-cvs
mailing list