From dcb640f02b1f9590c3bd4301a22bf31bd60c56d4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 22 Feb 2021 17:39:54 +0100 Subject: file-systems: 'mount-file-system' preserves source flags for bind mounts. Fixes . * gnu/build/file-systems.scm (mount-file-system): If FS is a bind mount, add its original mount flags to FLAGS. --- gnu/build/file-systems.scm | 45 ++++++++++++++++++++++++++++++--------------- 1 file changed, 30 insertions(+), 15 deletions(-) (limited to 'gnu/build') diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index ddf6117b67..aca4aad848 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2020 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2020, 2021 Ludovic Courtès ;;; Copyright © 2016, 2017 David Craven ;;; Copyright © 2017 Mathieu Othacehe ;;; Copyright © 2019 Guillaume Le Vaillant @@ -909,12 +909,27 @@ (define (mount-nfs source mount-point type flags options) (if options (string-append "," options) ""))))) - (let ((type (file-system-type fs)) - (options (file-system-options fs)) - (source (canonicalize-device-spec (file-system-device fs))) - (mount-point (string-append root "/" - (file-system-mount-point fs))) - (flags (mount-flags->bit-mask (file-system-flags fs)))) + (let* ((type (file-system-type fs)) + (source (canonicalize-device-spec (file-system-device fs))) + (target (string-append root "/" + (file-system-mount-point fs))) + (flags (logior (mount-flags->bit-mask (file-system-flags fs)) + + ;; For bind mounts, preserve the original flags such + ;; as MS_NOSUID, etc. Failing to do that, the + ;; MS_REMOUNT call below fails with EPERM. + ;; See + (if (memq 'bind-mount (file-system-flags fs)) + (or (and=> (find (let ((devno (stat:dev + (lstat source)))) + (lambda (mount) + (= (mount-device-number mount) + devno))) + (mounts)) + mount-flags) + 0) + 0))) + (options (file-system-options fs))) (when (file-system-check? fs) (check-file-system source type)) @@ -925,24 +940,24 @@ (define (mount-nfs source mount-point type flags options) ;; needed. (if (and (= MS_BIND (logand flags MS_BIND)) (not (file-is-directory? source))) - (unless (file-exists? mount-point) - (mkdir-p (dirname mount-point)) - (call-with-output-file mount-point (const #t))) - (mkdir-p mount-point)) + (unless (file-exists? target) + (mkdir-p (dirname target)) + (call-with-output-file target (const #t))) + (mkdir-p target)) (cond ((string-prefix? "nfs" type) - (mount-nfs source mount-point type flags options)) + (mount-nfs source target type flags options)) (else - (mount source mount-point type flags options))) + (mount source target type flags options))) ;; For read-only bind mounts, an extra remount is needed, as per ;; , which still applies to Linux ;; 4.0. (when (and (= MS_BIND (logand flags MS_BIND)) (= MS_RDONLY (logand flags MS_RDONLY))) - (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY))) - (mount source mount-point type flags #f)))) + (let ((flags (logior MS_REMOUNT flags))) + (mount source target type flags options)))) (lambda args (or (file-system-mount-may-fail? fs) (apply throw args)))))) -- cgit v1.2.3