From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:59919) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1dze5F-0001hk-IS for guix-patches@gnu.org; Wed, 04 Oct 2017 03:27:11 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1dze59-000645-4x for guix-patches@gnu.org; Wed, 04 Oct 2017 03:27:09 -0400 Received: from debbugs.gnu.org ([208.118.235.43]:38706) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1dze59-00063y-1a for guix-patches@gnu.org; Wed, 04 Oct 2017 03:27:03 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1dze58-0001ub-Rl for guix-patches@gnu.org; Wed, 04 Oct 2017 03:27:02 -0400 Subject: [bug#28696] [PATCH 1/5] file-systems: 'mount-file-system' now takes a object. References: <20171004072401.1251-1-ludo@gnu.org> In-Reply-To: <20171004072401.1251-1-ludo@gnu.org> Resent-Message-ID: From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Wed, 4 Oct 2017 09:25:50 +0200 Message-Id: <20171004072554.1377-1-ludo@gnu.org> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 28696@debbugs.gnu.org * gnu/build/file-systems.scm (mount-file-system): Rename 'spec' to 'fs' and assume it's a . * gnu/build/linux-boot.scm (boot-system): Assume MOUNTS is a list of and adjust accordingly. * gnu/build/linux-container.scm (mount-file-systems): Remove 'file-system->spec' call. * gnu/services/base.scm (file-system-shepherd-service): Add 'spec->file-system' call. Add (gnu system file-systems) to 'modules'. * gnu/system/linux-initrd.scm (raw-initrd): Use (gnu system file-systems). Add 'spec->file-system' call for #:mounts. --- gnu/build/file-systems.scm | 65 ++++++++++++++++++++++--------------------- gnu/build/linux-boot.scm | 20 ++++++------- gnu/build/linux-container.scm | 3 +- gnu/services/base.scm | 6 ++-- gnu/system/linux-initrd.scm | 6 +++- 5 files changed, 53 insertions(+), 47 deletions(-) diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index 32885f1d2..8b1a4cb19 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -20,9 +20,11 @@ (define-module (gnu build file-systems) #:use-module (gnu system uuid) + #:use-module (gnu system file-systems) #:use-module (guix build utils) #:use-module (guix build bournish) - #:use-module (guix build syscalls) + #:use-module ((guix build syscalls) + #:hide (file-system-type)) #:use-module (rnrs io ports) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) @@ -552,11 +554,8 @@ corresponds to the symbols listed in FLAGS." (() 0)))) -(define* (mount-file-system spec #:key (root "/root")) - "Mount the file system described by SPEC under ROOT. SPEC must have the -form: - - (DEVICE TITLE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?) +(define* (mount-file-system fs #:key (root "/root")) + "Mount the file system described by FS, a object, under ROOT. DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f; FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to @@ -582,34 +581,36 @@ run a file system check." (if options (string-append "," options) ""))))) - (match spec - ((source title mount-point type (flags ...) options check?) - (let ((source (canonicalize-device-spec source title)) - (mount-point (string-append root "/" mount-point)) - (flags (mount-flags->bit-mask flags))) - (when check? - (check-file-system source type)) + (let ((type (file-system-type fs)) + (options (file-system-options fs)) + (source (canonicalize-device-spec (file-system-device fs) + (file-system-title fs))) + (mount-point (string-append root "/" + (file-system-mount-point fs))) + (flags (mount-flags->bit-mask (file-system-flags fs)))) + (when (file-system-check? fs) + (check-file-system source type)) - ;; Create the mount point. Most of the time this is a directory, but - ;; in the case of a bind mount, a regular file or socket may be needed. - (if (and (= MS_BIND (logand flags MS_BIND)) - (not (file-is-directory? source))) - (unless (file-exists? mount-point) - (mkdir-p (dirname mount-point)) - (call-with-output-file mount-point (const #t))) - (mkdir-p mount-point)) + ;; Create the mount point. Most of the time this is a directory, but + ;; in the case of a bind mount, a regular file or socket may be needed. + (if (and (= MS_BIND (logand flags MS_BIND)) + (not (file-is-directory? source))) + (unless (file-exists? mount-point) + (mkdir-p (dirname mount-point)) + (call-with-output-file mount-point (const #t))) + (mkdir-p mount-point)) - (cond - ((string-prefix? "nfs" type) - (mount-nfs source mount-point type flags options)) - (else - (mount source mount-point type flags options))) + (cond + ((string-prefix? "nfs" type) + (mount-nfs source mount-point type flags options)) + (else + (mount source mount-point type flags options))) - ;; For read-only bind mounts, an extra remount is needed, as per - ;; , which still applies to Linux 4.0. - (when (and (= MS_BIND (logand flags MS_BIND)) - (= MS_RDONLY (logand flags MS_RDONLY))) - (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY))) - (mount source mount-point type flags #f))))))) + ;; For read-only bind mounts, an extra remount is needed, as per + ;; , which still applies to Linux 4.0. + (when (and (= MS_BIND (logand flags MS_BIND)) + (= MS_RDONLY (logand flags MS_RDONLY))) + (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY))) + (mount source mount-point type flags #f))))) ;;; file-systems.scm ends here diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm index 360ef3fae..3712abe91 100644 --- a/gnu/build/linux-boot.scm +++ b/gnu/build/linux-boot.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; Copyright © 2017 Mathieu Othacehe ;;; ;;; This file is part of GNU Guix. @@ -27,9 +27,11 @@ #:use-module (ice-9 match) #:use-module (ice-9 ftw) #:use-module (guix build utils) - #:use-module (guix build syscalls) + #:use-module ((guix build syscalls) + #:hide (file-system-type)) #:use-module (gnu build linux-modules) #:use-module (gnu build file-systems) + #:use-module (gnu system file-systems) #:export (mount-essential-file-systems linux-command-line find-long-option @@ -349,19 +351,17 @@ supports kernel command-line options '--load', '--root', and '--repl'. Mount the root file system, specified by the '--root' command-line argument, if any. -MOUNTS must be a list suitable for 'mount-file-system'. +MOUNTS must be a list of objects. When VOLATILE-ROOT? is true, the root file system is writable but any changes to it are lost." - (define root-mount-point? - (match-lambda - ((device _ "/" _ ...) #t) - (_ #f))) + (define (root-mount-point? fs) + (string=? (file-system-mount-point fs) "/")) (define root-fs-type - (or (any (match-lambda - ((device _ "/" type _ ...) type) - (_ #f)) + (or (any (lambda (fs) + (and (root-mount-point? fs) + (file-system-type fs))) mounts) "ext4")) diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm index 95bfd92dd..70e789403 100644 --- a/gnu/build/linux-container.scm +++ b/gnu/build/linux-container.scm @@ -152,8 +152,7 @@ for the process." ;; Mount user-specified file systems. (for-each (lambda (file-system) - (mount-file-system (file-system->spec file-system) - #:root root)) + (mount-file-system file-system #:root root)) mounts) ;; Jail the process inside the container's root file system. diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 64620a9b0..541ca76f1 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -307,7 +307,8 @@ FILE-SYSTEM." '#$packages)))) (lambda () (mount-file-system - '#$(file-system->spec file-system) + (spec->file-system + '#$(file-system->spec file-system)) #:root "/")) (lambda () (setenv "PATH" $PATH))) @@ -322,9 +323,10 @@ FILE-SYSTEM." (umount #$target) #f)) - ;; We need an additional module. + ;; We need additional modules. (modules `(((gnu build file-systems) #:select (mount-file-system)) + (gnu system file-systems) ,@%default-modules))))))) (define (file-system-shepherd-services file-systems) diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 5a7aec5c8..e78be8cd3 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -174,9 +174,11 @@ to it are lost." '((gnu build linux-boot) (guix build utils) (guix build bournish) + (gnu system file-systems) (gnu build file-systems))) #~(begin (use-modules (gnu build linux-boot) + (gnu system file-systems) (guix build utils) (guix build bournish) ;add the 'bournish' meta-command (srfi srfi-26) @@ -193,7 +195,9 @@ to it are lost." (set-path-environment-variable "PATH" '("bin" "sbin") '#$helper-packages))) - (boot-system #:mounts '#$(map file-system->spec file-systems) + (boot-system #:mounts + (map spec->file-system + '#$(map file-system->spec file-systems)) #:pre-mount (lambda () (and #$@device-mapping-commands)) #:linux-modules '#$linux-modules -- 2.14.2