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)