From dd8b6f66e4c90309835271c6605e9a7975ea546b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Fri, 26 Jan 2018 14:27:46 +0100
Subject: cuirass: Catch exceptions in the main fiber and stop everything.

* bin/cuirass.in (main): Add 'exit-channel' and read from it.
Catch exceptions in the main fiber and write to that channel upon
error.
---
 bin/cuirass.in | 39 +++++++++++++++++++++++++++++----------
 1 file changed, 29 insertions(+), 10 deletions(-)

(limited to 'bin')

diff --git a/bin/cuirass.in b/bin/cuirass.in
index 4f359c0..8f3fbf4 100644
--- a/bin/cuirass.in
+++ b/bin/cuirass.in
@@ -29,6 +29,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
              (cuirass logging)
              (guix ui)
              (fibers)
+             (fibers channels)
              (ice-9 getopt-long))
 
 (define (show-help)
@@ -107,7 +108,8 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
                                 new-specs)))
                (if one-shot?
                    (process-specs db (db-get-specifications db))
-                   (let ((pending
+                   (let ((exit-channel (make-channel))
+                         (pending
                           (begin
                             (log-message "retrieving list of pending builds...")
                             (db-get-builds db '((status pending))))))
@@ -119,18 +121,35 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
                         (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)))))
+
                      (spawn-fiber
                       (lambda ()
                         (with-database db
-                          (while #t
-                            (process-specs db (db-get-specifications db))
-                            (log-message "sleeping for ~a seconds" interval)
-                            (sleep interval)))))
+                          (run-cuirass-server db
+                                              #:host host
+                                              #:port port))))
 
-                     (with-database db
-                       (run-cuirass-server db
-                                           #:host host
-                                           #:port port))
-                     *unspecified*))))
+                     (primitive-exit (get-message exit-channel))))))
 
            #:drain? #t)))))))
-- 
cgit v1.2.3