cuirass: Add 'essential-task' and wrap the main fibers in it.

* src/cuirass/utils.scm (essential-task): New procedure.
* bin/cuirass.in (main): Wrap each fiber in 'essential-task'.

2 files changed, 50 insertions, 28 deletions

diff --git a/bin/cuirass.in b/bin/cuirass.in
index 13de395..4431a60 100644
--- a/bin/cuirass.in
+++ b/bin/cuirass.in
@@ -27,6 +27,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
 (use-modules (cuirass)
              (cuirass ui)
              (cuirass logging)
+             (cuirass utils)
              (guix ui)
              (fibers)
              (fibers channels)
@@ -117,38 +118,28 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
                      ;; First off, restart builds that had not completed or
                      ;; were not even started on a previous run.
                      (spawn-fiber
-                      (lambda ()
-                        (with-database db
-                          (restart-builds db pending))))
+                      (essential-task
+                       'restart-builds exit-channel
+                       (lambda ()
+                         (with-database db
+                           (restart-builds db pending)))))
 
                      (spawn-fiber
-                      (lambda ()
-                        (catch #t
-                          (lambda ()
-                            (with-database db
-                              (while #t
-                                (process-specs db (db-get-specifications db))
-                                (log-message "sleeping for ~a seconds" interval)
-                                (sleep interval))))
-                          (lambda (key . args)
-                            ;; If something goes wrong in this fiber, we have
-                            ;; a problem, so stop everything.
-                            (log-message "uncaught exception in main fiber!")
-
-                            (false-if-exception
-                             (let ((stack (make-stack #t)))
-                               (display-backtrace stack (current-error-port))
-                               (print-exception (current-error-port)
-                                                (stack-ref stack 0)
-                                                key args)))
-                            (put-message exit-channel 1)))))
+                      (essential-task
+                       'build exit-channel
+                       (lambda ()
+                         (with-database db
+                           (while #t
+                             (process-specs db (db-get-specifications db))
+                             (log-message "next evaluation in ~a seconds" interval)
+                             (sleep interval))))))
 
                      (spawn-fiber
-                      (lambda ()
-                        (with-database db
-                          (run-cuirass-server db
-                                              #:host host
-                                              #:port port))))
+                      (essential-task
+                       'web-server exit-channel
+                       (lambda ()
+                         (with-database db
+                           (run-cuirass-server db #:host host #:port port)))))
 
                      (primitive-exit (get-message exit-channel))))))
 
diff --git a/src/cuirass/utils.scm b/src/cuirass/utils.scm
index 06438b3..56dfced 100644
--- a/src/cuirass/utils.scm
+++ b/src/cuirass/utils.scm
@@ -19,6 +19,7 @@
 ;;; along with Cuirass.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (cuirass utils)
+  #:use-module (cuirass logging)
   #:use-module (ice-9 match)
   #:use-module (ice-9 threads)
   #:use-module (rnrs bytevectors)
@@ -32,6 +33,7 @@
             object->json-string
             define-enumeration
             non-blocking
+            essential-task
             bytevector-range))
 
 (define (alist? obj)
@@ -82,6 +84,35 @@ This is useful when passing control to non-cooperative and non-resumable code
 such as a 'clone' call in Guile-Git."
   (%non-blocking (lambda () exp ...)))
 
+(define (essential-task name exit-channel thunk)
+  "Return a thunk that wraps THUNK, catching exceptions and writing an exit
+code to EXIT-CHANNEL when an exception occurs.  The idea is that the other end
+of the EXIT-CHANNEL will exit altogether when that occurs.
+
+This is often necessary because an uncaught exception in a fiber causes it to
+die silently while the rest of the program keeps going."
+  (lambda ()
+    (catch #t
+      thunk
+      (lambda _
+        (put-message exit-channel 1))             ;to be sure...
+      (lambda (key . args)
+        ;; If something goes wrong in this fiber, we have a problem, so stop
+        ;; everything.
+        (log-message "fatal: uncaught exception '~a' in '~a' fiber!"
+                     key name)
+        (log-message "exception arguments: ~s" args)
+
+        (false-if-exception
+         (let ((stack (make-stack #t)))
+           (display-backtrace stack (current-error-port))
+           (print-exception (current-error-port)
+                            (stack-ref stack 0)
+                            key args)))
+
+        ;; Tell the other end to exit with a non-zero code.
+        (put-message exit-channel 1)))))
+
 (define %weak-references
   (make-weak-key-hash-table))