Commit | Line | Data |
---|---|---|
e1a87b90 | 1 | ;;; GNU Guix --- Functional package management for GNU |
be6520e6 | 2 | ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> |
944d2b17 | 3 | ;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org> |
2ca712bd | 4 | ;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name> |
07f812c4 | 5 | ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> |
01cc84da | 6 | ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com> |
af81311b | 7 | ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> |
26c1bd9d | 8 | ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> |
e1a87b90 LC |
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 | ||
548f7a8f | 25 | (define-module (gnu build vm) |
e1a87b90 | 26 | #:use-module (guix build utils) |
6fd1a796 | 27 | #:use-module (guix build store-copy) |
abf0880a | 28 | #:use-module (guix build syscalls) |
b27ef1d4 | 29 | #:use-module (guix store database) |
f8fd1157 | 30 | #:use-module (gnu build bootloader) |
8a9e21d1 | 31 | #:use-module (gnu build linux-boot) |
548f7a8f | 32 | #:use-module (gnu build install) |
47cef4ec | 33 | #:use-module (gnu system uuid) |
72b891e5 | 34 | #:use-module (guix records) |
a2278922 | 35 | #:use-module ((guix combinators) #:select (fold2)) |
ecf5d537 | 36 | #:use-module (ice-9 format) |
6a488a35 | 37 | #:use-module (ice-9 ftw) |
55651ff2 | 38 | #:use-module (ice-9 match) |
66670cf3 | 39 | #:use-module (ice-9 regex) |
718d44cc | 40 | #:use-module (ice-9 popen) |
72b891e5 LC |
41 | #:use-module (srfi srfi-1) |
42 | #:use-module (srfi srfi-9) | |
6901b924 | 43 | #:use-module (srfi srfi-19) |
55651ff2 | 44 | #:use-module (srfi srfi-26) |
66670cf3 LC |
45 | #:export (qemu-command |
46 | load-in-linux-vm | |
641f9a2a | 47 | format-partition |
72b891e5 LC |
48 | |
49 | partition | |
50 | partition? | |
51 | partition-device | |
52 | partition-size | |
53 | partition-file-system | |
54 | partition-label | |
01cc84da | 55 | partition-flags |
72b891e5 LC |
56 | partition-initializer |
57 | ||
a8ac4f08 | 58 | estimated-partition-size |
72b891e5 | 59 | root-partition-initializer |
641f9a2a | 60 | initialize-partition-table |
77f52962 | 61 | initialize-hard-disk)) |
e1a87b90 LC |
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 | ||
66670cf3 LC |
70 | (define* (qemu-command #:optional (system %host-type)) |
71 | "Return the default name of the QEMU command for SYSTEM." | |
b1dd6ac5 LC |
72 | (let ((cpu (substring system 0 |
73 | (string-index system #\-)))) | |
66670cf3 | 74 | (string-append "qemu-system-" |
c6d13063 MO |
75 | (cond |
76 | ((string-match "^i[3456]86$" cpu) "i386") | |
77 | ((string-match "armhf" cpu) "arm") | |
78 | (else cpu))))) | |
e1a87b90 LC |
79 | |
80 | (define* (load-in-linux-vm builder | |
81 | #:key | |
82 | output | |
83 | (qemu (qemu-command)) (memory-size 512) | |
84 | linux initrd | |
6efb98ed | 85 | make-disk-image? |
8d033e3e | 86 | single-file-output? |
acf54bca | 87 | target-arm32? |
1ee72bb5 | 88 | target-aarch64? |
6efb98ed | 89 | (disk-image-size (* 100 (expt 2 20))) |
c4a74364 | 90 | (disk-image-format "qcow2") |
e1a87b90 LC |
91 | (references-graphs '())) |
92 | "Run BUILDER, a Scheme file, into a VM running LINUX with INITRD, and copy | |
8d033e3e LC |
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. | |
e1a87b90 LC |
96 | |
97 | When MAKE-DISK-IMAGE? is true, OUTPUT will contain a VM image of | |
6efb98ed LC |
98 | DISK-IMAGE-SIZE bytes resulting from the execution of BUILDER, which may |
99 | access it via /dev/hda. | |
e1a87b90 LC |
100 | |
101 | REFERENCES-GRAPHS can specify a list of reference-graph files as produced by | |
102 | the #:references-graphs parameter of 'derivation'." | |
acf54bca | 103 | |
1ee72bb5 MO |
104 | (define target-arm? (or target-arm32? target-aarch64?)) |
105 | ||
acf54bca MO |
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. | |
1ee72bb5 MO |
109 | ,@(if target-arm? |
110 | '("-M" "virt") | |
111 | '()) | |
acf54bca | 112 | |
2608417a MO |
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 | ||
acf54bca MO |
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 | |
1ee72bb5 | 123 | ;; still buggy on some ARM boards. Do not use it even if available. |
acf54bca | 124 | ,@(if (and (file-exists? "/dev/kvm") |
1ee72bb5 | 125 | (not target-arm?)) |
acf54bca MO |
126 | '("-enable-kvm") |
127 | '()) | |
98e0b128 LC |
128 | |
129 | ;; Pass "panic=1" so that the guest dies upon error. | |
acf54bca | 130 | "-append" |
98e0b128 LC |
131 | ,(string-append "panic=1 --load=" builder |
132 | ||
133 | ;; The serial port name differs between emulated | |
134 | ;; architectures/machines. | |
135 | " console=" | |
8e53fe2b | 136 | (if target-arm? "ttyAMA0" "ttyS0")))) |
acf54bca | 137 | |
e1a87b90 | 138 | (when make-disk-image? |
a2cf57e7 LC |
139 | (format #t "creating ~a image of ~,2f MiB...~%" |
140 | disk-image-format (/ disk-image-size (expt 2 20))) | |
141 | (force-output) | |
e1d0f2aa LC |
142 | (invoke "qemu-img" "create" "-f" disk-image-format output |
143 | (number->string disk-image-size))) | |
e1a87b90 LC |
144 | |
145 | (mkdir "xchg") | |
8c9bf294 | 146 | (mkdir "tmp") |
e1a87b90 LC |
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 | ||
e1d0f2aa | 156 | (apply invoke qemu "-nographic" "-no-reboot" |
1ee72bb5 MO |
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" | |
e1d0f2aa | 160 | "-m" (number->string memory-size) |
8e53fe2b | 161 | "-nic" "user,model=virtio-net-pci" |
e1d0f2aa LC |
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") | |
8c9bf294 CM |
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") | |
e1d0f2aa LC |
177 | "-kernel" linux |
178 | "-initrd" initrd | |
e1d0f2aa LC |
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)) | |
e1a87b90 | 187 | |
be6520e6 LC |
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 | ||
d2bcf35e LC |
197 | ;; When MAKE-DISK-IMAGE? is true, the image is in OUTPUT already. |
198 | (unless make-disk-image? | |
8d033e3e LC |
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))))) | |
e1a87b90 | 210 | |
b27ef1d4 LC |
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 | ||
72b891e5 LC |
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")) | |
4d1ff68d LC |
238 | (file-system-options partition-file-system-options ;passed to 'mkfs.FS' |
239 | (default '())) | |
72b891e5 | 240 | (label partition-label (default #f)) |
bae28ccb | 241 | (uuid partition-uuid (default #f)) |
01cc84da | 242 | (flags partition-flags (default '())) |
72b891e5 LC |
243 | (initializer partition-initializer (default (const #t)))) |
244 | ||
a8ac4f08 LC |
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." | |
21ffcd65 TGR |
248 | ;; Simply add a 25% overhead. |
249 | (round (* 1.25 (closure-size graphs)))) | |
a8ac4f08 | 250 | |
72b891e5 | 251 | (define* (initialize-partition-table device partitions |
55651ff2 LC |
252 | #:key |
253 | (label-type "msdos") | |
641f9a2a | 254 | (offset (expt 2 20))) |
72b891e5 LC |
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))) | |
01cc84da MB |
263 | (append-map (lambda (flag) |
264 | (list "set" (number->string index) | |
265 | (symbol->string flag) "on")) | |
266 | (partition-flags part)))) | |
72b891e5 LC |
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 | ||
a2cf57e7 LC |
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 | ", ")) | |
e1d0f2aa LC |
294 | (apply invoke "parted" "--script" |
295 | device "mklabel" label-type | |
296 | (options partitions offset)) | |
72b891e5 LC |
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))) | |
55651ff2 | 310 | |
150e20dd LC |
311 | (define MS_BIND 4096) ; <sys/mounts.h> again! |
312 | ||
4d415f0c | 313 | (define* (create-ext-file-system partition type |
4d1ff68d | 314 | #:key label uuid (options '())) |
162a1374 | 315 | "Create an ext-family file system of TYPE on PARTITION. If LABEL is true, |
bae28ccb | 316 | use that as the volume name. If UUID is true, use it as the partition UUID." |
353df401 LC |
317 | (format #t "creating ~a partition... ~@[label: ~s~] ~@[uuid: ~s~]\n" |
318 | type label (and uuid (uuid->string uuid))) | |
e1d0f2aa LC |
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)) | |
4d1ff68d LC |
326 | '()) |
327 | ,@options))) | |
150e20dd | 328 | |
4d415f0c | 329 | (define* (create-fat-file-system partition |
4d1ff68d | 330 | #:key label uuid (options '())) |
162a1374 TGR |
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 | |
4d415f0c | 333 | volume name." |
bae28ccb | 334 | ;; FIXME: UUID is ignored! |
4d415f0c | 335 | (format #t "creating FAT partition...\n") |
e1d0f2aa | 336 | (apply invoke "mkfs.fat" partition |
4d1ff68d | 337 | (append (if label `("-n" ,label) '()) options))) |
4d415f0c MB |
338 | |
339 | (define* (format-partition partition type | |
4d1ff68d | 340 | #:key label uuid (options '())) |
4d415f0c | 341 | "Create a file system TYPE on PARTITION. If LABEL is true, use that as the |
4d1ff68d | 342 | volume name. Options is a list of command-line options passed to 'mkfs.FS'." |
4d415f0c | 343 | (cond ((string-prefix? "ext" type) |
4d1ff68d LC |
344 | (create-ext-file-system partition type #:label label #:uuid uuid |
345 | #:options options)) | |
4d415f0c | 346 | ((or (string-prefix? "fat" type) (string= "vfat" type)) |
4d1ff68d LC |
347 | (create-fat-file-system partition #:label label #:uuid uuid |
348 | #:options options)) | |
4d415f0c MB |
349 | (else (error "Unsupported file system.")))) |
350 | ||
72b891e5 LC |
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) | |
bae28ccb | 357 | #:label (partition-label partition) |
4d1ff68d LC |
358 | #:uuid (partition-uuid partition) |
359 | #:options (partition-file-system-options partition)) | |
72b891e5 LC |
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) | |
af81311b | 372 | system-directory |
82782d8c | 373 | (deduplicate? #t) |
cd45d656 LC |
374 | (make-device-nodes |
375 | make-essential-device-nodes) | |
82782d8c | 376 | (extra-directives '())) |
72b891e5 LC |
377 | "Return a procedure to initialize a root partition. |
378 | ||
af81311b CM |
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. | |
82782d8c LC |
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'." | |
72b891e5 LC |
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. | |
cd45d656 | 397 | (make-device-nodes target) |
72b891e5 LC |
398 | |
399 | ;; Optionally, register the inputs in the image's store. | |
400 | (when register-closures? | |
401 | (unless copy-closures? | |
ea0a06ce | 402 | ;; XXX: 'register-closure' wants to palpate the things it registers, so |
72b891e5 LC |
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 | |
af81311b | 410 | (string-append "/xchg/" closure) |
c45477d2 | 411 | #:reset-timestamps? copy-closures? |
af81311b | 412 | #:deduplicate? deduplicate?)) |
72b891e5 LC |
413 | closures) |
414 | (unless copy-closures? | |
415 | (umount target-store))) | |
416 | ||
417 | ;; Add the non-store directories and files. | |
418 | (display "populating...\n") | |
82782d8c LC |
419 | (populate-root-file-system system-directory target |
420 | #:extras extra-directives) | |
72b891e5 | 421 | |
ea0a06ce | 422 | ;; 'register-closure' resets timestamps and everything, so no need to do it |
72b891e5 LC |
423 | ;; once more in that case. |
424 | (unless register-closures? | |
6a488a35 LC |
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)))) | |
641f9a2a | 435 | |
9121ce55 | 436 | (define (register-bootcfg-root target bootcfg) |
07f812c4 | 437 | "On file system TARGET, register BOOTCFG as a GC root." |
6412e58a | 438 | (let ((directory (string-append target "/var/guix/gcroots"))) |
39d1f82b | 439 | (mkdir-p directory) |
9121ce55 | 440 | (symlink bootcfg (string-append directory "/bootcfg")))) |
39d1f82b | 441 | |
641f9a2a LC |
442 | (define* (initialize-hard-disk device |
443 | #:key | |
9121ce55 MO |
444 | bootloader-package |
445 | bootcfg | |
446 | bootcfg-location | |
447 | bootloader-installer | |
ecf5d537 | 448 | (grub-efi #f) |
72b891e5 LC |
449 | (partitions '())) |
450 | "Initialize DEVICE as a disk containing all the <partition> objects listed | |
07f812c4 | 451 | in PARTITIONS, and using BOOTCFG as its bootloader configuration file. |
641f9a2a | 452 | |
72b891e5 LC |
453 | Each partition is initialized by calling its 'initializer' procedure, |
454 | passing it a directory name where it is mounted." | |
01cc84da MB |
455 | |
456 | (define (partition-bootable? partition) | |
457 | "Return the first partition found with the boot flag set." | |
458 | (member 'boot (partition-flags partition))) | |
459 | ||
ecf5d537 MB |
460 | (define (partition-esp? partition) |
461 | "Return the first EFI System Partition." | |
462 | (member 'esp (partition-flags partition))) | |
463 | ||
72b891e5 LC |
464 | (let* ((partitions (initialize-partition-table device partitions)) |
465 | (root (find partition-bootable? partitions)) | |
ecf5d537 | 466 | (esp (find partition-esp? partitions)) |
72b891e5 LC |
467 | (target "/fs")) |
468 | (unless root | |
469 | (error "no bootable partition specified" partitions)) | |
55651ff2 | 470 | |
72b891e5 | 471 | (for-each initialize-partition partitions) |
55651ff2 | 472 | |
72b891e5 LC |
473 | (display "mounting root partition...\n") |
474 | (mkdir-p target) | |
475 | (mount (partition-device root) target (partition-file-system root)) | |
9121ce55 MO |
476 | (install-boot-config bootcfg bootcfg-location target) |
477 | (when bootloader-installer | |
ecf5d537 | 478 | (display "installing bootloader...\n") |
9121ce55 | 479 | (bootloader-installer bootloader-package device target)) |
39d1f82b | 480 | |
ecf5d537 MB |
481 | (when esp |
482 | ;; Mount the ESP somewhere and install GRUB UEFI image. | |
f8fd1157 | 483 | (let ((mount-point (string-append target "/boot/efi"))) |
ecf5d537 MB |
484 | (display "mounting EFI system partition...\n") |
485 | (mkdir-p mount-point) | |
486 | (mount (partition-device esp) mount-point | |
487 | (partition-file-system esp)) | |
488 | ||
ecf5d537 | 489 | (display "creating EFI firmware image...") |
f8fd1157 | 490 | (install-efi-loader grub-efi mount-point) |
ecf5d537 MB |
491 | (display "done.\n") |
492 | ||
ecf5d537 MB |
493 | (umount mount-point))) |
494 | ||
9121ce55 MO |
495 | ;; Register BOOTCFG as a GC root. |
496 | (register-bootcfg-root target bootcfg) | |
55651ff2 | 497 | |
72b891e5 | 498 | (umount target))) |
55651ff2 | 499 | |
e1a87b90 | 500 | ;;; vm.scm ends here |