From 7d57cfd3b6625d7ab7f796b90b9606c28ec3aeef Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Wed, 14 May 2014 16:38:21 +0200
Subject: system: When unionfs-fuse is used for /, don't kill it when halting.

* guix/build/linux-initrd.scm (pidof): New procedure.
  (mount-root-file-system)[mark-as-not-killable]: New procedure.
  Use it for unionfs when VOLATILE-ROOT?.
* gnu/services/base.scm (%do-not-kill-file): New variable.
  (user-processes-service)[stop]: Honor it.
---
 gnu/services/base.scm       | 42 +++++++++++++++++++++++++++++++++++++++---
 guix/build/linux-initrd.scm | 26 +++++++++++++++++++++++++-
 2 files changed, 64 insertions(+), 4 deletions(-)

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 1f5ff3e4cb..aec6050588 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -110,6 +110,11 @@ OPTIONS.  When CHECK? is true, check the file system before mounting it."
                 (umount #$target)
                 #f))))))
 
+(define %do-not-kill-file
+  ;; Name of the file listing PIDs of processes that must survive when halting
+  ;; the system.  Typical example is user-space file systems.
+  "/etc/dmd/do-not-kill")
+
 (define* (user-processes-service requirements #:key (grace-delay 2))
   "Return the service that is responsible for terminating all the processes so
 that the root file system can be re-mounted read-only, just before
@@ -128,6 +133,25 @@ stopped before 'kill' is called."
              (requirement (cons 'root-file-system requirements))
              (start #~(const #t))
              (stop #~(lambda _
+                       (define (kill-except omit signal)
+                         ;; Kill all the processes with SIGNAL except those
+                         ;; listed in OMIT and the current process.
+                         (let ((omit (cons (getpid) omit)))
+                           (for-each (lambda (pid)
+                                       (unless (memv pid omit)
+                                         (false-if-exception
+                                          (kill pid signal))))
+                                     (processes))))
+
+                       (define omitted-pids
+                         ;; List of PIDs that must not be killed.
+                         (if (file-exists? #$%do-not-kill-file)
+                             (map string->number
+                                  (call-with-input-file #$%do-not-kill-file
+                                    (compose string-tokenize
+                                             (@ (ice-9 rdelim) read-string))))
+                             '()))
+
                        ;; When this happens, all the processes have been
                        ;; killed, including 'deco', so DMD-OUTPUT-PORT and
                        ;; thus CURRENT-OUTPUT-PORT are dangling.
@@ -136,9 +160,21 @@ stopped before 'kill' is called."
                            (display "sending all processes the TERM signal\n"
                                     port)))
 
-                       (kill -1 SIGTERM)
-                       (sleep #$grace-delay)
-                       (kill -1 SIGKILL)
+                       (if (null? omitted-pids)
+                           (begin
+                             ;; Easy: terminate all of them.
+                             (kill -1 SIGTERM)
+                             (sleep #$grace-delay)
+                             (kill -1 SIGKILL))
+                           (begin
+                             ;; Kill them all except OMITTED-PIDS.  XXX: We
+                             ;; would like to (kill -1 SIGSTOP) to get a fixed
+                             ;; list of processes, like 'killall5' does, but
+                             ;; that seems unreliable.
+                             (kill-except omitted-pids SIGTERM)
+                             (sleep #$grace-delay)
+                             (kill-except omitted-pids SIGKILL)
+                             (delete-file #$%do-not-kill-file)))
 
                        (display "all processes have been terminated\n")
                        #f))
diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm
index 0c3b2f0d9f..b488668ee2 100644
--- a/guix/build/linux-initrd.scm
+++ b/guix/build/linux-initrd.scm
@@ -200,11 +200,30 @@ networking values.)  Return #t if INTERFACE is up, #f otherwise."
 the last argument of `mknod'."
   (+ (* major 256) minor))
 
+(define (pidof program)
+  "Return the PID of the first presumed instance of PROGRAM."
+  (let ((program (basename program)))
+    (find (lambda (pid)
+            (let ((exe (format #f "/proc/~a/exe" pid)))
+              (and=> (false-if-exception (readlink exe))
+                     (compose (cut string=? program <>) basename))))
+          (filter-map string->number (scandir "/proc")))))
+
 (define* (mount-root-file-system root type
                                  #:key volatile-root? (unionfs "unionfs"))
   "Mount the root file system of type TYPE at device ROOT.  If VOLATILE-ROOT?
 is true, mount ROOT read-only and make it a union with a writable tmpfs using
 UNIONFS."
+  (define (mark-as-not-killable pid)
+    ;; Tell the 'user-processes' dmd service that PID must be kept alive when
+    ;; shutting down.
+    (mkdir-p "/root/etc/dmd")
+    (let ((port (open-file "/root/etc/dmd/do-not-kill" "a")))
+      (chmod port #o600)
+      (write pid port)
+      (newline port)
+      (close-port port)))
+
   (catch #t
     (lambda ()
       (if volatile-root?
@@ -222,7 +241,12 @@ UNIONFS."
                                     "cow,allow_other,use_ino,suid,dev"
                                     "/rw-root=RW:/real-root=RO"
                                     "/root"))
-              (error "unionfs failed")))
+              (error "unionfs failed"))
+
+            ;; Make sure unionfs remains alive till the end.  Because
+            ;; 'fuse_daemonize' doesn't tell the PID of the forked daemon, we
+            ;; have to resort to 'pidof' here.
+            (mark-as-not-killable (pidof unionfs)))
           (begin
             (check-file-system root type)
             (mount root "/root" type))))
-- 
cgit 1.4.1