03/52: vm: 'qemu-image' can pass options to the 'mkfs' command.

[guix-commits]

janneke pushed a commit to branch wip-hurd-vm
in repository guix.

commit 73da2726cd0e7505c14fcd67844db0b9b4de796a
Author: Ludovic Courtès <address@hidden>
AuthorDate: Wed Apr 1 15:08:11 2020 +0200

    vm: 'qemu-image' can pass options to the 'mkfs' command.
    
    * gnu/build/vm.scm (<partition>)[file-system-options]: New field.
    (create-ext-file-system, create-fat-file-system)
    (format-partition): Add #:options and honor it.
    (initialize-partition): Pass #:options to 'format-partition'.
    * gnu/system/vm.scm (qemu-image): Add #:file-system-options and use it
    for the root partition.
---
 gnu/build/vm.scm  | 24 +++++++++++++++---------
 gnu/system/vm.scm |  5 ++++-
 2 files changed, 19 insertions(+), 10 deletions(-)

diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 9413798..c53dacf 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -233,6 +233,8 @@ deduplicates files common to CLOSURE and the rest of 
PREFIX."
   (device      partition-device (default #f))
   (size        partition-size)
   (file-system partition-file-system (default "ext4"))
+  (file-system-options partition-file-system-options ;passed to 'mkfs.FS'
+                       (default '()))
   (label       partition-label (default #f))
   (uuid        partition-uuid (default #f))
   (flags       partition-flags (default '()))
@@ -307,7 +309,7 @@ actual /dev name based on DEVICE."
 (define MS_BIND 4096)                             ; <sys/mounts.h> again!
 
 (define* (create-ext-file-system partition type
-                                 #:key label uuid)
+                                 #:key label uuid (options '()))
   "Create an ext-family file system of TYPE on PARTITION.  If LABEL is true,
 use that as the volume name.  If UUID is true, use it as the partition UUID."
   (format #t "creating ~a partition... ~@[label: ~s~] ~@[uuid: ~s~]\n"
@@ -319,26 +321,29 @@ use that as the volume name.  If UUID is true, use it as 
the partition UUID."
                  '())
            ,@(if uuid
                  `("-U" ,(uuid->string uuid))
-                 '()))))
+                 '())
+           ,@options)))
 
 (define* (create-fat-file-system partition
-                                 #:key label uuid)
+                                 #:key label uuid (options '()))
   "Create a FAT file system on PARTITION.  The number of File Allocation Tables
 will be determined based on file system size.  If LABEL is true, use that as 
the
 volume name."
   ;; FIXME: UUID is ignored!
   (format #t "creating FAT partition...\n")
   (apply invoke "mkfs.fat" partition
-         (if label `("-n" ,label) '())))
+         (append (if label `("-n" ,label) '()) options)))
 
 (define* (format-partition partition type
-                           #:key label uuid)
+                           #:key label uuid (options '()))
   "Create a file system TYPE on PARTITION.  If LABEL is true, use that as the
-volume name."
+volume name.  Options is a list of command-line options passed to 'mkfs.FS'."
   (cond ((string-prefix? "ext" type)
-         (create-ext-file-system partition type #:label label #:uuid uuid))
+         (create-ext-file-system partition type #:label label #:uuid uuid
+                                 #:options options))
         ((or (string-prefix? "fat" type) (string= "vfat" type))
-         (create-fat-file-system partition #:label label #:uuid uuid))
+         (create-fat-file-system partition #:label label #:uuid uuid
+                                 #:options options))
         (else (error "Unsupported file system."))))
 
 (define (initialize-partition partition)
@@ -348,7 +353,8 @@ it, run its initializer, and unmount it."
    (format-partition (partition-device partition)
                      (partition-file-system partition)
                      #:label (partition-label partition)
-                     #:uuid (partition-uuid partition))
+                     #:uuid (partition-uuid partition)
+                     #:options (partition-file-system-options partition))
    (mkdir-p target)
    (mount (partition-device partition) target
           (partition-file-system partition))
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index d81a789..f2f4912 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -360,6 +360,7 @@ INPUTS is a list of inputs (as for packages)."
                      (disk-image-size 'guess)
                      (disk-image-format "qcow2")
                      (file-system-type "ext4")
+                     (file-system-options '())
                      (extra-directives '())
                      file-system-label
                      file-system-uuid
@@ -373,7 +374,8 @@ INPUTS is a list of inputs (as for packages)."
 'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE.
 Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root
 partition; likewise FILE-SYSTEM-UUID, if true, specifies the UUID of the root
-partition (a UUID object).
+partition (a UUID object).  FILE-SYSTEM-OPTIONS is an optional list of
+command-line options passed to 'mkfs.ext4' (or similar).
 
 The returned image is a full disk image that runs OS-DERIVATION,
 with a GRUB installation that uses GRUB-CONFIGURATION as its configuration
@@ -463,6 +465,7 @@ system that is passed to 'populate-root-file-system'."
                              (uuid #$(and=> file-system-uuid
                                             uuid-bytevector))
                              (file-system #$file-system-type)
+                             (file-system-options '#$file-system-options)
                              (flags '(boot))
                              (initializer initialize)))
                       ;; Append a small EFI System Partition for use with UEFI