gnu/build/vm.scm

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