[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
bug#46292: ‘guix environment -C’ fails with Linux 4.19 (Debian)
From: |
Ludovic Courtès |
Subject: |
bug#46292: ‘guix environment -C’ fails with Linux 4.19 (Debian) |
Date: |
Mon, 22 Feb 2021 14:59:41 +0100 |
User-agent: |
Gnus/5.13 (Gnus v5.13) Emacs/27.1 (gnu/linux) |
Hi,
Lucas Nussbaum <lucas.nussbaum@inria.fr> skribis:
>>From strace:
> mount("/tmp/t", "/tmp/m", 0x55e75bf38cb0,
> MS_RDONLY|MS_NOSUID|MS_REMOUNT|MS_BIND, NULL) = 0
>
> MS_NOSUID is missing from mountflags in your invocation. Apparently data
> can be NULL.
Ooooh, got it. It’s another instance of the mount flag vs. option
confusion (/proc/mounts & co. lump flags and options together in one
string).
The attached patch solves that. I’ll polish it and push soon.
Thank you!
Ludo’.
diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index ddf6117b67..527c51cea0 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
<ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2020, 2021 Ludovic Courtès
<ludo@gnu.org>
;;; Copyright © 2016, 2017 David Craven <david@craven.ch>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net>
@@ -36,6 +36,7 @@
#:use-module (system foreign)
#:autoload (system repl repl) (start-repl)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
#:export (disk-partitions
partition-label-predicate
@@ -886,6 +887,98 @@ corresponds to the symbols listed in FLAGS."
(()
0))))
+;; Mount point information.
+(define-record-type <mount>
+ (%mount source point devno type options)
+ mount?
+ (devno mount-device-number) ;st_dev
+ (source mount-source) ;string
+ (point mount-point) ;string
+ (type mount-type) ;string
+ (options mount-options)) ;string
+
+(define (option-string->mount-flags str)
+ "Parse the \"option string\" STR as it appears in /proc/mounts and similar,
+and return two values: a mount bitmask (inclusive or of MS_* constants), and
+the remaining unprocessed options."
+ (define not-comma
+ (char-set-complement (char-set #\,)))
+
+ (define lst
+ (string-tokenize str not-comma))
+
+ (let loop ((options lst)
+ (mask 0)
+ (remainder '()))
+ (match options
+ (()
+ (values mask (string-concatenate-reverse remainder)))
+ ((head . tail)
+ (letrec-syntax ((match-options (syntax-rules (=>)
+ ((_)
+ (loop tail mask
+ (cons head remainder)))
+ ((_ (str => bit) rest ...)
+ (if (string=? str head)
+ (loop tail (logior bit mask)
+ remainder)
+ (match-options rest ...))))))
+ ;; TODO: Add MS_RELATIME and more flags.
+ (match-options ("ro" => MS_RDONLY)
+ ("nosuid" => MS_NOSUID)
+ ("nodev" => MS_NODEV)
+ ("noexec" => MS_NOEXEC)
+ ("noatime" => MS_NOATIME)))))))
+
+(define (mount-flags mount)
+ "Return the mount flags of MOUNT, a <mount> record, as an inclusive or of
+MS_* constants."
+ (option-string->mount-flags (mount-options mount)))
+
+(define (octal-decode str)
+ "Decode octal escapes from STR and return the corresponding string. STR may
+look like this: \"white\\040space\", which is decoded as \"white space\"."
+ (define char-set:octal
+ (char-set #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7))
+ (define (octal? c)
+ (char-set-contains? char-set:octal c))
+
+ (let loop ((chars (string->list str))
+ (result '()))
+ (match chars
+ (()
+ (list->string (reverse result)))
+ ((#\\ (? octal? a) (? octal? b) (? octal? c) . rest)
+ (loop rest
+ (cons (integer->char
+ (string->number (list->string (list a b c)) 8))
+ result)))
+ ((head . tail)
+ (loop tail (cons head result))))))
+
+(define (mounts)
+ "Return the list of mounts (<mount> records) visible in the namespace of the
+current process."
+ (define (string->device-number str)
+ (match (string-split str #\:)
+ (((= string->number major) (= string->number minor))
+ (+ (* major 256) minor))))
+
+ (call-with-input-file "/proc/self/mountinfo"
+ (lambda (port)
+ (let loop ((result '()))
+ (let ((line (read-line port)))
+ (if (eof-object? line)
+ (reverse result)
+ (match (string-tokenize line)
+ ((id parent-id major:minor root mount-point
+ options _ type source _ ...)
+ (let ((devno (string->device-number major:minor)))
+ (loop (cons (%mount (octal-decode source)
+ (octal-decode mount-point)
+ devno type options)
+ result)))))))))))
+
(define* (mount-file-system fs #:key (root "/root"))
"Mount the file system described by FS, a <file-system> object, under ROOT."
@@ -894,8 +987,8 @@ corresponds to the symbols listed in FLAGS."
(host-part (string-take source idx))
;; Strip [] from around host if present
(host (match (string-split host-part (string->char-set "[]"))
- (("" h "") h)
- ((h) h)))
+ (("" h "") h)
+ ((h) h)))
(aa (match (getaddrinfo host "nfs") ((x . _) x)))
(sa (addrinfo:addr aa))
(inet-addr (inet-ntop (sockaddr:fam sa)
@@ -909,12 +1002,22 @@ corresponds to the symbols listed in FLAGS."
(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))
+ (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 +1028,24 @@ corresponds to the symbols listed in FLAGS."
;; 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
;; <http://lwn.net/Articles/281157/>, 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))))))
- bug#46292: ‘guix environment -C’ fails with Linux 4.19 (Debian), Ludovic Courtès, 2021/02/04
- bug#46292: ‘guix environment -C’ fails with Linux 4.19 (Debian), zimoun, 2021/02/04
- bug#46292: ‘guix environment -C’ fails with Linux 4.19 (Debian), Ludovic Courtès, 2021/02/04
- bug#46292: more info, Lucas Nussbaum, 2021/02/10
- bug#46292: ‘guix environment -C’ fails with Linux 4.19 (Debian), Ludovic Courtès, 2021/02/18
- bug#46292: ‘guix environment -C’ fails with Linux 4.19 (Debian), Lucas Nussbaum, 2021/02/18
- bug#46292: ‘guix environment -C’ fails with Linux 4.19 (Debian), Ludovic Courtès, 2021/02/22
- bug#46292: ‘guix environment -C’ fails with Linux 4.19 (Debian), Lucas Nussbaum, 2021/02/22
- bug#46292: ‘guix environment -C’ fails with Linux 4.19 (Debian),
Ludovic Courtès <=
- bug#46292: [PATCH 1/3] syscalls: Define MS_RELATIME., Ludovic Courtès, 2021/02/22
- bug#46292: [PATCH 2/3] syscalls: Add 'mounts' and the <mount> record type., Ludovic Courtès, 2021/02/22
- bug#46292: [PATCH 3/3] file-systems: 'mount-file-system' preserves source flags for bind mounts., Ludovic Courtès, 2021/02/22
- bug#46292: ‘guix environment -C’ fails with Linux 4.19 (Debian), Ludovic Courtès, 2021/02/25
bug#46292: ‘guix environment -C’ fails with Linux 4.19 (Debian), Ludovic Courtès, 2021/02/18