summaryrefslogtreecommitdiff
path: root/guix/build/syscalls.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2021-02-22 15:20:41 +0100
committerLudovic Courtès <ludo@gnu.org>2021-02-25 11:29:35 +0100
commit7e9d9f28e997e7faad28cdd1c416be174d6986e7 (patch)
tree9b617a48137c287e6a6c96834dc5b55a13472226 /guix/build/syscalls.scm
parent46bb1a41aebf82a1f7cc57d22cccea8eafc4de0d (diff)
syscalls: Add 'mounts' and the <mount> record type.
* 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.
Diffstat (limited to 'guix/build/syscalls.scm')
-rw-r--r--guix/build/syscalls.scm112
1 files changed, 106 insertions, 6 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))))