unofficial mirror of bug-guix@gnu.org 
 help / color / mirror / code / Atom feed
From: "Ludovic Courtès" <ludovic.courtes@inria.fr>
To: Lucas Nussbaum <lucas.nussbaum@inria.fr>
Cc: 46292@debbugs.gnu.org
Subject: bug#46292: ‘guix environment -C’ fails with Linux 4.19 (Debian)
Date: Mon, 22 Feb 2021 14:59:41 +0100	[thread overview]
Message-ID: <8735xob3ua.fsf@gnu.org> (raw)
In-Reply-To: <20210222105736.GA31789@xanadu.blop.info> (Lucas Nussbaum's message of "Mon, 22 Feb 2021 11:57:36 +0100")

[-- Attachment #1: Type: text/plain, Size: 514 bytes --]

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


[-- Attachment #2: Type: text/x-patch, Size: 8633 bytes --]

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

  reply	other threads:[~2021-02-22 14:01 UTC|newest]

Thread overview: 16+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2021-02-04 10:43 bug#46292: ‘guix environment -C’ fails with Linux 4.19 (Debian) Ludovic Courtès
2021-02-04 12:38 ` zimoun
2021-02-04 14:41 ` Ludovic Courtès
2021-02-10  6:04 ` bug#46292: more info Lucas Nussbaum
2021-02-18 11:38   ` bug#46292: ‘guix environment -C’ fails with Linux 4.19 (Debian) Ludovic Courtès
2021-02-18 13:23     ` Lucas Nussbaum
2021-02-22  9:46       ` Ludovic Courtès
2021-02-22 10:57         ` Lucas Nussbaum
2021-02-22 13:59           ` Ludovic Courtès [this message]
2021-02-22 16:44             ` bug#46292: [PATCH 1/3] syscalls: Define MS_RELATIME Ludovic Courtès
2021-02-22 16:44               ` bug#46292: [PATCH 2/3] syscalls: Add 'mounts' and the <mount> record type Ludovic Courtès
2021-02-22 16:44               ` bug#46292: [PATCH 3/3] file-systems: 'mount-file-system' preserves source flags for bind mounts Ludovic Courtès
2021-02-25 10:43             ` bug#46292: ‘guix environment -C’ fails with Linux 4.19 (Debian) Ludovic Courtès
2021-02-18 11:36 ` Ludovic Courtès
2021-03-09 16:19 ` bug#46292: Reopen Andreas Enge
2021-03-09 20:55   ` Andreas Enge

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

  List information: https://guix.gnu.org/

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=8735xob3ua.fsf@gnu.org \
    --to=ludovic.courtes@inria.fr \
    --cc=46292@debbugs.gnu.org \
    --cc=lucas.nussbaum@inria.fr \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body.
Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/guix.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).