Merge branch 'master' into core-updates

4 files changed, 561 insertions, 191 deletions

diff --git a/gnu/system/image.scm b/gnu/system/image.scm
new file mode 100644
index 0000000000..571b7af5f3
--- /dev/null
+++ b/gnu/system/image.scm
@@ -0,0 +1,532 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu system image)
+  #:use-module (guix gexp)
+  #:use-module (guix modules)
+  #:use-module (guix monads)
+  #:use-module (guix records)
+  #:use-module (guix store)
+  #:use-module (guix ui)
+  #:use-module (guix utils)
+  #:use-module ((guix self) #:select (make-config.scm))
+  #:use-module (gnu bootloader)
+  #:use-module (gnu bootloader grub)
+  #:use-module (gnu image)
+  #:use-module (gnu services)
+  #:use-module (gnu services base)
+  #:use-module (gnu system)
+  #:use-module (gnu system file-systems)
+  #:use-module (gnu system uuid)
+  #:use-module (gnu system vm)
+  #:use-module (guix packages)
+  #:use-module (gnu packages base)
+  #:use-module (gnu packages bootloaders)
+  #:use-module (gnu packages cdrom)
+  #:use-module (gnu packages disk)
+  #:use-module (gnu packages gawk)
+  #:use-module (gnu packages genimage)
+  #:use-module (gnu packages guile)
+  #:autoload   (gnu packages gnupg) (guile-gcrypt)
+  #:use-module (gnu packages linux)
+  #:use-module (gnu packages mtools)
+  #:use-module ((srfi srfi-1) #:prefix srfi-1:)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-35)
+  #:use-module (rnrs bytevectors)
+  #:use-module (ice-9 match)
+  #:export (esp-partition
+            root-partition
+
+            efi-disk-image
+            iso9660-image
+
+            find-image
+            system-image))
+
+
+;;;
+;;; Images definitions.
+;;;
+
+(define esp-partition
+  (partition
+   (size (* 40 (expt 2 20)))
+   (label "GNU-ESP") ;cosmetic only
+   ;; Use "vfat" here since this property is used when mounting.  The actual
+   ;; FAT-ness is based on file system size (16 in this case).
+   (file-system "vfat")
+   (flags '(esp))
+   (initializer (gexp initialize-efi-partition))))
+
+(define root-partition
+  (partition
+   (size 'guess)
+   (label "Guix_image")
+   (file-system "ext4")
+   (flags '(boot))
+   (initializer (gexp initialize-root-partition))))
+
+(define efi-disk-image
+  (image
+   (format 'disk-image)
+   (partitions (list esp-partition root-partition))))
+
+(define iso9660-image
+  (image
+   (format 'iso9660)
+   (partitions
+    (list (partition
+           (size 'guess)
+           (label "GUIX_IMAGE")
+           (flags '(boot)))))
+   ;; XXX: Temporarily disable compression to speed-up the tests.
+   (compression? #f)))
+
+
+;;
+;; Helpers.
+;;
+
+(define not-config?
+  ;; Select (guix …) and (gnu …) modules, except (guix config).
+  (match-lambda
+    (('guix 'config) #f)
+    (('guix rest ...) #t)
+    (('gnu rest ...) #t)
+    (rest #f)))
+
+(define (partition->gexp partition)
+  "Turn PARTITION, a <partition> object, into a list-valued gexp suitable for
+'make-partition-image'."
+  #~'(#$@(list (partition-size partition))
+      #$(partition-file-system partition)
+      #$(partition-label partition)
+      #$(and=> (partition-uuid partition)
+               uuid-bytevector)))
+
+(define gcrypt-sqlite3&co
+  ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs.
+  (srfi-1:append-map
+   (lambda (package)
+     (cons package
+           (match (package-transitive-propagated-inputs package)
+             (((labels packages) ...)
+              packages))))
+   (list guile-gcrypt guile-sqlite3)))
+
+(define-syntax-rule (with-imported-modules* gexp* ...)
+  (with-extensions gcrypt-sqlite3&co
+    (with-imported-modules `(,@(source-module-closure
+                                '((gnu build vm)
+                                  (gnu build image)
+                                  (guix store database))
+                                #:select? not-config?)
+                             ((guix config) => ,(make-config.scm)))
+      #~(begin
+          (use-modules (gnu build vm)
+                       (gnu build image)
+                       (guix store database)
+                       (guix build utils))
+          gexp* ...))))
+
+
+;;
+;; Disk image.
+;;
+
+(define* (system-disk-image image
+                            #:key
+                            (name "disk-image")
+                            bootcfg
+                            bootloader
+                            register-closures?
+                            (inputs '()))
+  "Return as a file-like object, the disk-image described by IMAGE.  Said
+image can be copied on a USB stick as is.  BOOTLOADER is the bootloader that
+will be installed and configured according to BOOTCFG parameter.
+
+Raw images of the IMAGE partitions are first created.  Then, genimage is used
+to assemble the partition images into a disk-image without resorting to a
+virtual machine.
+
+INPUTS is a list of inputs (as for packages).  When REGISTER-CLOSURES? is
+true, register INPUTS in the store database of the image so that Guix can be
+used in the image."
+
+  (define genimage-name "image")
+
+  (define (image->genimage-cfg image)
+    ;; Return as a file-like object, the genimage configuration file
+    ;; describing the given IMAGE.
+    (define (format->image-type format)
+      ;; Return the genimage format corresponding to FORMAT.  For now, only
+      ;; the hdimage format (raw disk-image) is supported.
+      (case format
+        ((disk-image) "hdimage")
+        (else
+         (raise (condition
+                 (&message
+                  (message
+                   (format #f (G_ "Unsupported image type ~a~%.") format))))))))
+
+    (define (partition->dos-type partition)
+      ;; Return the MBR partition type corresponding to the given PARTITION.
+      ;; See: https://en.wikipedia.org/wiki/Partition_type.
+      (let ((flags (partition-flags partition)))
+        (cond
+         ((member 'esp flags) "0xEF")
+         (else "0x83"))))
+
+    (define (partition-image partition)
+      ;; Return as a file-like object, an image of the given PARTITION.  A
+      ;; directory, filled by calling the PARTITION initializer procedure, is
+      ;; first created within the store.  Then, an image of this directory is
+      ;; created using tools such as 'mke2fs' or 'mkdosfs', depending on the
+      ;; partition file-system type.
+      (let* ((os (image-operating-system image))
+             (schema (local-file (search-path %load-path
+                                              "guix/store/schema.sql")))
+             (graph (match inputs
+                      (((names . _) ...)
+                       names)))
+             (root-builder
+              (with-imported-modules*
+               (let* ((initializer #$(partition-initializer partition)))
+                 (sql-schema #$schema)
+
+                 ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be
+                 ;; decoded.
+                 (setenv "GUIX_LOCPATH"
+                         #+(file-append glibc-utf8-locales "/lib/locale"))
+                 (setlocale LC_ALL "en_US.utf8")
+
+                 (initializer #$output
+                              #:references-graphs '#$graph
+                              #:deduplicate? #f
+                              #:system-directory #$os
+                              #:bootloader-package
+                              #$(bootloader-package bootloader)
+                              #:bootcfg #$bootcfg
+                              #:bootcfg-location
+                              #$(bootloader-configuration-file bootloader)))))
+             (image-root
+              (computed-file "partition-image-root" root-builder
+                             #:options `(#:references-graphs ,inputs)))
+             (type (partition-file-system partition))
+             (image-builder
+              (with-imported-modules*
+               (let ((inputs '#$(list e2fsprogs dosfstools mtools)))
+                 (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+                 (make-partition-image #$(partition->gexp partition)
+                                       #$output
+                                       #$image-root)))))
+        (computed-file "partition.img" image-builder)))
+
+    (define (partition->config partition)
+      ;; Return the genimage partition configuration for PARTITION.
+      (let ((label (partition-label partition))
+            (dos-type (partition->dos-type partition))
+            (image (partition-image partition)))
+        #~(format #f "~/partition ~a {
+                                      ~/~/partition-type = ~a
+                                      ~/~/image = \"~a\"
+                                      ~/}"  #$label #$dos-type #$image)))
+
+    (let* ((format (image-format image))
+           (image-type (format->image-type format))
+           (partitions (image-partitions image))
+           (partitions-config (map partition->config partitions))
+           (builder
+            #~(begin
+                (let ((format (@ (ice-9 format) format)))
+                  (call-with-output-file #$output
+                    (lambda (port)
+                      (format port
+                              "\
+image ~a {
+~/~a {}
+~{~a~^~%~}
+}~%" #$genimage-name #$image-type (list #$@partitions-config))))))))
+      (computed-file "genimage.cfg" builder)))
+
+  (let* ((substitutable? (image-substitutable? image))
+         (builder
+          (with-imported-modules*
+           (let ((inputs '#$(list genimage coreutils findutils)))
+             (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+             (genimage #$(image->genimage-cfg image) #$output))))
+         (image-dir (computed-file "image-dir" builder)))
+    (computed-file name
+                   #~(symlink
+                      (string-append #$image-dir "/" #$genimage-name)
+                      #$output)
+                   #:options `(#:substitutable? ,substitutable?))))
+
+
+;;
+;; ISO9660 image.
+;;
+
+(define (has-guix-service-type? os)
+  "Return true if OS contains a service of the type GUIX-SERVICE-TYPE."
+  (not (not (srfi-1:find (lambda (service)
+                           (eq? (service-kind service) guix-service-type))
+                         (operating-system-services os)))))
+
+(define* (system-iso9660-image image
+                               #:key
+                               (name "iso9660-image")
+                               bootcfg
+                               bootloader
+                               register-closures?
+                               (inputs '())
+                               (grub-mkrescue-environment '()))
+  "Return as a file-like object a bootable, stand-alone iso9660 image.
+
+INPUTS is a list of inputs (as for packages).  When REGISTER-CLOSURES? is
+true, register INPUTS in the store database of the image so that Guix can be
+used in the image. "
+  (define root-label
+    (match (image-partitions image)
+      ((partition)
+       (partition-label partition))))
+
+  (define root-uuid
+    (match (image-partitions image)
+      ((partition)
+       (uuid-bytevector (partition-uuid partition)))))
+
+  (let* ((os (image-operating-system image))
+         (bootloader (bootloader-package bootloader))
+         (compression? (image-compression? image))
+         (substitutable? (image-substitutable? image))
+         (schema (local-file (search-path %load-path
+                                          "guix/store/schema.sql")))
+         (graph (match inputs
+                  (((names . _) ...)
+                   names)))
+         (root-builder
+          (with-imported-modules*
+           (sql-schema #$schema)
+
+           ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
+           (setenv "GUIX_LOCPATH"
+                   #+(file-append glibc-utf8-locales "/lib/locale"))
+           (setlocale LC_ALL "en_US.utf8")
+
+           (initialize-root-partition #$output
+                                      #:references-graphs '#$graph
+                                      #:deduplicate? #f
+                                      #:system-directory #$os)))
+         (image-root
+          (computed-file "image-root" root-builder
+                         #:options `(#:references-graphs ,inputs)))
+         (builder
+          (with-imported-modules*
+           (let* ((inputs '#$(list parted e2fsprogs dosfstools xorriso
+                                   sed grep coreutils findutils gawk)))
+             (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+             (make-iso9660-image #$xorriso
+                                 '#$grub-mkrescue-environment
+                                 #$bootloader
+                                 #$bootcfg
+                                 #$os
+                                 #$image-root
+                                 #$output
+                                 #:references-graphs '#$graph
+                                 #:register-closures? #$register-closures?
+                                 #:compression? #$compression?
+                                 #:volume-id #$root-label
+                                 #:volume-uuid #$root-uuid)))))
+    (computed-file name builder
+                   #:options `(#:references-graphs ,inputs
+                               #:substitutable? ,substitutable?))))
+
+
+;;
+;; Image creation.
+;;
+
+(define (root-partition? partition)
+  "Return true if PARTITION is the root partition, false otherwise."
+  (member 'boot (partition-flags partition)))
+
+(define (find-root-partition image)
+  "Return the root partition of the given IMAGE."
+  (srfi-1:find root-partition? (image-partitions image)))
+
+(define (image->root-file-system image)
+  "Return the IMAGE root partition file-system type."
+  (let ((format (image-format image)))
+    (if (eq? format 'iso9660)
+        "iso9660"
+        (partition-file-system (find-root-partition image)))))
+
+(define (root-size image)
+  "Return the root partition size of IMAGE."
+  (let* ((image-size (image-size image))
+         (root-partition (find-root-partition image))
+         (root-size (partition-size root-partition)))
+    (cond
+     ((and (eq? root-size 'guess) image-size)
+      image-size)
+     (else root-size))))
+
+(define* (image-with-os base-image os)
+  "Return an image based on BASE-IMAGE but with the operating-system field set
+to OS.  Also set the UUID and the size of the root partition."
+  (define root-file-system
+    (srfi-1:find
+     (lambda (fs)
+       (string=? (file-system-mount-point fs) "/"))
+     (operating-system-file-systems os)))
+
+  (let*-values (((partitions) (image-partitions base-image))
+                ((root-partition other-partitions)
+                 (srfi-1:partition root-partition? partitions)))
+    (image
+     (inherit base-image)
+     (operating-system os)
+     (partitions
+      (cons (partition
+             (inherit (car root-partition))
+             (uuid (file-system-device root-file-system))
+             (size (root-size base-image)))
+            other-partitions)))))
+
+(define (operating-system-for-image image)
+  "Return an operating-system based on the one specified in IMAGE, but
+suitable for image creation.  Assign an UUID to the root file-system, so that
+it can be used for bootloading."
+  (define volatile-root? (image-volatile-root? image))
+
+  (define (root-uuid os)
+    ;; UUID of the root file system, computed in a deterministic fashion.
+    ;; This is what we use to locate the root file system so it has to be
+    ;; different from the user's own file system UUIDs.
+    (let ((type (if (eq? (image-format image) 'iso9660)
+                    'iso9660
+                    'dce)))
+      (operating-system-uuid os type)))
+
+  (let* ((root-file-system-type (image->root-file-system image))
+         (base-os (image-operating-system image))
+         (file-systems-to-keep
+          (srfi-1:remove
+           (lambda (fs)
+             (string=? (file-system-mount-point fs) "/"))
+           (operating-system-file-systems base-os)))
+         (format (image-format image))
+         (os
+          (operating-system
+            (inherit base-os)
+            (initrd (lambda (file-systems . rest)
+                      (apply (operating-system-initrd base-os)
+                             file-systems
+                             #:volatile-root? volatile-root?
+                             rest)))
+            (bootloader (if (eq? format 'iso9660)
+                            (bootloader-configuration
+                             (inherit
+                              (operating-system-bootloader base-os))
+                             (bootloader grub-mkrescue-bootloader))
+                            (operating-system-bootloader base-os)))
+            (file-systems (cons (file-system
+                                  (mount-point "/")
+                                  (device "/dev/placeholder")
+                                  (type root-file-system-type))
+                                file-systems-to-keep))))
+         (uuid (root-uuid os)))
+    (operating-system
+      (inherit os)
+      (file-systems (cons (file-system
+                            (mount-point "/")
+                            (device uuid)
+                            (type root-file-system-type))
+                          file-systems-to-keep)))))
+
+(define* (make-system-image image)
+  "Return the derivation of IMAGE.  It can be a raw disk-image or an ISO9660
+image, depending on IMAGE format."
+  (define substitutable? (image-substitutable? image))
+
+  (let* ((os (operating-system-for-image image))
+         (image* (image-with-os image os))
+         (register-closures? (has-guix-service-type? os))
+         (bootcfg (operating-system-bootcfg os))
+         (bootloader (bootloader-configuration-bootloader
+                      (operating-system-bootloader os))))
+    (case (image-format image)
+      ((disk-image)
+       (system-disk-image image*
+                          #:bootcfg bootcfg
+                          #:bootloader bootloader
+                          #:register-closures? register-closures?
+                          #:inputs `(("system" ,os)
+                                     ("bootcfg" ,bootcfg))))
+      ((iso9660)
+       (system-iso9660-image image*
+                             #:bootcfg bootcfg
+                             #:bootloader bootloader
+                             #:register-closures? register-closures?
+                             #:inputs `(("system" ,os)
+                                        ("bootcfg" ,bootcfg))
+                             #:grub-mkrescue-environment
+                             '(("MKRESCUE_SED_MODE" . "mbr_hfs")))))))
+
+(define (find-image file-system-type)
+  "Find and return an image that could match the given FILE-SYSTEM-TYPE.  This
+is useful to adapt to interfaces written before the addition of the <image>
+record."
+  ;; XXX: Add support for system and target here, or in the caller.
+  (match file-system-type
+    ("iso9660" iso9660-image)
+    (_ efi-disk-image)))
+
+(define (system-image image)
+  "Wrap 'make-system-image' call, so that it is used only if the given IMAGE
+is supported.  Otherwise, fallback to image creation in a VM.  This is
+temporary and should be removed once 'make-system-image' is able to deal with
+all types of images."
+  (define substitutable? (image-substitutable? image))
+  (define volatile-root? (image-volatile-root? image))
+
+  (let* ((image-os (image-operating-system image))
+         (image-root-filesystem-type (image->root-file-system image))
+         (bootloader (bootloader-configuration-bootloader
+                      (operating-system-bootloader image-os)))
+         (bootloader-name (bootloader-name bootloader))
+         (size (image-size image))
+         (format (image-format image)))
+    (mbegin %store-monad
+      (if (and (or (eq? bootloader-name 'grub)
+                   (eq? bootloader-name 'extlinux))
+               (eq? format 'disk-image))
+          ;; Fallback to image creation in a VM when it is not yet supported
+          ;; by this module.
+          (system-disk-image-in-vm image-os
+                                   #:disk-image-size size
+                                   #:file-system-type image-root-filesystem-type
+                                   #:volatile? volatile-root?
+                                   #:substitutable? substitutable?)
+          (lower-object
+           (make-system-image image))))))
+
+;;; image.scm ends here
diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index 7166c12bcc..fe49ffdb94 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -523,6 +523,7 @@ Access documentation at any time by pressing Alt-F2.\x1b[0m
                      mdadm
                      dosfstools         ;mkfs.fat, for the UEFI boot partition
                      btrfs-progs
+                     f2fs-tools
                      jfsutils
                      openssh    ;we already have sshd, having ssh/scp can help
                      wireless-tools iw wpa-supplicant-minimal iproute
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index d84f352663..c43d53a210 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -245,6 +245,9 @@ FILE-SYSTEMS."
           '())
     ,@(if (find (file-system-type-predicate "jfs") file-systems)
           (list jfs_fsck/static)
+          '())
+    ,@(if (find (file-system-type-predicate "f2fs") file-systems)
+          (list f2fs-fsck/static)
           '())))
 
 (define-syntax vhash                              ;TODO: factorize
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 1d5ee39497..4ea82cfd50 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -77,7 +77,7 @@
 
             system-qemu-image/shared-store
             system-qemu-image/shared-store-script
-            system-disk-image
+            system-disk-image-in-vm
             system-docker-image
 
             virtual-machine
@@ -269,95 +269,6 @@ substitutable."
                      (eq? (service-kind service) guix-service-type))
                    (operating-system-services os)))))
 
-(define* (iso9660-image #:key
-                        (name "iso9660-image")
-                        file-system-label
-                        file-system-uuid
-                        (system (%current-system))
-                        (target (%current-target-system))
-                        (qemu qemu-minimal)
-                        os
-                        bootcfg-drv
-                        bootloader
-                        (register-closures? (has-guix-service-type? os))
-                        (inputs '())
-                        (grub-mkrescue-environment '())
-                        (substitutable? #t))
-  "Return a bootable, stand-alone iso9660 image.
-
-INPUTS is a list of inputs (as for packages)."
-  (define schema
-    (and register-closures?
-         (local-file (search-path %load-path
-                                  "guix/store/schema.sql"))))
-
-  (expression->derivation-in-linux-vm
-   name
-   (with-extensions gcrypt-sqlite3&co
-     (with-imported-modules `(,@(source-module-closure '((gnu build vm)
-                                                         (guix store database)
-                                                         (guix build utils))
-                                                       #:select? not-config?)
-                              ((guix config) => ,(make-config.scm)))
-       #~(begin
-           (use-modules (gnu build vm)
-                        (guix store database)
-                        (guix build utils))
-
-           (sql-schema #$schema)
-
-           ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
-           (setenv "GUIX_LOCPATH"
-                   #+(file-append glibc-utf8-locales "/lib/locale"))
-           (setlocale LC_ALL "en_US.utf8")
-
-           (let ((inputs
-                  '#$(append (list parted e2fsprogs dosfstools xorriso)
-                             (map canonical-package
-                                  (list sed grep coreutils findutils gawk))))
-
-
-                 (graphs     '#$(match inputs
-                                  (((names . _) ...)
-                                   names)))
-                 ;; This variable is unused but allows us to add INPUTS-TO-COPY
-                 ;; as inputs.
-                 (to-register
-                  '#$(map (match-lambda
-                            ((name thing) thing)
-                            ((name thing output) `(,thing ,output)))
-                          inputs)))
-
-             (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
-             (make-iso9660-image #$xorriso
-                                 '#$grub-mkrescue-environment
-                                 #$(bootloader-package bootloader)
-                                 #$bootcfg-drv
-                                 #$os
-                                 "/xchg/guixsd.iso"
-                                 #:register-closures? #$register-closures?
-                                 #:closures graphs
-                                 #:volume-id #$file-system-label
-                                 #:volume-uuid #$(and=> file-system-uuid
-                                                        uuid-bytevector))))))
-   #:system system
-   #:target target
-
-   ;; Keep a local file system for /tmp so that we can populate it directly as
-   ;; root and have files owned by root.  See <https://bugs.gnu.org/31752>.
-   #:file-systems (remove (lambda (file-system)
-                            (string=? (file-system-mount-point file-system)
-                                      "/tmp"))
-                          %linux-vm-file-systems)
-
-   #:make-disk-image? #f
-   #:single-file-output? #t
-   #:references-graphs inputs
-   #:substitutable? substitutable?
-
-   ;; Xorriso seems to be quite memory-hungry, so increase the VM's RAM size.
-   #:memory-size 512))
-
 (define* (qemu-image #:key
                      (name "qemu-image")
                      (system (%current-system))
@@ -624,62 +535,13 @@ system."
 ;;; VM and disk images.
 ;;;
 
-(define* (operating-system-uuid os #:optional (type 'dce))
-  "Compute UUID object with a deterministic \"UUID\" for OS, of the given
-TYPE (one of 'iso9660 or 'dce).  Return a UUID object."
-  ;; Note: For this to be deterministic, we must not hash things that contains
-  ;; (directly or indirectly) procedures, for example.  That rules out
-  ;; anything that contains gexps, thunk or delayed record fields, etc.
-
-  (define service-name
-    (compose service-type-name service-kind))
-
-  (define (file-system-digest fs)
-    ;; Return a hashable digest that does not contain 'dependencies' since
-    ;; this field can contain procedures.
-    (let ((device (file-system-device fs)))
-      (list (file-system-mount-point fs)
-            (file-system-type fs)
-            (file-system-device->string device)
-            (file-system-options fs))))
-
-  (if (eq? type 'iso9660)
-      (let ((pad (compose (cut string-pad <> 2 #\0)
-                          number->string))
-            (h   (hash (map service-name (operating-system-services os))
-                       3600)))
-        (bytevector->uuid
-         (string->iso9660-uuid
-          (string-append "1970-01-01-"
-                         (pad (hash (operating-system-host-name os) 24)) "-"
-                         (pad (quotient h 60)) "-"
-                         (pad (modulo h 60)) "-"
-                         (pad (hash (map file-system-digest
-                                         (operating-system-file-systems os))
-                                    100))))
-         'iso9660))
-      (bytevector->uuid
-       (uint-list->bytevector
-        (list (hash (map file-system-digest
-                         (operating-system-file-systems os))
-                    (- (expt 2 32) 1))
-              (hash (operating-system-host-name os)
-                    (- (expt 2 32) 1))
-              (hash (map service-name (operating-system-services os))
-                    (- (expt 2 32) 1))
-              (hash (map file-system-digest (operating-system-file-systems os))
-                    (- (expt 2 32) 1)))
-        (endianness little)
-        4)
-       type)))
-
-(define* (system-disk-image os
-                            #:key
-                            (name "disk-image")
-                            (file-system-type "ext4")
-                            (disk-image-size (* 900 (expt 2 20)))
-                            (volatile? #t)
-                            (substitutable? #t))
+(define* (system-disk-image-in-vm os
+                                  #:key
+                                  (name "disk-image")
+                                  (file-system-type "ext4")
+                                  (disk-image-size (* 900 (expt 2 20)))
+                                  (volatile? #t)
+                                  (substitutable? #t))
   "Return the derivation of a disk image of DISK-IMAGE-SIZE bytes of the
 system described by OS.  Said image can be copied on a USB stick as is.  When
 VOLATILE? is true, the root file system is made volatile; this is useful
@@ -687,25 +549,14 @@ to USB sticks meant to be read-only.
 
 SUBSTITUTABLE? determines whether the returned derivation should be marked as
 substitutable."
-  (define normalize-label
-    ;; ISO labels are all-caps (case-insensitive), but since
-    ;; 'find-partition-by-label' is case-sensitive, make it all-caps here.
-    (if (string=? "iso9660" file-system-type)
-        string-upcase
-        identity))
-
   (define root-label
-    ;; Volume name of the root file system.
-    (normalize-label "Guix_image"))
+    "Guix_image")
 
   (define (root-uuid os)
     ;; UUID of the root file system, computed in a deterministic fashion.
     ;; This is what we use to locate the root file system so it has to be
     ;; different from the user's own file system UUIDs.
-    (operating-system-uuid os
-                           (if (string=? file-system-type "iso9660")
-                               'iso9660
-                               'dce)))
+    (operating-system-uuid os 'dce))
 
   (define file-systems-to-keep
     (remove (lambda (fs)
@@ -722,11 +573,7 @@ substitutable."
                                 #:volatile-root? volatile?
                                 rest)))
 
-               (bootloader (if (string=? "iso9660" file-system-type)
-                               (bootloader-configuration
-                                 (inherit (operating-system-bootloader os))
-                                 (bootloader grub-mkrescue-bootloader))
-                               (operating-system-bootloader os)))
+               (bootloader (operating-system-bootloader os))
 
                ;; Force our own root file system.  (We need a "/" file system
                ;; to call 'root-uuid'.)
@@ -744,33 +591,20 @@ substitutable."
                                      (type file-system-type))
                                    file-systems-to-keep))))
         (bootcfg (operating-system-bootcfg os)))
-    (if (string=? "iso9660" file-system-type)
-        (iso9660-image #:name name
-                       #:file-system-label root-label
-                       #:file-system-uuid uuid
-                       #:os os
-                       #:bootcfg-drv bootcfg
-                       #:bootloader (bootloader-configuration-bootloader
-                                     (operating-system-bootloader os))
-                       #:inputs `(("system" ,os)
-                                  ("bootcfg" ,bootcfg))
-                       #:grub-mkrescue-environment
-                       '(("MKRESCUE_SED_MODE" . "mbr_hfs"))
-                       #:substitutable? substitutable?)
-        (qemu-image #:name name
-                    #:os os
-                    #:bootcfg-drv bootcfg
-                    #:bootloader (bootloader-configuration-bootloader
-                                  (operating-system-bootloader os))
-                    #:disk-image-size disk-image-size
-                    #:disk-image-format "raw"
-                    #:file-system-type file-system-type
-                    #:file-system-label root-label
-                    #:file-system-uuid uuid
-                    #:copy-inputs? #t
-                    #:inputs `(("system" ,os)
-                               ("bootcfg" ,bootcfg))
-                    #:substitutable? substitutable?))))
+    (qemu-image #:name name
+                #:os os
+                #:bootcfg-drv bootcfg
+                #:bootloader (bootloader-configuration-bootloader
+                              (operating-system-bootloader os))
+                #:disk-image-size disk-image-size
+                #:disk-image-format "raw"
+                #:file-system-type file-system-type
+                #:file-system-label root-label
+                #:file-system-uuid uuid
+                #:copy-inputs? #t
+                #:inputs `(("system" ,os)
+                           ("bootcfg" ,bootcfg))
+                #:substitutable? substitutable?)))
 
 (define* (system-qemu-image os
                             #:key