[bknr-cvs] r2055 - in trunk/projects/bos: m2 payment-website/templates/de worldpay-test
bknr at bknr.net
bknr at bknr.net
Sun Nov 5 13:25:48 UTC 2006
Author: hhubner
Date: 2006-11-05 08:25:47 -0500 (Sun, 05 Nov 2006)
New Revision: 2055
Modified:
trunk/projects/bos/m2/cert-daemon.lisp
trunk/projects/bos/m2/config.lisp
trunk/projects/bos/m2/m2.lisp
trunk/projects/bos/m2/mail-generator.lisp
trunk/projects/bos/m2/make-certificate.lisp
trunk/projects/bos/payment-website/templates/de/ueberweisung.xml
trunk/projects/bos/worldpay-test/sponsor-handlers.lisp
trunk/projects/bos/worldpay-test/tags.lisp
trunk/projects/bos/worldpay-test/worldpay-test.lisp
Log:
Certificate handling overhauled. All donors now have a downloadable
PDF certificate. Print certificates are send by mail to the office
and deleted from disk thereafter.
Modified: trunk/projects/bos/m2/cert-daemon.lisp
===================================================================
--- trunk/projects/bos/m2/cert-daemon.lisp 2006-11-05 13:23:45 UTC (rev 2054)
+++ trunk/projects/bos/m2/cert-daemon.lisp 2006-11-05 13:25:47 UTC (rev 2055)
@@ -14,7 +14,6 @@
(defun fill-form (fdf-pathname pdf-pathname output-pathname)
(handler-case
(progn
- (ignore-errors (run-tool "recode" (list "utf-8..latin-1" (unix-namestring fdf-pathname))))
(cond
((unix-namestring pdf-pathname)
(run-tool "pdftk" (list (unix-namestring pdf-pathname)
Modified: trunk/projects/bos/m2/config.lisp
===================================================================
--- trunk/projects/bos/m2/config.lisp 2006-11-05 13:23:45 UTC (rev 2054)
+++ trunk/projects/bos/m2/config.lisp 2006-11-05 13:25:47 UTC (rev 2055)
@@ -48,7 +48,7 @@
*pdf-base-directory*))
(defparameter *receipt-download-template* (merge-pathnames #p"spendenbescheinigung-download.pdf"
*pdf-base-directory*))
-(defparameter *cert-daemon-poll-seconds* 15
+(defparameter *cert-daemon-poll-seconds* 2
"Wartezeit zwischen zwei Directory-Scans des Urkunden-Daemons")
;; Mail-Stuff
Modified: trunk/projects/bos/m2/m2.lisp
===================================================================
--- trunk/projects/bos/m2/m2.lisp 2006-11-05 13:23:45 UTC (rev 2054)
+++ trunk/projects/bos/m2/m2.lisp 2006-11-05 13:25:47 UTC (rev 2055)
@@ -238,28 +238,31 @@
(deftransaction contract-set-download-only-p (contract newval)
(setf (contract-download-only contract) newval))
-(defmethod contract-fdf-pathname ((contract contract) language)
+(defmethod contract-fdf-pathname ((contract contract) &key language print)
+ (when (and print
+ (contract-download-only-p contract))
+ (error "no print fdf for download-only contract ~A" contract))
(merge-pathnames (make-pathname :name (format nil "~D-~(~A~)"
(store-object-id contract)
language)
:type "fdf")
- (if (contract-download-only-p contract) *cert-download-directory* *cert-mail-directory*)))
+ (if print *cert-mail-directory* *cert-download-directory*)))
-(defmethod contract-pdf-pathname ((contract contract))
+(defmethod contract-pdf-pathname ((contract contract) &key print)
(merge-pathnames (make-pathname :name (format nil "~D" (store-object-id contract))
:type "pdf")
- (if (contract-download-only-p contract)
- bos.m2::*cert-download-directory*
- bos.m2::*cert-mail-directory*)))
+ (if print bos.m2::*cert-mail-directory* bos.m2::*cert-download-directory*)))
(defmethod contract-pdf-url ((contract contract))
- (format nil "/~:[~;print-~]certificate/~A" (not (contract-download-only-p contract)) (store-object-id contract)))
+ (format nil "/certificate/~A" (store-object-id contract)))
(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))
(change-slot-values contract 'cert-issued t))))
(defmethod contract-image-tiles ((contract contract))
Modified: trunk/projects/bos/m2/mail-generator.lisp
===================================================================
--- trunk/projects/bos/m2/mail-generator.lisp 2006-11-05 13:23:45 UTC (rev 2054)
+++ trunk/projects/bos/m2/mail-generator.lisp 2006-11-05 13:25:47 UTC (rev 2055)
@@ -89,6 +89,7 @@
(apply #'vcard-field field))))))
(defun make-vcard (&key sponsor-id
+ note
vorname nachname
name
address postcode country
@@ -139,7 +140,7 @@
Gift: ~A
"
cartId
- sponsor-id
+ (store-object-id (contract-sponsor contract))
(length (contract-m2s contract))
authAmountString
cardType
@@ -153,13 +154,34 @@
:email email
:tel tel))))
+(defun mail-contract-data (contract type mime-parts)
+ (unless (contract-download-only-p contract)
+ (push (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)))
+ mime-parts))
+ (send-system-mail :subject (format nil "~A-Spenderdaten - Sponsor-ID ~D Contract-ID ~D"
+ type
+ (store-object-id (contract-sponsor contract))
+ (store-object-id contract))
+ :content-type "multipart/mixed"
+ :more-headers t
+ :text (with-output-to-string (s)
+ (print-mime s
+ (make-instance 'multipart-mime
+ :subtype "mixed"
+ :content mime-parts)
+ t t)))
+ (unless (contract-download-only-p contract)
+ (delete-file (contract-pdf-pathname contract :print t))))
+
(defun mail-manual-sponsor-data (req)
(with-query-params (req contract-id vorname name strasse plz ort email telefon donationcert-yearly)
(let* ((contract (store-object-with-id (parse-integer contract-id)))
(sponsor-id (store-object-id (contract-sponsor contract)))
- (mime (make-instance 'multipart-mime
- :subtype "mixed"
- :content (list (make-instance 'text-mime
+ (parts (list (make-instance 'text-mime
:type "text"
:subtype "html"
:charset "utf-8"
@@ -181,15 +203,7 @@
<tr><td></td></tr>
<tr><td>Spendenbescheinigung am Jahresende</td><td>~A</td></tr>~]
</table>
- <p>Email & Adresse fuer Cut&Paste:</p>
- <pre>
-~A
-
-~A ~A
-~A
-~A ~A
- </pre>
- <p><a href=\"~A/complete-transfer/~A\">Link zum Sponsor-Datensatz</a></p>
+ <p><a href=\"~A/complete-transfer/~A?email=~A\">Zahlungseingang bestätigen</a></p>
</body>
</html>
"
@@ -197,9 +211,7 @@
(length (contract-m2s contract))
vorname name strasse plz ort email telefon
(if donationcert-yearly "ja" "nein")
- email vorname name
- strasse plz ort
- *website-url* contract-id))
+ *website-url* contract-id email))
(make-instance 'text-mime
:type "text"
:subtype (format nil "xml; name=\"contract-~A.xml\"" contract-id)
@@ -223,7 +235,7 @@
:charset "utf-8"
:content (make-vcard :sponsor-id sponsor-id
:note (format nil "Paid-by: Manual money transfer
-Contract ID: ~Annn
+Contract ID: ~A
Sponsor ID: ~A
Number of sqms: ~A
Amount: EUR~A.00
@@ -234,32 +246,19 @@
(length (contract-m2s contract))
(* 3 (length (contract-m2s contract)))
(if donationcert-yearly "Yes" "No"))
- :contract-id contract-id
- :donationcert-yearly donationcert-yearly
:vorname vorname
:nachname name
:strasse strasse
:postcode plz
:ort ort
:email email
- :tel telefon))
- (make-instance 'mime
- :type "application"
- :subtype (format nil "pdf; name=\"contract-~A.pdf\"" contract-id)
- :encoding :base64
- :content (file-contents (contract-pdf-pathname contract)))))))
- (send-system-mail :subject (format nil "Ueberweisungsformular-Spenderdaten - Sponsor-ID ~D Contract-ID ~D"
- sponsor-id contract-id)
- :content-type "multipart/mixed"
- :more-headers t
- :text (with-output-to-string (s) (print-mime s mime t t))))))
+ :tel telefon)))))
+ (mail-contract-data contract "Ueberweisungsformular" parts))))
(defun mail-worldpay-sponsor-data (req)
(with-query-params (req cartId)
(let* ((contract (store-object-with-id (parse-integer cartId)))
- (mime (make-instance 'multipart-mime
- :subtype "mixed"
- :content (list (make-instance 'text-mime
+ (parts (list (make-instance 'text-mime
:type "text"
:subtype "html"
:charset "utf-8"
@@ -298,10 +297,5 @@
:type "text"
:subtype (format nil "x-vcard; name=\"contract-~A.vcf\"" (store-object-id contract))
:charset "utf-8"
- :content (worldpay-callback-request-to-vcard req))))))
- (send-system-mail :subject (format nil "Online-Spenderdaten - Sponsor-ID ~D Contract-ID ~D"
- (store-object-id (contract-sponsor contract))
- (store-object-id contract))
- :content-type "multipart/mixed"
- :more-headers t
- :text (with-output-to-string (s) (print-mime s mime t t))))))
+ :content (worldpay-callback-request-to-vcard req)))))
+ (mail-contract-data contract "WorldPay" parts))))
Modified: trunk/projects/bos/m2/make-certificate.lisp
===================================================================
--- trunk/projects/bos/m2/make-certificate.lisp 2006-11-05 13:23:45 UTC (rev 2054)
+++ trunk/projects/bos/m2/make-certificate.lisp 2006-11-05 13:25:47 UTC (rev 2055)
@@ -27,13 +27,15 @@
;; bzw. im Dateisystem für den Download durch den Spender abgelegt
;; werden.
-(defun make-certificate (contract name &key (address "") (language "en"))
+(defun make-certificate (contract name &key print (address "") (language "en"))
"Erzeugen einer FDF-Datei für das Ausfüllen der Urkunde. Wenn das
optionale address-Argument übergeben wird, wird die Urkunde per Post
verschickt und entsprechend eine andere Vorlage ausgewählt als für den
Download der Urkunde"
(let ((sponsor (contract-sponsor contract)))
- (make-fdf-file (contract-fdf-pathname contract language)
+ (make-fdf-file (contract-fdf-pathname contract
+ :language language
+ :print print)
:datum (format-date-time (contract-date contract) :show-time nil)
:name name
:address address
Modified: trunk/projects/bos/payment-website/templates/de/ueberweisung.xml
===================================================================
--- trunk/projects/bos/payment-website/templates/de/ueberweisung.xml 2006-11-05 13:23:45 UTC (rev 2054)
+++ trunk/projects/bos/payment-website/templates/de/ueberweisung.xml 2006-11-05 13:25:47 UTC (rev 2055)
@@ -103,16 +103,6 @@
<td><input name="telefon" type="text" size="25" maxlength="30" /></td>
</tr>
<tr>
- <td colspan="3" height="5"> </td>
- </tr>
- <tr>
- <td colspan="3">
- <bos:urkunde-per-post contract-id="$(contract-id)"
- min-amount="30"
- message="Ich möchte meine Regenwald-Urkunde per Post erhalten" />
- </td>
- </tr>
- <tr>
<td colspan="3" height="20"> </td>
</tr>
<tr>
Modified: trunk/projects/bos/worldpay-test/sponsor-handlers.lisp
===================================================================
--- trunk/projects/bos/worldpay-test/sponsor-handlers.lisp 2006-11-05 13:23:45 UTC (rev 2054)
+++ trunk/projects/bos/worldpay-test/sponsor-handlers.lisp 2006-11-05 13:25:47 UTC (rev 2055)
@@ -185,25 +185,26 @@
(redirect (format nil "/edit-sponsor/~D" (store-object-id (contract-sponsor contract)))
req)
(let ((numsqm (length (contract-m2s contract))))
- (with-bos-cms-page (req :title "Complete square meter sale with wire transfer payment")
- (html
- ((:form :name "form")
- ((:input :type "hidden" :name "numsqm" :value #?"$(numsqm)"))
- ((:table)
- (:tr (:td "Number of square meters")
- (:td (:princ-safe numsqm)))
- (:tr (:td "Bought on")
- (:td (:princ-safe (format-date-time (contract-date contract)))))
- (:tr (:td "Country code (2 chars)")
- (:td (text-field "country" :size 2 :value "DE")))
- (:tr (:td "Language")
- (:td ((:select :name "language")
- (loop
- for (language-symbol language-name) in (website-languages)
- do (html ((:option :value language-symbol) (:princ-safe language-name)))))))
- (:tr (:td "Email-Address")
- (:td (text-field "email" :size 20)))
- (:tr (:td (submit-button "process" "process" :formcheck "javascript:return check_complete_sale()"))))))))))
+ (with-query-params (req email)
+ (with-bos-cms-page (req :title "Complete square meter sale with wire transfer payment")
+ (html
+ ((:form :name "form")
+ ((:input :type "hidden" :name "numsqm" :value #?"$(numsqm)"))
+ ((:table)
+ (:tr (:td "Number of square meters")
+ (:td (:princ-safe numsqm)))
+ (:tr (:td "Bought on")
+ (:td (:princ-safe (format-date-time (contract-date contract)))))
+ (:tr (:td "Country code (2 chars)")
+ (:td (text-field "country" :size 2 :value "DE")))
+ (:tr (:td "Language")
+ (:td ((:select :name "language")
+ (loop
+ for (language-symbol language-name) in (website-languages)
+ do (html ((:option :value language-symbol) (:princ-safe language-name)))))))
+ (:tr (:td "Email-Address")
+ (:td (text-field "email" :size 20 :value email)))
+ (:tr (:td (submit-button "process" "process" :formcheck "javascript:return check_complete_sale()")))))))))))
(defmethod handle-object-form ((handler complete-transfer-handler) (action (eql :process)) contract req)
(with-query-params (req email country language)
Modified: trunk/projects/bos/worldpay-test/tags.lisp
===================================================================
--- trunk/projects/bos/worldpay-test/tags.lisp 2006-11-05 13:23:45 UTC (rev 2054)
+++ trunk/projects/bos/worldpay-test/tags.lisp 2006-11-05 13:25:47 UTC (rev 2055)
@@ -101,11 +101,10 @@
(define-bknr-tag mail-transfer ()
(with-query-params ((get-template-var :request)
- contract-id mail-certificate
+ contract-id
name vorname strasse plz ort)
(let* ((contract (store-object-with-id (parse-integer contract-id)))
- (download-only (or (< (contract-price contract) *mail-certificate-threshold*)
- (not mail-certificate))))
+ (download-only (< (contract-price contract) *mail-certificate-threshold*)))
(contract-set-download-only-p contract download-only)
(contract-issue-cert contract (format nil "~A ~A" vorname name)
:address (format nil "~A ~A~%~A~%~A ~A"
@@ -114,16 +113,15 @@
plz ort)
:language (session-variable :language))
(loop
- do (sleep 1)
+ do (progn
+ (format t "~&; waiting for generation of certificate, contract-id ~A" contract-id)
+ (sleep 2))
until (probe-file (contract-pdf-pathname contract)))
(mail-manual-sponsor-data (get-template-var :request)))))
(define-bknr-tag when-certificate (&key children)
(let ((sponsor (bknr-request-user (get-template-var :request))))
- (when (some #'(lambda (contract)
- (and (contract-download-only-p contract)
- (contract-pdf-pathname contract)))
- (sponsor-contracts sponsor))
+ (when (some #'contract-pdf-pathname (sponsor-contracts sponsor))
(mapc #'emit-template-node children))))
(define-bknr-tag send-info-request (&key children email)
Modified: trunk/projects/bos/worldpay-test/worldpay-test.lisp
===================================================================
--- trunk/projects/bos/worldpay-test/worldpay-test.lisp 2006-11-05 13:23:45 UTC (rev 2054)
+++ trunk/projects/bos/worldpay-test/worldpay-test.lisp 2006-11-05 13:25:47 UTC (rev 2055)
@@ -134,19 +134,6 @@
((:p :id "stats"))
((:script :type "text/javascript") "statistic_selected()"))))))
-(defclass print-certificate-handler (admin-only-handler object-handler)
- ()
- (:default-initargs :class 'contract))
-
-(defmethod handle-object ((handler print-certificate-handler) contract req)
- (let ((pdf (file-contents (merge-pathnames (make-pathname :type "pdf"
- :name (format nil "~D" (store-object-id contract)))
- *cert-mail-directory*))))
- (with-http-response (req *ent* :content-type "application/pdf")
- (setf (request-reply-content-length req) (length pdf))
- (with-http-body (req *ent* :external-format '(unsigned-byte 8))
- (write-sequence pdf *html-stream*)))))
-
(defclass admin-handler (admin-only-handler page-handler)
())
@@ -219,7 +206,6 @@
("/admin" admin-handler)
("/languages" languages-handler)
("/infosystem" infosystem-handler)
- ("/print-certificate" print-certificate-handler)
("/overview" image-tile-handler)
("/enlarge-overview" enlarge-tile-handler)
("/create-contract" create-contract-handler)
More information about the Bknr-cvs
mailing list