diff options
| -rw-r--r-- | gnu/packages/admin.scm | 13 | ||||
| -rw-r--r-- | gnu/services/base.scm | 51 | ||||
| -rw-r--r-- | gnu/tests/base.scm | 145 |
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. ;;; |