diff options
| author | Ludovic Courtès <ludo@gnu.org> | 2018-01-26 14:27:46 +0100 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2018-01-26 14:34:27 +0100 |
| commit | dd8b6f66e4c90309835271c6605e9a7975ea546b (patch) | |
| tree | df8779cddc78b10c369abf979a9d58679933c2a4 /bin | |
| parent | 5d559f8021b2f245aaba5bb184cb4a6b07a5e744 (diff) | |
| download | cuirass-dd8b6f66e4c90309835271c6605e9a7975ea546b.tar cuirass-dd8b6f66e4c90309835271c6605e9a7975ea546b.tar.gz | |
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.
Diffstat (limited to 'bin')
| -rw-r--r-- | bin/cuirass.in | 39 |
1 files 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:-@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)))))) @@ -121,16 +123,33 @@ exec ${GUILE:-@GUILE@} --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))))))) |