diff options
| -rw-r--r-- | bin/cuirass.in | 47 | ||||
| -rw-r--r-- | src/cuirass/utils.scm | 31 |
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)) |