guix
/
guix-cuirass
mirror of git://git.savannah.gnu.org/guix/guix-cuirass.git
2
0
Fork 0
Code Issues Releases Wiki Activity

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'.
This commit is contained in:
Ludovic Courtès 2018-01-27 16:04:31 +01:00
parent 4558d1c869
commit 0098e613db
2 changed files with 50 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
bin/cuirass.in
View File

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

31
src/cuirass/utils.scm
View File

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