aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--gnu/packages/admin.scm13
-rw-r--r--gnu/services/base.scm51
-rw-r--r--gnu/tests/base.scm145
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.
;;;