[bknr-cvs] r2121 - trunk/projects/bos/m2

[bknr at bknr.net]

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)