Commit | Line | Data |
---|---|---|
f19cf27c | 1 | ;;; GNU Guix --- Functional package management for GNU |
08b8f85e | 2 | ;;; Copyright © 2020, 2021, 2022 Mathieu Othacehe <othacehe@gnu.org> |
7ca533c7 | 3 | ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> |
76139eb2 | 4 | ;;; Copyright © 2022 Pavel Shlyak <p.shlyak@pantherx.org> |
62c86c83 | 5 | ;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org> |
8757c3f2 | 6 | ;;; Copyright © 2022 Alex Griffin <a@ajgrf.com> |
f19cf27c MO |
7 | ;;; |
8 | ;;; This file is part of GNU Guix. | |
9 | ;;; | |
10 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
11 | ;;; under the terms of the GNU General Public License as published by | |
12 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
13 | ;;; your option) any later version. | |
14 | ;;; | |
15 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
16 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;;; GNU General Public License for more details. | |
19 | ;;; | |
20 | ;;; You should have received a copy of the GNU General Public License | |
21 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
22 | ||
23 | (define-module (gnu system image) | |
10b135ce MO |
24 | #:use-module (guix diagnostics) |
25 | #:use-module (guix discovery) | |
f19cf27c MO |
26 | #:use-module (guix gexp) |
27 | #:use-module (guix modules) | |
28 | #:use-module (guix monads) | |
29 | #:use-module (guix records) | |
30 | #:use-module (guix store) | |
31 | #:use-module (guix ui) | |
32 | #:use-module (guix utils) | |
33 | #:use-module ((guix self) #:select (make-config.scm)) | |
34 | #:use-module (gnu bootloader) | |
35 | #:use-module (gnu bootloader grub) | |
8757c3f2 | 36 | #:use-module (gnu compression) |
f19cf27c | 37 | #:use-module (gnu image) |
dab819d5 | 38 | #:use-module (guix platform) |
f19cf27c MO |
39 | #:use-module (gnu services) |
40 | #:use-module (gnu services base) | |
41 | #:use-module (gnu system) | |
233cf9f0 | 42 | #:use-module (gnu system accounts) |
f19cf27c | 43 | #:use-module (gnu system file-systems) |
59912117 | 44 | #:use-module (gnu system linux-container) |
f19cf27c MO |
45 | #:use-module (gnu system uuid) |
46 | #:use-module (gnu system vm) | |
47 | #:use-module (guix packages) | |
48 | #:use-module (gnu packages base) | |
233cf9f0 | 49 | #:use-module (gnu packages bash) |
f19cf27c MO |
50 | #:use-module (gnu packages bootloaders) |
51 | #:use-module (gnu packages cdrom) | |
59912117 | 52 | #:use-module (gnu packages compression) |
f19cf27c MO |
53 | #:use-module (gnu packages disk) |
54 | #:use-module (gnu packages gawk) | |
55 | #:use-module (gnu packages genimage) | |
56 | #:use-module (gnu packages guile) | |
57 | #:autoload (gnu packages gnupg) (guile-gcrypt) | |
c77b9285 | 58 | #:use-module (gnu packages hurd) |
f19cf27c MO |
59 | #:use-module (gnu packages linux) |
60 | #:use-module (gnu packages mtools) | |
f441e3e8 | 61 | #:use-module (gnu packages virtualization) |
f19cf27c MO |
62 | #:use-module ((srfi srfi-1) #:prefix srfi-1:) |
63 | #:use-module (srfi srfi-11) | |
64 | #:use-module (srfi srfi-26) | |
281869e6 | 65 | #:use-module (srfi srfi-34) |
f19cf27c MO |
66 | #:use-module (srfi srfi-35) |
67 | #:use-module (rnrs bytevectors) | |
f441e3e8 | 68 | #:use-module (ice-9 format) |
f19cf27c | 69 | #:use-module (ice-9 match) |
b904b59c MO |
70 | #:export (root-offset |
71 | root-label | |
c009c286 | 72 | image-without-os |
b904b59c MO |
73 | |
74 | esp-partition | |
62c86c83 | 75 | esp32-partition |
f19cf27c MO |
76 | root-partition |
77 | ||
78 | efi-disk-image | |
79 | iso9660-image | |
59912117 | 80 | docker-image |
8757c3f2 | 81 | tarball-image |
233cf9f0 | 82 | wsl2-image |
d5073fd1 | 83 | raw-with-offset-disk-image |
f19cf27c | 84 | |
10b135ce | 85 | image-with-os |
2f497d94 | 86 | efi-raw-image-type |
62c86c83 | 87 | efi32-raw-image-type |
23ad7e92 | 88 | qcow2-image-type |
10b135ce MO |
89 | iso-image-type |
90 | uncompressed-iso-image-type | |
59912117 | 91 | docker-image-type |
8757c3f2 | 92 | tarball-image-type |
233cf9f0 | 93 | wsl2-image-type |
d5073fd1 | 94 | raw-with-offset-image-type |
10b135ce MO |
95 | |
96 | image-with-label | |
036f23f0 | 97 | system-image |
10b135ce MO |
98 | |
99 | %image-types | |
100 | lookup-image-type-by-name)) | |
f19cf27c MO |
101 | |
102 | \f | |
103 | ;;; | |
104 | ;;; Images definitions. | |
105 | ;;; | |
106 | ||
b7b45372 MO |
107 | ;; This is the offset before the first partition. GRUB will install itself in |
108 | ;; this post-MBR gap. | |
109 | (define root-offset (* 512 2048)) | |
110 | ||
111 | ;; Generic root partition label. | |
112 | (define root-label "Guix_image") | |
113 | ||
c009c286 MO |
114 | (define-syntax-rule (image-without-os . fields) |
115 | "Return an image record with the mandatory operating-system field set to | |
116 | #false. This is useful when creating an image record that will serve as a | |
117 | parent image record." | |
118 | (image (operating-system #false) . fields)) | |
119 | ||
f19cf27c MO |
120 | (define esp-partition |
121 | (partition | |
122 | (size (* 40 (expt 2 20))) | |
b7b45372 | 123 | (offset root-offset) |
f19cf27c MO |
124 | (label "GNU-ESP") ;cosmetic only |
125 | ;; Use "vfat" here since this property is used when mounting. The actual | |
126 | ;; FAT-ness is based on file system size (16 in this case). | |
127 | (file-system "vfat") | |
128 | (flags '(esp)) | |
129 | (initializer (gexp initialize-efi-partition)))) | |
130 | ||
62c86c83 DGC |
131 | (define esp32-partition |
132 | (partition | |
133 | (inherit esp-partition) | |
134 | (initializer (gexp initialize-efi32-partition)))) | |
135 | ||
f19cf27c MO |
136 | (define root-partition |
137 | (partition | |
138 | (size 'guess) | |
b7b45372 | 139 | (label root-label) |
f19cf27c MO |
140 | (file-system "ext4") |
141 | (flags '(boot)) | |
142 | (initializer (gexp initialize-root-partition)))) | |
143 | ||
144 | (define efi-disk-image | |
c009c286 | 145 | (image-without-os |
f19cf27c MO |
146 | (format 'disk-image) |
147 | (partitions (list esp-partition root-partition)))) | |
148 | ||
62c86c83 | 149 | (define efi32-disk-image |
c009c286 | 150 | (image-without-os |
62c86c83 DGC |
151 | (format 'disk-image) |
152 | (partitions (list esp32-partition root-partition)))) | |
153 | ||
f19cf27c | 154 | (define iso9660-image |
c009c286 | 155 | (image-without-os |
f19cf27c MO |
156 | (format 'iso9660) |
157 | (partitions | |
158 | (list (partition | |
159 | (size 'guess) | |
160 | (label "GUIX_IMAGE") | |
f56144e1 | 161 | (flags '(boot))))))) |
f19cf27c | 162 | |
59912117 | 163 | (define docker-image |
c009c286 | 164 | (image-without-os |
59912117 MO |
165 | (format 'docker))) |
166 | ||
8757c3f2 AG |
167 | (define tarball-image |
168 | (image-without-os | |
169 | (format 'tarball))) | |
170 | ||
233cf9f0 AG |
171 | (define wsl2-image |
172 | (image-without-os | |
173 | (format 'wsl2))) | |
174 | ||
d5073fd1 | 175 | (define* (raw-with-offset-disk-image #:optional (offset root-offset)) |
c009c286 | 176 | (image-without-os |
599954c1 | 177 | (format 'disk-image) |
599954c1 MO |
178 | (partitions |
179 | (list (partition | |
180 | (inherit root-partition) | |
b6473e50 | 181 | (offset offset)))) |
599954c1 MO |
182 | ;; FIXME: Deleting and creating "/var/run" and "/tmp" on the overlayfs |
183 | ;; fails. | |
184 | (volatile-root? #f))) | |
185 | ||
f19cf27c | 186 | \f |
10b135ce MO |
187 | ;;; |
188 | ;;; Images types. | |
189 | ;;; | |
190 | ||
191 | (define-syntax-rule (image-with-os base-image os) | |
192 | "Return an image inheriting from BASE-IMAGE, with the operating-system field | |
193 | set to the given OS." | |
194 | (image | |
195 | (inherit base-image) | |
196 | (operating-system os))) | |
197 | ||
2f497d94 | 198 | (define efi-raw-image-type |
10b135ce | 199 | (image-type |
2f497d94 | 200 | (name 'efi-raw) |
10b135ce MO |
201 | (constructor (cut image-with-os efi-disk-image <>)))) |
202 | ||
62c86c83 DGC |
203 | (define efi32-raw-image-type |
204 | (image-type | |
205 | (name 'efi32-raw) | |
206 | (constructor (cut image-with-os efi32-disk-image <>)))) | |
207 | ||
23ad7e92 MO |
208 | (define qcow2-image-type |
209 | (image-type | |
210 | (name 'qcow2) | |
211 | (constructor (cut image-with-os | |
212 | (image | |
213 | (inherit efi-disk-image) | |
214 | (name 'image.qcow2) | |
215 | (format 'compressed-qcow2)) | |
216 | <>)))) | |
217 | ||
10b135ce MO |
218 | (define iso-image-type |
219 | (image-type | |
220 | (name 'iso9660) | |
221 | (constructor (cut image-with-os iso9660-image <>)))) | |
222 | ||
223 | (define uncompressed-iso-image-type | |
224 | (image-type | |
225 | (name 'uncompressed-iso9660) | |
226 | (constructor (cut image-with-os | |
227 | (image | |
228 | (inherit iso9660-image) | |
229 | (compression? #f)) | |
230 | <>)))) | |
231 | ||
59912117 MO |
232 | (define docker-image-type |
233 | (image-type | |
234 | (name 'docker) | |
235 | (constructor (cut image-with-os docker-image <>)))) | |
236 | ||
8757c3f2 AG |
237 | (define tarball-image-type |
238 | (image-type | |
239 | (name 'tarball) | |
240 | (constructor (cut image-with-os tarball-image <>)))) | |
241 | ||
233cf9f0 AG |
242 | (define wsl2-image-type |
243 | (image-type | |
244 | (name 'wsl2) | |
245 | (constructor (cut image-with-os wsl2-image <>)))) | |
246 | ||
d5073fd1 | 247 | (define raw-with-offset-image-type |
599954c1 | 248 | (image-type |
d5073fd1 MO |
249 | (name 'raw-with-offset) |
250 | (constructor (cut image-with-os (raw-with-offset-disk-image) <>)))) | |
599954c1 | 251 | |
10b135ce | 252 | \f |
f19cf27c MO |
253 | ;; |
254 | ;; Helpers. | |
255 | ;; | |
256 | ||
257 | (define not-config? | |
258 | ;; Select (guix …) and (gnu …) modules, except (guix config). | |
259 | (match-lambda | |
260 | (('guix 'config) #f) | |
261 | (('guix rest ...) #t) | |
262 | (('gnu rest ...) #t) | |
263 | (rest #f))) | |
264 | ||
265 | (define (partition->gexp partition) | |
266 | "Turn PARTITION, a <partition> object, into a list-valued gexp suitable for | |
267 | 'make-partition-image'." | |
268 | #~'(#$@(list (partition-size partition)) | |
269 | #$(partition-file-system partition) | |
bd3716f6 | 270 | #$(partition-file-system-options partition) |
f19cf27c MO |
271 | #$(partition-label partition) |
272 | #$(and=> (partition-uuid partition) | |
bb662d71 PS |
273 | uuid-bytevector) |
274 | #$(partition-flags partition))) | |
f19cf27c MO |
275 | |
276 | (define gcrypt-sqlite3&co | |
277 | ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs. | |
278 | (srfi-1:append-map | |
279 | (lambda (package) | |
280 | (cons package | |
281 | (match (package-transitive-propagated-inputs package) | |
282 | (((labels packages) ...) | |
283 | packages)))) | |
dac7dd1b | 284 | (list guile-gcrypt guile-sqlite3))) |
f19cf27c MO |
285 | |
286 | (define-syntax-rule (with-imported-modules* gexp* ...) | |
287 | (with-extensions gcrypt-sqlite3&co | |
288 | (with-imported-modules `(,@(source-module-closure | |
59912117 | 289 | '((gnu build image) |
b97b423e | 290 | (gnu build bootloader) |
b37c5441 | 291 | (gnu build hurd-boot) |
c77b9285 | 292 | (gnu build linux-boot) |
f19cf27c MO |
293 | (guix store database)) |
294 | #:select? not-config?) | |
295 | ((guix config) => ,(make-config.scm))) | |
296 | #~(begin | |
59912117 | 297 | (use-modules (gnu build image) |
b97b423e | 298 | (gnu build bootloader) |
b37c5441 | 299 | (gnu build hurd-boot) |
c77b9285 | 300 | (gnu build linux-boot) |
f19cf27c MO |
301 | (guix store database) |
302 | (guix build utils)) | |
303 | gexp* ...)))) | |
304 | ||
7feefb3b MO |
305 | (define (root-partition? partition) |
306 | "Return true if PARTITION is the root partition, false otherwise." | |
307 | (member 'boot (partition-flags partition))) | |
308 | ||
309 | (define (find-root-partition image) | |
310 | "Return the root partition of the given IMAGE." | |
05a759ab LC |
311 | (or (srfi-1:find root-partition? (image-partitions image)) |
312 | (raise (formatted-message | |
313 | (G_ "image lacks a partition with the 'boot' flag"))))) | |
7feefb3b MO |
314 | |
315 | (define (root-partition-index image) | |
316 | "Return the index of the root partition of the given IMAGE." | |
317 | (1+ (srfi-1:list-index root-partition? (image-partitions image)))) | |
318 | ||
f19cf27c MO |
319 | \f |
320 | ;; | |
321 | ;; Disk image. | |
322 | ;; | |
323 | ||
324 | (define* (system-disk-image image | |
325 | #:key | |
326 | (name "disk-image") | |
327 | bootcfg | |
328 | bootloader | |
329 | register-closures? | |
330 | (inputs '())) | |
331 | "Return as a file-like object, the disk-image described by IMAGE. Said | |
332 | image can be copied on a USB stick as is. BOOTLOADER is the bootloader that | |
333 | will be installed and configured according to BOOTCFG parameter. | |
334 | ||
335 | Raw images of the IMAGE partitions are first created. Then, genimage is used | |
336 | to assemble the partition images into a disk-image without resorting to a | |
337 | virtual machine. | |
338 | ||
339 | INPUTS is a list of inputs (as for packages). When REGISTER-CLOSURES? is | |
340 | true, register INPUTS in the store database of the image so that Guix can be | |
341 | used in the image." | |
342 | ||
343 | (define genimage-name "image") | |
344 | ||
345 | (define (image->genimage-cfg image) | |
346 | ;; Return as a file-like object, the genimage configuration file | |
347 | ;; describing the given IMAGE. | |
348 | (define (format->image-type format) | |
349 | ;; Return the genimage format corresponding to FORMAT. For now, only | |
350 | ;; the hdimage format (raw disk-image) is supported. | |
f441e3e8 MO |
351 | (cond |
352 | ((memq format '(disk-image compressed-qcow2)) "hdimage") | |
17e3b7d2 MO |
353 | (else |
354 | (raise (condition | |
355 | (&message | |
356 | (message | |
db3193f5 | 357 | (format #f (G_ "unsupported image type: ~a") |
17e3b7d2 | 358 | format)))))))) |
f19cf27c MO |
359 | |
360 | (define (partition->dos-type partition) | |
361 | ;; Return the MBR partition type corresponding to the given PARTITION. | |
362 | ;; See: https://en.wikipedia.org/wiki/Partition_type. | |
76139eb2 PS |
363 | (let ((flags (partition-flags partition)) |
364 | (file-system (partition-file-system partition))) | |
f19cf27c MO |
365 | (cond |
366 | ((member 'esp flags) "0xEF") | |
76139eb2 | 367 | ((string-prefix? "ext" file-system) "0x83") |
8b680b00 PS |
368 | ((or (string=? file-system "vfat") |
369 | (string=? file-system "fat16")) "0x0E") | |
370 | ((string=? file-system "fat32") "0x0C") | |
76139eb2 PS |
371 | (else |
372 | (raise (condition | |
373 | (&message | |
374 | (message | |
375 | (format #f (G_ "unsupported partition type: ~a") | |
376 | file-system))))))))) | |
f19cf27c | 377 | |
096a2bf8 | 378 | (define (partition->gpt-type partition) |
6e99c020 PS |
379 | ;; Return the genimage GPT partition type code corresponding to the |
380 | ;; given PARTITION. See: | |
381 | ;; https://github.com/pengutronix/genimage/blob/master/README.rst | |
382 | (let ((flags (partition-flags partition)) | |
383 | (file-system (partition-file-system partition))) | |
096a2bf8 | 384 | (cond |
6e99c020 PS |
385 | ((member 'esp flags) "U") |
386 | ((string-prefix? "ext" file-system) "L") | |
8b680b00 PS |
387 | ((or (string=? file-system "vfat") |
388 | (string=? file-system "fat16") | |
389 | (string=? file-system "fat32")) "F") | |
6e99c020 PS |
390 | (else |
391 | (raise (condition | |
392 | (&message | |
393 | (message | |
394 | (format #f (G_ "unsupported partition type: ~a") | |
395 | file-system))))))))) | |
096a2bf8 | 396 | |
f19cf27c MO |
397 | (define (partition-image partition) |
398 | ;; Return as a file-like object, an image of the given PARTITION. A | |
399 | ;; directory, filled by calling the PARTITION initializer procedure, is | |
400 | ;; first created within the store. Then, an image of this directory is | |
401 | ;; created using tools such as 'mke2fs' or 'mkdosfs', depending on the | |
402 | ;; partition file-system type. | |
403 | (let* ((os (image-operating-system image)) | |
404 | (schema (local-file (search-path %load-path | |
405 | "guix/store/schema.sql"))) | |
406 | (graph (match inputs | |
407 | (((names . _) ...) | |
408 | names))) | |
7f75a7ec MO |
409 | (type (partition-file-system partition)) |
410 | (image-builder | |
f19cf27c | 411 | (with-imported-modules* |
9f530ef3 LC |
412 | (let ((initializer (or #$(partition-initializer partition) |
413 | initialize-root-partition)) | |
fd45ecb5 | 414 | (inputs '#+(list e2fsprogs fakeroot dosfstools mtools)) |
7f75a7ec | 415 | (image-root "tmp-root")) |
f19cf27c MO |
416 | (sql-schema #$schema) |
417 | ||
7f75a7ec MO |
418 | (set-path-environment-variable "PATH" '("bin" "sbin") inputs) |
419 | ||
f19cf27c MO |
420 | ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be |
421 | ;; decoded. | |
422 | (setenv "GUIX_LOCPATH" | |
423 | #+(file-append glibc-utf8-locales "/lib/locale")) | |
424 | (setlocale LC_ALL "en_US.utf8") | |
425 | ||
7f75a7ec | 426 | (initializer image-root |
f19cf27c MO |
427 | #:references-graphs '#$graph |
428 | #:deduplicate? #f | |
59912117 MO |
429 | #:copy-closures? (not |
430 | #$(image-shared-store? image)) | |
f19cf27c | 431 | #:system-directory #$os |
05f37c16 | 432 | #:grub-efi #+grub-efi |
62c86c83 | 433 | #:grub-efi32 #+grub-efi32 |
f19cf27c | 434 | #:bootloader-package |
9c1adb24 MO |
435 | #+(bootloader-package bootloader) |
436 | #:bootloader-installer | |
437 | #+(bootloader-installer bootloader) | |
f19cf27c MO |
438 | #:bootcfg #$bootcfg |
439 | #:bootcfg-location | |
7f75a7ec | 440 | #$(bootloader-configuration-file bootloader)) |
f19cf27c MO |
441 | (make-partition-image #$(partition->gexp partition) |
442 | #$output | |
7f75a7ec MO |
443 | image-root))))) |
444 | (computed-file "partition.img" image-builder | |
99efa804 LC |
445 | ;; Allow offloading so that this I/O-intensive process |
446 | ;; doesn't run on the build farm's head node. | |
447 | #:local-build? #f | |
6d6e74ea | 448 | #:options `(#:references-graphs ,inputs)))) |
f19cf27c | 449 | |
096a2bf8 RS |
450 | (define (gpt-image? image) |
451 | (eq? 'gpt (image-partition-table-type image))) | |
452 | ||
453 | (define (partition-type-values image partition) | |
454 | (if (gpt-image? image) | |
455 | (values "partition-type-uuid" (partition->gpt-type partition)) | |
456 | (values "partition-type" (partition->dos-type partition)))) | |
457 | ||
458 | (define (partition->config image partition) | |
f19cf27c | 459 | ;; Return the genimage partition configuration for PARTITION. |
096a2bf8 RS |
460 | (let-values (((partition-type-attribute partition-type-value) |
461 | (partition-type-values image partition))) | |
462 | (let ((label (partition-label partition)) | |
463 | (image (partition-image partition)) | |
bb662d71 PS |
464 | (offset (partition-offset partition)) |
465 | (bootable (if (memq 'boot (partition-flags partition)) | |
466 | "true" "false" ))) | |
096a2bf8 RS |
467 | #~(format #f "~/partition ~a { |
468 | ~/~/~a = ~a | |
469 | ~/~/image = \"~a\" | |
470 | ~/~/offset = \"~a\" | |
bb662d71 | 471 | ~/~/bootable = \"~a\" |
096a2bf8 RS |
472 | ~/}" |
473 | #$label | |
474 | #$partition-type-attribute | |
475 | #$partition-type-value | |
476 | #$image | |
bb662d71 PS |
477 | #$offset |
478 | #$bootable)))) | |
096a2bf8 RS |
479 | |
480 | (define (genimage-type-options image-type image) | |
481 | (cond | |
17e3b7d2 | 482 | ((equal? image-type "hdimage") |
ed19bc87 LC |
483 | (format #f "~%~/~/partition-table-type = \"~a\"~%~/" |
484 | (image-partition-table-type image))) | |
17e3b7d2 | 485 | (else ""))) |
f19cf27c MO |
486 | |
487 | (let* ((format (image-format image)) | |
488 | (image-type (format->image-type format)) | |
096a2bf8 | 489 | (image-type-options (genimage-type-options image-type image)) |
f19cf27c | 490 | (partitions (image-partitions image)) |
096a2bf8 | 491 | (partitions-config (map (cut partition->config image <>) partitions)) |
f19cf27c MO |
492 | (builder |
493 | #~(begin | |
494 | (let ((format (@ (ice-9 format) format))) | |
495 | (call-with-output-file #$output | |
496 | (lambda (port) | |
497 | (format port | |
498 | "\ | |
499 | image ~a { | |
096a2bf8 | 500 | ~/~a {~a} |
f19cf27c | 501 | ~{~a~^~%~} |
096a2bf8 RS |
502 | }~%" #$genimage-name #$image-type #$image-type-options |
503 | (list #$@partitions-config)))))))) | |
f19cf27c MO |
504 | (computed-file "genimage.cfg" builder))) |
505 | ||
f27bec10 MO |
506 | (let* ((image-name (image-name image)) |
507 | (name (if image-name | |
508 | (symbol->string image-name) | |
509 | name)) | |
f441e3e8 | 510 | (format (image-format image)) |
5980ec8a | 511 | (substitutable? (image-substitutable? image)) |
f19cf27c MO |
512 | (builder |
513 | (with-imported-modules* | |
f441e3e8 | 514 | (let ((inputs '#+(list genimage coreutils findutils qemu-minimal)) |
7feefb3b | 515 | (bootloader-installer |
f441e3e8 MO |
516 | #+(bootloader-disk-image-installer bootloader)) |
517 | (out-image (string-append "images/" #$genimage-name))) | |
f19cf27c | 518 | (set-path-environment-variable "PATH" '("bin" "sbin") inputs) |
f441e3e8 | 519 | (genimage #$(image->genimage-cfg image)) |
7feefb3b MO |
520 | ;; Install the bootloader directly on the disk-image. |
521 | (when bootloader-installer | |
522 | (bootloader-installer | |
523 | #+(bootloader-package bootloader) | |
524 | #$(root-partition-index image) | |
f441e3e8 MO |
525 | out-image)) |
526 | (convert-disk-image out-image '#$format #$output))))) | |
527 | (computed-file name builder | |
f9926c07 | 528 | #:local-build? #f ;too I/O-intensive |
6d6e74ea | 529 | #:options `(#:substitutable? ,substitutable?)))) |
f19cf27c MO |
530 | |
531 | \f | |
532 | ;; | |
533 | ;; ISO9660 image. | |
534 | ;; | |
535 | ||
536 | (define (has-guix-service-type? os) | |
537 | "Return true if OS contains a service of the type GUIX-SERVICE-TYPE." | |
538 | (not (not (srfi-1:find (lambda (service) | |
539 | (eq? (service-kind service) guix-service-type)) | |
540 | (operating-system-services os))))) | |
541 | ||
542 | (define* (system-iso9660-image image | |
543 | #:key | |
0996fcc6 | 544 | (name "image.iso") |
f19cf27c MO |
545 | bootcfg |
546 | bootloader | |
547 | register-closures? | |
548 | (inputs '()) | |
549 | (grub-mkrescue-environment '())) | |
550 | "Return as a file-like object a bootable, stand-alone iso9660 image. | |
551 | ||
552 | INPUTS is a list of inputs (as for packages). When REGISTER-CLOSURES? is | |
553 | true, register INPUTS in the store database of the image so that Guix can be | |
554 | used in the image. " | |
555 | (define root-label | |
556 | (match (image-partitions image) | |
557 | ((partition) | |
558 | (partition-label partition)))) | |
559 | ||
560 | (define root-uuid | |
561 | (match (image-partitions image) | |
562 | ((partition) | |
563 | (uuid-bytevector (partition-uuid partition))))) | |
564 | ||
565 | (let* ((os (image-operating-system image)) | |
566 | (bootloader (bootloader-package bootloader)) | |
567 | (compression? (image-compression? image)) | |
568 | (substitutable? (image-substitutable? image)) | |
569 | (schema (local-file (search-path %load-path | |
570 | "guix/store/schema.sql"))) | |
571 | (graph (match inputs | |
572 | (((names . _) ...) | |
573 | names))) | |
f19cf27c MO |
574 | (builder |
575 | (with-imported-modules* | |
576 | (let* ((inputs '#$(list parted e2fsprogs dosfstools xorriso | |
1cb9effc MO |
577 | sed grep coreutils findutils gawk)) |
578 | (image-root "tmp-root")) | |
579 | (sql-schema #$schema) | |
580 | ||
581 | ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded. | |
582 | (setenv "GUIX_LOCPATH" | |
583 | #+(file-append glibc-utf8-locales "/lib/locale")) | |
584 | ||
585 | (setlocale LC_ALL "en_US.utf8") | |
586 | ||
f19cf27c | 587 | (set-path-environment-variable "PATH" '("bin" "sbin") inputs) |
1cb9effc MO |
588 | |
589 | (initialize-root-partition image-root | |
590 | #:references-graphs '#$graph | |
591 | #:deduplicate? #f | |
592 | #:system-directory #$os) | |
f19cf27c MO |
593 | (make-iso9660-image #$xorriso |
594 | '#$grub-mkrescue-environment | |
595 | #$bootloader | |
596 | #$bootcfg | |
597 | #$os | |
1cb9effc | 598 | image-root |
f19cf27c MO |
599 | #$output |
600 | #:references-graphs '#$graph | |
601 | #:register-closures? #$register-closures? | |
602 | #:compression? #$compression? | |
603 | #:volume-id #$root-label | |
604 | #:volume-uuid #$root-uuid))))) | |
605 | (computed-file name builder | |
99efa804 LC |
606 | ;; Allow offloading so that this I/O-intensive process |
607 | ;; doesn't run on the build farm's head node. | |
608 | #:local-build? #f | |
6d6e74ea | 609 | #:options `(#:references-graphs ,inputs |
f19cf27c MO |
610 | #:substitutable? ,substitutable?)))) |
611 | ||
036f23f0 JL |
612 | (define (image-with-label base-image label) |
613 | "The volume ID of an ISO is the label of the first partition. This procedure | |
614 | returns an image record where the first partition's label is set to <label>." | |
615 | (image | |
616 | (inherit base-image) | |
617 | (partitions | |
618 | (match (image-partitions base-image) | |
619 | ((boot others ...) | |
620 | (cons | |
621 | (partition | |
622 | (inherit boot) | |
623 | (label label)) | |
624 | others)))))) | |
625 | ||
f19cf27c | 626 | \f |
59912117 MO |
627 | ;; |
628 | ;; Docker image. | |
629 | ;; | |
630 | ||
631 | (define* (system-docker-image image | |
632 | #:key | |
633 | (name "docker-image")) | |
634 | "Build a docker image for IMAGE. NAME is the base name to use for the | |
635 | output file." | |
636 | (define boot-program | |
637 | ;; Program that runs the boot script of OS, which in turn starts shepherd. | |
638 | (program-file "boot-program" | |
639 | #~(let ((system (cadr (command-line)))) | |
640 | (setenv "GUIX_NEW_SYSTEM" system) | |
641 | (execl #$(file-append guile-3.0 "/bin/guile") | |
642 | "guile" "--no-auto-compile" | |
643 | (string-append system "/boot"))))) | |
644 | ||
645 | (define shared-network? | |
646 | (image-shared-network? image)) | |
647 | ||
648 | (let* ((os (operating-system-with-gc-roots | |
649 | (containerized-operating-system | |
650 | (image-operating-system image) '() | |
651 | #:shared-network? | |
652 | shared-network?) | |
653 | (list boot-program))) | |
654 | (substitutable? (image-substitutable? image)) | |
a75deb88 TJB |
655 | (image-target (or (%current-target-system) |
656 | (nix-system->gnu-triplet))) | |
59912117 MO |
657 | (register-closures? (has-guix-service-type? os)) |
658 | (schema (and register-closures? | |
659 | (local-file (search-path %load-path | |
660 | "guix/store/schema.sql")))) | |
661 | (name (string-append name ".tar.gz")) | |
662 | (graph "system-graph")) | |
663 | (define builder | |
664 | (with-extensions (cons guile-json-3 ;for (guix docker) | |
665 | gcrypt-sqlite3&co) ;for (guix store database) | |
666 | (with-imported-modules `(,@(source-module-closure | |
667 | '((guix docker) | |
668 | (guix store database) | |
669 | (guix build utils) | |
670 | (guix build store-copy) | |
671 | (gnu build image)) | |
672 | #:select? not-config?) | |
673 | ((guix config) => ,(make-config.scm))) | |
674 | #~(begin | |
675 | (use-modules (guix docker) | |
676 | (guix build utils) | |
677 | (gnu build image) | |
678 | (srfi srfi-19) | |
679 | (guix build store-copy) | |
680 | (guix store database)) | |
681 | ||
682 | ;; Set the SQL schema location. | |
683 | (sql-schema #$schema) | |
684 | ||
685 | ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded. | |
686 | (setenv "GUIX_LOCPATH" | |
687 | #+(file-append glibc-utf8-locales "/lib/locale")) | |
688 | (setlocale LC_ALL "en_US.utf8") | |
689 | ||
690 | (set-path-environment-variable "PATH" '("bin" "sbin") '(#+tar)) | |
691 | ||
692 | (let ((image-root (string-append (getcwd) "/tmp-root"))) | |
693 | (mkdir-p image-root) | |
694 | (initialize-root-partition image-root | |
695 | #:references-graphs '(#$graph) | |
696 | #:copy-closures? #f | |
697 | #:register-closures? #$register-closures? | |
698 | #:deduplicate? #f | |
699 | #:system-directory #$os) | |
700 | (build-docker-image | |
701 | #$output | |
702 | (cons* image-root | |
703 | (map store-info-item | |
704 | (call-with-input-file #$graph | |
705 | read-reference-graph))) | |
706 | #$os | |
707 | #:entry-point '(#$boot-program #$os) | |
708 | #:compressor '(#+(file-append gzip "/bin/gzip") "-9n") | |
709 | #:creation-time (make-time time-utc 0 1) | |
a75deb88 | 710 | #:system #$image-target |
59912117 MO |
711 | #:transformations `((,image-root -> "")))))))) |
712 | ||
713 | (computed-file name builder | |
714 | ;; Allow offloading so that this I/O-intensive process | |
715 | ;; doesn't run on the build farm's head node. | |
716 | #:local-build? #f | |
717 | #:options `(#:references-graphs ((,graph ,os)) | |
718 | #:substitutable? ,substitutable?)))) | |
719 | ||
720 | \f | |
2784fcf1 MO |
721 | ;;; |
722 | ;;; Tarball image. | |
723 | ;;; | |
8757c3f2 | 724 | |
2784fcf1 | 725 | ;; TODO: Some bits can be factorized with (guix scripts pack). |
8757c3f2 AG |
726 | (define* (system-tarball-image image |
727 | #:key | |
728 | (name "image") | |
233cf9f0 AG |
729 | (compressor (srfi-1:first %compressors)) |
730 | (wsl? #f)) | |
8757c3f2 AG |
731 | "Build a tarball of IMAGE. NAME is the base name to use for the |
732 | output file." | |
733 | (let* ((os (image-operating-system image)) | |
734 | (substitutable? (image-substitutable? image)) | |
735 | (schema (local-file (search-path %load-path | |
736 | "guix/store/schema.sql"))) | |
737 | (name (string-append name ".tar" (compressor-extension compressor))) | |
233cf9f0 AG |
738 | (graph "system-graph") |
739 | (root (srfi-1:find (lambda (user) | |
740 | (and=> (user-account-uid user) zero?)) | |
741 | (operating-system-users os))) | |
742 | (root-shell (or (and=> root user-account-shell) | |
743 | (file-append bash "/bin/bash")))) | |
8757c3f2 AG |
744 | (define builder |
745 | (with-extensions gcrypt-sqlite3&co ;for (guix store database) | |
746 | (with-imported-modules `(,@(source-module-closure | |
747 | '((guix build pack) | |
748 | (guix build store-copy) | |
749 | (guix build utils) | |
750 | (guix store database) | |
751 | (gnu build image)) | |
752 | #:select? not-config?) | |
753 | ((guix config) => ,(make-config.scm))) | |
754 | #~(begin | |
755 | (use-modules (guix build pack) | |
756 | (guix build store-copy) | |
757 | (guix build utils) | |
758 | (guix store database) | |
759 | (gnu build image)) | |
760 | ||
761 | ;; Set the SQL schema location. | |
762 | (sql-schema #$schema) | |
763 | ||
764 | ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded. | |
765 | (setenv "GUIX_LOCPATH" | |
766 | #+(file-append glibc-utf8-locales "/lib/locale")) | |
767 | (setlocale LC_ALL "en_US.utf8") | |
768 | ||
769 | (let ((image-root (string-append (getcwd) "/tmp-root")) | |
770 | (tar #+(file-append tar "/bin/tar"))) | |
771 | ||
772 | (mkdir-p image-root) | |
773 | (initialize-root-partition image-root | |
774 | #:references-graphs '(#$graph) | |
775 | #:deduplicate? #f | |
776 | #:system-directory #$os) | |
777 | ||
778 | (with-directory-excursion image-root | |
233cf9f0 AG |
779 | #$@(if wsl? |
780 | #~(;; WSL requires /bin/sh. Will be overwritten by | |
781 | ;; system activation. | |
782 | (symlink #$root-shell "./bin/sh") | |
783 | ||
784 | ;; WSL requires /bin/mount to access the host fs. | |
785 | (symlink #$(file-append util-linux "/bin/mount") | |
786 | "./bin/mount")) | |
787 | #~()) | |
788 | ||
8757c3f2 AG |
789 | (apply invoke tar "-cvf" #$output "." |
790 | (tar-base-options | |
791 | #:tar tar | |
792 | #:compressor | |
793 | #+(and=> compressor compressor-command))))))))) | |
794 | ||
795 | (computed-file name builder | |
796 | ;; Allow offloading so that this I/O-intensive process | |
797 | ;; doesn't run on the build farm's head node. | |
798 | #:local-build? #f | |
799 | #:options `(#:references-graphs ((,graph ,os)) | |
800 | #:substitutable? ,substitutable?)))) | |
801 | ||
802 | \f | |
f19cf27c MO |
803 | ;; |
804 | ;; Image creation. | |
805 | ;; | |
806 | ||
f19cf27c MO |
807 | (define (image->root-file-system image) |
808 | "Return the IMAGE root partition file-system type." | |
59912117 MO |
809 | (case (image-format image) |
810 | ((iso9660) "iso9660") | |
233cf9f0 | 811 | ((docker tarball wsl2) "dummy") |
59912117 MO |
812 | (else |
813 | (partition-file-system (find-root-partition image))))) | |
f19cf27c MO |
814 | |
815 | (define (root-size image) | |
816 | "Return the root partition size of IMAGE." | |
817 | (let* ((image-size (image-size image)) | |
818 | (root-partition (find-root-partition image)) | |
819 | (root-size (partition-size root-partition))) | |
820 | (cond | |
821 | ((and (eq? root-size 'guess) image-size) | |
822 | image-size) | |
823 | (else root-size)))) | |
824 | ||
10b135ce | 825 | (define* (image-with-os* base-image os) |
f19cf27c MO |
826 | "Return an image based on BASE-IMAGE but with the operating-system field set |
827 | to OS. Also set the UUID and the size of the root partition." | |
828 | (define root-file-system | |
829 | (srfi-1:find | |
830 | (lambda (fs) | |
831 | (string=? (file-system-mount-point fs) "/")) | |
832 | (operating-system-file-systems os))) | |
833 | ||
74938105 MO |
834 | (image |
835 | (inherit base-image) | |
836 | (operating-system os) | |
837 | (partitions | |
838 | (map (lambda (p) | |
839 | (if (root-partition? p) | |
840 | (partition | |
841 | (inherit p) | |
842 | (uuid (file-system-device root-file-system)) | |
843 | (size (root-size base-image))) | |
844 | p)) | |
845 | (image-partitions base-image))))) | |
f19cf27c MO |
846 | |
847 | (define (operating-system-for-image image) | |
848 | "Return an operating-system based on the one specified in IMAGE, but | |
849 | suitable for image creation. Assign an UUID to the root file-system, so that | |
850 | it can be used for bootloading." | |
83de7ee6 MO |
851 | (define volatile-root? (if (eq? (image-format image) 'iso9660) |
852 | #t | |
853 | (image-volatile-root? image))) | |
f19cf27c MO |
854 | |
855 | (define (root-uuid os) | |
856 | ;; UUID of the root file system, computed in a deterministic fashion. | |
857 | ;; This is what we use to locate the root file system so it has to be | |
858 | ;; different from the user's own file system UUIDs. | |
859 | (let ((type (if (eq? (image-format image) 'iso9660) | |
860 | 'iso9660 | |
861 | 'dce))) | |
862 | (operating-system-uuid os type))) | |
863 | ||
864 | (let* ((root-file-system-type (image->root-file-system image)) | |
865 | (base-os (image-operating-system image)) | |
866 | (file-systems-to-keep | |
867 | (srfi-1:remove | |
868 | (lambda (fs) | |
1ec366cd MC |
869 | (let ((mount-point (file-system-mount-point fs))) |
870 | (or (string=? mount-point "/") | |
871 | (string=? mount-point "/boot/efi")))) | |
f19cf27c MO |
872 | (operating-system-file-systems base-os))) |
873 | (format (image-format image)) | |
874 | (os | |
875 | (operating-system | |
876 | (inherit base-os) | |
877 | (initrd (lambda (file-systems . rest) | |
878 | (apply (operating-system-initrd base-os) | |
879 | file-systems | |
880 | #:volatile-root? volatile-root? | |
881 | rest))) | |
882 | (bootloader (if (eq? format 'iso9660) | |
883 | (bootloader-configuration | |
884 | (inherit | |
885 | (operating-system-bootloader base-os)) | |
886 | (bootloader grub-mkrescue-bootloader)) | |
887 | (operating-system-bootloader base-os))) | |
888 | (file-systems (cons (file-system | |
889 | (mount-point "/") | |
890 | (device "/dev/placeholder") | |
891 | (type root-file-system-type)) | |
892 | file-systems-to-keep)))) | |
893 | (uuid (root-uuid os))) | |
894 | (operating-system | |
895 | (inherit os) | |
896 | (file-systems (cons (file-system | |
897 | (mount-point "/") | |
898 | (device uuid) | |
899 | (type root-file-system-type)) | |
900 | file-systems-to-keep))))) | |
901 | ||
e3f0155c | 902 | (define* (system-image image) |
f19cf27c MO |
903 | "Return the derivation of IMAGE. It can be a raw disk-image or an ISO9660 |
904 | image, depending on IMAGE format." | |
d5073fd1 MO |
905 | (define platform (image-platform image)) |
906 | ||
907 | ;; The image platform definition may provide the appropriate "system" | |
908 | ;; architecture for the image. If we are already running on this system, | |
909 | ;; the image can be built natively. If we are running on a different | |
910 | ;; system, then we need to cross-compile, using the "target" provided by the | |
911 | ;; image definition. | |
912 | (define system (and=> platform platform-system)) | |
913 | (define target (cond | |
914 | ;; No defined platform, let's use the user defined | |
915 | ;; system/target parameters. | |
916 | ((not platform) | |
917 | (%current-target-system)) | |
918 | ;; The current system is the same as the platform system, no | |
919 | ;; need to cross-compile. | |
920 | ((and system | |
921 | (string=? system (%current-system))) | |
922 | #f) | |
923 | ;; If there is a user defined target let's override the | |
924 | ;; platform target. Otherwise, we can cross-compile to the | |
925 | ;; platform target. | |
926 | (else | |
927 | (or (%current-target-system) | |
928 | (and=> platform platform-target))))) | |
c9f6e2e5 MO |
929 | |
930 | (with-parameters ((%current-target-system target)) | |
931 | (let* ((os (operating-system-for-image image)) | |
10b135ce | 932 | (image* (image-with-os* image os)) |
f441e3e8 | 933 | (image-format (image-format image)) |
c9f6e2e5 MO |
934 | (register-closures? (has-guix-service-type? os)) |
935 | (bootcfg (operating-system-bootcfg os)) | |
936 | (bootloader (bootloader-configuration-bootloader | |
937 | (operating-system-bootloader os)))) | |
f441e3e8 MO |
938 | (cond |
939 | ((memq image-format '(disk-image compressed-qcow2)) | |
f292d471 MO |
940 | (system-disk-image image* |
941 | #:bootcfg bootcfg | |
942 | #:bootloader bootloader | |
943 | #:register-closures? register-closures? | |
944 | #:inputs `(("system" ,os) | |
945 | ("bootcfg" ,bootcfg)))) | |
59912117 MO |
946 | ((memq image-format '(docker)) |
947 | (system-docker-image image*)) | |
8757c3f2 AG |
948 | ((memq image-format '(tarball)) |
949 | (system-tarball-image image*)) | |
233cf9f0 AG |
950 | ((memq image-format '(wsl2)) |
951 | (system-tarball-image image* #:wsl? #t)) | |
f441e3e8 | 952 | ((memq image-format '(iso9660)) |
f292d471 MO |
953 | (system-iso9660-image |
954 | image* | |
955 | #:bootcfg bootcfg | |
956 | #:bootloader bootloader | |
957 | #:register-closures? register-closures? | |
958 | #:inputs `(("system" ,os) | |
959 | ("bootcfg" ,bootcfg)) | |
960 | ;; Make sure to use a mode that does no imply | |
961 | ;; HFS+ tree creation that may fail with: | |
962 | ;; | |
963 | ;; "libisofs: FAILURE : Too much files to mangle, | |
964 | ;; cannot guarantee unique file names" | |
965 | ;; | |
966 | ;; This happens if some limits are exceeded, see: | |
967 | ;; https://lists.gnu.org/archive/html/grub-devel/2020-06/msg00048.html | |
968 | #:grub-mkrescue-environment | |
e871c3a8 LC |
969 | '(("MKRESCUE_SED_MODE" . "mbr_only")))) |
970 | (else | |
971 | (raise (formatted-message | |
972 | (G_ "~a: unsupported image format") image-format))))))) | |
f19cf27c | 973 | |
10b135ce MO |
974 | \f |
975 | ;; | |
976 | ;; Image detection. | |
977 | ;; | |
978 | ||
979 | (define (image-modules) | |
980 | "Return the list of image modules." | |
981 | (cons (resolve-interface '(gnu system image)) | |
982 | (all-modules (map (lambda (entry) | |
983 | `(,entry . "gnu/system/images/")) | |
984 | %load-path) | |
985 | #:warn warn-about-load-error))) | |
986 | ||
987 | (define %image-types | |
988 | ;; The list of publically-known image types. | |
989 | (delay (fold-module-public-variables (lambda (obj result) | |
990 | (if (image-type? obj) | |
991 | (cons obj result) | |
992 | result)) | |
993 | '() | |
994 | (image-modules)))) | |
995 | ||
996 | (define (lookup-image-type-by-name name) | |
997 | "Return the image type called NAME." | |
998 | (or (srfi-1:find (lambda (image-type) | |
999 | (eq? name (image-type-name image-type))) | |
1000 | (force %image-types)) | |
1001 | (raise | |
281869e6 | 1002 | (formatted-message (G_ "~a: no such image type") name)))) |
f19cf27c MO |
1003 | |
1004 | ;;; image.scm ends here |