diff options
author | Ludovic Courtès <ludo@gnu.org> | 2021-02-22 15:20:41 +0100 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2021-02-25 11:29:35 +0100 |
commit | 7e9d9f28e997e7faad28cdd1c416be174d6986e7 (patch) | |
tree | 9b617a48137c287e6a6c96834dc5b55a13472226 /guix/build | |
parent | 46bb1a41aebf82a1f7cc57d22cccea8eafc4de0d (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')
-rw-r--r-- | guix/build/syscalls.scm | 112 |
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)))) |