projects/guix·blob ruby-team · refs

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