projects/guix·blob python-team · refs

489 lines · 19.6 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2013-2020, 2025 Ludovic Courtès <[email protected]>
3;;; Copyright © 2016 Christine Lemmer-Webber <[email protected]>
4;;; Copyright © 2016, 2017 Leo Famulari <[email protected]>
5;;; Copyright © 2017 Marius Bakke <[email protected]>
6;;; Copyright © 2020, 2022 Tobias Geerinckx-Rice <[email protected]>
7;;; Copyright © 2020 Mathieu Othacehe <[email protected]>
8;;; Copyright © 2022 Pavel Shlyak <[email protected]>
9;;; Copyright © 2022, 2025 Denis 'GNUtoo' Carikli <[email protected]>
10;;; Copyright © 2023 Efraim Flashner <[email protected]>
11;;;
12;;; This file is part of GNU Guix.
13;;;
14;;; GNU Guix is free software; you can redistribute it and/or modify it
15;;; under the terms of the GNU General Public License as published by
16;;; the Free Software Foundation; either version 3 of the License, or (at
17;;; your option) any later version.
18;;;
19;;; GNU Guix is distributed in the hope that it will be useful, but
20;;; WITHOUT ANY WARRANTY; without even the implied warranty of
21;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22;;; GNU General Public License for more details.
23;;;
24;;; You should have received a copy of the GNU General Public License
25;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
26
27(define-module (gnu build image)
28 #:use-module (guix build store-copy)
29 #:use-module (guix build syscalls)
30 #:use-module (guix build utils)
31 #:use-module (guix store database)
32 #:use-module (guix utils)
33 #:use-module (gnu build bootloader)
34 #:use-module (gnu build install)
35 #:use-module (gnu build linux-boot)
36 #:use-module (gnu image)
37 #:use-module (gnu system uuid)
38 #:use-module (ice-9 ftw)
39 #:use-module (ice-9 match)
40 #:use-module (srfi srfi-19)
41 #:use-module (srfi srfi-34)
42 #:use-module (srfi srfi-35)
43 #:export (make-partition-image
44 convert-disk-image
45 genimage
46 initialize-efi-partition
47 initialize-efi32-partition
48 initialize-root-partition
49
50 make-iso9660-image))
51
52(define (sexp->partition sexp)
53 "Take SEXP, a tuple as returned by 'partition->gexp', and turn it into a
54<partition> record."
55 (match sexp
56 ((size file-system file-system-options label uuid flags)
57 (partition (size size)
58 (file-system file-system)
59 (file-system-options file-system-options)
60 (label label)
61 (uuid uuid)
62 (flags flags)))))
63
64(define (size-in-kib size)
65 "Convert SIZE expressed in bytes, to kilobytes and return it as a string."
66 (number->string
67 (inexact->exact (ceiling (/ size 1024)))))
68
69(define* (estimate-partition-size root #:optional (margin .25))
70 "Given the ROOT directory, evaluate and return its size. As this doesn't
71take the partition metadata size into account, take a MARGIN. As this in
72turn doesn't take any constant overhead into account, force a 1-MiB minimum."
73 (max (ash 1 20)
74 ;; without inexact->exact, 'guess can result in an error like that:
75 ;; "Wrong type (expecting exact integer): 7179941140.0".
76 (inexact->exact (round (* (+ 1. margin) (file-size root))))))
77
78(define* (make-btrfs-image partition target root)
79 "Handle the creation of BTRFS partition images. See
80'make-partition-image'."
81 (let ((size (partition-size partition))
82 (fs-options (partition-file-system-options partition))
83 (label (partition-label partition))
84 (uuid (partition-uuid partition)))
85 (apply invoke
86 `("unshare" "--map-root-user" "mkfs.btrfs"
87 "-r" ,root
88 "-L" ,label
89 ,@(if uuid
90 `("-U" ,(uuid->string uuid))
91 '())
92 "--shrink"
93 ,@fs-options
94 ,target))))
95
96(define* (make-erofs-image partition target root)
97 "Handle the creation of EROFS partition images. See 'make-partition-image'."
98 (let ((uuid (partition-uuid partition))
99 (label (partition-label partition))
100 (fs-options (partition-file-system-options partition)))
101 (apply invoke
102 `("fakeroot" "mkfs.erofs"
103 ;; GRUB doesn't support compression yet
104 ;; "-zlzma,level=109,dictsize=8388608"
105 ,@(if uuid
106 `("-U" ,(uuid->string uuid))
107 '())
108 ,@(if label
109 `("-L" ,label)
110 '())
111 ,@fs-options
112 ,target
113 ,root))))
114
115(define* (make-ext-image partition target root
116 #:key
117 (owner-uid 0)
118 (owner-gid 0))
119 "Handle the creation of EXT2/3/4 partition images. See
120'make-partition-image'."
121 (let ((size (partition-size partition))
122 (fs (partition-file-system partition))
123 (fs-options (partition-file-system-options partition))
124 (label (partition-label partition))
125 (uuid (partition-uuid partition))
126 (journal-options "lazy_itable_init=1,lazy_journal_init=1"))
127 (apply invoke
128 `("fakeroot" "mke2fs" "-t" ,fs "-d" ,root
129 "-L" ,label
130 ,@(if uuid
131 `("-U" ,(uuid->string uuid))
132 '())
133 "-E" ,(format #f "root_owner=~a:~a,~a"
134 owner-uid owner-gid journal-options)
135 ,@fs-options
136 ,target
137 ,(format #f "~ak"
138 (size-in-kib
139 (if (eq? size 'guess)
140 (estimate-partition-size root)
141 size)))))
142
143 ;; 'mke2fs' does not create directory indexes by default, meaning that
144 ;; directories have a limit of 65,000 sub-directories, which can be
145 ;; problematic for the store. To avoid that, run 'e2fsck -D' to create
146 ;; those directory indexes. See
147 ;; <https://github.com/tytso/e2fsprogs/issues/257>.
148 (invoke "e2fsck" "-fDy" target)))
149
150(define* (make-f2fs-image partition target root
151 #:key
152 (owner-uid 0)
153 (owner-gid 0))
154 "Handle the creation of F2FS partition images. See 'make-partition-image'."
155 (let ((size (partition-size partition))
156 (label (partition-label partition))
157 (uuid (partition-uuid partition))
158 (fs-options (partition-file-system-options partition)))
159 ;; The mkfs.f2fs utility can't create files, so we need to create one
160 ;; before running it.
161 (call-with-output-file target (const #t))
162 (truncate-file
163 target
164 (if (eq? size 'guess)
165 ;; The F2FS filesystem has more overhead than other filesystems like
166 ;; BTRFS and ext4.
167 (estimate-partition-size root .50)
168 size))
169 (apply invoke "fakeroot" "mkfs.f2fs"
170 "-l" label
171 "-R" (format #f "~a:~a" owner-uid owner-gid)
172 `(,@(if uuid
173 `("-U" ,(uuid->string uuid))
174 '())
175 ,@fs-options
176 ,target))
177 (invoke "fakeroot" "sload.f2fs" "-P" "-f" root target)))
178
179(define* (make-squashfs-image partition target root
180 #:key
181 (owner-uid 0)
182 (owner-gid 0))
183 "Handle the creation of SQUASHFS partition images. See 'make-partition-image'."
184 (let ((size (partition-size partition))
185 (label (partition-label partition))
186 (uuid (partition-uuid partition))
187 (fs-options (partition-file-system-options partition)))
188 (apply invoke "fakeroot" "mksquashfs"
189 root
190 target
191 "-root-uid" (number->string owner-uid)
192 "-root-gid" (number->string owner-gid)
193 "-comp" "xz"
194 "-Xdict-size" "100%"
195 `(,@fs-options))))
196
197(define* (make-vfat-image partition target root fs-bits)
198 "Handle the creation of VFAT partition images. See 'make-partition-image'."
199 (let ((size (partition-size partition))
200 (label (partition-label partition))
201 (flags (partition-flags partition))
202 (fs-options (partition-file-system-options partition)))
203 (apply invoke "fakeroot" "mkdosfs" "-n" label "-C" target
204 "-F" (number->string fs-bits)
205 (size-in-kib
206 (if (eq? size 'guess)
207 (estimate-partition-size root)
208 size))
209 ;; u-boot in particular needs the formatted block
210 ;; size and the physical block size to be equal.
211 ;; TODO: What about 4k blocks?
212 (if (and (member 'esp flags)
213 (not (member "-S" fs-options)))
214 (append (list "-S" "512") fs-options)
215 fs-options))
216 (for-each (lambda (file)
217 (unless (member file '("." ".."))
218 (invoke "mcopy" "-bsp" "-i" target
219 (string-append root "/" file)
220 (string-append "::" file))))
221 (scandir root))))
222
223(define* (make-swap-image partition target)
224 "Make a swap partition of a certain size."
225 (let ((size (partition-size partition))
226 (label (partition-label partition))
227 (uuid (partition-uuid partition))
228 (fs-options (partition-file-system-options partition)))
229 (apply invoke "fakeroot" "mkswap"
230 "--pagesize" "4096"
231 "--endianness" "little"
232 "-L" label
233 "--file" target
234 "--size" (number->string size)
235 `(,@(if uuid
236 `("-U" ,(uuid->string uuid))
237 '())
238 ,@fs-options))))
239
240(define* (make-unformatted-image partition target)
241 "Make an unformatted partition of a certain size."
242 (let ((size (partition-size partition)))
243 ;; Create the file and then truncate it to the desired size.
244 (with-output-to-file target
245 (lambda _ (display "")))
246 (truncate-file target size)))
247
248(define* (make-partition-image partition-sexp target root)
249 "Create and return the image of PARTITION-SEXP as TARGET. Use the given
250ROOT directory to populate the image."
251 (let* ((partition (sexp->partition partition-sexp))
252 (type (partition-file-system partition)))
253 (cond
254 ((string=? "btrfs" type)
255 (make-btrfs-image partition target root))
256 ((string=? type "erofs")
257 (make-erofs-image partition target root))
258 ((string-prefix? "ext" type)
259 (make-ext-image partition target root))
260 ((string=? "f2fs" type)
261 (make-f2fs-image partition target root))
262 ((or (string=? type "vfat") (string=? type "fat16"))
263 (make-vfat-image partition target root 16))
264 ((string=? type "fat32")
265 (make-vfat-image partition target root 32))
266 ((string=? type "squashfs")
267 (make-squashfs-image partition target root))
268 ((string=? "swap" type)
269 (make-swap-image partition target))
270 ((string=? type "unformatted")
271 (make-unformatted-image partition target))
272 (else
273 (raise (condition
274 (&message
275 (message "unsupported partition type"))))))))
276
277(define (convert-disk-image image format output)
278 "Convert IMAGE to OUTPUT according to the given FORMAT."
279 (case format
280 ((compressed-qcow2)
281 (invoke "qemu-img" "convert" "-c" "-f" "raw"
282 ;; The maximum number of co-routines is 16.
283 "-m" (number->string (min 16 (parallel-job-count)))
284 "-O" "qcow2"
285 "-o" "compression_type=zstd"
286 image output))
287 (else
288 (copy-file image output))))
289
290(define* (genimage config)
291 "Use genimage to generate in TARGET directory, the image described in the
292given CONFIG file."
293 ;; genimage needs a 'root' directory.
294 (mkdir "root")
295 (invoke "genimage" "--config" config))
296
297(define* (register-closure prefix closure
298 #:key
299 (schema (sql-schema))
300 (wal-mode? #t))
301 "Register CLOSURE in PREFIX, where PREFIX is the directory name of the
302target store and CLOSURE is the name of a file containing a reference graph as
303produced by #:references-graphs. Pass WAL-MODE? to call-with-database."
304 (let ((items (call-with-input-file closure read-reference-graph)))
305 (parameterize ((sql-schema schema))
306 (with-database (store-database-file #:prefix prefix) db
307 #:wal-mode? wal-mode?
308 (register-items db items
309 #:prefix prefix
310 #:registration-time %epoch)))))
311
312(define* (initialize-efi-partition root
313 #:key
314 grub-efi
315 #:allow-other-keys)
316 "Install in ROOT directory, an EFI loader using GRUB-EFI."
317 (install-efi-loader grub-efi root))
318
319(define* (initialize-efi32-partition root
320 #:key
321 grub-efi32
322 #:allow-other-keys)
323 "Install in ROOT directory, an EFI 32bit loader using GRUB-EFI32."
324 (install-efi-loader grub-efi32 root
325 #:targets (cond ((target-x86?)
326 '("i386-efi" . "BOOTIA32.EFI"))
327 ((target-arm?)
328 '("arm-efi" . "BOOTARM.EFI")))))
329
330(define* (initialize-root-partition root
331 #:key
332 bootcfg
333 bootcfg-location
334 bootloader-package
335 bootloader-installer
336 (copy-closures? #t)
337 (deduplicate? #t)
338 references-graphs
339 (register-closures? #t)
340 system-directory
341 make-device-nodes
342 (wal-mode? #t)
343 #:allow-other-keys)
344 "Initialize the given ROOT directory. Use BOOTCFG and BOOTCFG-LOCATION to
345install the bootloader configuration.
346
347If COPY-CLOSURES? is true, copy all of REFERENCES-GRAPHS to the partition. If
348REGISTER-CLOSURES? is true, register REFERENCES-GRAPHS in the store. If
349DEDUPLICATE? is true, then also deduplicate files common to CLOSURES and the
350rest of the store when registering the closures. SYSTEM-DIRECTORY is the name
351of the directory of the 'system' derivation. Pass WAL-MODE? to
352register-closure."
353 (define root-store
354 (string-append root (%store-directory)))
355
356 (define tmp-store ".tmp-store")
357
358 (populate-root-file-system system-directory root)
359
360 (when copy-closures?
361 (populate-store references-graphs root
362 #:deduplicate? deduplicate?))
363
364 ;; Populate /dev.
365 (when make-device-nodes
366 (make-device-nodes #:root root))
367
368 (when register-closures?
369 (unless copy-closures?
370 ;; XXX: 'register-closure' wants to palpate the things it registers, so
371 ;; create a symlink to the store.
372 (rename-file root-store tmp-store)
373 (symlink (%store-directory) root-store))
374
375 (for-each (lambda (closure)
376 (register-closure root closure
377 #:wal-mode? wal-mode?))
378 references-graphs)
379
380 (unless copy-closures?
381 (delete-file root-store)
382 (rename-file tmp-store root-store)))
383
384 ;; There's no point installing a bootloader if we do not populate the store.
385 (when copy-closures?
386 (when bootloader-installer
387 (display "installing bootloader...\n")
388 (bootloader-installer bootloader-package #f root))
389 (when bootcfg
390 (install-boot-config bootcfg bootcfg-location root))))
391
392(define* (make-iso9660-image xorriso grub-mkrescue-environment
393 grub bootcfg system-directory root target
394 #:key (volume-id "Guix_image") (volume-uuid #f)
395 register-closures? (references-graphs '())
396 (compression? #t))
397 "Given a GRUB package, creates an iso image as TARGET, using BOOTCFG as
398GRUB configuration and OS-DRV as the stuff in it."
399 (define grub-mkrescue
400 (string-append grub "/bin/grub-mkrescue"))
401
402 (define grub-mkrescue-sed.sh
403 (string-append (getcwd) "/" "grub-mkrescue-sed.sh"))
404
405 ;; Use a modified version of grub-mkrescue-sed.sh, see below.
406 (copy-file (string-append xorriso
407 "/bin/grub-mkrescue-sed.sh")
408 grub-mkrescue-sed.sh)
409
410 ;; Force grub-mkrescue-sed.sh to use the build directory instead of /tmp
411 ;; that is read-only inside the build container.
412 (substitute* grub-mkrescue-sed.sh
413 (("/tmp/") (string-append (getcwd) "/"))
414 (("MKRESCUE_SED_XORRISO_ARGS \\$x")
415 (format #f "MKRESCUE_SED_XORRISO_ARGS $(echo $x | sed \"s|/tmp|~a|\")"
416 (getcwd))))
417
418 ;; 'grub-mkrescue' calls out to mtools programs to create 'efi.img', a FAT
419 ;; file system image, and mtools honors SOURCE_DATE_EPOCH for the mtime of
420 ;; those files. The epoch for FAT is Jan. 1st 1980, not 1970, so choose
421 ;; that.
422 (setenv "SOURCE_DATE_EPOCH"
423 (number->string
424 (time-second
425 (date->time-utc (make-date 0 0 0 0 1 1 1980 0)))))
426
427 ;; Our patched 'grub-mkrescue' honors this environment variable and passes
428 ;; it to 'mformat', which makes it the serial number of 'efi.img'. This
429 ;; allows for deterministic builds.
430 (setenv "GRUB_FAT_SERIAL_NUMBER"
431 (number->string (if volume-uuid
432
433 ;; On 32-bit systems the 2nd argument must be
434 ;; lower than 2^32.
435 (string-hash (iso9660-uuid->string volume-uuid)
436 (- (expt 2 32) 1))
437
438 #x77777777)
439 16))
440
441 (setenv "MKRESCUE_SED_MODE" "original")
442 (setenv "MKRESCUE_SED_XORRISO" (string-append xorriso "/bin/xorriso"))
443 (setenv "MKRESCUE_SED_IN_EFI_NO_PT" "yes")
444
445 (for-each (match-lambda
446 ((name . value) (setenv name value)))
447 grub-mkrescue-environment)
448
449 (apply invoke grub-mkrescue
450 (string-append "--xorriso=" grub-mkrescue-sed.sh)
451 "-o" target
452 (string-append "boot/grub/grub.cfg=" bootcfg)
453 root
454 "--"
455 ;; Set all timestamps to 1.
456 "-volume_date" "all_file_dates" "=1"
457
458 `(,@(if compression?
459 '(;; ‘zisofs’ compression reduces the total image size by ~60%.
460 "-zisofs" "level=9:block_size=128k" ; highest compression
461 ;; It's transparent to our Linux-Libre kernel but not to
462 ;; GRUB. Don't compress the kernel, initrd, and other files
463 ;; read by grub.cfg, as well as common already-compressed
464 ;; file names.
465 "-find" "/" "-type" "f"
466 ;; XXX Even after "--" above, and despite documentation
467 ;; claiming otherwise, "-or" is stolen by grub-mkrescue which
468 ;; then chokes on it (as ‘-o …’) and dies. Don't use "-or".
469 "-not" "-wholename" "/boot/*"
470 "-not" "-wholename" "/System/*"
471 "-not" "-name" "unicode.pf2"
472 "-not" "-name" "bzImage"
473 "-not" "-name" "zImage"
474 "-not" "-name" "Image"
475 "-not" "-name" "vmlinuz"
476 "-not" "-name" "*.gz" ; initrd
477 "-not" "-name" "*.zst" ; all man pages
478 "-not" "-name" "*.png" ; includes grub-image.png
479 "-exec" "set_filter" "--zisofs"
480 "--")
481 '())
482 "-volid" ,(string-upcase volume-id)
483 ,@(if volume-uuid
484 `("-volume_date" "uuid"
485 ,(string-filter (lambda (value)
486 (not (char=? #\- value)))
487 (iso9660-uuid->string
488 volume-uuid)))
489 '()))))