Commit | Line | Data |
---|---|---|
f09d925b | 1 | ;;; GNU Guix --- Functional package management for GNU |
12adffd4 | 2 | ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> |
cc023e32 | 3 | ;;; Copyright © 2016 Mark H Weaver <mhw@netris.org> |
ad857912 | 4 | ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org> |
fdbf4447 | 5 | ;;; Copyright © 2017, 2019 Mathieu Othacehe <m.othacehe@gmail.com> |
10defc57 | 6 | ;;; Copyright © 2019, 2020 Tobias Geerinckx-Rice <me@tobias.gr> |
f09d925b LC |
7 | ;;; |
8 | ;;; This file is part of GNU Guix. | |
9 | ;;; | |
10 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
11 | ;;; under the terms of the GNU General Public License as published by | |
12 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
13 | ;;; your option) any later version. | |
14 | ;;; | |
15 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
16 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;;; GNU General Public License for more details. | |
19 | ;;; | |
20 | ;;; You should have received a copy of the GNU General Public License | |
21 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
22 | ||
735c6dd7 | 23 | (define-module (gnu system linux-initrd) |
0c21d92b | 24 | #:use-module (guix gexp) |
f09d925b | 25 | #:use-module (guix utils) |
d4254711 LC |
26 | #:use-module ((guix store) |
27 | #:select (%store-prefix)) | |
1c96c1bb LC |
28 | #:use-module ((guix derivations) |
29 | #:select (derivation->output-path)) | |
239c6e27 | 30 | #:use-module (guix modules) |
f09d925b | 31 | #:use-module (gnu packages compression) |
866872aa | 32 | #:use-module (gnu packages disk) |
f09d925b | 33 | #:use-module (gnu packages linux) |
c7b5cfb0 | 34 | #:use-module (gnu packages file-systems) |
f989fa39 | 35 | #:use-module (gnu packages guile) |
ae7a316b LC |
36 | #:use-module ((gnu packages xorg) |
37 | #:select (console-setup xkeyboard-config)) | |
f09d925b | 38 | #:use-module ((gnu packages make-bootstrap) |
57833803 | 39 | #:select (%guile-3.0-static-stripped)) |
c5df1839 | 40 | #:use-module (gnu system file-systems) |
060d62a7 | 41 | #:use-module (gnu system mapped-devices) |
ae7a316b | 42 | #:use-module (gnu system keyboard) |
1c96c1bb | 43 | #:use-module (ice-9 match) |
217b862f | 44 | #:use-module (ice-9 regex) |
615a89e3 | 45 | #:use-module (ice-9 vlist) |
83bcd0b8 | 46 | #:use-module (srfi srfi-1) |
42d10464 | 47 | #:use-module (srfi srfi-26) |
735c6dd7 | 48 | #:export (expression->initrd |
bc499b11 | 49 | %base-initrd-modules |
47bdc5a1 | 50 | raw-initrd |
278d486b | 51 | file-system-packages |
8ab10c19 | 52 | base-initrd)) |
f09d925b LC |
53 | |
54 | \f | |
55 | ;;; Commentary: | |
56 | ;;; | |
57 | ;;; Tools to build initial RAM disks (initrd's) for Linux-Libre, and in | |
58 | ;;; particular initrd's that run Guile. | |
59 | ;;; | |
60 | ;;; Code: | |
61 | ||
62 | ||
63 | (define* (expression->initrd exp | |
64 | #:key | |
57833803 | 65 | (guile %guile-3.0-static-stripped) |
f09d925b LC |
66 | (gzip gzip) |
67 | (name "guile-initrd") | |
4ee96a79 | 68 | (system (%current-system))) |
e34ae75d | 69 | "Return as a file-like object a Linux initrd (a gzipped cpio archive) |
df650fa8 | 70 | containing GUILE and that evaluates EXP, a G-expression, upon booting. All |
4ee96a79 | 71 | the derivations referenced by EXP are automatically copied to the initrd." |
f09d925b LC |
72 | |
73 | ;; General Linux overview in `Documentation/early-userspace/README' and | |
74 | ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'. | |
75 | ||
6d9a8590 LC |
76 | (define init |
77 | (program-file "init" exp #:guile guile)) | |
78 | ||
6a060ff2 LC |
79 | (define (import-module? module) |
80 | ;; Since we don't use deduplication support in 'populate-store', don't | |
81 | ;; import (guix store deduplication) and its dependencies, which includes | |
82 | ;; Guile-Gcrypt. That way we can run tests with '--bootstrap'. | |
83 | (and (guix-module-name? module) | |
84 | (not (equal? module '(guix store deduplication))))) | |
85 | ||
6d9a8590 | 86 | (define builder |
755f365b MO |
87 | ;; Do not use "guile-zlib" extension here, otherwise it would drag the |
88 | ;; non-static "zlib" package to the initrd closure. It is not needed | |
89 | ;; anyway because the modules are stored uncompressed within the initrd. | |
6d9a8590 | 90 | (with-imported-modules (source-module-closure |
6a060ff2 LC |
91 | '((gnu build linux-initrd)) |
92 | #:select? import-module?) | |
6d9a8590 LC |
93 | #~(begin |
94 | (use-modules (gnu build linux-initrd)) | |
95 | ||
96 | (mkdir #$output) | |
b36e06c2 CB |
97 | |
98 | ;; The guile used in the initrd must be present in the store, so | |
99 | ;; that module loading works once the root is switched. | |
100 | ;; | |
101 | ;; To ensure that is the case, add an explicit reference to the | |
102 | ;; guile package used in the initrd to the output. | |
103 | ;; | |
104 | ;; This fixes guix-patches bug #28399, "Fix mysql activation, and | |
105 | ;; add a basic test". | |
106 | (call-with-output-file (string-append #$ output "/references") | |
107 | (lambda (port) | |
108 | (simple-format port "~A\n" #$guile))) | |
109 | ||
d422cbb3 | 110 | (build-initrd (string-append #$output "/initrd.cpio.gz") |
6d9a8590 LC |
111 | #:guile #$guile |
112 | #:init #$init | |
113 | ;; Copy everything INIT refers to into the initrd. | |
114 | #:references-graphs '("closure") | |
328a4c5b | 115 | #:gzip (string-append #+gzip "/bin/gzip"))))) |
6d9a8590 | 116 | |
d422cbb3 LC |
117 | (file-append (computed-file name builder |
118 | #:options | |
119 | `(#:references-graphs (("closure" ,init)))) | |
120 | "/initrd.cpio.gz")) | |
735c6dd7 | 121 | |
b21a1c5a LC |
122 | (define (flat-linux-module-directory linux modules) |
123 | "Return a flat directory containing the Linux kernel modules listed in | |
124 | MODULES and taken from LINUX." | |
755f365b MO |
125 | (define imported-modules |
126 | (source-module-closure '((gnu build linux-modules) | |
127 | (guix build utils)))) | |
b21a1c5a | 128 | |
755f365b MO |
129 | (define build-exp |
130 | (with-imported-modules imported-modules | |
131 | (with-extensions (list guile-zlib) | |
132 | #~(begin | |
133 | (use-modules (gnu build linux-modules) | |
134 | (guix build utils) | |
135 | (srfi srfi-1) | |
136 | (srfi srfi-26)) | |
137 | ||
138 | (define module-dir | |
139 | (string-append #$linux "/lib/modules")) | |
140 | ||
141 | (define modules | |
142 | (let* ((lookup (cut find-module-file module-dir <>)) | |
143 | (modules (map lookup '#$modules))) | |
144 | (append modules | |
145 | (recursive-module-dependencies | |
146 | modules | |
147 | #:lookup-module lookup)))) | |
148 | ||
149 | (define (maybe-uncompress file) | |
150 | ;; If FILE is a compressed module, uncompress it, as the initrd | |
151 | ;; is already gzipped as a whole. | |
152 | (cond | |
153 | ((string-contains file ".ko.gz") | |
154 | (invoke #+(file-append gzip "/bin/gunzip") file)))) | |
155 | ||
156 | (mkdir #$output) | |
157 | (for-each (lambda (module) | |
158 | (let ((out-module | |
159 | (string-append #$output "/" | |
160 | (basename module)))) | |
161 | (format #t "copying '~a'...~%" module) | |
162 | (copy-file module out-module) | |
163 | (maybe-uncompress out-module))) | |
164 | (delete-duplicates modules)) | |
165 | ||
166 | ;; Hyphen or underscore? This database tells us. | |
167 | (write-module-name-database #$output))))) | |
b21a1c5a | 168 | |
6d9a8590 | 169 | (computed-file "linux-modules" build-exp)) |
b21a1c5a | 170 | |
47bdc5a1 MO |
171 | (define* (raw-initrd file-systems |
172 | #:key | |
173 | (linux linux-libre) | |
174 | (linux-modules '()) | |
175 | (mapped-devices '()) | |
ae7a316b | 176 | (keyboard-layout #f) |
47bdc5a1 MO |
177 | (helper-packages '()) |
178 | qemu-networking? | |
aeed74f3 LC |
179 | volatile-root? |
180 | (on-error 'debug)) | |
e34ae75d | 181 | "Return as a file-like object a raw initrd, with kernel |
47bdc5a1 MO |
182 | modules taken from LINUX. FILE-SYSTEMS is a list of file-systems to be |
183 | mounted by the initrd, possibly in addition to the root file system specified | |
184 | on the kernel command line via '--root'. LINUX-MODULES is a list of kernel | |
185 | modules to be loaded at boot time. MAPPED-DEVICES is a list of device | |
186 | mappings to realize before FILE-SYSTEMS are mounted. | |
187 | HELPER-PACKAGES is a list of packages to be copied in the initrd. It may include | |
188 | e2fsck/static or other packages needed by the initrd to check root partition. | |
189 | ||
ae7a316b LC |
190 | When true, KEYBOARD-LAYOUT is a <keyboard-layout> record denoting the desired |
191 | console keyboard layout. This is done before MAPPED-DEVICES are set up and | |
192 | before FILE-SYSTEMS are mounted such that, should the user need to enter a | |
193 | passphrase or use the REPL, this happens using the intended keyboard layout. | |
194 | ||
47bdc5a1 MO |
195 | When QEMU-NETWORKING? is true, set up networking with the standard QEMU |
196 | parameters. | |
aeed74f3 | 197 | |
47bdc5a1 | 198 | When VOLATILE-ROOT? is true, the root file system is writable but any changes |
aeed74f3 LC |
199 | to it are lost. |
200 | ||
201 | ON-ERROR is passed to 'call-with-error-handling'; it determines what happens | |
202 | upon error." | |
47bdc5a1 MO |
203 | (define device-mapping-commands |
204 | ;; List of gexps to open the mapped devices. | |
205 | (map (lambda (md) | |
788df2ec MT |
206 | (let* ((source (mapped-device-source md)) |
207 | (targets (mapped-device-targets md)) | |
208 | (type (mapped-device-type md)) | |
209 | (open (mapped-device-kind-open type))) | |
210 | (open source targets))) | |
47bdc5a1 MO |
211 | mapped-devices)) |
212 | ||
6d9a8590 LC |
213 | (define kodir |
214 | (flat-linux-module-directory linux linux-modules)) | |
215 | ||
216 | (expression->initrd | |
217 | (with-imported-modules (source-module-closure | |
218 | '((gnu build linux-boot) | |
219 | (guix build utils) | |
220 | (guix build bournish) | |
1c65cca5 | 221 | (gnu system file-systems) |
6d9a8590 LC |
222 | (gnu build file-systems))) |
223 | #~(begin | |
224 | (use-modules (gnu build linux-boot) | |
1c65cca5 | 225 | (gnu system file-systems) |
12adffd4 | 226 | ((guix build utils) #:hide (delete)) |
6d9a8590 | 227 | (guix build bournish) ;add the 'bournish' meta-command |
a9a2fdaa | 228 | (srfi srfi-1) ;for lvm-device-mapping |
6d9a8590 LC |
229 | (srfi srfi-26) |
230 | ||
231 | ;; FIXME: The following modules are for | |
232 | ;; LUKS-DEVICE-MAPPING. We should instead propagate | |
233 | ;; this info via gexps. | |
234 | ((gnu build file-systems) | |
235 | #:select (find-partition-by-luks-uuid)) | |
236 | (rnrs bytevectors)) | |
237 | ||
238 | (with-output-to-port (%make-void-port "w") | |
239 | (lambda () | |
240 | (set-path-environment-variable "PATH" '("bin" "sbin") | |
241 | '#$helper-packages))) | |
242 | ||
12adffd4 LC |
243 | (parameterize ((current-warning-port (%make-void-port "w"))) |
244 | (boot-system #:mounts | |
245 | (map spec->file-system | |
246 | '#$(map file-system->spec file-systems)) | |
247 | #:pre-mount (lambda () | |
248 | (and #$@device-mapping-commands)) | |
249 | #:linux-modules '#$linux-modules | |
250 | #:linux-module-directory '#$kodir | |
251 | #:keymap-file #+(and=> keyboard-layout | |
252 | keyboard-layout->console-keymap) | |
253 | #:qemu-guest-networking? #$qemu-networking? | |
254 | #:volatile-root? '#$volatile-root? | |
255 | #:on-error '#$on-error)))) | |
6d9a8590 | 256 | #:name "raw-initrd")) |
47bdc5a1 | 257 | |
278d486b LC |
258 | (define* (file-system-packages file-systems #:key (volatile-root? #f)) |
259 | "Return the list of statically-linked, stripped packages to check | |
260 | FILE-SYSTEMS." | |
261 | `(,@(if (find (lambda (fs) | |
262 | (string-prefix? "ext" (file-system-type fs))) | |
263 | file-systems) | |
264 | (list e2fsck/static) | |
265 | '()) | |
266 | ,@(if (find (lambda (fs) | |
267 | (string-suffix? "fat" (file-system-type fs))) | |
268 | file-systems) | |
269 | (list fatfsck/static) | |
270 | '()) | |
10defc57 TGR |
271 | ,@(if (find (file-system-type-predicate "bcachefs") file-systems) |
272 | (list bcachefs-tools/static) | |
273 | '()) | |
278d486b LC |
274 | ,@(if (find (file-system-type-predicate "btrfs") file-systems) |
275 | (list btrfs-progs/static) | |
c7b5cfb0 TGR |
276 | '()) |
277 | ,@(if (find (file-system-type-predicate "jfs") file-systems) | |
278 | (list jfs_fsck/static) | |
33eab4a1 DM |
279 | '()) |
280 | ,@(if (find (file-system-type-predicate "f2fs") file-systems) | |
281 | (list f2fs-fsck/static) | |
278d486b LC |
282 | '()))) |
283 | ||
615a89e3 LC |
284 | (define-syntax vhash ;TODO: factorize |
285 | (syntax-rules (=>) | |
286 | "Build a vhash with the given key/value mappings." | |
287 | ((_) | |
288 | vlist-null) | |
289 | ((_ (key others ... => value) rest ...) | |
290 | (vhash-cons key value | |
291 | (vhash (others ... => value) rest ...))) | |
292 | ((_ (=> value) rest ...) | |
293 | (vhash rest ...)))) | |
294 | ||
295 | (define-syntax lookup-procedure | |
296 | (syntax-rules (else) | |
297 | "Return a procedure that lookups keys in the given dictionary." | |
298 | ((_ mapping ... (else default)) | |
299 | (let ((table (vhash mapping ...))) | |
300 | (lambda (key) | |
301 | (match (vhash-assoc key table) | |
3cb3a4e6 LC |
302 | (#f default) |
303 | ((key . value) value))))))) | |
615a89e3 LC |
304 | |
305 | (define file-system-type-modules | |
306 | ;; Given a file system type, return the list of modules it needs. | |
307 | (lookup-procedure ("cifs" => '("md4" "ecb" "cifs")) | |
308 | ("9p" => '("9p" "9pnet_virtio")) | |
10defc57 | 309 | ("bcachefs" => '("bcachefs")) |
615a89e3 LC |
310 | ("btrfs" => '("btrfs")) |
311 | ("iso9660" => '("isofs")) | |
c7b5cfb0 | 312 | ("jfs" => '("jfs")) |
27efeef3 | 313 | ("f2fs" => '("f2fs" "crc32_generic")) |
615a89e3 LC |
314 | (else '()))) |
315 | ||
316 | (define (file-system-modules file-systems) | |
317 | "Return the list of Linux modules needed to mount FILE-SYSTEMS." | |
318 | (append-map (compose file-system-type-modules file-system-type) | |
319 | file-systems)) | |
320 | ||
fdbf4447 MO |
321 | (define* (default-initrd-modules |
322 | #:optional | |
323 | (system (or (%current-target-system) | |
324 | (%current-system)))) | |
bc499b11 | 325 | "Return the list of modules included in the initrd by default." |
eac026e5 LC |
326 | (define virtio-modules |
327 | ;; Modules for Linux para-virtualized devices, for use in QEMU guests. | |
328 | '("virtio_pci" "virtio_balloon" "virtio_blk" "virtio_net" | |
d2823887 | 329 | "virtio_console" "virtio-rng")) |
eac026e5 | 330 | |
bc499b11 LC |
331 | `("ahci" ;for SATA controllers |
332 | "usb-storage" "uas" ;for the installation image etc. | |
333 | "usbhid" "hid-generic" "hid-apple" ;keyboards during early boot | |
334 | "dm-crypt" "xts" "serpent_generic" "wp512" ;for encrypted root partitions | |
335 | "nls_iso8859-1" ;for `mkfs.fat`, et.al | |
336 | ,@(if (string-match "^(x86_64|i[3-6]86)-" system) | |
337 | '("pata_acpi" "pata_atiixp" ;for ATA controllers | |
338 | "isci") ;for SAS controllers like Intel C602 | |
eac026e5 LC |
339 | '()) |
340 | ||
341 | ,@virtio-modules)) | |
bc499b11 LC |
342 | |
343 | (define-syntax %base-initrd-modules | |
344 | ;; This more closely matches our naming convention. | |
345 | (identifier-syntax (default-initrd-modules))) | |
346 | ||
060238ae | 347 | (define* (base-initrd file-systems |
83bcd0b8 | 348 | #:key |
0d275f4a | 349 | (linux linux-libre) |
bc499b11 | 350 | (linux-modules '()) |
de1c158f | 351 | (mapped-devices '()) |
ae7a316b | 352 | (keyboard-layout #f) |
4fc96187 | 353 | qemu-networking? |
24e0160a | 354 | volatile-root? |
bc499b11 | 355 | (extra-modules '()) ;deprecated |
aeed74f3 | 356 | (on-error 'debug)) |
e34ae75d | 357 | "Return as a file-like object a generic initrd, with kernel |
0d275f4a AW |
358 | modules taken from LINUX. FILE-SYSTEMS is a list of file-systems to be |
359 | mounted by the initrd, possibly in addition to the root file system specified | |
360 | on the kernel command line via '--root'. MAPPED-DEVICES is a list of device | |
361 | mappings to realize before FILE-SYSTEMS are mounted. | |
f09d925b | 362 | |
ae7a316b LC |
363 | When true, KEYBOARD-LAYOUT is a <keyboard-layout> record denoting the desired |
364 | console keyboard layout. This is done before MAPPED-DEVICES are set up and | |
365 | before FILE-SYSTEMS are mounted such that, should the user need to enter a | |
366 | passphrase or use the REPL, this happens using the intended keyboard layout. | |
367 | ||
47bdc5a1 MO |
368 | QEMU-NETWORKING? and VOLATILE-ROOT? behaves as in raw-initrd. |
369 | ||
fa16f845 | 370 | The initrd is automatically populated with all the kernel modules necessary |
eac026e5 LC |
371 | for FILE-SYSTEMS and for the given options. Additional kernel |
372 | modules can be listed in LINUX-MODULES. They will be added to the initrd, and | |
6c1df081 | 373 | loaded at boot time in the order in which they appear." |
bc499b11 | 374 | (define linux-modules* |
d4254711 | 375 | ;; Modules added to the initrd and loaded from the initrd. |
bc499b11 | 376 | `(,@linux-modules |
615a89e3 | 377 | ,@(file-system-modules file-systems) |
1c96c1bb | 378 | ,@(if volatile-root? |
c8289690 | 379 | '("overlay") |
fa16f845 LC |
380 | '()) |
381 | ,@extra-modules)) | |
f09d925b | 382 | |
3c05b4bc | 383 | (define helper-packages |
ae7a316b LC |
384 | (append (file-system-packages file-systems |
385 | #:volatile-root? volatile-root?) | |
386 | (if keyboard-layout | |
387 | (list loadkeys-static) | |
388 | '()))) | |
3c05b4bc | 389 | |
47bdc5a1 MO |
390 | (raw-initrd file-systems |
391 | #:linux linux | |
bc499b11 | 392 | #:linux-modules linux-modules* |
47bdc5a1 MO |
393 | #:mapped-devices mapped-devices |
394 | #:helper-packages helper-packages | |
ae7a316b | 395 | #:keyboard-layout keyboard-layout |
47bdc5a1 | 396 | #:qemu-networking? qemu-networking? |
aeed74f3 LC |
397 | #:volatile-root? volatile-root? |
398 | #:on-error on-error)) | |
f09d925b LC |
399 | |
400 | ;;; linux-initrd.scm ends here |