ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 21:38:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

syscalls: Add 'mounts' and the <mount> record type.

Browse source 
* 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.
This commit is contained in:
Ludovic Courtès 2021-02-22 15:20:41 +01:00
parent 46bb1a41ae
commit 7e9d9f28e9
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 121 additions and 7 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

112
guix/build/syscalls.scm
View file

@ -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 @@ (define-module (guix build syscalls)
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 @@ (define-as-needed (umount target
(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))))

16
tests/syscalls.scm
View file

@ -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 @@ (define temp-file
;; 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>.)