@@ -50,8 +50,9 @@ dist_pkgmodule_DATA = \
src/cuirass/metrics.scm \
src/cuirass/send-events.scm \
src/cuirass/ui.scm \
- src/cuirass/utils.scm \
- src/cuirass/templates.scm
+ src/cuirass/utils.scm \
+ src/cuirass/templates.scm \
+ src/cuirass/watchdog.scm
nodist_pkgmodule_DATA = \
src/cuirass/config.scm
@@ -31,6 +31,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
(cuirass logging)
(cuirass metrics)
(cuirass utils)
+ (cuirass watchdog)
(guix ui)
((guix build utils) #:select (mkdir-p))
(fibers)
@@ -142,7 +143,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
(if one-shot?
(process-specs (db-get-specifications))
(let ((exit-channel (make-channel)))
-
+ (start-watchdog)
(if (option-ref opts 'web #f)
(begin
(spawn-fiber
@@ -37,6 +37,9 @@
define-enumeration
unwind-protect
+ with-timeout
+ get-message-with-timeout
+
make-worker-thread-channel
call-with-worker-thread
with-worker-thread
new file mode 100644
@@ -0,0 +1,81 @@
+;;; watchdog.scm -- Monitor fibers scheduling.
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation, either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; Cuirass is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Cuirass. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (cuirass watchdog)
+ #:use-module (cuirass logging)
+ #:use-module (cuirass utils)
+ #:use-module (fibers)
+ #:use-module (fibers channels)
+ #:use-module (fibers internal)
+ #:use-module (fibers operations)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 threads)
+ #:export (start-watchdog))
+
+(define* (watchdog-fiber scheduler channel
+ #:key
+ timeout)
+ "Spawn a fiber running on SCHEDULER that sends over CHANNEL, every TIMEOUT
+seconds, the scheduler name and the current time."
+ (spawn-fiber
+ (lambda ()
+ (while #t
+ (put-message channel (list (scheduler-name scheduler)
+ (current-time)))
+ (sleep timeout)))
+ scheduler))
+
+(define* (start-watchdog #:key (timeout 5))
+ "Start a watchdog checking that each Fibers scheduler is not blocked for
+more than TIMEOUT seconds.
+
+The watchdog mechanism consists in spawning a dedicated fiber per running
+Fiber scheduler, using the above watchdog-fiber method. Those fibers send a
+ping signal periodically to a separate thread. If no signal is received from
+one of the schedulers for more than TIMEOUT seconds, a warning message is
+printed."
+ (define (check-timeouts pings)
+ (for-each
+ (match-lambda
+ ((scheduler . time)
+ (let* ((cur-time (current-time))
+ (diff-ping (- cur-time time)))
+ (when (> diff-ping timeout)
+ (log-message "Scheduler ~a blocked since ~a seconds."
+ scheduler diff-ping)))))
+ pings))
+
+ (let ((watchdog-channel (make-channel)))
+ (parameterize (((@@ (fibers internal) current-fiber) #f))
+ (call-with-new-thread
+ (lambda ()
+ (let loop ((pings '()))
+ (let ((operation-timeout 2))
+ (match (perform-operation
+ (with-timeout
+ (get-operation watchdog-channel)
+ #:seconds operation-timeout
+ #:wrap (const 'timeout)))
+ ((scheduler ping)
+ (loop (assq-set! pings scheduler ping)))
+ ('timeout
+ (check-timeouts pings)
+ (loop pings))))))))
+ (fold-all-schedulers
+ (lambda (name scheduler seed)
+ (watchdog-fiber scheduler watchdog-channel
+ #:timeout timeout))
+ '())))