diff options
| -rw-r--r-- | gnu/services/base.scm | 13 | ||||
| -rw-r--r-- | gnu/tests/base.scm | 83 |
2 files changed, 96 insertions, 0 deletions
diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 54bd9ca2fb..5001298ab3 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -456,6 +456,19 @@ in KNOWN-MOUNT-POINTS when it is stopped." (delete-file #$%do-not-kill-file))) (let wait () + ;; Reap children, if any, so that we don't end up with + ;; zombies and enter an infinite loop. + (let reap-children () + (define result + (false-if-exception + (waitpid WAIT_ANY (if (null? omitted-pids) + 0 + WNOHANG)))) + + (when (and (pair? result) + (not (zero? (car result)))) + (reap-children))) + (let ((pids (processes))) (unless (lset= = pids (cons 1 omitted-pids)) (format #t "waiting for process termination\ diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm index 6132aa96ef..5b40d4514a 100644 --- a/gnu/tests/base.scm +++ b/gnu/tests/base.scm @@ -32,12 +32,15 @@ #:use-module (gnu packages imagemagick) #:use-module (gnu packages ocr) #:use-module (gnu packages package-management) + #:use-module (gnu packages linux) + #:use-module (gnu packages tmux) #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix packages) #:use-module (srfi srfi-1) #:export (run-basic-test %test-basic-os + %test-halt %test-mcron %test-nss-mdns)) @@ -405,6 +408,86 @@ functionality tests.") ;;; +;;; Halt. +;;; + +(define (run-halt-test vm) + ;; As reported in <http://bugs.gnu.org/26931>, running tmux would previously + ;; lead the 'stop' method of 'user-processes' to an infinite loop, with the + ;; tmux server process as a zombie that remains in the list of processes. + ;; This test reproduces this scenario. + (define test + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (gnu build marionette)) + + (define marionette + (make-marionette '(#$vm))) + + (define ocrad + #$(file-append ocrad "/bin/ocrad")) + + ;; Wait for tty1 and log in. + (marionette-eval '(begin + (use-modules (gnu services herd)) + (start-service 'term-tty1)) + marionette) + (marionette-type "root\n" marionette) + (wait-for-screen-text marionette + (lambda (text) + (string-contains text "root@komputilo")) + #:ocrad ocrad) + + ;; Start tmux and wait for it to be ready. + (marionette-type "tmux new-session 'echo 1 > /ready; bash'\n" + marionette) + (wait-for-file "/ready" marionette) + + ;; Make sure to stop the test after a while. + (sigaction SIGALRM (lambda _ + (format (current-error-port) + "FAIL: Time is up, but VM still running.\n") + (primitive-exit 1))) + (alarm 10) + + ;; Get debugging info. + (marionette-eval '(current-output-port + (open-file "/dev/console" "w0")) + marionette) + (marionette-eval '(system* #$(file-append procps "/bin/ps") + "-eo" "pid,ppid,stat,comm") + marionette) + + ;; See if 'halt' actually works. + (marionette-eval '(system* "/run/current-system/profile/sbin/halt") + marionette) + + ;; If we reach this line, that means the VM was properly stopped in + ;; a timely fashion. + (alarm 0) + (call-with-output-file #$output + (lambda (port) + (display "success!" port)))))) + + (gexp->derivation "halt" test)) + +(define %test-halt + (system-test + (name "halt") + (description + "Use the 'halt' command and make sure it succeeds and does not get stuck +in a loop. See <http://bugs.gnu.org/26931>.") + (value + (let ((os (marionette-operating-system + (operating-system + (inherit %simple-os) + (packages (cons tmux %base-packages))) + #:imported-modules '((gnu services herd) + (guix combinators))))) + (run-halt-test (virtual-machine os)))))) + + +;;; ;;; Mcron. ;;; |