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