From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp0 ([2001:41d0:8:6d80::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms11 with LMTPS id +MwqM5nfM2B+bgAA0tVLHw (envelope-from ) for ; Mon, 22 Feb 2021 16:45:13 +0000 Received: from aspmx1.migadu.com ([2001:41d0:8:6d80::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp0 with LMTPS id WCbzLpnfM2CQQQAA1q6Kng (envelope-from ) for ; Mon, 22 Feb 2021 16:45:13 +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 aspmx1.migadu.com (Postfix) with ESMTPS id 4A0D92A68F for ; Mon, 22 Feb 2021 17:45:13 +0100 (CET) Received: from localhost ([::1]:58644 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lEEKd-0005r5-4x for larch@yhetil.org; Mon, 22 Feb 2021 11:45:11 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]:34392) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1lEEKU-0005qm-OX for bug-guix@gnu.org; Mon, 22 Feb 2021 11:45:03 -0500 Received: from debbugs.gnu.org ([209.51.188.43]:45835) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lEEKU-0007V2-Gn for bug-guix@gnu.org; Mon, 22 Feb 2021 11:45:02 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1lEEKU-0002K5-FP for bug-guix@gnu.org; Mon, 22 Feb 2021 11:45:02 -0500 X-Loop: help-debbugs@gnu.org Subject: bug#46292: [PATCH 2/3] syscalls: Add 'mounts' and the record type. 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 16:45: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: 46292@debbugs.gnu.org Received: via spool by 46292-submit@debbugs.gnu.org id=B46292.16140122748866 (code B ref 46292); Mon, 22 Feb 2021 16:45:02 +0000 Received: (at 46292) by debbugs.gnu.org; 22 Feb 2021 16:44:34 +0000 Received: from localhost ([127.0.0.1]:57378 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lEEK1-0002Ip-9J for submit@debbugs.gnu.org; Mon, 22 Feb 2021 11:44:33 -0500 Received: from eggs.gnu.org ([209.51.188.92]:44582) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lEEJy-0002IN-By for 46292@debbugs.gnu.org; Mon, 22 Feb 2021 11:44:31 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]:57977) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lEEJr-0007K0-Mg; Mon, 22 Feb 2021 11:44:24 -0500 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=39738 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1lEEJr-0000oc-8a; Mon, 22 Feb 2021 11:44:23 -0500 From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Mon, 22 Feb 2021 17:44:12 +0100 Message-Id: <20210222164413.30996-2-ludo@gnu.org> X-Mailer: git-send-email 2.30.0 In-Reply-To: <20210222164413.30996-1-ludo@gnu.org> References: <8735xob3ua.fsf@gnu.org> <20210222164413.30996-1-ludo@gnu.org> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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: , Errors-To: bug-guix-bounces+larch=yhetil.org@gnu.org Sender: "bug-Guix" X-Migadu-Flow: FLOW_IN X-Migadu-Spam-Score: -1.87 Authentication-Results: aspmx1.migadu.com; dkim=none; dmarc=pass (policy=none) header.from=gnu.org; spf=pass (aspmx1.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: 4A0D92A68F X-Spam-Score: -1.87 X-Migadu-Scanner: scn1.migadu.com X-TUID: IwQlGY+cwWVU * guix/build/syscalls.scm (): 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 +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; Copyright © 2015 David Thompson ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2017 Mathieu Othacehe @@ -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 ." (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 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 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 #\:) + (((= 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 +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; Copyright © 2015 David Thompson ;;; Copyright © 2020 Simon South ;;; Copyright © 2020 Mathieu Othacehe @@ -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 .) -- 2.30.0