Commit | Line | Data |
---|---|---|
f19cf27c MO |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> | |
3 | ;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org> | |
4 | ;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name> | |
5 | ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com> | |
6 | ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> | |
7 | ;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com> | |
8 | ;;; | |
9 | ;;; This file is part of GNU Guix. | |
10 | ;;; | |
11 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
12 | ;;; under the terms of the GNU General Public License as published by | |
13 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
14 | ;;; your option) any later version. | |
15 | ;;; | |
16 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
17 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
18 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
19 | ;;; GNU General Public License for more details. | |
20 | ;;; | |
21 | ;;; You should have received a copy of the GNU General Public License | |
22 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
23 | ||
24 | (define-module (gnu build image) | |
25 | #:use-module (guix build store-copy) | |
26 | #:use-module (guix build syscalls) | |
27 | #:use-module (guix build utils) | |
28 | #:use-module (guix store database) | |
29 | #:use-module (gnu build bootloader) | |
30 | #:use-module (gnu build install) | |
31 | #:use-module (gnu build linux-boot) | |
32 | #:use-module (gnu image) | |
33 | #:use-module (gnu system uuid) | |
34 | #:use-module (ice-9 ftw) | |
35 | #:use-module (ice-9 match) | |
36 | #:use-module (srfi srfi-19) | |
37 | #:use-module (srfi srfi-34) | |
38 | #:use-module (srfi srfi-35) | |
39 | #:export (make-partition-image | |
40 | genimage | |
41 | initialize-efi-partition | |
42 | initialize-root-partition | |
43 | ||
44 | make-iso9660-image)) | |
45 | ||
46 | (define (sexp->partition sexp) | |
47 | "Take SEXP, a tuple as returned by 'partition->gexp', and turn it into a | |
48 | <partition> record." | |
49 | (match sexp | |
bd3716f6 | 50 | ((size file-system file-system-options label uuid) |
f19cf27c MO |
51 | (partition (size size) |
52 | (file-system file-system) | |
bd3716f6 | 53 | (file-system-options file-system-options) |
f19cf27c MO |
54 | (label label) |
55 | (uuid uuid))))) | |
56 | ||
57 | (define (size-in-kib size) | |
58 | "Convert SIZE expressed in bytes, to kilobytes and return it as a string." | |
59 | (number->string | |
60 | (inexact->exact (ceiling (/ size 1024))))) | |
61 | ||
62 | (define (estimate-partition-size root) | |
63 | "Given the ROOT directory, evalute and return its size. As this doesn't | |
64 | take the partition metadata size into account, take a 25% margin." | |
65 | (* 1.25 (file-size root))) | |
66 | ||
16f9124d MO |
67 | (define* (make-ext-image partition target root |
68 | #:key | |
69 | (owner-uid 0) | |
70 | (owner-gid 0)) | |
71 | "Handle the creation of EXT2/3/4 partition images. See | |
72 | 'make-partition-image'." | |
f19cf27c | 73 | (let ((size (partition-size partition)) |
16f9124d | 74 | (fs (partition-file-system partition)) |
bd3716f6 | 75 | (fs-options (partition-file-system-options partition)) |
f19cf27c MO |
76 | (label (partition-label partition)) |
77 | (uuid (partition-uuid partition)) | |
bd3716f6 MO |
78 | (journal-options "lazy_itable_init=1,lazy_journal_init=1")) |
79 | (apply invoke | |
80 | `("mke2fs" "-t" ,fs "-d" ,root | |
81 | "-L" ,label "-U" ,(uuid->string uuid) | |
82 | "-E" ,(format #f "root_owner=~a:~a,~a" | |
83 | owner-uid owner-gid journal-options) | |
84 | ,@fs-options | |
85 | ,target | |
86 | ,(format #f "~ak" | |
87 | (size-in-kib | |
88 | (if (eq? size 'guess) | |
89 | (estimate-partition-size root) | |
90 | size))))))) | |
f19cf27c MO |
91 | |
92 | (define* (make-vfat-image partition target root) | |
93 | "Handle the creation of VFAT partition images. See 'make-partition-image'." | |
94 | (let ((size (partition-size partition)) | |
95 | (label (partition-label partition))) | |
96 | (invoke "mkdosfs" "-n" label "-C" target "-F" "16" "-S" "1024" | |
97 | (size-in-kib | |
98 | (if (eq? size 'guess) | |
99 | (estimate-partition-size root) | |
100 | size))) | |
101 | (for-each (lambda (file) | |
102 | (unless (member file '("." "..")) | |
103 | (invoke "mcopy" "-bsp" "-i" target | |
104 | (string-append root "/" file) | |
105 | (string-append "::" file)))) | |
106 | (scandir root)))) | |
107 | ||
108 | (define* (make-partition-image partition-sexp target root) | |
109 | "Create and return the image of PARTITION-SEXP as TARGET. Use the given | |
110 | ROOT directory to populate the image." | |
111 | (let* ((partition (sexp->partition partition-sexp)) | |
112 | (type (partition-file-system partition))) | |
113 | (cond | |
16f9124d MO |
114 | ((string-prefix? "ext" type) |
115 | (make-ext-image partition target root)) | |
f19cf27c MO |
116 | ((string=? type "vfat") |
117 | (make-vfat-image partition target root)) | |
118 | (else | |
119 | (format (current-error-port) | |
120 | "Unsupported partition type~%."))))) | |
121 | ||
122 | (define* (genimage config target) | |
123 | "Use genimage to generate in TARGET directory, the image described in the | |
124 | given CONFIG file." | |
125 | ;; genimage needs a 'root' directory. | |
126 | (mkdir "root") | |
127 | (invoke "genimage" "--config" config | |
128 | "--outputpath" target)) | |
129 | ||
130 | (define* (register-closure prefix closure | |
131 | #:key | |
132 | (deduplicate? #t) (reset-timestamps? #t) | |
133 | (schema (sql-schema))) | |
134 | "Register CLOSURE in PREFIX, where PREFIX is the directory name of the | |
135 | target store and CLOSURE is the name of a file containing a reference graph as | |
136 | produced by #:references-graphs.. As a side effect, if RESET-TIMESTAMPS? is | |
137 | true, reset timestamps on store files and, if DEDUPLICATE? is true, | |
138 | deduplicates files common to CLOSURE and the rest of PREFIX." | |
139 | (let ((items (call-with-input-file closure read-reference-graph))) | |
140 | (register-items items | |
141 | #:prefix prefix | |
142 | #:deduplicate? deduplicate? | |
143 | #:reset-timestamps? reset-timestamps? | |
144 | #:registration-time %epoch | |
145 | #:schema schema))) | |
146 | ||
147 | (define* (initialize-efi-partition root | |
148 | #:key | |
149 | bootloader-package | |
150 | #:allow-other-keys) | |
151 | "Install in ROOT directory, an EFI loader using BOOTLOADER-PACKAGE." | |
152 | (install-efi-loader bootloader-package root)) | |
153 | ||
154 | (define* (initialize-root-partition root | |
155 | #:key | |
156 | bootcfg | |
157 | bootcfg-location | |
9c1adb24 MO |
158 | bootloader-package |
159 | bootloader-installer | |
f19cf27c MO |
160 | (deduplicate? #t) |
161 | references-graphs | |
162 | (register-closures? #t) | |
163 | system-directory | |
164 | #:allow-other-keys) | |
165 | "Initialize the given ROOT directory. Use BOOTCFG and BOOTCFG-LOCATION to | |
166 | install the bootloader configuration. | |
167 | ||
168 | If REGISTER-CLOSURES? is true, register REFERENCES-GRAPHS in the store. If | |
169 | DEDUPLICATE? is true, then also deduplicate files common to CLOSURES and the | |
170 | rest of the store when registering the closures. SYSTEM-DIRECTORY is the name | |
171 | of the directory of the 'system' derivation." | |
172 | (populate-root-file-system system-directory root) | |
173 | (populate-store references-graphs root) | |
174 | ||
175 | (when register-closures? | |
176 | (for-each (lambda (closure) | |
177 | (register-closure root | |
178 | closure | |
179 | #:reset-timestamps? #t | |
180 | #:deduplicate? deduplicate?)) | |
181 | references-graphs)) | |
182 | ||
9c1adb24 MO |
183 | (when bootloader-installer |
184 | (display "installing bootloader...\n") | |
185 | (bootloader-installer bootloader-package #f root)) | |
f19cf27c MO |
186 | (when bootcfg |
187 | (install-boot-config bootcfg bootcfg-location root))) | |
188 | ||
189 | (define* (make-iso9660-image xorriso grub-mkrescue-environment | |
190 | grub bootcfg system-directory root target | |
191 | #:key (volume-id "Guix_image") (volume-uuid #f) | |
192 | register-closures? (references-graphs '()) | |
193 | (compression? #t)) | |
194 | "Given a GRUB package, creates an iso image as TARGET, using BOOTCFG as | |
195 | GRUB configuration and OS-DRV as the stuff in it." | |
196 | (define grub-mkrescue | |
197 | (string-append grub "/bin/grub-mkrescue")) | |
198 | ||
199 | (define grub-mkrescue-sed.sh | |
200 | (string-append (getcwd) "/" "grub-mkrescue-sed.sh")) | |
201 | ||
202 | ;; Use a modified version of grub-mkrescue-sed.sh, see below. | |
203 | (copy-file (string-append xorriso | |
204 | "/bin/grub-mkrescue-sed.sh") | |
205 | grub-mkrescue-sed.sh) | |
206 | ||
207 | ;; Force grub-mkrescue-sed.sh to use the build directory instead of /tmp | |
208 | ;; that is read-only inside the build container. | |
209 | (substitute* grub-mkrescue-sed.sh | |
210 | (("/tmp/") (string-append (getcwd) "/")) | |
211 | (("MKRESCUE_SED_XORRISO_ARGS \\$x") | |
212 | (format #f "MKRESCUE_SED_XORRISO_ARGS $(echo $x | sed \"s|/tmp|~a|\")" | |
213 | (getcwd)))) | |
214 | ||
215 | ;; 'grub-mkrescue' calls out to mtools programs to create 'efi.img', a FAT | |
216 | ;; file system image, and mtools honors SOURCE_DATE_EPOCH for the mtime of | |
217 | ;; those files. The epoch for FAT is Jan. 1st 1980, not 1970, so choose | |
218 | ;; that. | |
219 | (setenv "SOURCE_DATE_EPOCH" | |
220 | (number->string | |
221 | (time-second | |
222 | (date->time-utc (make-date 0 0 0 0 1 1 1980 0))))) | |
223 | ||
224 | ;; Our patched 'grub-mkrescue' honors this environment variable and passes | |
225 | ;; it to 'mformat', which makes it the serial number of 'efi.img'. This | |
226 | ;; allows for deterministic builds. | |
227 | (setenv "GRUB_FAT_SERIAL_NUMBER" | |
228 | (number->string (if volume-uuid | |
229 | ||
230 | ;; On 32-bit systems the 2nd argument must be | |
231 | ;; lower than 2^32. | |
232 | (string-hash (iso9660-uuid->string volume-uuid) | |
233 | (- (expt 2 32) 1)) | |
234 | ||
235 | #x77777777) | |
236 | 16)) | |
237 | ||
238 | (setenv "MKRESCUE_SED_MODE" "original") | |
239 | (setenv "MKRESCUE_SED_XORRISO" (string-append xorriso "/bin/xorriso")) | |
240 | (setenv "MKRESCUE_SED_IN_EFI_NO_PT" "yes") | |
241 | ||
242 | (for-each (match-lambda | |
243 | ((name . value) (setenv name value))) | |
244 | grub-mkrescue-environment) | |
245 | ||
246 | (apply invoke grub-mkrescue | |
247 | (string-append "--xorriso=" grub-mkrescue-sed.sh) | |
248 | "-o" target | |
249 | (string-append "boot/grub/grub.cfg=" bootcfg) | |
250 | root | |
251 | "--" | |
252 | ;; Set all timestamps to 1. | |
253 | "-volume_date" "all_file_dates" "=1" | |
254 | ||
255 | `(,@(if compression? | |
256 | '(;; ‘zisofs’ compression reduces the total image size by | |
257 | ;; ~60%. | |
258 | "-zisofs" "level=9:block_size=128k" ; highest compression | |
259 | ;; It's transparent to our Linux-Libre kernel but not to | |
260 | ;; GRUB. Don't compress the kernel, initrd, and other | |
261 | ;; files read by grub.cfg, as well as common | |
262 | ;; already-compressed file names. | |
263 | "-find" "/" "-type" "f" | |
264 | ;; XXX Even after "--" above, and despite documentation | |
265 | ;; claiming otherwise, "-or" is stolen by grub-mkrescue | |
266 | ;; which then chokes on it (as ‘-o …’) and dies. Don't use | |
267 | ;; "-or". | |
268 | "-not" "-wholename" "/boot/*" | |
269 | "-not" "-wholename" "/System/*" | |
270 | "-not" "-name" "unicode.pf2" | |
271 | "-not" "-name" "bzImage" | |
272 | "-not" "-name" "*.gz" ; initrd & all man pages | |
273 | "-not" "-name" "*.png" ; includes grub-image.png | |
274 | "-exec" "set_filter" "--zisofs" | |
275 | "--") | |
276 | '()) | |
277 | "-volid" ,(string-upcase volume-id) | |
278 | ,@(if volume-uuid | |
279 | `("-volume_date" "uuid" | |
280 | ,(string-filter (lambda (value) | |
281 | (not (char=? #\- value))) | |
282 | (iso9660-uuid->string | |
283 | volume-uuid))) | |
284 | '())))) |