unofficial mirror of bug-guix@gnu.org 
 help / color / mirror / code / Atom feed
From: "Ludovic Courtès" <ludo@gnu.org>
To: 46292@debbugs.gnu.org
Subject: bug#46292: [PATCH 2/3] syscalls: Add 'mounts' and the <mount> record type.
Date: Mon, 22 Feb 2021 17:44:12 +0100	[thread overview]
Message-ID: <20210222164413.30996-2-ludo@gnu.org> (raw)
In-Reply-To: <20210222164413.30996-1-ludo@gnu.org>

* guix/build/syscalls.scm (<mount>): New record type.
(option-string->mount-flags, mount-flags)
(octal-decode, mounts): New procedures.
(mount-points): Rewrite in terms of 'mount'.
* tests/syscalls.scm ("mounts"): New test.
---
 guix/build/syscalls.scm | 112 +++++++++++++++++++++++++++++++++++++---
 tests/syscalls.scm      |  16 +++++-
 2 files changed, 121 insertions(+), 7 deletions(-)

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index b19a7a271b..552343a481 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
@@ -54,7 +54,18 @@
             UMOUNT_NOFOLLOW
 
             restart-on-EINTR
+
+            mount?
+            mount-device-number
+            mount-source
+            mount-point
+            mount-type
+            mount-options
+            mount-flags
+
+            mounts
             mount-points
+
             swapon
             swapoff
 
@@ -521,17 +532,106 @@ constants from <sys/mount.h>."
       (when update-mtab?
         (remove-from-mtab target)))))
 
-(define (mount-points)
-  "Return the mounts points for currently mounted file systems."
-  (call-with-input-file "/proc/mounts"
+;; 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."
+  ;; Why do we need to do this?  Because mount flags and mount options are
+  ;; often lumped together; this is the case in /proc/mounts & co., so we need
+  ;; to extract the bits that actually correspond to mount flags.
+
+  (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 ...))))))
+         (match-options ("rw"         => 0)
+                        ("ro"         => MS_RDONLY)
+                        ("nosuid"     => MS_NOSUID)
+                        ("nodev"      => MS_NODEV)
+                        ("noexec"     => MS_NOEXEC)
+                        ("relatime"   => MS_RELATIME)
+                        ("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)
-                ((source mount-point _ ...)
-                 (loop (cons mount-point result))))))))))
+                ((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-points)
+  "Return the mounts points for currently mounted file systems."
+  (map mount-point (mounts)))
 
 (define swapon
   (let ((proc (syscall->procedure int "swapon" (list '* int))))
diff --git a/tests/syscalls.scm b/tests/syscalls.scm
index 09aa228e8e..706dd4177f 100644
--- a/tests/syscalls.scm
+++ b/tests/syscalls.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
 ;;; Copyright © 2020 Simon South <simon@simonsouth.net>
 ;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
@@ -56,6 +56,20 @@
       ;; Both return values have been encountered in the wild.
       (memv (system-error-errno args) (list EPERM ENOENT)))))
 
+(test-assert "mounts"
+  ;; Check for one of the common mount points.
+  (let ((mounts (mounts)))
+    (any (match-lambda
+           ((point . type)
+            (let ((mount (find (lambda (mount)
+                                 (string=? (mount-point mount) point))
+                               mounts)))
+              (and mount
+                   (string=? (mount-type mount) type)))))
+         '(("/proc"    . "proc")
+           ("/sys"     . "sysfs")
+           ("/dev/shm" . "tmpfs")))))
+
 (test-assert "mount-points"
   ;; Reportedly "/" is not always listed as a mount point, so check a few
   ;; others (see <http://bugs.gnu.org/20261>.)
-- 
2.30.0





  reply	other threads:[~2021-02-22 16:45 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
2021-02-22 16:44             ` bug#46292: [PATCH 1/3] syscalls: Define MS_RELATIME Ludovic Courtès
2021-02-22 16:44               ` Ludovic Courtès [this message]
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=20210222164413.30996-2-ludo@gnu.org \
    --to=ludo@gnu.org \
    --cc=46292@debbugs.gnu.org \
    /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).