services: root-file-system: Cleanly unmount upon shutdown.

Fixes <https://issues.guix.gnu.org/56209>.
Reported by angry rectangle <angryrectangle@cock.li>.

* gnu/packages/admin.scm (shepherd-0.9)[modules, snippet]: New fields.
* gnu/services/base.scm (%root-file-system-shepherd-service): In 'stop'
method, remove 'call-with-blocked-asyncs'.  When 'mount' throws to
'system-error, call (@ (fibers) sleep) and try again.
* gnu/tests/base.scm (run-root-unmount-test): New procedure.
(%test-root-unmount): New variable.

3 files changed, 184 insertions, 25 deletions

diff --git a/gnu/packages/admin.scm b/gnu/packages/admin.scm
index 17b7b38a15..dea58354d9 100644
--- a/gnu/packages/admin.scm
+++ b/gnu/packages/admin.scm
@@ -328,7 +328,18 @@ interface and is based on GNU Guile.")
                                   version ".tar.gz"))
               (sha256
                (base32
-                "0l2arn6gsyw88xk9phxnyplvv1mn8sqp3ipgyyb0nszdzvxlgd36"))))
+                "0l2arn6gsyw88xk9phxnyplvv1mn8sqp3ipgyyb0nszdzvxlgd36"))
+              (modules '((guix build utils)))
+              (snippet
+               ;; Avoid continuation barriers so (@ (fibers) sleep) can be
+               ;; called from a service's 'stop' method
+               '(substitute* "modules/shepherd/service.scm"
+                  (("call-with-blocked-asyncs")   ;in 'stop' method
+                   "(lambda (thunk) (thunk))")
+                  (("\\(for-each-service\n")      ;in 'shutdown-services'
+                   "((lambda (proc)
+                       (for-each proc
+                                 (fold-services cons '())))\n")))))
     (arguments
      (list #:configure-flags #~'("--localstatedir=/var")
            #:make-flags #~'("GUILE_AUTO_COMPILE=0")
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 75a0cf69d7..27eae75c46 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -300,27 +300,36 @@ system objects.")))
              ;; Return #f if successfully stopped.
              (sync)
 
-             (call-with-blocked-asyncs
-              (lambda ()
-                (let ((null (%make-void-port "w")))
-                  ;; Close 'shepherd.log'.
-                  (display "closing log\n")
-                  ((@ (shepherd comm) stop-logging))
-
-                  ;; Redirect the default output ports..
-                  (set-current-output-port null)
-                  (set-current-error-port null)
-
-                  ;; Close /dev/console.
-                  (for-each close-fdes '(0 1 2))
-
-                  ;; At this point, there are no open files left, so the
-                  ;; root file system can be re-mounted read-only.
-                  (mount #f "/" #f
-                         (logior MS_REMOUNT MS_RDONLY)
-                         #:update-mtab? #f)
-
-                  #f)))))
+             (let ((null (%make-void-port "w")))
+               ;; Close 'shepherd.log'.
+               (display "closing log\n")
+               ((@ (shepherd comm) stop-logging))
+
+               ;; Redirect the default output ports..
+               (set-current-output-port null)
+               (set-current-error-port null)
+
+               ;; Close /dev/console.
+               (for-each close-fdes '(0 1 2))
+
+               ;; At this point, there should be no open files left so the
+               ;; root file system can be re-mounted read-only.
+               (let loop ((n 10))
+                 (unless (catch 'system-error
+                           (lambda ()
+                             (mount #f "/" #f
+                                    (logior MS_REMOUNT MS_RDONLY)
+                                    #:update-mtab? #f)
+                             #t)
+                           (const #f))
+                   (unless (zero? n)
+                     ;; Yield to the other fibers.  That gives logging fibers
+                     ;; an opportunity to close log files so the 'mount' call
+                     ;; doesn't fail with EBUSY.
+                     ((@ (fibers) sleep) 1)
+                     (loop (- n 1)))))
+
+               #f)))
    (respawn? #f)))
 
 (define root-file-system-service-type
diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm
index cfaa736aec..8284446868 100644
--- a/gnu/tests/base.scm
+++ b/gnu/tests/base.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018, 2019, 2020, 2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -19,7 +19,9 @@
 
 (define-module (gnu tests base)
   #:use-module (gnu tests)
+  #:use-module (gnu image)
   #:use-module (gnu system)
+  #:autoload   (gnu system image) (system-image)
   #:use-module (gnu system shadow)
   #:use-module (gnu system nss)
   #:use-module (gnu system vm)
@@ -33,19 +35,22 @@
   #:use-module (gnu packages base)
   #:use-module (gnu packages bash)
   #:use-module (gnu packages imagemagick)
+  #:use-module (gnu packages linux)
   #:use-module (gnu packages ocr)
   #:use-module (gnu packages package-management)
-  #:use-module (gnu packages linux)
   #:use-module (gnu packages tmux)
+  #:use-module (gnu packages virtualization)
   #:use-module (guix gexp)
   #:use-module (guix store)
   #:use-module (guix monads)
+  #:use-module (guix modules)
   #:use-module (guix packages)
-  #:use-module (srfi srfi-1)
+  #:use-module ((srfi srfi-1) #:hide (partition))
   #:use-module (ice-9 match)
   #:export (run-basic-test
             %test-basic-os
             %test-halt
+            %test-root-unmount
             %test-cleanup
             %test-mcron
             %test-nss-mdns))
@@ -617,6 +622,140 @@ in a loop.  See <http://bugs.gnu.org/26931>.")
 
 
 ;;;
+;;; Root cleanly unmounted.
+;;;
+
+(define (run-root-unmount-test os)
+  (define test-image
+    (image (operating-system os)
+           (format 'compressed-qcow2)
+           (volatile-root? #f)
+           (shared-store? #f)
+           (partition-table-type 'mbr)
+           (partitions
+            (list (partition
+                   (size 'guess)
+                   (offset (* 512 2048))          ;leave room for GRUB
+                   (flags '(boot))
+                   (initializer #~initialize-root-partition)
+                   (label "root-under-test")))))) ;max 16 characters!
+
+  (define observer-os
+    (marionette-operating-system
+     %simple-os
+     #:imported-modules
+     (source-module-closure '((guix build syscalls)
+                              (gnu build file-systems)))))
+
+  (define test
+    (with-imported-modules (source-module-closure
+                            '((gnu build marionette)
+                              (guix build utils)))
+      #~(begin
+          (use-modules (gnu build marionette)
+                       (guix build utils)
+                       (srfi srfi-64)
+                       (ice-9 ftw))
+
+          (define image
+            "/tmp/writable-image.qcow2")
+
+          (define (test-system-marionette)
+            ;; Return a marionette on a system where we'll run 'halt'.
+            (invoke #$(file-append qemu-minimal "/bin/qemu-img")
+                    "create" "-f" "qcow2" image "3G"
+                    "-b" #$(system-image test-image) "-F" "qcow2")
+            (make-marionette
+             `(,(string-append #$qemu-minimal "/bin/" (qemu-command))
+               ,@(if (file-exists? "/dev/kvm")
+                     '("-enable-kvm")
+                     '())
+               "-no-reboot"
+               "-m" "1024"                        ;memory size, in MiB
+               "-drive" ,(format #f "file=~a,if=virtio" image))))
+
+          (define witness-size
+            ;; Size of the /witness file.
+            (* 20 (expt 2 20)))
+
+          (test-runner-current (system-test-runner #$output))
+          (test-begin "root-unmount")
+
+          (let ((marionette (test-system-marionette)))
+            (test-assert "file created"
+              (marionette-eval `(begin
+                                  (use-modules (guix build utils))
+                                  (call-with-output-file "/witness"
+                                    (lambda (port)
+                                      (call-with-input-file "/dev/random"
+                                        (lambda (input)
+                                          (dump-port input port
+                                                     ,witness-size))))))
+                               marionette))
+
+            ;; Halt the system.
+            (marionette-eval '(system* "/run/current-system/profile/sbin/halt")
+                             marionette))
+
+          ;; Remove the sockets used by the marionette above to avoid
+          ;; EADDRINUSE.
+          (for-each delete-file
+                    (find-files "/tmp" (lambda (file stat)
+                                         (eq? (stat:type stat) 'socket))))
+
+          ;; Now boot another system and check whether the root file system of
+          ;; the first one was cleanly unmounted.
+
+          (let ((observer
+                 (make-marionette (list #$(virtual-machine observer-os)
+                                        "-drive"
+                                        (format #f "file=~a,if=virtio" image)))))
+            (test-assert "partitions"
+              (marionette-eval '(begin
+                                  (use-modules (gnu build file-systems))
+                                  (disk-partitions))
+                               observer))
+
+            (test-assert "partition found"
+              (marionette-eval '(find-partition-by-label "root-under-test")
+                               observer))
+
+            (test-assert "root file system is clean"
+              (marionette-eval '(cleanly-unmounted-ext2?
+                                 (find-partition-by-label "root-under-test"))
+                               observer))
+
+            (test-equal "root file system contains /witness"
+              witness-size
+              (let ((files (marionette-eval
+                            '(begin
+                               (use-modules (guix build syscalls)
+                                            (ice-9 ftw))
+                               (mount (find-partition-by-label "root-under-test")
+                                      "/mnt" "ext4" MS_RDONLY)
+                               (scandir "/mnt"))
+                            observer)))
+                (if (member "witness" files)
+                    (marionette-eval '(stat:size (stat "/mnt/witness"))
+                                     observer)
+                    files))))
+
+          (test-end))))
+
+  (gexp->derivation "root-unmount" test))
+
+(define %test-root-unmount
+  (system-test
+   (name "root-unmount")
+   (description
+    "Make sure the root file system is cleanly unmounted when the system is
+halted.")
+   (value
+    (let ((os (marionette-operating-system %simple-os)))
+      (run-root-unmount-test os)))))
+
+
+;;;
 ;;; Cleanup of /tmp, /var/run, etc.
 ;;;