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.master
Ludovic Courtès
parent
4636640de8
commit
0483c71cc5
|
|
@ -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")
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
(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)
|
||||
;; 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))
|
||||
;; 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)
|
||||
;; 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)))))
|
||||
#f)))
|
||||
(respawn? #f)))
|
||||
|
||||
(define root-file-system-service-type
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
@ -615,6 +620,140 @@ in a loop. See <http://bugs.gnu.org/26931>.")
|
|||
(guix combinators)))))
|
||||
(run-halt-test (virtual-machine os))))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; 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.
|
||||
|
|
|
|||
Reference in New Issue