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 | |
50 | ((size file-system label uuid) | |
51 | (partition (size size) | |
52 | (file-system file-system) | |
53 | (label label) | |
54 | (uuid uuid))))) | |
55 | ||
56 | (define (size-in-kib size) | |
57 | "Convert SIZE expressed in bytes, to kilobytes and return it as a string." | |
58 | (number->string | |
59 | (inexact->exact (ceiling (/ size 1024))))) | |
60 | ||
61 | (define (estimate-partition-size root) | |
62 | "Given the ROOT directory, evalute and return its size. As this doesn't | |
63 | take the partition metadata size into account, take a 25% margin." | |
64 | (* 1.25 (file-size root))) | |
65 | ||
66 | (define* (make-ext4-image partition target root | |
67 | #:key | |
68 | (owner-uid 0) | |
69 | (owner-gid 0)) | |
70 | "Handle the creation of EXT4 partition images. See 'make-partition-image'." | |
71 | (let ((size (partition-size partition)) | |
72 | (label (partition-label partition)) | |
73 | (uuid (partition-uuid partition)) | |
74 | (options "lazy_itable_init=1,lazy_journal_init=1")) | |
75 | (invoke "mke2fs" "-t" "ext4" "-d" root | |
76 | "-L" label "-U" (uuid->string uuid) | |
77 | "-E" (format #f "root_owner=~a:~a,~a" | |
78 | owner-uid owner-gid options) | |
79 | target | |
80 | (format #f "~ak" | |
81 | (size-in-kib | |
82 | (if (eq? size 'guess) | |
83 | (estimate-partition-size root) | |
84 | size)))))) | |
85 | ||
86 | (define* (make-vfat-image partition target root) | |
87 | "Handle the creation of VFAT partition images. See 'make-partition-image'." | |
88 | (let ((size (partition-size partition)) | |
89 | (label (partition-label partition))) | |
90 | (invoke "mkdosfs" "-n" label "-C" target "-F" "16" "-S" "1024" | |
91 | (size-in-kib | |
92 | (if (eq? size 'guess) | |
93 | (estimate-partition-size root) | |
94 | size))) | |
95 | (for-each (lambda (file) | |
96 | (unless (member file '("." "..")) | |
97 | (invoke "mcopy" "-bsp" "-i" target | |
98 | (string-append root "/" file) | |
99 | (string-append "::" file)))) | |
100 | (scandir root)))) | |
101 | ||
102 | (define* (make-partition-image partition-sexp target root) | |
103 | "Create and return the image of PARTITION-SEXP as TARGET. Use the given | |
104 | ROOT directory to populate the image." | |
105 | (let* ((partition (sexp->partition partition-sexp)) | |
106 | (type (partition-file-system partition))) | |
107 | (cond | |
108 | ((string=? type "ext4") | |
109 | (make-ext4-image partition target root)) | |
110 | ((string=? type "vfat") | |
111 | (make-vfat-image partition target root)) | |
112 | (else | |
113 | (format (current-error-port) | |
114 | "Unsupported partition type~%."))))) | |
115 | ||
116 | (define* (genimage config target) | |
117 | "Use genimage to generate in TARGET directory, the image described in the | |
118 | given CONFIG file." | |
119 | ;; genimage needs a 'root' directory. | |
120 | (mkdir "root") | |
121 | (invoke "genimage" "--config" config | |
122 | "--outputpath" target)) | |
123 | ||
124 | (define* (register-closure prefix closure | |
125 | #:key | |
126 | (deduplicate? #t) (reset-timestamps? #t) | |
127 | (schema (sql-schema))) | |
128 | "Register CLOSURE in PREFIX, where PREFIX is the directory name of the | |
129 | target store and CLOSURE is the name of a file containing a reference graph as | |
130 | produced by #:references-graphs.. As a side effect, if RESET-TIMESTAMPS? is | |
131 | true, reset timestamps on store files and, if DEDUPLICATE? is true, | |
132 | deduplicates files common to CLOSURE and the rest of PREFIX." | |
133 | (let ((items (call-with-input-file closure read-reference-graph))) | |
134 | (register-items items | |
135 | #:prefix prefix | |
136 | #:deduplicate? deduplicate? | |
137 | #:reset-timestamps? reset-timestamps? | |
138 | #:registration-time %epoch | |
139 | #:schema schema))) | |
140 | ||
141 | (define* (initialize-efi-partition root | |
142 | #:key | |
143 | bootloader-package | |
144 | #:allow-other-keys) | |
145 | "Install in ROOT directory, an EFI loader using BOOTLOADER-PACKAGE." | |
146 | (install-efi-loader bootloader-package root)) | |
147 | ||
148 | (define* (initialize-root-partition root | |
149 | #:key | |
150 | bootcfg | |
151 | bootcfg-location | |
152 | (deduplicate? #t) | |
153 | references-graphs | |
154 | (register-closures? #t) | |
155 | system-directory | |
156 | #:allow-other-keys) | |
157 | "Initialize the given ROOT directory. Use BOOTCFG and BOOTCFG-LOCATION to | |
158 | install the bootloader configuration. | |
159 | ||
160 | If REGISTER-CLOSURES? is true, register REFERENCES-GRAPHS in the store. If | |
161 | DEDUPLICATE? is true, then also deduplicate files common to CLOSURES and the | |
162 | rest of the store when registering the closures. SYSTEM-DIRECTORY is the name | |
163 | of the directory of the 'system' derivation." | |
164 | (populate-root-file-system system-directory root) | |
165 | (populate-store references-graphs root) | |
166 | ||
167 | (when register-closures? | |
168 | (for-each (lambda (closure) | |
169 | (register-closure root | |
170 | closure | |
171 | #:reset-timestamps? #t | |
172 | #:deduplicate? deduplicate?)) | |
173 | references-graphs)) | |
174 | ||
175 | (when bootcfg | |
176 | (install-boot-config bootcfg bootcfg-location root))) | |
177 | ||
178 | (define* (make-iso9660-image xorriso grub-mkrescue-environment | |
179 | grub bootcfg system-directory root target | |
180 | #:key (volume-id "Guix_image") (volume-uuid #f) | |
181 | register-closures? (references-graphs '()) | |
182 | (compression? #t)) | |
183 | "Given a GRUB package, creates an iso image as TARGET, using BOOTCFG as | |
184 | GRUB configuration and OS-DRV as the stuff in it." | |
185 | (define grub-mkrescue | |
186 | (string-append grub "/bin/grub-mkrescue")) | |
187 | ||
188 | (define grub-mkrescue-sed.sh | |
189 | (string-append (getcwd) "/" "grub-mkrescue-sed.sh")) | |
190 | ||
191 | ;; Use a modified version of grub-mkrescue-sed.sh, see below. | |
192 | (copy-file (string-append xorriso | |
193 | "/bin/grub-mkrescue-sed.sh") | |
194 | grub-mkrescue-sed.sh) | |
195 | ||
196 | ;; Force grub-mkrescue-sed.sh to use the build directory instead of /tmp | |
197 | ;; that is read-only inside the build container. | |
198 | (substitute* grub-mkrescue-sed.sh | |
199 | (("/tmp/") (string-append (getcwd) "/")) | |
200 | (("MKRESCUE_SED_XORRISO_ARGS \\$x") | |
201 | (format #f "MKRESCUE_SED_XORRISO_ARGS $(echo $x | sed \"s|/tmp|~a|\")" | |
202 | (getcwd)))) | |
203 | ||
204 | ;; 'grub-mkrescue' calls out to mtools programs to create 'efi.img', a FAT | |
205 | ;; file system image, and mtools honors SOURCE_DATE_EPOCH for the mtime of | |
206 | ;; those files. The epoch for FAT is Jan. 1st 1980, not 1970, so choose | |
207 | ;; that. | |
208 | (setenv "SOURCE_DATE_EPOCH" | |
209 | (number->string | |
210 | (time-second | |
211 | (date->time-utc (make-date 0 0 0 0 1 1 1980 0))))) | |
212 | ||
213 | ;; Our patched 'grub-mkrescue' honors this environment variable and passes | |
214 | ;; it to 'mformat', which makes it the serial number of 'efi.img'. This | |
215 | ;; allows for deterministic builds. | |
216 | (setenv "GRUB_FAT_SERIAL_NUMBER" | |
217 | (number->string (if volume-uuid | |
218 | ||
219 | ;; On 32-bit systems the 2nd argument must be | |
220 | ;; lower than 2^32. | |
221 | (string-hash (iso9660-uuid->string volume-uuid) | |
222 | (- (expt 2 32) 1)) | |
223 | ||
224 | #x77777777) | |
225 | 16)) | |
226 | ||
227 | (setenv "MKRESCUE_SED_MODE" "original") | |
228 | (setenv "MKRESCUE_SED_XORRISO" (string-append xorriso "/bin/xorriso")) | |
229 | (setenv "MKRESCUE_SED_IN_EFI_NO_PT" "yes") | |
230 | ||
231 | (for-each (match-lambda | |
232 | ((name . value) (setenv name value))) | |
233 | grub-mkrescue-environment) | |
234 | ||
235 | (apply invoke grub-mkrescue | |
236 | (string-append "--xorriso=" grub-mkrescue-sed.sh) | |
237 | "-o" target | |
238 | (string-append "boot/grub/grub.cfg=" bootcfg) | |
239 | root | |
240 | "--" | |
241 | ;; Set all timestamps to 1. | |
242 | "-volume_date" "all_file_dates" "=1" | |
243 | ||
244 | `(,@(if compression? | |
245 | '(;; ‘zisofs’ compression reduces the total image size by | |
246 | ;; ~60%. | |
247 | "-zisofs" "level=9:block_size=128k" ; highest compression | |
248 | ;; It's transparent to our Linux-Libre kernel but not to | |
249 | ;; GRUB. Don't compress the kernel, initrd, and other | |
250 | ;; files read by grub.cfg, as well as common | |
251 | ;; already-compressed file names. | |
252 | "-find" "/" "-type" "f" | |
253 | ;; XXX Even after "--" above, and despite documentation | |
254 | ;; claiming otherwise, "-or" is stolen by grub-mkrescue | |
255 | ;; which then chokes on it (as ‘-o …’) and dies. Don't use | |
256 | ;; "-or". | |
257 | "-not" "-wholename" "/boot/*" | |
258 | "-not" "-wholename" "/System/*" | |
259 | "-not" "-name" "unicode.pf2" | |
260 | "-not" "-name" "bzImage" | |
261 | "-not" "-name" "*.gz" ; initrd & all man pages | |
262 | "-not" "-name" "*.png" ; includes grub-image.png | |
263 | "-exec" "set_filter" "--zisofs" | |
264 | "--") | |
265 | '()) | |
266 | "-volid" ,(string-upcase volume-id) | |
267 | ,@(if volume-uuid | |
268 | `("-volume_date" "uuid" | |
269 | ,(string-filter (lambda (value) | |
270 | (not (char=? #\- value))) | |
271 | (iso9660-uuid->string | |
272 | volume-uuid))) | |
273 | '())))) |