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