projects/guix·blob python-team · refs

1176 lines · 45.4 KiB

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