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