Author: hhubner Date: 2007-01-02 06:24:22 -0500 (Tue, 02 Jan 2007) New Revision: 2121
Modified: trunk/projects/bos/m2/cert-daemon.lisp trunk/projects/bos/m2/m2.lisp Log: Catch error message if certificate cannot be generated. Time out if certificate generator hangs, generating an error message to the sponsor.
Modified: trunk/projects/bos/m2/cert-daemon.lisp =================================================================== --- trunk/projects/bos/m2/cert-daemon.lisp 2006-12-19 05:35:36 UTC (rev 2120) +++ trunk/projects/bos/m2/cert-daemon.lisp 2007-01-02 11:24:22 UTC (rev 2121) @@ -31,14 +31,17 @@ (dolist (fdf-pathname (remove "fdf" (directory directory) :test (complement #'string-equal) :key #'pathname-type)) - (destructuring-bind (id &optional (country "en")) (split "-" (pathname-name fdf-pathname)) - (let ((language-specific-template-pathname (merge-pathnames (make-pathname :name (format nil "~A-~A" (pathname-name template-pathname) country)) - template-pathname)) - (output-pathname (merge-pathnames (make-pathname :name id :type "pdf") fdf-pathname))) - (fill-form fdf-pathname (if (probe-file language-specific-template-pathname) - language-specific-template-pathname - template-pathname) - output-pathname))))) + (handler-case + (destructuring-bind (id &optional (country "en")) (split "-" (pathname-name fdf-pathname)) + (let ((language-specific-template-pathname (merge-pathnames (make-pathname :name (format nil "~A-~A" (pathname-name template-pathname) country)) + template-pathname)) + (output-pathname (merge-pathnames (make-pathname :name id :type "pdf") fdf-pathname))) + (fill-form fdf-pathname (if (probe-file language-specific-template-pathname) + language-specific-template-pathname + template-pathname) + output-pathname))) + (error (e) + (format "Error generating certificate from file ~A: ~A~%" fdf-pathname e)))))
(defun generate-certs () (fill-forms *cert-mail-directory* *cert-mail-template*)
Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2006-12-19 05:35:36 UTC (rev 2120) +++ trunk/projects/bos/m2/m2.lisp 2007-01-02 11:24:22 UTC (rev 2121) @@ -266,12 +266,13 @@ (make-certificate contract name :address address :language language) (unless (contract-download-only-p contract) (make-certificate contract name :address address :language language :print t)) - (loop - do (progn - (format t "~&; waiting for generation of certificate, contract-id ~A" (store-object-id contract)) - (sleep 2)) - until (probe-file (contract-pdf-pathname contract))) - (change-slot-values contract 'cert-issued 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")))))
(defmethod contract-image-tiles ((contract contract)) (let (image-tiles)