Revision: 3554 Author: hans URL: http://bknr.net/trac/changeset/3554

Never block in contract-issue-cert. In the frontend, the user will always spend enough time on the following pages so that the certificate will be generated. In order to support the CMS workflow, the /certificate handler now waits until the certificates have been generated before serving the PDF.

U trunk/bknr/datastore/src/data/object.lisp U trunk/projects/bos/m2/m2.lisp U trunk/projects/bos/m2/packages.lisp U trunk/projects/bos/web/contract-handlers.lisp U trunk/projects/bos/web/kml-handlers.lisp U trunk/projects/bos/web/webserver.lisp

Modified: trunk/bknr/datastore/src/data/object.lisp =================================================================== --- trunk/bknr/datastore/src/data/object.lisp 2008-07-22 11:48:19 UTC (rev 3553) +++ trunk/bknr/datastore/src/data/object.lisp 2008-07-22 12:02:48 UTC (rev 3554) @@ -41,7 +41,7 @@ (let ((instance-count (length (class-instances class)))) (when (plusp instance-count) (unless *suppress-schema-warnings* - (warn "updating ~A instances of ~A for class changes" instance-count class)) + (format *trace-output* "~&; updating ~A instances of ~A for class changes~%" instance-count class)) (mapc #'reinitialize-instance (class-instances class)))))

(defmethod instance :after ((class persistent-class) &rest args)

Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2008-07-22 11:48:19 UTC (rev 3553) +++ trunk/projects/bos/m2/m2.lisp 2008-07-22 12:02:48 UTC (rev 3554) @@ -342,15 +342,6 @@ (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) (when (contract-cert-issued contract) (warn "re-issuing cert for ~A" contract)) @@ -358,7 +349,6 @@ (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))

Modified: trunk/projects/bos/m2/packages.lisp =================================================================== --- trunk/projects/bos/m2/packages.lisp 2008-07-22 11:48:19 UTC (rev 3553) +++ trunk/projects/bos/m2/packages.lisp 2008-07-22 12:02:48 UTC (rev 3554) @@ -161,6 +161,7 @@ #:contract-set-download-only-p #:contract-price #:contract-issue-cert + #:contract-certificates-generated-p #:contract-worldpay-trans-id #:contract-pdf-pathname #:contract-pdf-url

Modified: trunk/projects/bos/web/contract-handlers.lisp =================================================================== --- trunk/projects/bos/web/contract-handlers.lisp 2008-07-22 11:48:19 UTC (rev 3553) +++ trunk/projects/bos/web/contract-handlers.lisp 2008-07-22 12:02:48 UTC (rev 3554) @@ -32,4 +32,5 @@ (:td (:princ-safe (contract-color contract)))) #+(or) (:tr (:td "cert issued?") - (:td (:princ-safe (if (contract-cert-issued contract) "yes" "no"))))))) \ No newline at end of file + (:td (:princ-safe (if (contract-cert-issued contract) "yes" "no"))))))) +

Modified: trunk/projects/bos/web/kml-handlers.lisp =================================================================== --- trunk/projects/bos/web/kml-handlers.lisp 2008-07-22 11:48:19 UTC (rev 3553) +++ trunk/projects/bos/web/kml-handlers.lisp 2008-07-22 12:02:48 UTC (rev 3554) @@ -138,7 +138,7 @@ (hunchentoot:handle-if-modified-since timestamp) (setf (hunchentoot:header-out :last-modified) (hunchentoot:rfc-1123-date timestamp)) - (with-xml-response (:content-type #+nil "text/xml" "application/vnd.google-earth.kml+xml; charset=utf-8" + (with-xml-response (:content-type "application/vnd.google-earth.kml+xml; charset=utf-8" :root-element "kml") (with-query-params ((lang "en")) (with-element "Document"

Modified: trunk/projects/bos/web/webserver.lisp =================================================================== --- trunk/projects/bos/web/webserver.lisp 2008-07-22 11:48:19 UTC (rev 3553) +++ trunk/projects/bos/web/webserver.lisp 2008-07-22 12:02:48 UTC (rev 3554) @@ -122,7 +122,17 @@ (defmethod handle-object ((handler certificate-handler) contract) (unless contract (setf contract (find-if #'contract-pdf-pathname (sponsor-contracts (bknr.web:bknr-session-user))))) - (redirect (format nil "/certificates/~D.pdf" (store-object-id contract)))) + (if (contract-certificates-generated-p contract) + (redirect (format nil "/certificates/~D.pdf" (store-object-id contract))) + (with-http-response (:content-type "text/html; charset=UTF-8") + (with-http-body () + (html + (:html + (:head + (:title "Waiting for certificate generation...") + ((:meta :http-equiv "Refresh" :content (format nil "3; ~A" (hunchentoot:script-name*))))) + (:body + "Please wait, certificate is being generated")))))))

(defclass statistics-handler (editor-only-handler prefix-handler) ())