summaryrefslogtreecommitdiff
path: root/gnu/tests/base.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2022-07-01 09:38:09 +0200
committerLudovic Courtès <ludo@gnu.org>2022-07-01 12:10:28 +0200
commit0483c71cc5aeb3b69f6deb154fe12c0b2e6dc17f (patch)
tree6e6d54505a3e9828a328d7057ca9904054cd2311 /gnu/tests/base.scm
parent4636640de8ecd9e3702bca75c9ce0649ac5d4979 (diff)
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.
Diffstat (limited to 'gnu/tests/base.scm')
-rw-r--r--gnu/tests/base.scm145
1 files changed, 142 insertions, 3 deletions
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.
;;;