Commit | Line | Data |
---|---|---|
f19cf27c MO |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com> | |
3 | ;;; | |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
7 | ;;; under the terms of the GNU General Public License as published by | |
8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
9 | ;;; your option) any later version. | |
10 | ;;; | |
11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;;; GNU General Public License for more details. | |
15 | ;;; | |
16 | ;;; You should have received a copy of the GNU General Public License | |
17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
18 | ||
19 | (define-module (gnu system image) | |
20 | #:use-module (guix gexp) | |
21 | #:use-module (guix modules) | |
22 | #:use-module (guix monads) | |
23 | #:use-module (guix records) | |
24 | #:use-module (guix store) | |
25 | #:use-module (guix ui) | |
26 | #:use-module (guix utils) | |
27 | #:use-module ((guix self) #:select (make-config.scm)) | |
28 | #:use-module (gnu bootloader) | |
29 | #:use-module (gnu bootloader grub) | |
30 | #:use-module (gnu image) | |
31 | #:use-module (gnu services) | |
32 | #:use-module (gnu services base) | |
33 | #:use-module (gnu system) | |
34 | #:use-module (gnu system file-systems) | |
35 | #:use-module (gnu system uuid) | |
36 | #:use-module (gnu system vm) | |
37 | #:use-module (guix packages) | |
38 | #:use-module (gnu packages base) | |
39 | #:use-module (gnu packages bootloaders) | |
40 | #:use-module (gnu packages cdrom) | |
41 | #:use-module (gnu packages disk) | |
42 | #:use-module (gnu packages gawk) | |
43 | #:use-module (gnu packages genimage) | |
44 | #:use-module (gnu packages guile) | |
45 | #:autoload (gnu packages gnupg) (guile-gcrypt) | |
46 | #:use-module (gnu packages linux) | |
47 | #:use-module (gnu packages mtools) | |
48 | #:use-module ((srfi srfi-1) #:prefix srfi-1:) | |
49 | #:use-module (srfi srfi-11) | |
50 | #:use-module (srfi srfi-26) | |
51 | #:use-module (srfi srfi-35) | |
52 | #:use-module (rnrs bytevectors) | |
53 | #:use-module (ice-9 match) | |
54 | #:export (esp-partition | |
55 | root-partition | |
56 | ||
57 | efi-disk-image | |
58 | iso9660-image | |
59 | ||
60 | find-image | |
61 | system-image)) | |
62 | ||
63 | \f | |
64 | ;;; | |
65 | ;;; Images definitions. | |
66 | ;;; | |
67 | ||
68 | (define esp-partition | |
69 | (partition | |
70 | (size (* 40 (expt 2 20))) | |
71 | (label "GNU-ESP") ;cosmetic only | |
72 | ;; Use "vfat" here since this property is used when mounting. The actual | |
73 | ;; FAT-ness is based on file system size (16 in this case). | |
74 | (file-system "vfat") | |
75 | (flags '(esp)) | |
76 | (initializer (gexp initialize-efi-partition)))) | |
77 | ||
78 | (define root-partition | |
79 | (partition | |
80 | (size 'guess) | |
81 | (label "Guix_image") | |
82 | (file-system "ext4") | |
83 | (flags '(boot)) | |
84 | (initializer (gexp initialize-root-partition)))) | |
85 | ||
86 | (define efi-disk-image | |
87 | (image | |
88 | (format 'disk-image) | |
89 | (partitions (list esp-partition root-partition)))) | |
90 | ||
91 | (define iso9660-image | |
92 | (image | |
93 | (format 'iso9660) | |
94 | (partitions | |
95 | (list (partition | |
96 | (size 'guess) | |
97 | (label "GUIX_IMAGE") | |
98 | (flags '(boot))))) | |
99 | ;; XXX: Temporarily disable compression to speed-up the tests. | |
100 | (compression? #f))) | |
101 | ||
102 | \f | |
103 | ;; | |
104 | ;; Helpers. | |
105 | ;; | |
106 | ||
107 | (define not-config? | |
108 | ;; Select (guix …) and (gnu …) modules, except (guix config). | |
109 | (match-lambda | |
110 | (('guix 'config) #f) | |
111 | (('guix rest ...) #t) | |
112 | (('gnu rest ...) #t) | |
113 | (rest #f))) | |
114 | ||
115 | (define (partition->gexp partition) | |
116 | "Turn PARTITION, a <partition> object, into a list-valued gexp suitable for | |
117 | 'make-partition-image'." | |
118 | #~'(#$@(list (partition-size partition)) | |
119 | #$(partition-file-system partition) | |
bd3716f6 | 120 | #$(partition-file-system-options partition) |
f19cf27c MO |
121 | #$(partition-label partition) |
122 | #$(and=> (partition-uuid partition) | |
123 | uuid-bytevector))) | |
124 | ||
125 | (define gcrypt-sqlite3&co | |
126 | ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs. | |
127 | (srfi-1:append-map | |
128 | (lambda (package) | |
129 | (cons package | |
130 | (match (package-transitive-propagated-inputs package) | |
131 | (((labels packages) ...) | |
132 | packages)))) | |
133 | (list guile-gcrypt guile-sqlite3))) | |
134 | ||
135 | (define-syntax-rule (with-imported-modules* gexp* ...) | |
136 | (with-extensions gcrypt-sqlite3&co | |
137 | (with-imported-modules `(,@(source-module-closure | |
138 | '((gnu build vm) | |
139 | (gnu build image) | |
140 | (guix store database)) | |
141 | #:select? not-config?) | |
142 | ((guix config) => ,(make-config.scm))) | |
143 | #~(begin | |
144 | (use-modules (gnu build vm) | |
145 | (gnu build image) | |
146 | (guix store database) | |
147 | (guix build utils)) | |
148 | gexp* ...)))) | |
149 | ||
150 | \f | |
151 | ;; | |
152 | ;; Disk image. | |
153 | ;; | |
154 | ||
155 | (define* (system-disk-image image | |
156 | #:key | |
157 | (name "disk-image") | |
158 | bootcfg | |
159 | bootloader | |
160 | register-closures? | |
161 | (inputs '())) | |
162 | "Return as a file-like object, the disk-image described by IMAGE. Said | |
163 | image can be copied on a USB stick as is. BOOTLOADER is the bootloader that | |
164 | will be installed and configured according to BOOTCFG parameter. | |
165 | ||
166 | Raw images of the IMAGE partitions are first created. Then, genimage is used | |
167 | to assemble the partition images into a disk-image without resorting to a | |
168 | virtual machine. | |
169 | ||
170 | INPUTS is a list of inputs (as for packages). When REGISTER-CLOSURES? is | |
171 | true, register INPUTS in the store database of the image so that Guix can be | |
172 | used in the image." | |
173 | ||
174 | (define genimage-name "image") | |
175 | ||
176 | (define (image->genimage-cfg image) | |
177 | ;; Return as a file-like object, the genimage configuration file | |
178 | ;; describing the given IMAGE. | |
179 | (define (format->image-type format) | |
180 | ;; Return the genimage format corresponding to FORMAT. For now, only | |
181 | ;; the hdimage format (raw disk-image) is supported. | |
182 | (case format | |
183 | ((disk-image) "hdimage") | |
184 | (else | |
185 | (raise (condition | |
186 | (&message | |
187 | (message | |
188 | (format #f (G_ "Unsupported image type ~a~%.") format)))))))) | |
189 | ||
190 | (define (partition->dos-type partition) | |
191 | ;; Return the MBR partition type corresponding to the given PARTITION. | |
192 | ;; See: https://en.wikipedia.org/wiki/Partition_type. | |
193 | (let ((flags (partition-flags partition))) | |
194 | (cond | |
195 | ((member 'esp flags) "0xEF") | |
196 | (else "0x83")))) | |
197 | ||
198 | (define (partition-image partition) | |
199 | ;; Return as a file-like object, an image of the given PARTITION. A | |
200 | ;; directory, filled by calling the PARTITION initializer procedure, is | |
201 | ;; first created within the store. Then, an image of this directory is | |
202 | ;; created using tools such as 'mke2fs' or 'mkdosfs', depending on the | |
203 | ;; partition file-system type. | |
204 | (let* ((os (image-operating-system image)) | |
205 | (schema (local-file (search-path %load-path | |
206 | "guix/store/schema.sql"))) | |
207 | (graph (match inputs | |
208 | (((names . _) ...) | |
209 | names))) | |
210 | (root-builder | |
211 | (with-imported-modules* | |
212 | (let* ((initializer #$(partition-initializer partition))) | |
213 | (sql-schema #$schema) | |
214 | ||
215 | ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be | |
216 | ;; decoded. | |
217 | (setenv "GUIX_LOCPATH" | |
218 | #+(file-append glibc-utf8-locales "/lib/locale")) | |
219 | (setlocale LC_ALL "en_US.utf8") | |
220 | ||
221 | (initializer #$output | |
222 | #:references-graphs '#$graph | |
223 | #:deduplicate? #f | |
224 | #:system-directory #$os | |
225 | #:bootloader-package | |
226 | #$(bootloader-package bootloader) | |
227 | #:bootcfg #$bootcfg | |
228 | #:bootcfg-location | |
229 | #$(bootloader-configuration-file bootloader))))) | |
230 | (image-root | |
231 | (computed-file "partition-image-root" root-builder | |
232 | #:options `(#:references-graphs ,inputs))) | |
233 | (type (partition-file-system partition)) | |
234 | (image-builder | |
235 | (with-imported-modules* | |
1dbd0005 | 236 | (let ((inputs '#+(list e2fsprogs dosfstools mtools))) |
f19cf27c MO |
237 | (set-path-environment-variable "PATH" '("bin" "sbin") inputs) |
238 | (make-partition-image #$(partition->gexp partition) | |
239 | #$output | |
240 | #$image-root))))) | |
241 | (computed-file "partition.img" image-builder))) | |
242 | ||
243 | (define (partition->config partition) | |
244 | ;; Return the genimage partition configuration for PARTITION. | |
245 | (let ((label (partition-label partition)) | |
246 | (dos-type (partition->dos-type partition)) | |
1b4fa785 MO |
247 | (image (partition-image partition)) |
248 | (offset (partition-offset partition))) | |
f19cf27c MO |
249 | #~(format #f "~/partition ~a { |
250 | ~/~/partition-type = ~a | |
251 | ~/~/image = \"~a\" | |
1b4fa785 MO |
252 | ~/~/offset = \"~a\" |
253 | ~/}" | |
254 | #$label | |
255 | #$dos-type | |
256 | #$image | |
1dd7b87f | 257 | #$offset))) |
f19cf27c MO |
258 | |
259 | (let* ((format (image-format image)) | |
260 | (image-type (format->image-type format)) | |
261 | (partitions (image-partitions image)) | |
262 | (partitions-config (map partition->config partitions)) | |
263 | (builder | |
264 | #~(begin | |
265 | (let ((format (@ (ice-9 format) format))) | |
266 | (call-with-output-file #$output | |
267 | (lambda (port) | |
268 | (format port | |
269 | "\ | |
270 | image ~a { | |
271 | ~/~a {} | |
272 | ~{~a~^~%~} | |
273 | }~%" #$genimage-name #$image-type (list #$@partitions-config)))))))) | |
274 | (computed-file "genimage.cfg" builder))) | |
275 | ||
276 | (let* ((substitutable? (image-substitutable? image)) | |
277 | (builder | |
278 | (with-imported-modules* | |
1dbd0005 | 279 | (let ((inputs '#+(list genimage coreutils findutils))) |
f19cf27c MO |
280 | (set-path-environment-variable "PATH" '("bin" "sbin") inputs) |
281 | (genimage #$(image->genimage-cfg image) #$output)))) | |
282 | (image-dir (computed-file "image-dir" builder))) | |
283 | (computed-file name | |
284 | #~(symlink | |
285 | (string-append #$image-dir "/" #$genimage-name) | |
286 | #$output) | |
287 | #:options `(#:substitutable? ,substitutable?)))) | |
288 | ||
289 | \f | |
290 | ;; | |
291 | ;; ISO9660 image. | |
292 | ;; | |
293 | ||
294 | (define (has-guix-service-type? os) | |
295 | "Return true if OS contains a service of the type GUIX-SERVICE-TYPE." | |
296 | (not (not (srfi-1:find (lambda (service) | |
297 | (eq? (service-kind service) guix-service-type)) | |
298 | (operating-system-services os))))) | |
299 | ||
300 | (define* (system-iso9660-image image | |
301 | #:key | |
302 | (name "iso9660-image") | |
303 | bootcfg | |
304 | bootloader | |
305 | register-closures? | |
306 | (inputs '()) | |
307 | (grub-mkrescue-environment '())) | |
308 | "Return as a file-like object a bootable, stand-alone iso9660 image. | |
309 | ||
310 | INPUTS is a list of inputs (as for packages). When REGISTER-CLOSURES? is | |
311 | true, register INPUTS in the store database of the image so that Guix can be | |
312 | used in the image. " | |
313 | (define root-label | |
314 | (match (image-partitions image) | |
315 | ((partition) | |
316 | (partition-label partition)))) | |
317 | ||
318 | (define root-uuid | |
319 | (match (image-partitions image) | |
320 | ((partition) | |
321 | (uuid-bytevector (partition-uuid partition))))) | |
322 | ||
323 | (let* ((os (image-operating-system image)) | |
324 | (bootloader (bootloader-package bootloader)) | |
325 | (compression? (image-compression? image)) | |
326 | (substitutable? (image-substitutable? image)) | |
327 | (schema (local-file (search-path %load-path | |
328 | "guix/store/schema.sql"))) | |
329 | (graph (match inputs | |
330 | (((names . _) ...) | |
331 | names))) | |
332 | (root-builder | |
333 | (with-imported-modules* | |
334 | (sql-schema #$schema) | |
335 | ||
336 | ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded. | |
337 | (setenv "GUIX_LOCPATH" | |
338 | #+(file-append glibc-utf8-locales "/lib/locale")) | |
339 | (setlocale LC_ALL "en_US.utf8") | |
340 | ||
341 | (initialize-root-partition #$output | |
342 | #:references-graphs '#$graph | |
343 | #:deduplicate? #f | |
344 | #:system-directory #$os))) | |
345 | (image-root | |
346 | (computed-file "image-root" root-builder | |
347 | #:options `(#:references-graphs ,inputs))) | |
348 | (builder | |
349 | (with-imported-modules* | |
350 | (let* ((inputs '#$(list parted e2fsprogs dosfstools xorriso | |
351 | sed grep coreutils findutils gawk))) | |
352 | (set-path-environment-variable "PATH" '("bin" "sbin") inputs) | |
353 | (make-iso9660-image #$xorriso | |
354 | '#$grub-mkrescue-environment | |
355 | #$bootloader | |
356 | #$bootcfg | |
357 | #$os | |
358 | #$image-root | |
359 | #$output | |
360 | #:references-graphs '#$graph | |
361 | #:register-closures? #$register-closures? | |
362 | #:compression? #$compression? | |
363 | #:volume-id #$root-label | |
364 | #:volume-uuid #$root-uuid))))) | |
365 | (computed-file name builder | |
366 | #:options `(#:references-graphs ,inputs | |
367 | #:substitutable? ,substitutable?)))) | |
368 | ||
369 | \f | |
370 | ;; | |
371 | ;; Image creation. | |
372 | ;; | |
373 | ||
374 | (define (root-partition? partition) | |
375 | "Return true if PARTITION is the root partition, false otherwise." | |
376 | (member 'boot (partition-flags partition))) | |
377 | ||
378 | (define (find-root-partition image) | |
379 | "Return the root partition of the given IMAGE." | |
380 | (srfi-1:find root-partition? (image-partitions image))) | |
381 | ||
382 | (define (image->root-file-system image) | |
383 | "Return the IMAGE root partition file-system type." | |
384 | (let ((format (image-format image))) | |
385 | (if (eq? format 'iso9660) | |
386 | "iso9660" | |
387 | (partition-file-system (find-root-partition image))))) | |
388 | ||
389 | (define (root-size image) | |
390 | "Return the root partition size of IMAGE." | |
391 | (let* ((image-size (image-size image)) | |
392 | (root-partition (find-root-partition image)) | |
393 | (root-size (partition-size root-partition))) | |
394 | (cond | |
395 | ((and (eq? root-size 'guess) image-size) | |
396 | image-size) | |
397 | (else root-size)))) | |
398 | ||
399 | (define* (image-with-os base-image os) | |
400 | "Return an image based on BASE-IMAGE but with the operating-system field set | |
401 | to OS. Also set the UUID and the size of the root partition." | |
402 | (define root-file-system | |
403 | (srfi-1:find | |
404 | (lambda (fs) | |
405 | (string=? (file-system-mount-point fs) "/")) | |
406 | (operating-system-file-systems os))) | |
407 | ||
408 | (let*-values (((partitions) (image-partitions base-image)) | |
409 | ((root-partition other-partitions) | |
410 | (srfi-1:partition root-partition? partitions))) | |
411 | (image | |
412 | (inherit base-image) | |
413 | (operating-system os) | |
414 | (partitions | |
415 | (cons (partition | |
416 | (inherit (car root-partition)) | |
417 | (uuid (file-system-device root-file-system)) | |
418 | (size (root-size base-image))) | |
419 | other-partitions))))) | |
420 | ||
421 | (define (operating-system-for-image image) | |
422 | "Return an operating-system based on the one specified in IMAGE, but | |
423 | suitable for image creation. Assign an UUID to the root file-system, so that | |
424 | it can be used for bootloading." | |
425 | (define volatile-root? (image-volatile-root? image)) | |
426 | ||
427 | (define (root-uuid os) | |
428 | ;; UUID of the root file system, computed in a deterministic fashion. | |
429 | ;; This is what we use to locate the root file system so it has to be | |
430 | ;; different from the user's own file system UUIDs. | |
431 | (let ((type (if (eq? (image-format image) 'iso9660) | |
432 | 'iso9660 | |
433 | 'dce))) | |
434 | (operating-system-uuid os type))) | |
435 | ||
436 | (let* ((root-file-system-type (image->root-file-system image)) | |
437 | (base-os (image-operating-system image)) | |
438 | (file-systems-to-keep | |
439 | (srfi-1:remove | |
440 | (lambda (fs) | |
441 | (string=? (file-system-mount-point fs) "/")) | |
442 | (operating-system-file-systems base-os))) | |
443 | (format (image-format image)) | |
444 | (os | |
445 | (operating-system | |
446 | (inherit base-os) | |
447 | (initrd (lambda (file-systems . rest) | |
448 | (apply (operating-system-initrd base-os) | |
449 | file-systems | |
450 | #:volatile-root? volatile-root? | |
451 | rest))) | |
452 | (bootloader (if (eq? format 'iso9660) | |
453 | (bootloader-configuration | |
454 | (inherit | |
455 | (operating-system-bootloader base-os)) | |
456 | (bootloader grub-mkrescue-bootloader)) | |
457 | (operating-system-bootloader base-os))) | |
458 | (file-systems (cons (file-system | |
459 | (mount-point "/") | |
460 | (device "/dev/placeholder") | |
461 | (type root-file-system-type)) | |
462 | file-systems-to-keep)))) | |
463 | (uuid (root-uuid os))) | |
464 | (operating-system | |
465 | (inherit os) | |
466 | (file-systems (cons (file-system | |
467 | (mount-point "/") | |
468 | (device uuid) | |
469 | (type root-file-system-type)) | |
470 | file-systems-to-keep))))) | |
471 | ||
472 | (define* (make-system-image image) | |
473 | "Return the derivation of IMAGE. It can be a raw disk-image or an ISO9660 | |
474 | image, depending on IMAGE format." | |
475 | (define substitutable? (image-substitutable? image)) | |
476 | ||
477 | (let* ((os (operating-system-for-image image)) | |
478 | (image* (image-with-os image os)) | |
479 | (register-closures? (has-guix-service-type? os)) | |
480 | (bootcfg (operating-system-bootcfg os)) | |
481 | (bootloader (bootloader-configuration-bootloader | |
482 | (operating-system-bootloader os)))) | |
483 | (case (image-format image) | |
484 | ((disk-image) | |
485 | (system-disk-image image* | |
486 | #:bootcfg bootcfg | |
487 | #:bootloader bootloader | |
488 | #:register-closures? register-closures? | |
489 | #:inputs `(("system" ,os) | |
490 | ("bootcfg" ,bootcfg)))) | |
491 | ((iso9660) | |
492 | (system-iso9660-image image* | |
493 | #:bootcfg bootcfg | |
494 | #:bootloader bootloader | |
495 | #:register-closures? register-closures? | |
496 | #:inputs `(("system" ,os) | |
497 | ("bootcfg" ,bootcfg)) | |
498 | #:grub-mkrescue-environment | |
499 | '(("MKRESCUE_SED_MODE" . "mbr_hfs"))))))) | |
500 | ||
501 | (define (find-image file-system-type) | |
502 | "Find and return an image that could match the given FILE-SYSTEM-TYPE. This | |
503 | is useful to adapt to interfaces written before the addition of the <image> | |
504 | record." | |
505 | ;; XXX: Add support for system and target here, or in the caller. | |
506 | (match file-system-type | |
507 | ("iso9660" iso9660-image) | |
508 | (_ efi-disk-image))) | |
509 | ||
510 | (define (system-image image) | |
511 | "Wrap 'make-system-image' call, so that it is used only if the given IMAGE | |
512 | is supported. Otherwise, fallback to image creation in a VM. This is | |
513 | temporary and should be removed once 'make-system-image' is able to deal with | |
514 | all types of images." | |
515 | (define substitutable? (image-substitutable? image)) | |
516 | (define volatile-root? (image-volatile-root? image)) | |
517 | ||
518 | (let* ((image-os (image-operating-system image)) | |
519 | (image-root-filesystem-type (image->root-file-system image)) | |
520 | (bootloader (bootloader-configuration-bootloader | |
521 | (operating-system-bootloader image-os))) | |
522 | (bootloader-name (bootloader-name bootloader)) | |
523 | (size (image-size image)) | |
524 | (format (image-format image))) | |
525 | (mbegin %store-monad | |
526 | (if (and (or (eq? bootloader-name 'grub) | |
527 | (eq? bootloader-name 'extlinux)) | |
528 | (eq? format 'disk-image)) | |
529 | ;; Fallback to image creation in a VM when it is not yet supported | |
530 | ;; by this module. | |
531 | (system-disk-image-in-vm image-os | |
532 | #:disk-image-size size | |
533 | #:file-system-type image-root-filesystem-type | |
534 | #:volatile? volatile-root? | |
535 | #:substitutable? substitutable?) | |
536 | (lower-object | |
537 | (make-system-image image)))))) | |
538 | ||
539 | ;;; image.scm ends here |