1 files changed, 86 insertions, 12 deletions
diff --git a/gnu/installer/final.scm b/gnu/installer/final.scm
index 8c2185e36f..3c170e5d0f 100644
--- a/gnu/installer/final.scm
+++ b/gnu/installer/final.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2018, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -28,6 +28,12 @@
   #:use-module (gnu build accounts)
   #:use-module ((gnu system shadow) #:prefix sys:)
   #:use-module (rnrs io ports)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 rdelim)
   #:export (install-system))
 
 (define %seed
@@ -97,24 +103,92 @@ USERS."
   (write-passwd password (string-append etc "/passwd"))
   (write-shadow shadow (string-append etc "/shadow")))
 
+(define* (kill-cow-users cow-path #:key (spare '("udevd")))
+  "Kill all processes that have references to the given COW-PATH in their
+'maps' file.  The process whose names are in SPARE list are spared."
+  (define %not-nul
+    (char-set-complement (char-set #\nul)))
+
+  (let ((pids
+         (filter-map (lambda (pid)
+                       (call-with-input-file
+                           (string-append "/proc/" pid "/maps")
+                         (lambda (port)
+                           (and (string-contains (get-string-all port)
+                                                 cow-path)
+                                (string->number pid)))))
+                     (scandir "/proc" string->number))))
+    (for-each (lambda (pid)
+                ;; cmdline does not always exist.
+                (false-if-exception
+                 (call-with-input-file
+                     (string-append "/proc/" (number->string pid) "/cmdline")
+                   (lambda (port)
+                     (match (string-tokenize (read-string port) %not-nul)
+                       ((argv0 _ ...)
+                        (unless (member (pk (basename argv0)) spare)
+                          (syslog "Killing process ~a~%" pid)
+                          (kill pid SIGKILL)))
+                       (_ #f))))))
+              pids)))
+
 (define (umount-cow-store)
   "Remove the store overlay and the bind-mount on /tmp created by the
-cow-store service."
-  (let ((tmp-dir "/remove"))
-    (mkdir-p tmp-dir)
-    (mount (%store-directory) tmp-dir "" MS_MOVE)
-    (umount tmp-dir)
-    (umount "/tmp")))
+cow-store service.  This procedure is very fragile and a better approach would
+be much appreciated."
+
+  ;; Remove when integrated in (gnu services herd).
+  (define (restart-service name)
+    (with-shepherd-action name ('restart) result
+      result))
+
+  (catch #t
+    (lambda ()
+      (let ((tmp-dir "/remove"))
+        (mkdir-p tmp-dir)
+        (mount (%store-directory) tmp-dir "" MS_MOVE)
+
+        ;; The guix-daemon has possibly opened files from the cow-store,
+        ;; restart it.
+        (restart-service 'guix-daemon)
+
+        ;; Kill all processes started while the cow-store was active (logins
+        ;; on other TTYs for instance).
+        (kill-cow-users tmp-dir)
+
+        ;; Try to umount the store overlay. Some process such as udevd
+        ;; workers might still be active, so do some retries.
+        (let loop ((try 5))
+          (sleep 1)
+          (let ((umounted? (false-if-exception (umount tmp-dir))))
+            (if (and (not umounted?) (> try 0))
+                (loop (- try 1))
+                (if umounted?
+                    (syslog "Umounted ~a successfully.~%" tmp-dir)
+                    (syslog "Failed to umount ~a.~%" tmp-dir)))))
+
+        (umount "/tmp")))
+    (lambda args
+      (syslog "~a~%" args))))
 
 (define* (install-system locale #:key (users '()))
   "Create /etc/shadow and /etc/passwd on the installation target for USERS.
 Start COW-STORE service on target directory and launch guix install command in
 a subshell.  LOCALE must be the locale name under which that command will run,
 or #f.  Return #t on success and #f on failure."
-  (let ((install-command
-         (format #f "guix system init --fallback ~a ~a"
-                 (%installer-configuration-file)
-                 (%installer-target-dir))))
+  (let* ((options         (catch 'system-error
+                            (lambda ()
+                              ;; If this file exists, it can provide
+                              ;; additional command-line options.
+                              (call-with-input-file
+                                  "/tmp/installer-system-init-options"
+                                read))
+                            (const '())))
+         (install-command (append (list "guix" "system" "init"
+                                        "--fallback")
+                                  options
+                                  (list (%installer-configuration-file)
+                                        (%installer-target-dir)))))
     (mkdir-p (%installer-target-dir))
 
     ;; We want to initialize user passwords but we don't want to store them in
@@ -128,7 +202,7 @@ or #f.  Return #t on success and #f on failure."
       (lambda ()
         (start-service 'cow-store (list (%installer-target-dir))))
       (lambda ()
-        (run-shell-command install-command #:locale locale))
+        (run-command install-command #:locale locale))
       (lambda ()
         (stop-service 'cow-store)
         ;; Remove the store overlay created at cow-store service start.