From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp2 ([2001:41d0:2:c151::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms11 with LMTPS id MGnWMFK5M2C/aAAA0tVLHw (envelope-from ) for ; Mon, 22 Feb 2021 14:01:54 +0000 Received: from aspmx2.migadu.com ([2001:41d0:2:c151::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp2 with LMTPS id qJO6LFK5M2AeYgAAB5/wlQ (envelope-from ) for ; Mon, 22 Feb 2021 14:01:54 +0000 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by aspmx2.migadu.com (Postfix) with ESMTPS id CFB24BE34 for ; Mon, 22 Feb 2021 15:01:53 +0100 (CET) Received: from localhost ([::1]:34212 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lEBmZ-0006X7-Q8 for larch@yhetil.org; Mon, 22 Feb 2021 09:01:51 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]:40220) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1lEBkp-0005LF-NH for bug-guix@gnu.org; Mon, 22 Feb 2021 09:00:05 -0500 Received: from debbugs.gnu.org ([209.51.188.43]:44481) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lEBko-00030f-GD for bug-guix@gnu.org; Mon, 22 Feb 2021 09:00:03 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1lEBko-0008BL-Bx for bug-guix@gnu.org; Mon, 22 Feb 2021 09:00:02 -0500 X-Loop: help-debbugs@gnu.org Subject: bug#46292: =?UTF-8?Q?=E2=80=98guix?= environment =?UTF-8?Q?-C=E2=80=99?= fails with Linux 4.19 (Debian) Resent-From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: bug-guix@gnu.org Resent-Date: Mon, 22 Feb 2021 14:00:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 46292 X-GNU-PR-Package: guix X-GNU-PR-Keywords: To: Lucas Nussbaum Received: via spool by 46292-submit@debbugs.gnu.org id=B46292.161400239431406 (code B ref 46292); Mon, 22 Feb 2021 14:00:02 +0000 Received: (at 46292) by debbugs.gnu.org; 22 Feb 2021 13:59:54 +0000 Received: from localhost ([127.0.0.1]:56027 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lEBkc-0008AR-I6 for submit@debbugs.gnu.org; Mon, 22 Feb 2021 08:59:54 -0500 Received: from mail3-relais-sop.national.inria.fr ([192.134.164.104]:54182) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lEBka-0008AC-Pr for 46292@debbugs.gnu.org; Mon, 22 Feb 2021 08:59:49 -0500 X-IronPort-AV: E=Sophos;i="5.81,197,1610406000"; d="scan'208";a="373771688" Received: from 91-160-117-201.subs.proxad.net (HELO ribbon) ([91.160.117.201]) by mail3-relais-sop.national.inria.fr with ESMTP/TLS/DHE-RSA-AES256-GCM-SHA384; 22 Feb 2021 14:59:42 +0100 From: Ludovic =?UTF-8?Q?Court=C3=A8s?= References: <87h7ms8658.fsf@inria.fr> <20210210060403.GA15175@xanadu.blop.info> <877dn5sj14.fsf_-_@gnu.org> <20210218132334.GC20744@xanadu.blop.info> <871rd8e8p2.fsf@gnu.org> <20210222105736.GA31789@xanadu.blop.info> Date: Mon, 22 Feb 2021 14:59:41 +0100 In-Reply-To: <20210222105736.GA31789@xanadu.blop.info> (Lucas Nussbaum's message of "Mon, 22 Feb 2021 11:57:36 +0100") Message-ID: <8735xob3ua.fsf@gnu.org> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/27.1 (gnu/linux) MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: bug-guix@gnu.org List-Id: Bug reports for GNU Guix List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Cc: 46292@debbugs.gnu.org Errors-To: bug-guix-bounces+larch=yhetil.org@gnu.org Sender: "bug-Guix" X-Migadu-Flow: FLOW_IN X-Migadu-Spam-Score: -2.37 Authentication-Results: aspmx2.migadu.com; dkim=none; dmarc=none; spf=pass (aspmx2.migadu.com: domain of bug-guix-bounces@gnu.org designates 209.51.188.17 as permitted sender) smtp.mailfrom=bug-guix-bounces@gnu.org X-Migadu-Queue-Id: CFB24BE34 X-Spam-Score: -2.37 X-Migadu-Scanner: scn0.migadu.com X-TUID: Wm/Bib4WGQtq --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Hi, Lucas Nussbaum skribis: >>>From strace: > mount("/tmp/t", "/tmp/m", 0x55e75bf38cb0, MS_RDONLY|MS_NOSUID|MS_REMOUNT|= MS_BIND, NULL) =3D 0 > > MS_NOSUID is missing from mountflags in your invocation. Apparently data > can be NULL. Ooooh, got it. It=E2=80=99s 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=E2=80=99ll polish it and push soon. Thank you! Ludo=E2=80=99. --=-=-= Content-Type: text/x-patch; charset=utf-8 Content-Disposition: inline Content-Transfer-Encoding: quoted-printable 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 =C2=A9 2014, 2015, 2016, 2017, 2018, 2020 Ludovic Court=C3= =A8s +;;; Copyright =C2=A9 2014, 2015, 2016, 2017, 2018, 2020, 2021 Ludovic Cour= t=C3=A8s ;;; Copyright =C2=A9 2016, 2017 David Craven ;;; Copyright =C2=A9 2017 Mathieu Othacehe ;;; Copyright =C2=A9 2019 Guillaume Le Vaillant @@ -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)))) =20 +;; Mount point information. +(define-record-type + (%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 simil= ar, +and return two values: a mount bitmask (inclusive or of MS_* constants), a= nd +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 (=3D>) + ((_) + (loop tail mask + (cons head remainder))) + ((_ (str =3D> bit) rest ...) + (if (string=3D? str head) + (loop tail (logior bit mask) + remainder) + (match-options rest ...)))))) + ;; TODO: Add MS_RELATIME and more flags. + (match-options ("ro" =3D> MS_RDONLY) + ("nosuid" =3D> MS_NOSUID) + ("nodev" =3D> MS_NODEV) + ("noexec" =3D> MS_NOEXEC) + ("noatime" =3D> MS_NOATIME))))))) + +(define (mount-flags mount) + "Return the mount flags of MOUNT, a 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 ( records) visible in the namespace of= the +current process." + (define (string->device-number str) + (match (string-split str #\:) + (((=3D string->number major) (=3D 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 object, under RO= OT." =20 @@ -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=3D> (find (let ((devno (stat:dev + (lstat source= )))) + (lambda (mount) + (=3D (mount-device-numb= er mount) + devno))) + (mounts)) + mount-flags) + 0) + 0))) + (options (file-system-options fs))) (when (file-system-check? fs) (check-file-system source type)) =20 @@ -925,24 +1028,24 @@ corresponds to the symbols listed in FLAGS." ;; needed. (if (and (=3D 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)) =20 (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))) =20 ;; For read-only bind mounts, an extra remount is needed, as per ;; , which still applies to Linux ;; 4.0. (when (and (=3D MS_BIND (logand flags MS_BIND)) (=3D 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)))))) --=-=-=--