file-systems: 'mount-file-system' now takes a <file-system> object.

* gnu/build/file-systems.scm (mount-file-system): Rename 'spec' to 'fs' and assume it's a <file-system>. * gnu/build/linux-boot.scm (boot-system): Assume MOUNTS is a list of <file-system> 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.
2017-10-03 23:25:38 +02:00 · 2017-10-03 23:25:38 +02:00 · 1c65cca574
parent f26af33aec
commit 1c65cca574
5 changed files with 53 additions and 47 deletions
--- 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 <file-system> 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
-       ;; <http://lwn.net/Articles/281157/>, 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
+    ;; <http://lwn.net/Articles/281157/>, 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
--- 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 <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
 ;;; 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 <file-system> 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"))

--- 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.
--- 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)
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@ -187,9 +187,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)
@ -206,7 +208,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