05/10: file-systems: Represent the file system options as an alist.

[guix-commits]

apteryx pushed a commit to branch allow-booting-from-btrfs-subvolume
in repository guix.

commit af61745d8b686755a5d9deb9e21c9eac624fb43e
Author: Maxim Cournoyer <address@hidden>
AuthorDate: Wed Sep 25 22:43:41 2019 +0900

    file-systems: Represent the file system options as an alist.
    
    This allows accessing the parameter values easily, without having to parse a
    string.
    
    * gnu/system/file-systems.scm (<file-system>): Update the default value of 
the
    OPTIONS field, doc.
    (%file-system-options): Field accessor renamed from `file-system-options'.
    (file-system-options, file-system-options->string): New procedures.
    * gnu/build/file-systems.scm (mount-file-system): Adapt.
    * gnu/services/base.scm (file-system->fstab-entry): Likewise.
    * tests/file-systems.scm: New tests.
    * doc/guix.texi (File Systems): Document the modified default value of the
    'file-system-options' field.
---
 doc/guix.texi               | 11 ++++++-----
 gnu/build/file-systems.scm  | 15 +++++++++------
 gnu/services/base.scm       | 35 +++++++++++++++++++----------------
 gnu/system/file-systems.scm | 35 +++++++++++++++++++++++++++++++++--
 tests/file-systems.scm      | 24 ++++++++++++++++++++++++
 5 files changed, 91 insertions(+), 29 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 85cfabc..5d526b1 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -11405,11 +11405,12 @@ update time on the in-memory version of the file 
inode), and
 @xref{Mount-Unmount-Remount,,, libc, The GNU C Library Reference
 Manual}, for more information on these flags.
 
-@item @code{options} (default: @code{#f})
-This is either @code{#f}, or a string denoting mount options passed to the
-file system driver.  @xref{Mount-Unmount-Remount,,, libc, The GNU C Library
-Reference Manual}, for details and run @command{man 8 mount} for options for
-various file systems.
+@item @code{options} (default: @code{'()})
+A list of parameters and/or of pairs of parameter name and values, as
+strings.  Those represent the mount options that are passed to the file
+system driver.  @xref{Mount-Unmount-Remount,,, libc, The GNU C Library
+Reference Manual}, for details and run @command{man 8 mount} for options
+for various file systems.
 
 @item @code{mount?} (default: @code{#t})
 This value indicates whether to automatically mount the file system when
diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index ee63755..cfa3898 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -662,12 +662,15 @@ corresponds to the symbols listed in FLAGS."
                             (if options
                                 (string-append "," options)
                                 "")))))
-  (let ((type        (file-system-type fs))
-        (options     (file-system-options fs))
-        (source      (canonicalize-device-spec (file-system-device fs)))
-        (mount-point (string-append root "/"
-                                    (file-system-mount-point fs)))
-        (flags       (mount-flags->bit-mask (file-system-flags fs))))
+  (let* ((type        (file-system-type fs))
+         (fs-options (file-system-options fs))
+         (options (if (null? fs-options)
+                      #f
+                      (file-system-options->string fs-options)))
+         (source      (canonicalize-device-spec (file-system-device 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))
 
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 0c154d1..6104b47 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -313,22 +313,25 @@ seconds after @code{SIGTERM} has been sent are terminated 
with
 
 (define (file-system->fstab-entry file-system)
   "Return a @file{/etc/fstab} entry for @var{file-system}."
-  (string-append (match (file-system-device file-system)
-                   ((? file-system-label? label)
-                    (string-append "LABEL="
-                                   (file-system-label->string label)))
-                   ((? uuid? uuid)
-                    (string-append "UUID=" (uuid->string uuid)))
-                   ((? string? device)
-                    device))
-                 "\t"
-                 (file-system-mount-point file-system) "\t"
-                 (file-system-type file-system) "\t"
-                 (or (file-system-options file-system) "defaults") "\t"
-
-                 ;; XXX: Omit the 'fs_freq' and 'fs_passno' fields because we
-                 ;; don't have anything sensible to put in there.
-                 ))
+  (let ((options (file-system-options file-system)))
+    (string-append (match (file-system-device file-system)
+                     ((? file-system-label? label)
+                      (string-append "LABEL="
+                                     (file-system-label->string label)))
+                     ((? uuid? uuid)
+                      (string-append "UUID=" (uuid->string uuid)))
+                     ((? string? device)
+                      device))
+                   "\t"
+                   (file-system-mount-point file-system) "\t"
+                   (file-system-type file-system) "\t"
+                   (if (null? options)
+                       "defaults"
+                       (file-system-options->string options)) "\t"
+
+                   ;; XXX: Omit the 'fs_freq' and 'fs_passno' fields because we
+                   ;; don't have anything sensible to put in there.
+                   )))
 
 (define (file-systems->fstab file-systems)
   "Return a @file{/etc} entry for an @file{fstab} describing
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index fc383d8..6dc0e68 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès 
<address@hidden>
+;;; Copyright © 2020 Maxim Cournoyer <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -37,6 +38,7 @@
             file-system-needed-for-boot?
             file-system-flags
             file-system-options
+            file-system-options->string
             file-system-mount?
             file-system-check?
             file-system-create-mount-point?
@@ -97,8 +99,8 @@
   (type             file-system-type)             ; string
   (flags            file-system-flags             ; list of symbols
                     (default '()))
-  (options          file-system-options           ; string or #f
-                    (default #f))
+  (options          %file-system-options          ; list of strings and/or
+                    (default '()))                ; pair of strings
   (mount?           file-system-mount?            ; Boolean
                     (default #t))
   (needed-for-boot? %file-system-needed-for-boot? ; Boolean
@@ -250,6 +252,35 @@ UUID-TYPE, a symbol such as 'dce or 'iso9660."
     ((? string?)
      device)))
 
+(define (file-system-options fs)
+  "Return the options of a <file-system> record, as a list of options or
+option/value pairs."
+
+  ;; Support the deprecated options format (a string).
+  (define (options-string->options-list str)
+    (let ((option-list (string-split str #\,)))
+      (map (lambda (param)
+             (if (string-contains param "=")
+                 (apply cons (string-split param #\=))
+                 param))
+           option-list)))
+
+  (let ((fs-options (%file-system-options fs)))
+    (if (string? fs-options)
+        (options-string->options-list fs-options)
+        fs-options)))
+
+(define (file-system-options->string options)
+  "Return the string representation of the OPTIONS field of a <file-system>
+record"
+  (string-join (map (match-lambda
+                      ((key . value)
+                       (string-append key "=" value))
+                      (key
+                       key))
+                    options)
+               ","))
+
 (define (file-system-needed-for-boot? fs)
   "Return true if FS has the 'needed-for-boot?' flag set, or if it holds the
 store--e.g., if FS is the root file system."
diff --git a/tests/file-systems.scm b/tests/file-systems.scm
index 4c28d0e..b9f4f50 100644
--- a/tests/file-systems.scm
+++ b/tests/file-systems.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015, 2017 Ludovic Courtès <address@hidden>
+;;; Copyright © 2020 Maxim Cournoyer <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -64,4 +65,27 @@
           (_ #f))
         (source-module-closure '((gnu system file-systems)))))
 
+(define %fs-with-deprecated-options-string
+  (file-system
+    (device (file-system-label "btrfs-pool"))
+    (mount-point "/home")
+    (type "btrfs")
+    (options "autodefrag,subvol=home,compress=lzo")))
+
+(define %fs
+  (file-system
+    (device (file-system-label "btrfs-pool"))
+    (mount-point "/root")
+    (type "btrfs")
+    (options '("autodefrag" ("subvol" . "root") ("compress" . "lzo")))))
+
+(test-equal "<file-system> options given as a string (deprecated)"
+  '("autodefrag" ("subvol" . "home") ("compress" . "lzo"))
+  (file-system-options %fs-with-deprecated-options-string))
+
+(test-equal "<file-system> options conversion to string"
+  "autodefrag,subvol=root,compress=lzo"
+  (file-system-options->string
+   (file-system-options %fs)))
+
 (test-end)