[no subject]

[Ludovic Courtès]

branch: master
commit dd8b6f66e4c90309835271c6605e9a7975ea546b
Author: Ludovic Courtès <address@hidden>
Date:   Fri Jan 26 14:27:46 2018 +0100

    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(-)

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:address@hidden@} --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:address@hidden@} --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))))))
@@ -121,16 +123,33 @@ exec ${GUILE:address@hidden@} --no-auto-compile -e main 
-s "$0" "$@"
 
                      (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)))))))