Merge remote-tracking branch 'origin/master' into core-updates

7 files changed, 306 insertions, 159 deletions

diff --git a/gnu/system/examples/yggdrasil.tmpl b/gnu/system/examples/yggdrasil.tmpl
new file mode 100644
index 0000000000..be80bf4de9
--- /dev/null
+++ b/gnu/system/examples/yggdrasil.tmpl
@@ -0,0 +1,60 @@
+;; This is an operating system configuration template
+;; for a "bare bones" setup, with no X11 display server.
+
+(use-modules (gnu))
+(use-service-modules networking ssh)
+(use-package-modules admin curl networking screen)
+
+(operating-system
+  (host-name "ruby-guard-5545")
+  (timezone "Europe/Budapest")
+  (locale "en_US.utf8")
+
+  ;; Boot in "legacy" BIOS mode, assuming /dev/sdX is the
+  ;; target hard disk, and "my-root" is the label of the target
+  ;; root file system.
+  (bootloader (bootloader-configuration
+                (bootloader grub-bootloader)
+                (target "/dev/sdX")))
+  (file-systems (cons (file-system
+                        (device (file-system-label "my-root"))
+                        (mount-point "/")
+                        (type "ext4"))
+                      %base-file-systems))
+  (users (cons (user-account
+                (name "alice")
+                (comment "Bob's sister")
+                (group "users")
+                ;; adding her to the yggdrasil group means she can use
+                ;; yggdrasilctl to modify the configuration
+                (supplementary-groups '("wheel" "yggdrasil")))
+               %base-user-accounts))
+
+  ;; Globally-installed packages.
+  (packages (cons* screen curl %base-packages))
+
+  ;; Add services to the baseline: a DHCP client and
+  ;; an SSH server.
+  ;; If you add an /etc/yggdrasil-private.conf, you can log in to ssh
+  ;; using your Yggdrasil IPv6 address from another machine running Yggdrasil.
+  ;; Alternatively, the client can sit behind a router that has Yggdrasil.
+  ;; That file is specifically _not_ handled by Guix, because we don't want its
+  ;; contents to sit in the world-readable /gnu/store.
+  (services
+   (append
+    (list
+     (service dhcp-client-service-type)
+     (service yggdrasil-service-type
+              (yggdrasil-configuration
+               (log-to 'stdout)
+               (log-level 'debug)
+               (autoconf? #f)
+               (json-config
+                ;; choose a few from
+                ;; https://github.com/yggdrasil-network/public-peers
+                '((peers . #("tcp://1.2.3.4:1337"))))
+               (config-file #f)))
+     (service openssh-service-type
+              (openssh-configuration
+               (port-number 2222))))
+    %base-services)))
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index bc6610b14c..4972d9067b 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -66,6 +66,7 @@
 
             efi-disk-image
             iso9660-image
+            arm32-disk-image
             arm64-disk-image
 
             image-with-os
@@ -73,6 +74,7 @@
             qcow2-image-type
             iso-image-type
             uncompressed-iso-image-type
+            arm32-image-type
             arm64-image-type
 
             image-with-label
@@ -126,10 +128,10 @@
            (label "GUIX_IMAGE")
            (flags '(boot)))))))
 
-(define arm64-disk-image
+(define arm32-disk-image
   (image
    (format 'disk-image)
-   (target "aarch64-linux-gnu")
+   (target "arm-linux-gnueabihf")
    (partitions
     (list (partition
            (inherit root-partition)
@@ -138,6 +140,11 @@
    ;; fails.
    (volatile-root? #f)))
 
+(define arm64-disk-image
+  (image
+   (inherit arm32-disk-image)
+   (target "aarch64-linux-gnu")))
+
 
 ;;;
 ;;; Images types.
@@ -179,9 +186,14 @@ set to the given OS."
                   (compression? #f))
                  <>))))
 
+(define arm32-image-type
+  (image-type
+   (name 'arm32-raw)
+   (constructor (cut image-with-os arm32-disk-image <>))))
+
 (define arm64-image-type
   (image-type
-   (name 'arm)
+   (name 'arm64-raw)
    (constructor (cut image-with-os arm64-disk-image <>))))
 
 
@@ -342,6 +354,9 @@ used in the image."
                                        #$output
                                        image-root)))))
         (computed-file "partition.img" image-builder
+                       ;; Allow offloading so that this I/O-intensive process
+                       ;; doesn't run on the build farm's head node.
+                       #:local-build? #f
                        #:options `(#:references-graphs ,inputs))))
 
     (define (partition->config partition)
@@ -399,6 +414,7 @@ image ~a {
                 out-image))
              (convert-disk-image out-image '#$format #$output)))))
     (computed-file name builder
+                   #:local-build? #f              ;too I/O-intensive
                    #:options `(#:substitutable? ,substitutable?))))
 
 
@@ -476,6 +492,9 @@ used in the image. "
                                  #:volume-id #$root-label
                                  #:volume-uuid #$root-uuid)))))
     (computed-file name builder
+                   ;; Allow offloading so that this I/O-intensive process
+                   ;; doesn't run on the build farm's head node.
+                   #:local-build? #f
                    #:options `(#:references-graphs ,inputs
                                #:substitutable? ,substitutable?))))
 
@@ -557,7 +576,9 @@ it can be used for bootloading."
          (file-systems-to-keep
           (srfi-1:remove
            (lambda (fs)
-             (string=? (file-system-mount-point fs) "/"))
+             (let ((mount-point (file-system-mount-point fs)))
+               (or (string=? mount-point "/")
+                   (string=? mount-point "/boot/efi"))))
            (operating-system-file-systems base-os)))
          (format (image-format image))
          (os
diff --git a/gnu/system/images/pinebook-pro.scm b/gnu/system/images/pinebook-pro.scm
new file mode 100644
index 0000000000..b038e262cb
--- /dev/null
+++ b/gnu/system/images/pinebook-pro.scm
@@ -0,0 +1,66 @@
+;;; 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 images pinebook-pro)
+  #:use-module (gnu bootloader)
+  #:use-module (gnu bootloader u-boot)
+  #:use-module (gnu image)
+  #:use-module (gnu packages linux)
+  #:use-module (gnu services)
+  #:use-module (gnu services base)
+  #:use-module (gnu system)
+  #:use-module (gnu system file-systems)
+  #:use-module (gnu system image)
+  #:use-module (srfi srfi-26)
+  #:export (pinebook-pro-barebones-os
+            pinebook-pro-image-type
+            pinebook-pro-barebones-raw-image))
+
+(define pinebook-pro-barebones-os
+  (operating-system
+    (host-name "viso")
+    (timezone "Europe/Paris")
+    (locale "en_US.utf8")
+    (bootloader (bootloader-configuration
+                 (bootloader u-boot-pinebook-pro-rk3399-bootloader)
+                 (target "/dev/vda")))
+    (initrd-modules '())
+    (kernel linux-libre-arm64-generic)
+    (file-systems (cons (file-system
+                          (device (file-system-label "my-root"))
+                          (mount-point "/")
+                          (type "ext4"))
+                        %base-file-systems))
+    (services (cons (service agetty-service-type
+                             (agetty-configuration
+                              (extra-options '("-L")) ; no carrier detect
+                              (baud-rate "115200")
+                              (term "vt100")
+                              (tty "ttyS0")))
+                    %base-services))))
+
+(define pinebook-pro-image-type
+  (image-type
+   (name 'pinebook-pro-raw)
+   (constructor (cut image-with-os arm64-disk-image <>))))
+
+(define pinebook-pro-barebones-raw-image
+  (image
+   (inherit
+    (os->image pinebook-pro-barebones-os #:type pinebook-pro-image-type))
+   (name 'pinebook-pro-barebones-raw-image)))
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index b8a30c0abc..85e493fecb 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -195,11 +195,11 @@ upon error."
   (define device-mapping-commands
     ;; List of gexps to open the mapped devices.
     (map (lambda (md)
-           (let* ((source (mapped-device-source md))
-                  (target (mapped-device-target md))
-                  (type   (mapped-device-type md))
-                  (open   (mapped-device-kind-open type)))
-             (open source target)))
+           (let* ((source  (mapped-device-source md))
+                  (targets (mapped-device-targets md))
+                  (type    (mapped-device-type md))
+                  (open    (mapped-device-kind-open type)))
+             (open source targets)))
          mapped-devices))
 
   (define kodir
@@ -217,6 +217,7 @@ upon error."
                       (gnu system file-systems)
                       ((guix build utils) #:hide (delete))
                       (guix build bournish)   ;add the 'bournish' meta-command
+                      (srfi srfi-1)           ;for lvm-device-mapping
                       (srfi srfi-26)
 
                       ;; FIXME: The following modules are for
diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm
index 31c50c4e40..559c27bb28 100644
--- a/gnu/system/mapped-devices.scm
+++ b/gnu/system/mapped-devices.scm
@@ -28,6 +28,7 @@
                           formatted-message
                           &fix-hint
                           &error-location))
+  #:use-module (guix deprecation)
   #:use-module (gnu services)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system uuid)
@@ -35,17 +36,19 @@
   #:autoload   (gnu build linux-modules)
                  (missing-modules)
   #:autoload   (gnu packages cryptsetup) (cryptsetup-static)
-  #:autoload   (gnu packages linux) (mdadm-static)
+  #:autoload   (gnu packages linux) (mdadm-static lvm2-static)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
-  #:export (mapped-device
+  #:export (%mapped-device
+            mapped-device
             mapped-device?
             mapped-device-source
             mapped-device-target
+            mapped-device-targets
             mapped-device-type
             mapped-device-location
 
@@ -61,7 +64,8 @@
             check-device-initrd-modules           ;XXX: needs a better place
 
             luks-device-mapping
-            raid-device-mapping))
+            raid-device-mapping
+            lvm-device-mapping))
 
 ;;; Commentary:
 ;;;
@@ -70,15 +74,36 @@
 ;;;
 ;;; Code:
 
-(define-record-type* <mapped-device> mapped-device
+(define-record-type* <mapped-device> %mapped-device
   make-mapped-device
   mapped-device?
   (source    mapped-device-source)                ;string | list of strings
-  (target    mapped-device-target)                ;string
+  (targets   mapped-device-targets)               ;list of strings
   (type      mapped-device-type)                  ;<mapped-device-kind>
   (location  mapped-device-location
              (default (current-source-location)) (innate)))
 
+(define-syntax mapped-device-compatibility-helper
+  (syntax-rules (target)
+    ((_ () (fields ...))
+     (%mapped-device fields ...))
+    ((_ ((target exp) rest ...) (others ...))
+     (%mapped-device others ...
+                      (targets (list exp))
+                      rest ...))
+    ((_ (field rest ...) (others ...))
+     (mapped-device-compatibility-helper (rest ...)
+                                         (others ... field)))))
+
+(define-syntax-rule (mapped-device fields ...)
+  "Build an <mapped-device> record, automatically converting 'target' field
+specifications to 'targets'."
+  (mapped-device-compatibility-helper (fields ...) ()))
+
+(define-deprecated (mapped-device-target md)
+  mapped-device-targets
+  (car (mapped-device-targets md)))
+
 (define-record-type* <mapped-device-type> mapped-device-kind
   make-mapped-device-kind
   mapped-device-kind?
@@ -97,14 +122,14 @@
   (shepherd-service-type
    'device-mapping
    (match-lambda
-     (($ <mapped-device> source target
+     (($ <mapped-device> source targets
                          ($ <mapped-device-type> open close))
       (shepherd-service
-       (provision (list (symbol-append 'device-mapping- (string->symbol target))))
+       (provision (list (symbol-append 'device-mapping- (string->symbol (string-join targets "-")))))
        (requirement '(udev))
        (documentation "Map a device node using Linux's device mapper.")
-       (start #~(lambda () #$(open source target)))
-       (stop #~(lambda _ (not #$(close source target))))
+       (start #~(lambda () #$(open source targets)))
+       (stop #~(lambda _ (not #$(close source targets))))
        (respawn? #f))))))
 
 (define (device-mapping-service mapped-device)
@@ -162,48 +187,52 @@ option of @command{guix system}.\n")
 ;;; Common device mappings.
 ;;;
 
-(define (open-luks-device source target)
+(define (open-luks-device source targets)
   "Return a gexp that maps SOURCE to TARGET as a LUKS device, using
 'cryptsetup'."
   (with-imported-modules (source-module-closure
                           '((gnu build file-systems)))
-    #~(let ((source #$(if (uuid? source)
-                          (uuid-bytevector source)
-                          source)))
-        ;; XXX: 'use-modules' should be at the top level.
-        (use-modules (rnrs bytevectors)           ;bytevector?
-                     ((gnu build file-systems)
-                      #:select (find-partition-by-luks-uuid)))
-
-        ;; Use 'cryptsetup-static', not 'cryptsetup', to avoid pulling the
-        ;; whole world inside the initrd (for when we're in an initrd).
-        (zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
-                        "open" "--type" "luks"
-
-                        ;; Note: We cannot use the "UUID=source" syntax here
-                        ;; because 'cryptsetup' implements it by searching the
-                        ;; udev-populated /dev/disk/by-id directory but udev may
-                        ;; be unavailable at the time we run this.
-                        (if (bytevector? source)
-                            (or (let loop ((tries-left 10))
-                                  (and (positive? tries-left)
-                                       (or (find-partition-by-luks-uuid source)
-                                           ;; If the underlying partition is
-                                           ;; not found, try again after
-                                           ;; waiting a second, up to ten
-                                           ;; times.  FIXME: This should be
-                                           ;; dealt with in a more robust way.
-                                           (begin (sleep 1)
-                                                  (loop (- tries-left 1))))))
-                                (error "LUKS partition not found" source))
-                            source)
-
-                        #$target)))))
-
-(define (close-luks-device source target)
+    (match targets
+      ((target)
+       #~(let ((source #$(if (uuid? source)
+                             (uuid-bytevector source)
+                             source)))
+           ;; XXX: 'use-modules' should be at the top level.
+           (use-modules (rnrs bytevectors) ;bytevector?
+                        ((gnu build file-systems)
+                         #:select (find-partition-by-luks-uuid)))
+
+           ;; Use 'cryptsetup-static', not 'cryptsetup', to avoid pulling the
+           ;; whole world inside the initrd (for when we're in an initrd).
+           (zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
+                           "open" "--type" "luks"
+
+                           ;; Note: We cannot use the "UUID=source" syntax here
+                           ;; because 'cryptsetup' implements it by searching the
+                           ;; udev-populated /dev/disk/by-id directory but udev may
+                           ;; be unavailable at the time we run this.
+                           (if (bytevector? source)
+                               (or (let loop ((tries-left 10))
+                                     (and (positive? tries-left)
+                                          (or (find-partition-by-luks-uuid source)
+                                              ;; If the underlying partition is
+                                              ;; not found, try again after
+                                              ;; waiting a second, up to ten
+                                              ;; times.  FIXME: This should be
+                                              ;; dealt with in a more robust way.
+                                              (begin (sleep 1)
+                                                     (loop (- tries-left 1))))))
+                                   (error "LUKS partition not found" source))
+                               source)
+
+                           #$target)))))))
+
+(define (close-luks-device source targets)
   "Return a gexp that closes TARGET, a LUKS device."
-  #~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
-                    "close" #$target)))
+  (match targets
+    ((target)
+     #~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
+                       "close" #$target)))))
 
 (define* (check-luks-device md #:key
                             needed-for-boot?
@@ -235,36 +264,40 @@ option of @command{guix system}.\n")
    (close close-luks-device)
    (check check-luks-device)))
 
-(define (open-raid-device sources target)
+(define (open-raid-device sources targets)
   "Return a gexp that assembles SOURCES (a list of devices) to the RAID device
 TARGET (e.g., \"/dev/md0\"), using 'mdadm'."
-  #~(let ((sources '#$sources)
-
-          ;; XXX: We're not at the top level here.  We could use a
-          ;; non-top-level 'use-modules' form but that doesn't work when the
-          ;; code is eval'd, like the Shepherd does.
-          (every   (@ (srfi srfi-1) every))
-          (format  (@ (ice-9 format) format)))
-      (let loop ((attempts 0))
-        (unless (every file-exists? sources)
-          (when (> attempts 20)
-            (error "RAID devices did not show up; bailing out"
-                   sources))
-
-          (format #t "waiting for RAID source devices~{ ~a~}...~%"
-                  sources)
-          (sleep 1)
-          (loop (+ 1 attempts))))
-
-      ;; Use 'mdadm-static' rather than 'mdadm' to avoid pulling its whole
-      ;; closure (80 MiB) in the initrd when a RAID device is needed for boot.
-      (zero? (apply system* #$(file-append mdadm-static "/sbin/mdadm")
-                    "--assemble" #$target sources))))
-
-(define (close-raid-device sources target)
+  (match targets
+    ((target)
+     #~(let ((sources '#$sources)
+
+             ;; XXX: We're not at the top level here.  We could use a
+             ;; non-top-level 'use-modules' form but that doesn't work when the
+             ;; code is eval'd, like the Shepherd does.
+             (every   (@ (srfi srfi-1) every))
+             (format  (@ (ice-9 format) format)))
+         (let loop ((attempts 0))
+           (unless (every file-exists? sources)
+             (when (> attempts 20)
+               (error "RAID devices did not show up; bailing out"
+                      sources))
+
+             (format #t "waiting for RAID source devices~{ ~a~}...~%"
+                     sources)
+             (sleep 1)
+             (loop (+ 1 attempts))))
+
+         ;; Use 'mdadm-static' rather than 'mdadm' to avoid pulling its whole
+         ;; closure (80 MiB) in the initrd when a RAID device is needed for boot.
+         (zero? (apply system* #$(file-append mdadm-static "/sbin/mdadm")
+                       "--assemble" #$target sources))))))
+
+(define (close-raid-device sources targets)
   "Return a gexp that stops the RAID device TARGET."
-  #~(zero? (system* #$(file-append mdadm-static "/sbin/mdadm")
-                    "--stop" #$target)))
+  (match targets
+    ((target)
+     #~(zero? (system* #$(file-append mdadm-static "/sbin/mdadm")
+                       "--stop" #$target)))))
 
 (define raid-device-mapping
   ;; The type of RAID mapped devices.
@@ -272,4 +305,24 @@ TARGET (e.g., \"/dev/md0\"), using 'mdadm'."
    (open open-raid-device)
    (close close-raid-device)))
 
+(define (open-lvm-device source targets)
+  #~(and
+     (zero? (system* #$(file-append lvm2-static "/sbin/lvm")
+                     "vgchange" "--activate" "ay" #$source))
+     ; /dev/mapper nodes are usually created by udev, but udev may be unavailable at the time we run this. So we create them here.
+     (zero? (system* #$(file-append lvm2-static "/sbin/lvm")
+                     "vgscan" "--mknodes"))
+     (every file-exists? (map (lambda (file) (string-append "/dev/mapper/" file))
+                              '#$targets))))
+
+
+(define (close-lvm-device source targets)
+  #~(zero? (system* #$(file-append lvm2-static "/sbin/lvm")
+                    "vgchange" "--activate" "n" #$source)))
+
+(define lvm-device-mapping
+  (mapped-device-kind
+   (open open-lvm-device)
+   (close close-lvm-device)))
+
 ;;; mapped-devices.scm ends here
diff --git a/gnu/system/uuid.scm b/gnu/system/uuid.scm
index c8352f4933..f4c4be6e2b 100644
--- a/gnu/system/uuid.scm
+++ b/gnu/system/uuid.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Danny Milosavljevic <dannym@scratchpost.org>
-;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2019, 2020 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -42,6 +42,7 @@
             string->ext2-uuid
             string->ext3-uuid
             string->ext4-uuid
+            string->bcachefs-uuid
             string->btrfs-uuid
             string->fat-uuid
             string->jfs-uuid
@@ -236,6 +237,7 @@ ISO9660 UUID representation."
 (define string->ext2-uuid string->dce-uuid)
 (define string->ext3-uuid string->dce-uuid)
 (define string->ext4-uuid string->dce-uuid)
+(define string->bcachefs-uuid string->dce-uuid)
 (define string->btrfs-uuid string->dce-uuid)
 (define string->jfs-uuid string->dce-uuid)
 
@@ -251,14 +253,14 @@ ISO9660 UUID representation."
 
 (define %uuid-parsers
   (vhashq
-   ('dce 'ext2 'ext3 'ext4 'btrfs 'jfs 'luks => string->dce-uuid)
+   ('dce 'ext2 'ext3 'ext4 'bcachefs 'btrfs 'jfs 'luks => string->dce-uuid)
    ('fat32 'fat16 'fat => string->fat-uuid)
    ('ntfs => string->ntfs-uuid)
    ('iso9660 => string->iso9660-uuid)))
 
 (define %uuid-printers
   (vhashq
-   ('dce 'ext2 'ext3 'ext4 'btrfs 'jfs 'luks => dce-uuid->string)
+   ('dce 'ext2 'ext3 'ext4 'bcachefs 'btrfs 'jfs 'luks => dce-uuid->string)
    ('iso9660 => iso9660-uuid->string)
    ('fat32 'fat16 'fat => fat-uuid->string)
    ('ntfs => ntfs-uuid->string)))
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 3a5204e11b..93a79b12d6 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -77,7 +77,6 @@
 
             system-qemu-image/shared-store
             system-qemu-image/shared-store-script
-            system-disk-image-in-vm
             system-docker-image
 
             virtual-machine
@@ -224,6 +223,12 @@ substitutable."
               (use-modules (guix build utils)
                            (gnu build vm))
 
+              ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded
+              ;; by 'estimated-partition-size' below.
+              (setenv "GUIX_LOCPATH"
+                      #+(file-append glibc-utf8-locales "/lib/locale"))
+              (setlocale LC_ALL "en_US.utf8")
+
               (let* ((native-inputs
                       '#+(list qemu (canonical-package coreutils)))
                      (linux   (string-append
@@ -557,77 +562,6 @@ the operating system."
 ;;; VM and disk images.
 ;;;
 
-(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
-to USB sticks meant to be read-only.
-
-SUBSTITUTABLE? determines whether the returned derivation should be marked as
-substitutable."
-  (define root-label
-    "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 'dce))
-
-  (define file-systems-to-keep
-    (remove (lambda (fs)
-              (string=? (file-system-mount-point fs) "/"))
-            (operating-system-file-systems os)))
-
-  (let* ((os (operating-system (inherit os)
-               ;; Since this is meant to be used on real hardware, don't
-               ;; install QEMU networking or anything like that.  Assume USB
-               ;; mass storage devices (usb-storage.ko) are available.
-               (initrd (lambda (file-systems . rest)
-                         (apply (operating-system-initrd os)
-                                file-systems
-                                #:volatile-root? volatile?
-                                rest)))
-
-               (bootloader (operating-system-bootloader os))
-
-               ;; Force our own root file system.  (We need a "/" file system
-               ;; to call 'root-uuid'.)
-               (file-systems (cons (file-system
-                                     (mount-point "/")
-                                     (device "/dev/placeholder")
-                                     (type file-system-type))
-                                   file-systems-to-keep))))
-         (uuid (root-uuid os))
-         (os (operating-system
-               (inherit os)
-               (file-systems (cons (file-system
-                                     (mount-point "/")
-                                     (device uuid)
-                                     (type file-system-type))
-                                   file-systems-to-keep))))
-        (bootcfg (operating-system-bootcfg os)))
-    (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
                             (file-system-type "ext4")
@@ -641,7 +575,10 @@ of the GNU system as described by OS."
               (let ((target (file-system-mount-point fs))
                     (source (file-system-device fs)))
                 (or (string=? target "/")
-                    (string-prefix? "/dev/" source))))
+                    (and (string? source)
+                         (string-prefix? "/dev/" source))
+                    (uuid? source)
+                    (file-system-label? source))))
             (operating-system-file-systems os)))
 
   (define root-uuid
@@ -652,7 +589,14 @@ of the GNU system as described by OS."
                                'dce)))
 
 
-  (let* ((os (operating-system (inherit os)
+  (let* ((os (operating-system
+               (inherit os)
+
+               ;; As in 'virtualized-operating-system', use BIOS-style GRUB.
+               (bootloader (bootloader-configuration
+                            (bootloader grub-bootloader)
+                            (target "/dev/vda")))
+
                ;; Assume we have an initrd with the whole QEMU shebang.
 
                ;; Force our own root file system.  Refer to it by UUID so that