futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
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.
This commit is contained in:
Ludovic Courtès 2022-07-01 09:38:09 +02:00
parent 4636640de8
commit 0483c71cc5
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
3 changed files with 180 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
gnu/packages/admin.scm
View File

@ -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")

43
gnu/services/base.scm
View File

@ -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

145
gnu/tests/base.scm
View File

@ -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.