gnu/build/vm.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
   4 ;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name>
   5 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
   6 ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
   7 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
   8 ;;;
   9 ;;; This file is part of GNU Guix.
  10 ;;;
  11 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  12 ;;; under the terms of the GNU General Public License as published by
  13 ;;; the Free Software Foundation; either version 3 of the License, or (at
  14 ;;; your option) any later version.
  15 ;;;
  16 ;;; GNU Guix is distributed in the hope that it will be useful, but
  17 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;;; GNU General Public License for more details.
  20 ;;;
  21 ;;; You should have received a copy of the GNU General Public License
  22 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 (define-module (gnu build vm)
  25   #:use-module (guix build utils)
  26   #:use-module (guix build store-copy)
  27   #:use-module (guix build syscalls)
  28   #:use-module (guix store database)
  29   #:use-module (gnu build linux-boot)
  30   #:use-module (gnu build install)
  31   #:use-module (gnu system uuid)
  32   #:use-module (guix records)
  33   #:use-module ((guix combinators) #:select (fold2))
  34   #:use-module (ice-9 format)
  35   #:use-module (ice-9 match)
  36   #:use-module (ice-9 regex)
  37   #:use-module (ice-9 popen)
  38   #:use-module (srfi srfi-1)
  39   #:use-module (srfi srfi-9)
  40   #:use-module (srfi srfi-19)
  41   #:use-module (srfi srfi-26)
  42   #:export (qemu-command
  43             load-in-linux-vm
  44             format-partition
  45
  46             partition
  47             partition?
  48             partition-device
  49             partition-size
  50             partition-file-system
  51             partition-label
  52             partition-flags
  53             partition-initializer
  54
  55             estimated-partition-size
  56             root-partition-initializer
  57             initialize-partition-table
  58             initialize-hard-disk
  59             make-iso9660-image))
  60
  61 ;;; Commentary:
  62 ;;;
  63 ;;; This module provides supporting code to run virtual machines and build
  64 ;;; virtual machine images using QEMU.
  65 ;;;
  66 ;;; Code:
  67
  68 (define* (qemu-command #:optional (system %host-type))
  69   "Return the default name of the QEMU command for SYSTEM."
  70   (let ((cpu (substring system 0
  71                         (string-index system #\-))))
  72     (string-append "qemu-system-"
  73                    (cond
  74                     ((string-match "^i[3456]86$" cpu) "i386")
  75                     ((string-match "armhf" cpu) "arm")
  76                     (else cpu)))))
  77
  78 (define* (load-in-linux-vm builder
  79                            #:key
  80                            output
  81                            (qemu (qemu-command)) (memory-size 512)
  82                            linux initrd
  83                            make-disk-image?
  84                            single-file-output?
  85                            target-arm32?
  86                            target-aarch64?
  87                            (disk-image-size (* 100 (expt 2 20)))
  88                            (disk-image-format "qcow2")
  89                            (references-graphs '()))
  90   "Run BUILDER, a Scheme file, into a VM running LINUX with INITRD, and copy
  91 the result to OUTPUT.  If SINGLE-FILE-OUTPUT? is true, copy a single file from
  92 /xchg to OUTPUT.  Otherwise, copy the contents of /xchg to a new directory
  93 OUTPUT.
  94
  95 When MAKE-DISK-IMAGE? is true, OUTPUT will contain a VM image of
  96 DISK-IMAGE-SIZE bytes resulting from the execution of BUILDER, which may
  97 access it via /dev/hda.
  98
  99 REFERENCES-GRAPHS can specify a list of reference-graph files as produced by
 100 the #:references-graphs parameter of 'derivation'."
 101
 102   (define target-arm? (or target-arm32? target-aarch64?))
 103
 104   (define arch-specific-flags
 105     `(;; On ARM, a machine has to be specified. Use "virt" machine to avoid
 106       ;; hardware limits imposed by other machines.
 107       ,@(if target-arm?
 108             '("-M" "virt")
 109             '())
 110
 111       ;; On ARM32, if the kernel is built without LPAE support, ECAM conflicts
 112       ;; with VIRT_PCIE_MMIO causing PCI devices not to show up.  Disable
 113       ;; explicitely highmem to fix it.
 114       ;; See: https://bugs.launchpad.net/qemu/+bug/1790975.
 115       ,@(if target-arm32?
 116             '("-machine" "highmem=off")
 117             '())
 118
 119       ;; Only enable kvm if we see /dev/kvm exists.  This allows users without
 120       ;; hardware virtualization to still use these commands.  KVM support is
 121       ;; still buggy on some ARM boards. Do not use it even if available.
 122       ,@(if (and (file-exists? "/dev/kvm")
 123                  (not target-arm?))
 124             '("-enable-kvm")
 125             '())
 126
 127       ;; Pass "panic=1" so that the guest dies upon error.
 128       "-append"
 129       ,(string-append "panic=1 --load=" builder
 130
 131                       ;; The serial port name differs between emulated
 132                       ;; architectures/machines.
 133                       " console="
 134                       (if target-arm? "ttyAMA0" "ttyS0"))
 135
 136       ;; NIC is not supported on ARM "virt" machine, so use a user mode
 137       ;; network stack instead.
 138       ,@(if target-arm?
 139             '("-device" "virtio-net-pci,netdev=mynet"
 140               "-netdev" "user,id=mynet")
 141             '("-net" "nic,model=virtio"))))
 142
 143   (when make-disk-image?
 144     (format #t "creating ~a image of ~,2f MiB...~%"
 145             disk-image-format (/ disk-image-size (expt 2 20)))
 146     (force-output)
 147     (invoke "qemu-img" "create" "-f" disk-image-format output
 148              (number->string disk-image-size)))
 149
 150   (mkdir "xchg")
 151   (mkdir "tmp")
 152
 153   (match references-graphs
 154     ((graph-files ...)
 155      ;; Copy the reference-graph files under xchg/ so EXP can access it.
 156      (map (lambda (file)
 157             (copy-file file (string-append "xchg/" file)))
 158           graph-files))
 159     (_ #f))
 160
 161   (apply invoke qemu "-nographic" "-no-reboot"
 162          ;; CPU "max" behaves as "host" when KVM is enabled, and like a system
 163          ;; CPU with the maximum possible feature set otherwise.
 164          "-cpu" "max"
 165          "-m" (number->string memory-size)
 166          "-object" "rng-random,filename=/dev/urandom,id=guixsd-vm-rng"
 167          "-device" "virtio-rng-pci,rng=guixsd-vm-rng"
 168          "-virtfs"
 169          (string-append "local,id=store_dev,path="
 170                         (%store-directory)
 171                         ",security_model=none,mount_tag=store")
 172          "-virtfs"
 173          (string-append "local,id=xchg_dev,path=xchg"
 174                         ",security_model=none,mount_tag=xchg")
 175          "-virtfs"
 176          ;; Some programs require more space in /tmp than is normally
 177          ;; available in the guest.  Accommodate such programs by sharing a
 178          ;; temporary directory.
 179          (string-append "local,id=tmp_dev,path=tmp"
 180                         ",security_model=none,mount_tag=tmp")
 181          "-kernel" linux
 182          "-initrd" initrd
 183          (append
 184           (if make-disk-image?
 185               `("-device" "virtio-blk,drive=myhd"
 186                 "-drive" ,(string-append "if=none,file=" output
 187                                          ",format=" disk-image-format
 188                                          ",id=myhd"))
 189               '())
 190           arch-specific-flags))
 191
 192   ;; When MAKE-DISK-IMAGE? is true, the image is in OUTPUT already.
 193   (unless make-disk-image?
 194     (if single-file-output?
 195         (let ((graph? (lambda (name stat)
 196                         (member (basename name) references-graphs))))
 197           (match (find-files "xchg" (negate graph?))
 198             ((result)
 199              (copy-file result output))
 200             (x
 201              (error "did not find a single result file" x))))
 202         (begin
 203           (mkdir output)
 204           (copy-recursively "xchg" output)))))
 205
 206 (define* (register-closure prefix closure
 207                            #:key
 208                            (deduplicate? #t) (reset-timestamps? #t)
 209                            (schema (sql-schema)))
 210   "Register CLOSURE in PREFIX, where PREFIX is the directory name of the
 211 target store and CLOSURE is the name of a file containing a reference graph as
 212 produced by #:references-graphs..  As a side effect, if RESET-TIMESTAMPS? is
 213 true, reset timestamps on store files and, if DEDUPLICATE? is true,
 214 deduplicates files common to CLOSURE and the rest of PREFIX."
 215   (let ((items (call-with-input-file closure read-reference-graph)))
 216     (register-items items
 217                     #:prefix prefix
 218                     #:deduplicate? deduplicate?
 219                     #:reset-timestamps? reset-timestamps?
 220                     #:registration-time %epoch
 221                     #:schema schema)))
 222
 223 \f
 224 ;;;
 225 ;;; Partitions.
 226 ;;;
 227
 228 (define-record-type* <partition> partition make-partition
 229   partition?
 230   (device      partition-device (default #f))
 231   (size        partition-size)
 232   (file-system partition-file-system (default "ext4"))
 233   (label       partition-label (default #f))
 234   (uuid        partition-uuid (default #f))
 235   (flags       partition-flags (default '()))
 236   (initializer partition-initializer (default (const #t))))
 237
 238 (define (estimated-partition-size graphs)
 239   "Return the estimated size of a partition that can store the store items
 240 given by GRAPHS, a list of file names produced by #:references-graphs."
 241   ;; Simply add a 25% overhead.
 242   (round (* 1.25 (closure-size graphs))))
 243
 244 (define* (initialize-partition-table device partitions
 245                                      #:key
 246                                      (label-type "msdos")
 247                                      (offset (expt 2 20)))
 248   "Create on DEVICE a partition table of type LABEL-TYPE, containing the given
 249 PARTITIONS (a list of <partition> objects), starting at OFFSET bytes.  On
 250 success, return PARTITIONS with their 'device' field changed to reflect their
 251 actual /dev name based on DEVICE."
 252   (define (partition-options part offset index)
 253     (cons* "mkpart" "primary" "ext2"
 254            (format #f "~aB" offset)
 255            (format #f "~aB" (+ offset (partition-size part)))
 256            (append-map (lambda (flag)
 257                          (list "set" (number->string index)
 258                                (symbol->string flag) "on"))
 259                        (partition-flags part))))
 260
 261   (define (options partitions offset)
 262     (let loop ((partitions partitions)
 263                (offset     offset)
 264                (index      1)
 265                (result     '()))
 266       (match partitions
 267         (()
 268          (concatenate (reverse result)))
 269         ((head tail ...)
 270          (loop tail
 271                ;; Leave one sector (512B) between partitions to placate
 272                ;; Parted.
 273                (+ offset 512 (partition-size head))
 274                (+ 1 index)
 275                (cons (partition-options head offset index)
 276                      result))))))
 277
 278   (format #t "creating partition table with ~a partitions (~a)...\n"
 279           (length partitions)
 280           (string-join (map (compose (cut string-append <> " MiB")
 281                                      number->string
 282                                      (lambda (size)
 283                                        (round (/ size (expt 2. 20))))
 284                                      partition-size)
 285                             partitions)
 286                        ", "))
 287   (apply invoke "parted" "--script"
 288          device "mklabel" label-type
 289          (options partitions offset))
 290
 291   ;; Set the 'device' field of each partition.
 292   (reverse
 293    (fold2 (lambda (part result index)
 294             (values (cons  (partition
 295                             (inherit part)
 296                             (device (string-append device
 297                                                    (number->string index))))
 298                            result)
 299                     (+ 1 index)))
 300           '()
 301           1
 302           partitions)))
 303
 304 (define MS_BIND 4096)                             ; <sys/mounts.h> again!
 305
 306 (define* (create-ext-file-system partition type
 307                                  #:key label uuid)
 308   "Create an ext-family file system of TYPE on PARTITION.  If LABEL is true,
 309 use that as the volume name.  If UUID is true, use it as the partition UUID."
 310   (format #t "creating ~a partition... ~@[label: ~s~] ~@[uuid: ~s~]\n"
 311           type label (and uuid (uuid->string uuid)))
 312   (apply invoke (string-append "mkfs." type)
 313          "-F" partition
 314          `(,@(if label
 315                  `("-L" ,label)
 316                  '())
 317            ,@(if uuid
 318                  `("-U" ,(uuid->string uuid))
 319                  '()))))
 320
 321 (define* (create-fat-file-system partition
 322                                  #:key label uuid)
 323   "Create a FAT file system on PARTITION.  The number of File Allocation Tables
 324 will be determined based on file system size.  If LABEL is true, use that as the
 325 volume name."
 326   ;; FIXME: UUID is ignored!
 327   (format #t "creating FAT partition...\n")
 328   (apply invoke "mkfs.fat" partition
 329          (if label `("-n" ,label) '())))
 330
 331 (define* (format-partition partition type
 332                            #:key label uuid)
 333   "Create a file system TYPE on PARTITION.  If LABEL is true, use that as the
 334 volume name."
 335   (cond ((string-prefix? "ext" type)
 336          (create-ext-file-system partition type #:label label #:uuid uuid))
 337         ((or (string-prefix? "fat" type) (string= "vfat" type))
 338          (create-fat-file-system partition #:label label #:uuid uuid))
 339         (else (error "Unsupported file system."))))
 340
 341 (define (initialize-partition partition)
 342   "Format PARTITION, a <partition> object with a non-#f 'device' field, mount
 343 it, run its initializer, and unmount it."
 344   (let ((target "/fs"))
 345    (format-partition (partition-device partition)
 346                      (partition-file-system partition)
 347                      #:label (partition-label partition)
 348                      #:uuid (partition-uuid partition))
 349    (mkdir-p target)
 350    (mount (partition-device partition) target
 351           (partition-file-system partition))
 352
 353    ((partition-initializer partition) target)
 354
 355    (umount target)
 356    partition))
 357
 358 (define* (root-partition-initializer #:key (closures '())
 359                                      copy-closures?
 360                                      (register-closures? #t)
 361                                      system-directory
 362                                      (deduplicate? #t))
 363   "Return a procedure to initialize a root partition.
 364
 365 If REGISTER-CLOSURES? is true, register all of CLOSURES in the partition's
 366 store.  If DEDUPLICATE? is true, then also deduplicate files common to
 367 CLOSURES and the rest of the store when registering the closures.  If
 368 COPY-CLOSURES? is true, copy all of CLOSURES to the partition.
 369 SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation."
 370   (lambda (target)
 371     (define target-store
 372       (string-append target (%store-directory)))
 373
 374     (when copy-closures?
 375       ;; Populate the store.
 376       (populate-store (map (cut string-append "/xchg/" <>) closures)
 377                       target))
 378
 379     ;; Populate /dev.
 380     (make-essential-device-nodes #:root target)
 381
 382     ;; Optionally, register the inputs in the image's store.
 383     (when register-closures?
 384       (unless copy-closures?
 385         ;; XXX: 'register-closure' wants to palpate the things it registers, so
 386         ;; bind-mount the store on the target.
 387         (mkdir-p target-store)
 388         (mount (%store-directory) target-store "" MS_BIND))
 389
 390       (display "registering closures...\n")
 391       (for-each (lambda (closure)
 392                   (register-closure target
 393                                     (string-append "/xchg/" closure)
 394                                     #:reset-timestamps? copy-closures?
 395                                     #:deduplicate? deduplicate?))
 396                 closures)
 397       (unless copy-closures?
 398         (umount target-store)))
 399
 400     ;; Add the non-store directories and files.
 401     (display "populating...\n")
 402     (populate-root-file-system system-directory target)
 403
 404     ;; 'register-closure' resets timestamps and everything, so no need to do it
 405     ;; once more in that case.
 406     (unless register-closures?
 407       (reset-timestamps target))))
 408
 409 (define (register-bootcfg-root target bootcfg)
 410   "On file system TARGET, register BOOTCFG as a GC root."
 411   (let ((directory (string-append target "/var/guix/gcroots")))
 412     (mkdir-p directory)
 413     (symlink bootcfg (string-append directory "/bootcfg"))))
 414
 415 (define (install-efi grub esp config-file)
 416   "Write a self-contained GRUB EFI loader to the mounted ESP using CONFIG-FILE."
 417   (let* ((system %host-type)
 418          ;; Hard code the output location to a well-known path recognized by
 419          ;; compliant firmware. See "3.5.1.1 Removable Media Boot Behaviour":
 420          ;; http://www.uefi.org/sites/default/files/resources/UEFI%20Spec%202_6.pdf
 421          (grub-mkstandalone (string-append grub "/bin/grub-mkstandalone"))
 422          (efi-directory (string-append esp "/EFI/BOOT"))
 423          ;; Map grub target names to boot file names.
 424          (efi-targets (cond ((string-prefix? "x86_64" system)
 425                              '("x86_64-efi" . "BOOTX64.EFI"))
 426                             ((string-prefix? "i686" system)
 427                              '("i386-efi" . "BOOTIA32.EFI"))
 428                             ((string-prefix? "armhf" system)
 429                              '("arm-efi" . "BOOTARM.EFI"))
 430                             ((string-prefix? "aarch64" system)
 431                              '("arm64-efi" . "BOOTAA64.EFI")))))
 432     ;; grub-mkstandalone requires a TMPDIR to prepare the firmware image.
 433     (setenv "TMPDIR" esp)
 434
 435     (mkdir-p efi-directory)
 436     (invoke grub-mkstandalone "-O" (car efi-targets)
 437             "-o" (string-append efi-directory "/"
 438                                 (cdr efi-targets))
 439             ;; Graft the configuration file onto the image.
 440             (string-append "boot/grub/grub.cfg=" config-file))))
 441
 442 (define* (make-iso9660-image xorriso grub-mkrescue-environment
 443                              grub config-file os-drv target
 444                              #:key (volume-id "Guix_image") (volume-uuid #f)
 445                              register-closures? (closures '()))
 446   "Given a GRUB package, creates an iso image as TARGET, using CONFIG-FILE as
 447 GRUB configuration and OS-DRV as the stuff in it."
 448   (define grub-mkrescue
 449     (string-append grub "/bin/grub-mkrescue"))
 450
 451   (define grub-mkrescue-sed.sh
 452     (string-append xorriso "/bin/grub-mkrescue-sed.sh"))
 453
 454   (define target-store
 455     (string-append "/tmp/root" (%store-directory)))
 456
 457   (define items
 458     ;; The store items to add to the image.
 459     (delete-duplicates
 460      (append-map (lambda (closure)
 461                    (map store-info-item
 462                         (call-with-input-file (string-append "/xchg/" closure)
 463                           read-reference-graph)))
 464                  closures)))
 465
 466   (populate-root-file-system os-drv "/tmp/root")
 467   (mount (%store-directory) target-store "" MS_BIND)
 468
 469   (when register-closures?
 470     (display "registering closures...\n")
 471     (for-each (lambda (closure)
 472                 (register-closure
 473                  "/tmp/root"
 474                  (string-append "/xchg/" closure)
 475
 476                  ;; TARGET-STORE is a read-only bind-mount so we shouldn't try
 477                  ;; to modify it.
 478                  #:deduplicate? #f
 479                  #:reset-timestamps? #f))
 480               closures)
 481     (register-bootcfg-root "/tmp/root" config-file))
 482
 483   ;; 'grub-mkrescue' calls out to mtools programs to create 'efi.img', a FAT
 484   ;; file system image, and mtools honors SOURCE_DATE_EPOCH for the mtime of
 485   ;; those files.  The epoch for FAT is Jan. 1st 1980, not 1970, so choose
 486   ;; that.
 487   (setenv "SOURCE_DATE_EPOCH"
 488           (number->string
 489            (time-second
 490             (date->time-utc (make-date 0 0 0 0 1 1 1980 0)))))
 491
 492   ;; Our patched 'grub-mkrescue' honors this environment variable and passes
 493   ;; it to 'mformat', which makes it the serial number of 'efi.img'.  This
 494   ;; allows for deterministic builds.
 495   (setenv "GRUB_FAT_SERIAL_NUMBER"
 496           (number->string (if volume-uuid
 497
 498                               ;; On 32-bit systems the 2nd argument must be
 499                               ;; lower than 2^32.
 500                               (string-hash (iso9660-uuid->string volume-uuid)
 501                                            (- (expt 2 32) 1))
 502
 503                               #x77777777)
 504                           16))
 505
 506   (setenv "MKRESCUE_SED_MODE" "original")
 507   (setenv "MKRESCUE_SED_XORRISO" (string-append xorriso
 508                                                 "/bin/xorriso"))
 509   (setenv "MKRESCUE_SED_IN_EFI_NO_PT" "yes")
 510   (for-each (match-lambda
 511              ((name . value) (setenv name value)))
 512             grub-mkrescue-environment)
 513
 514   (let ((pipe
 515          (apply open-pipe* OPEN_WRITE
 516                 grub-mkrescue
 517                 (string-append "--xorriso=" grub-mkrescue-sed.sh)
 518                 "-o" target
 519                 (string-append "boot/grub/grub.cfg=" config-file)
 520                 "etc=/tmp/root/etc"
 521                 "var=/tmp/root/var"
 522                 "run=/tmp/root/run"
 523                 ;; /mnt is used as part of the installation
 524                 ;; process, as the mount point for the target
 525                 ;; file system, so create it.
 526                 "mnt=/tmp/root/mnt"
 527                 "-path-list" "-"
 528                 "--"
 529
 530                 ;; Set all timestamps to 1.
 531                 "-volume_date" "all_file_dates" "=1"
 532
 533                 "-volid" (string-upcase volume-id)
 534                 (if volume-uuid
 535                     `("-volume_date" "uuid"
 536                       ,(string-filter (lambda (value)
 537                                         (not (char=? #\- value)))
 538                                       (iso9660-uuid->string
 539                                        volume-uuid)))
 540                     `()))))
 541     ;; Pass lines like 'gnu/store/…-x=/gnu/store/…-x' corresponding to the
 542     ;; '-path-list -' option.
 543     (for-each (lambda (item)
 544                 (format pipe "~a=~a~%"
 545                         (string-drop item 1) item))
 546               items)
 547     (unless (zero? (close-pipe pipe))
 548       (error "oh, my! grub-mkrescue failed" grub-mkrescue))))
 549
 550 (define* (initialize-hard-disk device
 551                                #:key
 552                                bootloader-package
 553                                bootcfg
 554                                bootcfg-location
 555                                bootloader-installer
 556                                (grub-efi #f)
 557                                (partitions '()))
 558   "Initialize DEVICE as a disk containing all the <partition> objects listed
 559 in PARTITIONS, and using BOOTCFG as its bootloader configuration file.
 560
 561 Each partition is initialized by calling its 'initializer' procedure,
 562 passing it a directory name where it is mounted."
 563
 564   (define (partition-bootable? partition)
 565     "Return the first partition found with the boot flag set."
 566     (member 'boot (partition-flags partition)))
 567
 568   (define (partition-esp? partition)
 569     "Return the first EFI System Partition."
 570     (member 'esp (partition-flags partition)))
 571
 572   (let* ((partitions (initialize-partition-table device partitions))
 573          (root       (find partition-bootable? partitions))
 574          (esp        (find partition-esp? partitions))
 575          (target     "/fs"))
 576     (unless root
 577       (error "no bootable partition specified" partitions))
 578
 579     (for-each initialize-partition partitions)
 580
 581     (display "mounting root partition...\n")
 582     (mkdir-p target)
 583     (mount (partition-device root) target (partition-file-system root))
 584     (install-boot-config bootcfg bootcfg-location target)
 585     (when bootloader-installer
 586       (display "installing bootloader...\n")
 587       (bootloader-installer bootloader-package device target))
 588
 589     (when esp
 590       ;; Mount the ESP somewhere and install GRUB UEFI image.
 591       (let ((mount-point (string-append target "/boot/efi"))
 592             (grub-config (string-append target "/tmp/grub-standalone.cfg")))
 593         (display "mounting EFI system partition...\n")
 594         (mkdir-p mount-point)
 595         (mount (partition-device esp) mount-point
 596                (partition-file-system esp))
 597
 598         ;; Create a tiny configuration file telling the embedded grub
 599         ;; where to load the real thing.
 600         ;; XXX This is quite fragile, and can prevent the image from booting
 601         ;; when there's more than one volume with this label present.
 602         ;; Reproducible almost-UUIDs could reduce the risk (not eliminate it).
 603         (call-with-output-file grub-config
 604           (lambda (port)
 605             (format port
 606                     "insmod part_msdos~@
 607                     search --set=root --label Guix_image~@
 608                     configfile /boot/grub/grub.cfg~%")))
 609
 610         (display "creating EFI firmware image...")
 611         (install-efi grub-efi mount-point grub-config)
 612         (display "done.\n")
 613
 614         (delete-file grub-config)
 615         (umount mount-point)))
 616
 617     ;; Register BOOTCFG as a GC root.
 618     (register-bootcfg-root target bootcfg)
 619
 620     (umount target)))
 621
 622 ;;; vm.scm ends here