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