06/06: services: user-processes: Reap child processes.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 7f090203d5fb033eb1b64778b03afad5bb35f5f2
Author: Ludovic Courtès <address@hidden>
Date:   Mon Aug 28 09:54:03 2017 +0200

    services: user-processes: Reap child processes.
    
    Fixes <http://bugs.gnu.org/26931>.
    Reported by Leo Famulari <address@hidden>.
    
    * gnu/services/base.scm (user-processes-service-type)[stop]: Add
    'reap-children' loop.
    * gnu/tests/base.scm (run-halt-test): New procedure.
    (%test-halt): New variable.
---
 gnu/services/base.scm | 13 ++++++++
 gnu/tests/base.scm    | 83 +++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 96 insertions(+)

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 54bd9ca..5001298 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 6132aa9..5b40d45 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 "address@hidden"))
+                                #: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.
 ;;;