projects/guix·blob java-team · refs

1175 lines · 45.3 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_ "EFI bootloader required with GPT partitioning"))))
612
613 (let* ((format (image-format image))
614 (image-type (format->image-type format))
615 (image-type-options (genimage-type-options image-type image))
616 (partitions (image-partitions image))
617 (partitions-config (map (cut partition->config image <>) partitions))
618 (builder
619 #~(begin
620 (let ((format (@ (ice-9 format) format)))
621 (call-with-output-file #$output
622 (lambda (port)
623 (format port
624 "\
625image ~a {
626~/~a {~a}
627~{~a~^~%~}
628}~%" #$genimage-name #$image-type #$image-type-options
629 (list #$@partitions-config))))))))
630 (computed-file "genimage.cfg" builder)))
631
632 (let* ((image-name (image-name image))
633 (name (if image-name
634 (symbol->string image-name)
635 name))
636 (format (image-format image))
637 (substitutable? (image-substitutable? image))
638 (builder
639 (with-imported-modules*
640 (let ((inputs '#+(list genimage coreutils findutils qemu-minimal))
641 (bootloader-installer
642 #+(bootloader-disk-image-installer bootloader))
643 (out-image (string-append "images/" #$genimage-name)))
644 (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
645 (genimage #$(image->genimage-cfg image))
646 ;; Install the bootloader directly on the disk-image.
647 (when bootloader-installer
648 (bootloader-installer
649 #+(bootloader-package bootloader)
650 #$(root-partition-index image)
651 out-image))
652 (convert-disk-image out-image '#$format #$output)))))
653 (computed-file name builder
654 #:local-build? #f ;too I/O-intensive
655 #:options `(#:substitutable? ,substitutable?))))
656
657
658;;
659;; ISO9660 image.
660;;
661
662(define (has-guix-service-type? os)
663 "Return true if OS contains a service of the type GUIX-SERVICE-TYPE."
664 (not (not (srfi-1:find (lambda (service)
665 (eq? (service-kind service) guix-service-type))
666 (operating-system-services os)))))
667
668(define* (system-iso9660-image image
669 #:key
670 (name "image.iso")
671 bootcfg
672 bootloader
673 register-closures?
674 (inputs '())
675 (grub-mkrescue-environment '()))
676 "Return as a file-like object a bootable, stand-alone iso9660 image.
677
678INPUTS is a list of inputs (as for packages). When REGISTER-CLOSURES? is
679true, register INPUTS in the store database of the image so that Guix can be
680used in the image. "
681 (define root-label
682 (match (image-partitions image)
683 ((partition)
684 (partition-label partition))))
685
686 (define root-uuid
687 (match (image-partitions image)
688 ((partition)
689 (uuid-bytevector (partition-uuid partition)))))
690
691 (let* ((os (image-operating-system image))
692 (image-name (image-name image))
693 (name (if image-name
694 (symbol->string image-name)
695 name))
696 (bootloader (bootloader-package bootloader))
697 (compression? (image-compression? image))
698 (substitutable? (image-substitutable? image))
699 (schema (local-file (search-path %load-path
700 "guix/store/schema.sql")))
701 (graph (match inputs
702 (((names . _) ...)
703 names)))
704 (builder
705 (with-imported-modules*
706 (let* ((inputs '#$(list parted e2fsprogs dosfstools xorriso
707 sed grep coreutils findutils gawk))
708 (image-root "tmp-root"))
709 (sql-schema #$schema)
710
711 ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
712 (setenv "GUIX_LOCPATH"
713 #+(file-append (libc-utf8-locales-for-target (%current-system))
714 "/lib/locale"))
715
716 (setlocale LC_ALL "en_US.utf8")
717
718 (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
719
720 (initialize-root-partition image-root
721 #:references-graphs '#$graph
722 #:deduplicate? #f
723 #:system-directory #$os)
724 (make-iso9660-image #$xorriso
725 '#$grub-mkrescue-environment
726 #$bootloader
727 #$bootcfg
728 #$os
729 image-root
730 #$output
731 #:references-graphs '#$graph
732 #:register-closures? #$register-closures?
733 #:compression? #$compression?
734 #:volume-id #$root-label
735 #:volume-uuid #$root-uuid)))))
736 (computed-file name builder
737 ;; Allow offloading so that this I/O-intensive process
738 ;; doesn't run on the build farm's head node.
739 #:local-build? #f
740 #:options `(#:references-graphs ,inputs
741 #:substitutable? ,substitutable?))))
742
743(define (image-with-label base-image label)
744 "The volume ID of an ISO is the label of the first partition. This procedure
745returns an image record where the first partition's label is set to <label>."
746 (image
747 (inherit base-image)
748 (partitions
749 (match (image-partitions base-image)
750 ((boot others ...)
751 (cons
752 (partition
753 (inherit boot)
754 (label label))
755 others))))))
756
757
758;;
759;; Docker image.
760;;
761
762(define* (system-docker-image image
763 #:key
764 (name "docker-image")
765 (archiver tar))
766 "Build a docker image for IMAGE. NAME is the base name to use for the
767output file."
768 (define boot-program
769 ;; Program that runs the boot script of OS, which in turn starts shepherd.
770 (program-file "boot-program"
771 #~(let ((system (cadr (command-line))))
772 (setenv "GUIX_NEW_SYSTEM" system)
773 (execl #$(file-append guile-3.0 "/bin/guile")
774 "guile" "--no-auto-compile"
775 (string-append system "/boot")))))
776
777 (define shared-network?
778 (image-shared-network? image))
779
780 (let* ((os (operating-system-with-gc-roots
781 (containerized-operating-system
782 (image-operating-system image) '()
783 #:shared-network?
784 shared-network?)
785 (list boot-program)))
786 (substitutable? (image-substitutable? image))
787 (image-target (or (%current-target-system)
788 (nix-system->gnu-triplet)))
789 (register-closures? (has-guix-service-type? os))
790 (schema (and register-closures?
791 (local-file (search-path %load-path
792 "guix/store/schema.sql"))))
793 (name (string-append name ".tar.gz"))
794 (graph "system-graph"))
795 (define builder
796 (with-extensions (cons guile-json-3 ;for (guix docker)
797 gcrypt-sqlite3&co) ;for (guix store database)
798 (with-imported-modules `(,@(source-module-closure
799 '((guix docker)
800 (guix store database)
801 (guix build utils)
802 (guix build store-copy)
803 (gnu build image))
804 #:select? neither-config-nor-git?)
805 ((guix config) => ,(make-config.scm)))
806 #~(begin
807 (use-modules (guix docker)
808 (guix build utils)
809 (gnu build image)
810 (srfi srfi-1)
811 (srfi srfi-19)
812 (guix build store-copy)
813 (guix store database))
814
815 ;; Set the SQL schema location.
816 (sql-schema #$schema)
817
818 ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
819 (setenv "GUIX_LOCPATH"
820 #+(file-append (libc-utf8-locales-for-target (%current-system))
821 "/lib/locale"))
822 (setlocale LC_ALL "en_US.utf8")
823
824 (set-path-environment-variable "PATH" '("bin" "sbin") '(#+tar))
825
826 (let ((image-root (string-append (getcwd) "/tmp-root")))
827 (mkdir-p image-root)
828 (initialize-root-partition image-root
829 #:references-graphs '(#$graph)
830 #:copy-closures? #f
831 #:register-closures? #$register-closures?
832 #:deduplicate? #f
833 #:system-directory #$os)
834 (when #$(image-max-layers image)
835 (setenv "PATH"
836 (string-join (list #+(file-append archiver "/bin")
837 #+(file-append gzip "/bin"))
838 ":")))
839 (apply build-docker-image
840 (append (list #$output
841 (append (if #$(image-max-layers image)
842 '()
843 (list image-root))
844 (map store-info-item
845 (call-with-input-file #$graph
846 read-reference-graph)))
847 #$os
848 #:entry-point '(#$boot-program #$os)
849 #:compressor
850 '(#+(file-append gzip "/bin/gzip") "-9n")
851 #:creation-time (make-time time-utc 0 1)
852 #:system #$image-target
853 #:transformations `((,image-root -> "")))
854 (if #$(image-max-layers image)
855 (list #:root-system image-root
856 #:max-layers #$(image-max-layers image))
857 '()))))))))
858
859 (computed-file name builder
860 ;; Allow offloading so that this I/O-intensive process
861 ;; doesn't run on the build farm's head node.
862 #:local-build? #f
863 #:options `(#:references-graphs ((,graph ,os))
864 #:substitutable? ,substitutable?))))
865
866
867;;;
868;;; Tarball image.
869;;;
870
871;; TODO: Some bits can be factorized with (guix scripts pack).
872(define* (system-tarball-image image
873 #:key
874 (name "image")
875 (compressor (srfi-1:first %compressors))
876 (wsl? #f))
877 "Build a tarball of IMAGE. NAME is the base name to use for the
878output file."
879 (let* ((os (image-operating-system image))
880 (substitutable? (image-substitutable? image))
881 (schema (local-file (search-path %load-path
882 "guix/store/schema.sql")))
883 (name (string-append name ".tar" (compressor-extension compressor)))
884 (graph "system-graph")
885 (root (srfi-1:find (lambda (user)
886 (and=> (user-account-uid user) zero?))
887 (operating-system-users os)))
888 (root-shell (or (and=> root user-account-shell)
889 (file-append bash "/bin/bash"))))
890 (define builder
891 (with-extensions gcrypt-sqlite3&co ;for (guix store database)
892 (with-imported-modules `(,@(source-module-closure
893 '((guix build pack)
894 (guix build store-copy)
895 (guix build utils)
896 (guix store database)
897 (gnu build image))
898 #:select? neither-config-nor-git?)
899 ((guix config) => ,(make-config.scm)))
900 #~(begin
901 (use-modules (guix build pack)
902 (guix build store-copy)
903 (guix build utils)
904 (guix store database)
905 (gnu build image))
906
907 ;; Set the SQL schema location.
908 (sql-schema #$schema)
909
910 ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
911 (setenv "GUIX_LOCPATH"
912 #+(file-append (libc-utf8-locales-for-target (%current-system))
913 "/lib/locale"))
914 (setlocale LC_ALL "en_US.utf8")
915
916 (let ((image-root (string-append (getcwd) "/tmp-root"))
917 (tar #+(file-append tar "/bin/tar")))
918
919 (mkdir-p image-root)
920 (initialize-root-partition image-root
921 #:references-graphs '(#$graph)
922 #:deduplicate? #f
923 #:system-directory #$os)
924
925 (with-directory-excursion image-root
926 #$@(if wsl?
927 #~(;; WSL requires /bin/sh. Will be overwritten by
928 ;; system activation.
929 (symlink #$root-shell "./bin/sh")
930
931 ;; WSL requires /bin/mount to access the host fs.
932 (symlink #$(file-append util-linux "/bin/mount")
933 "./bin/mount"))
934 #~())
935
936 (apply invoke tar "-cvf" #$output "."
937 (tar-base-options
938 #:tar tar
939 #:compressor
940 #+(and=> compressor compressor-command)))))))))
941
942 (computed-file name builder
943 ;; Allow offloading so that this I/O-intensive process
944 ;; doesn't run on the build farm's head node.
945 #:local-build? #f
946 #:options `(#:references-graphs ((,graph ,os))
947 #:substitutable? ,substitutable?))))
948
949
950;;
951;; Image creation.
952;;
953
954(define (image->root-file-system image)
955 "Return the IMAGE root partition file-system type."
956 (case (image-format image)
957 ((iso9660) "iso9660")
958 ((docker tarball wsl2) "dummy")
959 (else
960 (partition-file-system (find-root-partition image)))))
961
962(define (root-size image)
963 "Return the root partition size of IMAGE."
964 (let* ((image-size (image-size image))
965 (root-partition (find-root-partition image))
966 (root-size (partition-size root-partition)))
967 (cond
968 ((and (eq? root-size 'guess) image-size)
969 image-size)
970 (else root-size))))
971
972(define* (image-with-os* base-image os)
973 "Return an image based on BASE-IMAGE but with the operating-system field set
974to OS. Also set the UUID and the size of the root partition."
975 (define root-file-system
976 (srfi-1:find
977 (lambda (fs)
978 (string=? (file-system-mount-point fs) "/"))
979 (operating-system-file-systems os)))
980
981 (image
982 (inherit base-image)
983 (operating-system os)
984 (partitions
985 (map (lambda (p)
986 (if (root-partition? p)
987 (partition
988 (inherit p)
989 (uuid (file-system-device root-file-system))
990 (size (root-size base-image)))
991 p))
992 (image-partitions base-image)))))
993
994(define (operating-system-for-image image)
995 "Return an operating-system based on the one specified in IMAGE, but
996suitable for image creation. Assign an UUID to the root file-system, so that
997it can be used for bootloading."
998 (define volatile-root? (if (eq? (image-format image) 'iso9660)
999 #t
1000 (image-volatile-root? image)))
1001
1002 (define (root-uuid os)
1003 ;; UUID of the root file system, computed in a deterministic fashion.
1004 ;; This is what we use to locate the root file system so it has to be
1005 ;; different from the user's own file system UUIDs.
1006 (let ((type (if (eq? (image-format image) 'iso9660)
1007 'iso9660
1008 'dce)))
1009 (operating-system-uuid os type)))
1010
1011 (let* ((root-file-system-type (image->root-file-system image))
1012 (base-os (image-operating-system image))
1013 (esp-partition (find-esp-partition image))
1014 ;; In case the user has added /boot/efi file-system,
1015 ;; try to respect it and add a file-system pointing
1016 ;; to the correct esp.
1017 (wants-boot-efi? (and
1018 (srfi-1:any
1019 (lambda (fs)
1020 (let ((mount-point (file-system-mount-point fs)))
1021 (string=? mount-point "/boot/efi")))
1022 (operating-system-file-systems base-os))
1023 esp-partition))
1024 ;; Replace root file system with one with proper UUID that the
1025 ;; target image will have. Similarly for /boot/efi.
1026 (file-systems-to-keep
1027 (srfi-1:remove
1028 (lambda (fs)
1029 (let ((mount-point (file-system-mount-point fs)))
1030 (or (string=? mount-point "/")
1031 (string=? mount-point "/boot/efi"))))
1032 (operating-system-file-systems base-os)))
1033 (format (image-format image))
1034 (os
1035 (operating-system
1036 (inherit base-os)
1037 (initrd (lambda (file-systems . rest)
1038 (apply (operating-system-initrd base-os)
1039 file-systems
1040 #:volatile-root? volatile-root?
1041 rest)))
1042 ;; Only replace with grub-mkrescue-bootloader if grub-pc
1043 ;; is supported. AArch64 doesn't support it. In such
1044 ;; cases, respect bootloader of the system. Still,
1045 ;; for now make-iso9660-image installs only GRUB.
1046 (bootloader (if (and (eq? format 'iso9660)
1047 (supported-package? grub-hybrid))
1048 (bootloader-configuration
1049 (inherit
1050 (operating-system-bootloader base-os))
1051 (bootloader grub-mkrescue-bootloader))
1052 (operating-system-bootloader base-os)))
1053 (file-systems (cons (file-system
1054 (mount-point "/")
1055 (device "/dev/placeholder")
1056 (type root-file-system-type))
1057 file-systems-to-keep))))
1058 (uuid (root-uuid os)))
1059 (operating-system
1060 (inherit os)
1061 (file-systems (append
1062 (list (file-system
1063 (mount-point "/")
1064 (device uuid)
1065 (type root-file-system-type)))
1066 (if wants-boot-efi?
1067 (list (file-system
1068 (mount-point "/boot/efi")
1069 (type "vfat")
1070 (device (file-system-label
1071 (partition-label esp-partition)))))
1072 '())
1073 file-systems-to-keep)))))
1074
1075(define* (system-image image)
1076 "Return the derivation of IMAGE. It can be a raw disk-image or an ISO9660
1077image, depending on IMAGE format."
1078 (define platform (image-platform image))
1079
1080 ;; The image platform definition may provide the appropriate "system"
1081 ;; architecture for the image. If we are already running on this system,
1082 ;; the image can be built natively. If we are running on a different
1083 ;; system, then we need to cross-compile, using the "target" provided by the
1084 ;; image definition.
1085 (define system (and=> platform platform-system))
1086 (define target (cond
1087 ;; No defined platform, let's use the user defined
1088 ;; system/target parameters.
1089 ((not platform)
1090 (%current-target-system))
1091 ;; The current system is the same as the platform system, no
1092 ;; need to cross-compile.
1093 ((and system
1094 (string=? system (%current-system)))
1095 #f)
1096 ;; If there is a user defined target let's override the
1097 ;; platform target. Otherwise, we can cross-compile to the
1098 ;; platform target.
1099 (else
1100 (or (%current-target-system)
1101 (and=> platform platform-target)))))
1102
1103 (with-parameters ((%current-target-system target))
1104 (let* ((os (operating-system-for-image image))
1105 (image* (image-with-os* image os))
1106 (image-format (image-format image))
1107 (register-closures? (has-guix-service-type? os))
1108 (bootcfg (operating-system-bootcfg os))
1109 (bootloader (bootloader-configuration-bootloader
1110 (operating-system-bootloader os))))
1111 (cond
1112 ((memq image-format '(disk-image compressed-qcow2))
1113 (system-disk-image image*
1114 #:bootcfg bootcfg
1115 #:bootloader bootloader
1116 #:register-closures? register-closures?
1117 #:inputs `(("system" ,os)
1118 ("bootcfg" ,bootcfg))))
1119 ((memq image-format '(docker))
1120 (system-docker-image image*))
1121 ((memq image-format '(tarball))
1122 (system-tarball-image image*))
1123 ((memq image-format '(wsl2))
1124 (system-tarball-image image* #:wsl? #t))
1125 ((memq image-format '(iso9660))
1126 (system-iso9660-image
1127 image*
1128 #:bootcfg bootcfg
1129 #:bootloader bootloader
1130 #:register-closures? register-closures?
1131 #:inputs `(("system" ,os)
1132 ("bootcfg" ,bootcfg))
1133 ;; Make sure to use a mode that does no imply
1134 ;; HFS+ tree creation that may fail with:
1135 ;;
1136 ;; "libisofs: FAILURE : Too much files to mangle,
1137 ;; cannot guarantee unique file names"
1138 ;;
1139 ;; This happens if some limits are exceeded, see:
1140 ;; https://lists.gnu.org/archive/html/grub-devel/2020-06/msg00048.html
1141 #:grub-mkrescue-environment
1142 '(("MKRESCUE_SED_MODE" . "mbr_only"))))
1143 (else
1144 (raise (formatted-message
1145 (G_ "~a: unsupported image format") image-format)))))))
1146
1147
1148;;;
1149;;; Image type discovery.
1150;;;
1151
1152(define (image-modules)
1153 "Return the list of image modules."
1154 (cons (resolve-interface '(gnu system image))
1155 (modules-from-current-profile "gnu/system/images"
1156 #:warn warn-about-load-error)))
1157
1158(define %image-types
1159 ;; The list of publically-known image types.
1160 (delay (fold-module-public-variables (lambda (obj result)
1161 (if (image-type? obj)
1162 (cons obj result)
1163 result))
1164 '()
1165 (image-modules))))
1166
1167(define (lookup-image-type-by-name name)
1168 "Return the image type called NAME."
1169 (or (srfi-1:find (lambda (image-type)
1170 (eq? name (image-type-name image-type)))
1171 (force %image-types))
1172 (raise
1173 (formatted-message (G_ "~a: no such image type") name))))
1174
1175;;; image.scm ends here