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

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 1c65cca5743e9171bbd94307195f123d26c0535e
Author: Ludovic Courtès <address@hidden>
Date:   Tue Oct 3 23:25:38 2017 +0200

    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.
---
 gnu/build/file-systems.scm    | 71 ++++++++++++++++++++++---------------------
 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, 56 insertions(+), 50 deletions(-)

diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index 140bcb4..bcb0c53 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 <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))
-
-       ;; 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)))
-
-       ;; 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)))))))
+  (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))
+
+    (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)))))
 
 ;;; file-systems.scm ends here
diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm
index 360ef3f..3712abe 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 <address@hidden>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2017 Mathieu Othacehe <address@hidden>
 ;;;
 ;;; 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"))
 
diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm
index 95bfd92..70e7894 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 64620a9..541ca76 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 969a892..948c543 100644
--- 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 address@hidden))
                       #:linux-modules '#$linux-modules