Commit | Line | Data |
---|---|---|
f19cf27c MO |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com> | |
7ca533c7 | 3 | ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> |
f19cf27c MO |
4 | ;;; |
5 | ;;; This file is part of GNU Guix. | |
6 | ;;; | |
7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
8 | ;;; under the terms of the GNU General Public License as published by | |
9 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
10 | ;;; your option) any later version. | |
11 | ;;; | |
12 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;;; GNU General Public License for more details. | |
16 | ;;; | |
17 | ;;; You should have received a copy of the GNU General Public License | |
18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
19 | ||
20 | (define-module (gnu system image) | |
10b135ce MO |
21 | #:use-module (guix diagnostics) |
22 | #:use-module (guix discovery) | |
f19cf27c MO |
23 | #:use-module (guix gexp) |
24 | #:use-module (guix modules) | |
25 | #:use-module (guix monads) | |
26 | #:use-module (guix records) | |
27 | #:use-module (guix store) | |
28 | #:use-module (guix ui) | |
29 | #:use-module (guix utils) | |
30 | #:use-module ((guix self) #:select (make-config.scm)) | |
31 | #:use-module (gnu bootloader) | |
32 | #:use-module (gnu bootloader grub) | |
33 | #:use-module (gnu image) | |
34 | #:use-module (gnu services) | |
35 | #:use-module (gnu services base) | |
36 | #:use-module (gnu system) | |
37 | #:use-module (gnu system file-systems) | |
38 | #:use-module (gnu system uuid) | |
39 | #:use-module (gnu system vm) | |
40 | #:use-module (guix packages) | |
41 | #:use-module (gnu packages base) | |
42 | #:use-module (gnu packages bootloaders) | |
43 | #:use-module (gnu packages cdrom) | |
44 | #:use-module (gnu packages disk) | |
45 | #:use-module (gnu packages gawk) | |
46 | #:use-module (gnu packages genimage) | |
47 | #:use-module (gnu packages guile) | |
48 | #:autoload (gnu packages gnupg) (guile-gcrypt) | |
c77b9285 | 49 | #:use-module (gnu packages hurd) |
f19cf27c MO |
50 | #:use-module (gnu packages linux) |
51 | #:use-module (gnu packages mtools) | |
f441e3e8 | 52 | #:use-module (gnu packages virtualization) |
f19cf27c MO |
53 | #:use-module ((srfi srfi-1) #:prefix srfi-1:) |
54 | #:use-module (srfi srfi-11) | |
55 | #:use-module (srfi srfi-26) | |
281869e6 | 56 | #:use-module (srfi srfi-34) |
f19cf27c MO |
57 | #:use-module (srfi srfi-35) |
58 | #:use-module (rnrs bytevectors) | |
f441e3e8 | 59 | #:use-module (ice-9 format) |
f19cf27c | 60 | #:use-module (ice-9 match) |
b904b59c MO |
61 | #:export (root-offset |
62 | root-label | |
63 | ||
64 | esp-partition | |
f19cf27c MO |
65 | root-partition |
66 | ||
67 | efi-disk-image | |
68 | iso9660-image | |
c0458011 | 69 | arm32-disk-image |
599954c1 | 70 | arm64-disk-image |
f19cf27c | 71 | |
10b135ce MO |
72 | image-with-os |
73 | raw-image-type | |
23ad7e92 | 74 | qcow2-image-type |
10b135ce MO |
75 | iso-image-type |
76 | uncompressed-iso-image-type | |
c0458011 | 77 | arm32-image-type |
599954c1 | 78 | arm64-image-type |
10b135ce MO |
79 | |
80 | image-with-label | |
036f23f0 | 81 | system-image |
10b135ce MO |
82 | |
83 | %image-types | |
84 | lookup-image-type-by-name)) | |
f19cf27c MO |
85 | |
86 | \f | |
87 | ;;; | |
88 | ;;; Images definitions. | |
89 | ;;; | |
90 | ||
b7b45372 MO |
91 | ;; This is the offset before the first partition. GRUB will install itself in |
92 | ;; this post-MBR gap. | |
93 | (define root-offset (* 512 2048)) | |
94 | ||
95 | ;; Generic root partition label. | |
96 | (define root-label "Guix_image") | |
97 | ||
f19cf27c MO |
98 | (define esp-partition |
99 | (partition | |
100 | (size (* 40 (expt 2 20))) | |
b7b45372 | 101 | (offset root-offset) |
f19cf27c MO |
102 | (label "GNU-ESP") ;cosmetic only |
103 | ;; Use "vfat" here since this property is used when mounting. The actual | |
104 | ;; FAT-ness is based on file system size (16 in this case). | |
105 | (file-system "vfat") | |
106 | (flags '(esp)) | |
107 | (initializer (gexp initialize-efi-partition)))) | |
108 | ||
109 | (define root-partition | |
110 | (partition | |
111 | (size 'guess) | |
b7b45372 | 112 | (label root-label) |
f19cf27c MO |
113 | (file-system "ext4") |
114 | (flags '(boot)) | |
115 | (initializer (gexp initialize-root-partition)))) | |
116 | ||
117 | (define efi-disk-image | |
118 | (image | |
119 | (format 'disk-image) | |
120 | (partitions (list esp-partition root-partition)))) | |
121 | ||
122 | (define iso9660-image | |
123 | (image | |
124 | (format 'iso9660) | |
125 | (partitions | |
126 | (list (partition | |
127 | (size 'guess) | |
128 | (label "GUIX_IMAGE") | |
f56144e1 | 129 | (flags '(boot))))))) |
f19cf27c | 130 | |
c0458011 | 131 | (define arm32-disk-image |
599954c1 MO |
132 | (image |
133 | (format 'disk-image) | |
c0458011 | 134 | (target "arm-linux-gnueabihf") |
599954c1 MO |
135 | (partitions |
136 | (list (partition | |
137 | (inherit root-partition) | |
138 | (offset root-offset)))) | |
139 | ;; FIXME: Deleting and creating "/var/run" and "/tmp" on the overlayfs | |
140 | ;; fails. | |
141 | (volatile-root? #f))) | |
142 | ||
c0458011 MO |
143 | (define arm64-disk-image |
144 | (image | |
145 | (inherit arm32-disk-image) | |
146 | (target "aarch64-linux-gnu"))) | |
147 | ||
f19cf27c | 148 | \f |
10b135ce MO |
149 | ;;; |
150 | ;;; Images types. | |
151 | ;;; | |
152 | ||
153 | (define-syntax-rule (image-with-os base-image os) | |
154 | "Return an image inheriting from BASE-IMAGE, with the operating-system field | |
155 | set to the given OS." | |
156 | (image | |
157 | (inherit base-image) | |
158 | (operating-system os))) | |
159 | ||
160 | (define raw-image-type | |
161 | (image-type | |
162 | (name 'raw) | |
163 | (constructor (cut image-with-os efi-disk-image <>)))) | |
164 | ||
23ad7e92 MO |
165 | (define qcow2-image-type |
166 | (image-type | |
167 | (name 'qcow2) | |
168 | (constructor (cut image-with-os | |
169 | (image | |
170 | (inherit efi-disk-image) | |
171 | (name 'image.qcow2) | |
172 | (format 'compressed-qcow2)) | |
173 | <>)))) | |
174 | ||
10b135ce MO |
175 | (define iso-image-type |
176 | (image-type | |
177 | (name 'iso9660) | |
178 | (constructor (cut image-with-os iso9660-image <>)))) | |
179 | ||
180 | (define uncompressed-iso-image-type | |
181 | (image-type | |
182 | (name 'uncompressed-iso9660) | |
183 | (constructor (cut image-with-os | |
184 | (image | |
185 | (inherit iso9660-image) | |
186 | (compression? #f)) | |
187 | <>)))) | |
188 | ||
c0458011 MO |
189 | (define arm32-image-type |
190 | (image-type | |
191 | (name 'arm32-raw) | |
192 | (constructor (cut image-with-os arm32-disk-image <>)))) | |
193 | ||
599954c1 MO |
194 | (define arm64-image-type |
195 | (image-type | |
c0458011 | 196 | (name 'arm64-raw) |
599954c1 MO |
197 | (constructor (cut image-with-os arm64-disk-image <>)))) |
198 | ||
10b135ce | 199 | \f |
f19cf27c MO |
200 | ;; |
201 | ;; Helpers. | |
202 | ;; | |
203 | ||
204 | (define not-config? | |
205 | ;; Select (guix …) and (gnu …) modules, except (guix config). | |
206 | (match-lambda | |
207 | (('guix 'config) #f) | |
208 | (('guix rest ...) #t) | |
209 | (('gnu rest ...) #t) | |
210 | (rest #f))) | |
211 | ||
212 | (define (partition->gexp partition) | |
213 | "Turn PARTITION, a <partition> object, into a list-valued gexp suitable for | |
214 | 'make-partition-image'." | |
215 | #~'(#$@(list (partition-size partition)) | |
216 | #$(partition-file-system partition) | |
bd3716f6 | 217 | #$(partition-file-system-options partition) |
f19cf27c MO |
218 | #$(partition-label partition) |
219 | #$(and=> (partition-uuid partition) | |
220 | uuid-bytevector))) | |
221 | ||
222 | (define gcrypt-sqlite3&co | |
223 | ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs. | |
224 | (srfi-1:append-map | |
225 | (lambda (package) | |
226 | (cons package | |
227 | (match (package-transitive-propagated-inputs package) | |
228 | (((labels packages) ...) | |
229 | packages)))) | |
dac7dd1b | 230 | (list guile-gcrypt guile-sqlite3))) |
f19cf27c MO |
231 | |
232 | (define-syntax-rule (with-imported-modules* gexp* ...) | |
233 | (with-extensions gcrypt-sqlite3&co | |
234 | (with-imported-modules `(,@(source-module-closure | |
235 | '((gnu build vm) | |
236 | (gnu build image) | |
b97b423e | 237 | (gnu build bootloader) |
b37c5441 | 238 | (gnu build hurd-boot) |
c77b9285 | 239 | (gnu build linux-boot) |
f19cf27c MO |
240 | (guix store database)) |
241 | #:select? not-config?) | |
242 | ((guix config) => ,(make-config.scm))) | |
243 | #~(begin | |
244 | (use-modules (gnu build vm) | |
245 | (gnu build image) | |
b97b423e | 246 | (gnu build bootloader) |
b37c5441 | 247 | (gnu build hurd-boot) |
c77b9285 | 248 | (gnu build linux-boot) |
f19cf27c MO |
249 | (guix store database) |
250 | (guix build utils)) | |
251 | gexp* ...)))) | |
252 | ||
7feefb3b MO |
253 | (define (root-partition? partition) |
254 | "Return true if PARTITION is the root partition, false otherwise." | |
255 | (member 'boot (partition-flags partition))) | |
256 | ||
257 | (define (find-root-partition image) | |
258 | "Return the root partition of the given IMAGE." | |
259 | (srfi-1:find root-partition? (image-partitions image))) | |
260 | ||
261 | (define (root-partition-index image) | |
262 | "Return the index of the root partition of the given IMAGE." | |
263 | (1+ (srfi-1:list-index root-partition? (image-partitions image)))) | |
264 | ||
f19cf27c MO |
265 | \f |
266 | ;; | |
267 | ;; Disk image. | |
268 | ;; | |
269 | ||
270 | (define* (system-disk-image image | |
271 | #:key | |
272 | (name "disk-image") | |
273 | bootcfg | |
274 | bootloader | |
275 | register-closures? | |
276 | (inputs '())) | |
277 | "Return as a file-like object, the disk-image described by IMAGE. Said | |
278 | image can be copied on a USB stick as is. BOOTLOADER is the bootloader that | |
279 | will be installed and configured according to BOOTCFG parameter. | |
280 | ||
281 | Raw images of the IMAGE partitions are first created. Then, genimage is used | |
282 | to assemble the partition images into a disk-image without resorting to a | |
283 | virtual machine. | |
284 | ||
285 | INPUTS is a list of inputs (as for packages). When REGISTER-CLOSURES? is | |
286 | true, register INPUTS in the store database of the image so that Guix can be | |
287 | used in the image." | |
288 | ||
289 | (define genimage-name "image") | |
290 | ||
291 | (define (image->genimage-cfg image) | |
292 | ;; Return as a file-like object, the genimage configuration file | |
293 | ;; describing the given IMAGE. | |
294 | (define (format->image-type format) | |
295 | ;; Return the genimage format corresponding to FORMAT. For now, only | |
296 | ;; the hdimage format (raw disk-image) is supported. | |
f441e3e8 MO |
297 | (cond |
298 | ((memq format '(disk-image compressed-qcow2)) "hdimage") | |
f19cf27c MO |
299 | (else |
300 | (raise (condition | |
301 | (&message | |
302 | (message | |
303 | (format #f (G_ "Unsupported image type ~a~%.") format)))))))) | |
304 | ||
305 | (define (partition->dos-type partition) | |
306 | ;; Return the MBR partition type corresponding to the given PARTITION. | |
307 | ;; See: https://en.wikipedia.org/wiki/Partition_type. | |
308 | (let ((flags (partition-flags partition))) | |
309 | (cond | |
310 | ((member 'esp flags) "0xEF") | |
311 | (else "0x83")))) | |
312 | ||
313 | (define (partition-image partition) | |
314 | ;; Return as a file-like object, an image of the given PARTITION. A | |
315 | ;; directory, filled by calling the PARTITION initializer procedure, is | |
316 | ;; first created within the store. Then, an image of this directory is | |
317 | ;; created using tools such as 'mke2fs' or 'mkdosfs', depending on the | |
318 | ;; partition file-system type. | |
319 | (let* ((os (image-operating-system image)) | |
320 | (schema (local-file (search-path %load-path | |
321 | "guix/store/schema.sql"))) | |
322 | (graph (match inputs | |
323 | (((names . _) ...) | |
324 | names))) | |
7f75a7ec MO |
325 | (type (partition-file-system partition)) |
326 | (image-builder | |
f19cf27c | 327 | (with-imported-modules* |
7f75a7ec | 328 | (let ((initializer #$(partition-initializer partition)) |
fd45ecb5 | 329 | (inputs '#+(list e2fsprogs fakeroot dosfstools mtools)) |
7f75a7ec | 330 | (image-root "tmp-root")) |
f19cf27c MO |
331 | (sql-schema #$schema) |
332 | ||
7f75a7ec MO |
333 | (set-path-environment-variable "PATH" '("bin" "sbin") inputs) |
334 | ||
f19cf27c MO |
335 | ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be |
336 | ;; decoded. | |
337 | (setenv "GUIX_LOCPATH" | |
338 | #+(file-append glibc-utf8-locales "/lib/locale")) | |
339 | (setlocale LC_ALL "en_US.utf8") | |
340 | ||
7f75a7ec | 341 | (initializer image-root |
f19cf27c MO |
342 | #:references-graphs '#$graph |
343 | #:deduplicate? #f | |
344 | #:system-directory #$os | |
05f37c16 | 345 | #:grub-efi #+grub-efi |
f19cf27c | 346 | #:bootloader-package |
9c1adb24 MO |
347 | #+(bootloader-package bootloader) |
348 | #:bootloader-installer | |
349 | #+(bootloader-installer bootloader) | |
f19cf27c MO |
350 | #:bootcfg #$bootcfg |
351 | #:bootcfg-location | |
7f75a7ec | 352 | #$(bootloader-configuration-file bootloader)) |
f19cf27c MO |
353 | (make-partition-image #$(partition->gexp partition) |
354 | #$output | |
7f75a7ec MO |
355 | image-root))))) |
356 | (computed-file "partition.img" image-builder | |
99efa804 LC |
357 | ;; Allow offloading so that this I/O-intensive process |
358 | ;; doesn't run on the build farm's head node. | |
359 | #:local-build? #f | |
6d6e74ea | 360 | #:options `(#:references-graphs ,inputs)))) |
f19cf27c MO |
361 | |
362 | (define (partition->config partition) | |
363 | ;; Return the genimage partition configuration for PARTITION. | |
364 | (let ((label (partition-label partition)) | |
365 | (dos-type (partition->dos-type partition)) | |
1b4fa785 MO |
366 | (image (partition-image partition)) |
367 | (offset (partition-offset partition))) | |
f19cf27c | 368 | #~(format #f "~/partition ~a { |
7d4ecda6 MO |
369 | ~/~/partition-type = ~a |
370 | ~/~/image = \"~a\" | |
371 | ~/~/offset = \"~a\" | |
372 | ~/}" | |
1b4fa785 MO |
373 | #$label |
374 | #$dos-type | |
375 | #$image | |
1dd7b87f | 376 | #$offset))) |
f19cf27c MO |
377 | |
378 | (let* ((format (image-format image)) | |
379 | (image-type (format->image-type format)) | |
380 | (partitions (image-partitions image)) | |
381 | (partitions-config (map partition->config partitions)) | |
382 | (builder | |
383 | #~(begin | |
384 | (let ((format (@ (ice-9 format) format))) | |
385 | (call-with-output-file #$output | |
386 | (lambda (port) | |
387 | (format port | |
388 | "\ | |
389 | image ~a { | |
390 | ~/~a {} | |
391 | ~{~a~^~%~} | |
392 | }~%" #$genimage-name #$image-type (list #$@partitions-config)))))))) | |
393 | (computed-file "genimage.cfg" builder))) | |
394 | ||
f27bec10 MO |
395 | (let* ((image-name (image-name image)) |
396 | (name (if image-name | |
397 | (symbol->string image-name) | |
398 | name)) | |
f441e3e8 | 399 | (format (image-format image)) |
5980ec8a | 400 | (substitutable? (image-substitutable? image)) |
f19cf27c MO |
401 | (builder |
402 | (with-imported-modules* | |
f441e3e8 | 403 | (let ((inputs '#+(list genimage coreutils findutils qemu-minimal)) |
7feefb3b | 404 | (bootloader-installer |
f441e3e8 MO |
405 | #+(bootloader-disk-image-installer bootloader)) |
406 | (out-image (string-append "images/" #$genimage-name))) | |
f19cf27c | 407 | (set-path-environment-variable "PATH" '("bin" "sbin") inputs) |
f441e3e8 | 408 | (genimage #$(image->genimage-cfg image)) |
7feefb3b MO |
409 | ;; Install the bootloader directly on the disk-image. |
410 | (when bootloader-installer | |
411 | (bootloader-installer | |
412 | #+(bootloader-package bootloader) | |
413 | #$(root-partition-index image) | |
f441e3e8 MO |
414 | out-image)) |
415 | (convert-disk-image out-image '#$format #$output))))) | |
416 | (computed-file name builder | |
f9926c07 | 417 | #:local-build? #f ;too I/O-intensive |
6d6e74ea | 418 | #:options `(#:substitutable? ,substitutable?)))) |
f19cf27c MO |
419 | |
420 | \f | |
421 | ;; | |
422 | ;; ISO9660 image. | |
423 | ;; | |
424 | ||
425 | (define (has-guix-service-type? os) | |
426 | "Return true if OS contains a service of the type GUIX-SERVICE-TYPE." | |
427 | (not (not (srfi-1:find (lambda (service) | |
428 | (eq? (service-kind service) guix-service-type)) | |
429 | (operating-system-services os))))) | |
430 | ||
431 | (define* (system-iso9660-image image | |
432 | #:key | |
0996fcc6 | 433 | (name "image.iso") |
f19cf27c MO |
434 | bootcfg |
435 | bootloader | |
436 | register-closures? | |
437 | (inputs '()) | |
438 | (grub-mkrescue-environment '())) | |
439 | "Return as a file-like object a bootable, stand-alone iso9660 image. | |
440 | ||
441 | INPUTS is a list of inputs (as for packages). When REGISTER-CLOSURES? is | |
442 | true, register INPUTS in the store database of the image so that Guix can be | |
443 | used in the image. " | |
444 | (define root-label | |
445 | (match (image-partitions image) | |
446 | ((partition) | |
447 | (partition-label partition)))) | |
448 | ||
449 | (define root-uuid | |
450 | (match (image-partitions image) | |
451 | ((partition) | |
452 | (uuid-bytevector (partition-uuid partition))))) | |
453 | ||
454 | (let* ((os (image-operating-system image)) | |
455 | (bootloader (bootloader-package bootloader)) | |
456 | (compression? (image-compression? image)) | |
457 | (substitutable? (image-substitutable? image)) | |
458 | (schema (local-file (search-path %load-path | |
459 | "guix/store/schema.sql"))) | |
460 | (graph (match inputs | |
461 | (((names . _) ...) | |
462 | names))) | |
f19cf27c MO |
463 | (builder |
464 | (with-imported-modules* | |
465 | (let* ((inputs '#$(list parted e2fsprogs dosfstools xorriso | |
1cb9effc MO |
466 | sed grep coreutils findutils gawk)) |
467 | (image-root "tmp-root")) | |
468 | (sql-schema #$schema) | |
469 | ||
470 | ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded. | |
471 | (setenv "GUIX_LOCPATH" | |
472 | #+(file-append glibc-utf8-locales "/lib/locale")) | |
473 | ||
474 | (setlocale LC_ALL "en_US.utf8") | |
475 | ||
f19cf27c | 476 | (set-path-environment-variable "PATH" '("bin" "sbin") inputs) |
1cb9effc MO |
477 | |
478 | (initialize-root-partition image-root | |
479 | #:references-graphs '#$graph | |
480 | #:deduplicate? #f | |
481 | #:system-directory #$os) | |
f19cf27c MO |
482 | (make-iso9660-image #$xorriso |
483 | '#$grub-mkrescue-environment | |
484 | #$bootloader | |
485 | #$bootcfg | |
486 | #$os | |
1cb9effc | 487 | image-root |
f19cf27c MO |
488 | #$output |
489 | #:references-graphs '#$graph | |
490 | #:register-closures? #$register-closures? | |
491 | #:compression? #$compression? | |
492 | #:volume-id #$root-label | |
493 | #:volume-uuid #$root-uuid))))) | |
494 | (computed-file name builder | |
99efa804 LC |
495 | ;; Allow offloading so that this I/O-intensive process |
496 | ;; doesn't run on the build farm's head node. | |
497 | #:local-build? #f | |
6d6e74ea | 498 | #:options `(#:references-graphs ,inputs |
f19cf27c MO |
499 | #:substitutable? ,substitutable?)))) |
500 | ||
036f23f0 JL |
501 | (define (image-with-label base-image label) |
502 | "The volume ID of an ISO is the label of the first partition. This procedure | |
503 | returns an image record where the first partition's label is set to <label>." | |
504 | (image | |
505 | (inherit base-image) | |
506 | (partitions | |
507 | (match (image-partitions base-image) | |
508 | ((boot others ...) | |
509 | (cons | |
510 | (partition | |
511 | (inherit boot) | |
512 | (label label)) | |
513 | others)))))) | |
514 | ||
f19cf27c MO |
515 | \f |
516 | ;; | |
517 | ;; Image creation. | |
518 | ;; | |
519 | ||
f19cf27c MO |
520 | (define (image->root-file-system image) |
521 | "Return the IMAGE root partition file-system type." | |
522 | (let ((format (image-format image))) | |
523 | (if (eq? format 'iso9660) | |
524 | "iso9660" | |
525 | (partition-file-system (find-root-partition image))))) | |
526 | ||
527 | (define (root-size image) | |
528 | "Return the root partition size of IMAGE." | |
529 | (let* ((image-size (image-size image)) | |
530 | (root-partition (find-root-partition image)) | |
531 | (root-size (partition-size root-partition))) | |
532 | (cond | |
533 | ((and (eq? root-size 'guess) image-size) | |
534 | image-size) | |
535 | (else root-size)))) | |
536 | ||
10b135ce | 537 | (define* (image-with-os* base-image os) |
f19cf27c MO |
538 | "Return an image based on BASE-IMAGE but with the operating-system field set |
539 | to OS. Also set the UUID and the size of the root partition." | |
540 | (define root-file-system | |
541 | (srfi-1:find | |
542 | (lambda (fs) | |
543 | (string=? (file-system-mount-point fs) "/")) | |
544 | (operating-system-file-systems os))) | |
545 | ||
74938105 MO |
546 | (image |
547 | (inherit base-image) | |
548 | (operating-system os) | |
549 | (partitions | |
550 | (map (lambda (p) | |
551 | (if (root-partition? p) | |
552 | (partition | |
553 | (inherit p) | |
554 | (uuid (file-system-device root-file-system)) | |
555 | (size (root-size base-image))) | |
556 | p)) | |
557 | (image-partitions base-image))))) | |
f19cf27c MO |
558 | |
559 | (define (operating-system-for-image image) | |
560 | "Return an operating-system based on the one specified in IMAGE, but | |
561 | suitable for image creation. Assign an UUID to the root file-system, so that | |
562 | it can be used for bootloading." | |
563 | (define volatile-root? (image-volatile-root? image)) | |
564 | ||
565 | (define (root-uuid os) | |
566 | ;; UUID of the root file system, computed in a deterministic fashion. | |
567 | ;; This is what we use to locate the root file system so it has to be | |
568 | ;; different from the user's own file system UUIDs. | |
569 | (let ((type (if (eq? (image-format image) 'iso9660) | |
570 | 'iso9660 | |
571 | 'dce))) | |
572 | (operating-system-uuid os type))) | |
573 | ||
574 | (let* ((root-file-system-type (image->root-file-system image)) | |
575 | (base-os (image-operating-system image)) | |
576 | (file-systems-to-keep | |
577 | (srfi-1:remove | |
578 | (lambda (fs) | |
1ec366cd MC |
579 | (let ((mount-point (file-system-mount-point fs))) |
580 | (or (string=? mount-point "/") | |
581 | (string=? mount-point "/boot/efi")))) | |
f19cf27c MO |
582 | (operating-system-file-systems base-os))) |
583 | (format (image-format image)) | |
584 | (os | |
585 | (operating-system | |
586 | (inherit base-os) | |
587 | (initrd (lambda (file-systems . rest) | |
588 | (apply (operating-system-initrd base-os) | |
589 | file-systems | |
590 | #:volatile-root? volatile-root? | |
591 | rest))) | |
592 | (bootloader (if (eq? format 'iso9660) | |
593 | (bootloader-configuration | |
594 | (inherit | |
595 | (operating-system-bootloader base-os)) | |
596 | (bootloader grub-mkrescue-bootloader)) | |
597 | (operating-system-bootloader base-os))) | |
598 | (file-systems (cons (file-system | |
599 | (mount-point "/") | |
600 | (device "/dev/placeholder") | |
601 | (type root-file-system-type)) | |
602 | file-systems-to-keep)))) | |
603 | (uuid (root-uuid os))) | |
604 | (operating-system | |
605 | (inherit os) | |
606 | (file-systems (cons (file-system | |
607 | (mount-point "/") | |
608 | (device uuid) | |
609 | (type root-file-system-type)) | |
610 | file-systems-to-keep))))) | |
611 | ||
e3f0155c | 612 | (define* (system-image image) |
f19cf27c MO |
613 | "Return the derivation of IMAGE. It can be a raw disk-image or an ISO9660 |
614 | image, depending on IMAGE format." | |
615 | (define substitutable? (image-substitutable? image)) | |
c9f6e2e5 MO |
616 | (define target (image-target image)) |
617 | ||
618 | (with-parameters ((%current-target-system target)) | |
619 | (let* ((os (operating-system-for-image image)) | |
10b135ce | 620 | (image* (image-with-os* image os)) |
f441e3e8 | 621 | (image-format (image-format image)) |
c9f6e2e5 MO |
622 | (register-closures? (has-guix-service-type? os)) |
623 | (bootcfg (operating-system-bootcfg os)) | |
624 | (bootloader (bootloader-configuration-bootloader | |
625 | (operating-system-bootloader os)))) | |
f441e3e8 MO |
626 | (cond |
627 | ((memq image-format '(disk-image compressed-qcow2)) | |
f292d471 MO |
628 | (system-disk-image image* |
629 | #:bootcfg bootcfg | |
630 | #:bootloader bootloader | |
631 | #:register-closures? register-closures? | |
632 | #:inputs `(("system" ,os) | |
633 | ("bootcfg" ,bootcfg)))) | |
f441e3e8 | 634 | ((memq image-format '(iso9660)) |
f292d471 MO |
635 | (system-iso9660-image |
636 | image* | |
637 | #:bootcfg bootcfg | |
638 | #:bootloader bootloader | |
639 | #:register-closures? register-closures? | |
640 | #:inputs `(("system" ,os) | |
641 | ("bootcfg" ,bootcfg)) | |
642 | ;; Make sure to use a mode that does no imply | |
643 | ;; HFS+ tree creation that may fail with: | |
644 | ;; | |
645 | ;; "libisofs: FAILURE : Too much files to mangle, | |
646 | ;; cannot guarantee unique file names" | |
647 | ;; | |
648 | ;; This happens if some limits are exceeded, see: | |
649 | ;; https://lists.gnu.org/archive/html/grub-devel/2020-06/msg00048.html | |
650 | #:grub-mkrescue-environment | |
651 | '(("MKRESCUE_SED_MODE" . "mbr_only")))))))) | |
f19cf27c | 652 | |
10b135ce MO |
653 | \f |
654 | ;; | |
655 | ;; Image detection. | |
656 | ;; | |
657 | ||
658 | (define (image-modules) | |
659 | "Return the list of image modules." | |
660 | (cons (resolve-interface '(gnu system image)) | |
661 | (all-modules (map (lambda (entry) | |
662 | `(,entry . "gnu/system/images/")) | |
663 | %load-path) | |
664 | #:warn warn-about-load-error))) | |
665 | ||
666 | (define %image-types | |
667 | ;; The list of publically-known image types. | |
668 | (delay (fold-module-public-variables (lambda (obj result) | |
669 | (if (image-type? obj) | |
670 | (cons obj result) | |
671 | result)) | |
672 | '() | |
673 | (image-modules)))) | |
674 | ||
675 | (define (lookup-image-type-by-name name) | |
676 | "Return the image type called NAME." | |
677 | (or (srfi-1:find (lambda (image-type) | |
678 | (eq? name (image-type-name image-type))) | |
679 | (force %image-types)) | |
680 | (raise | |
281869e6 | 681 | (formatted-message (G_ "~a: no such image type") name)))) |
f19cf27c MO |
682 | |
683 | ;;; image.scm ends here |