projects/guix·blob master · refs

442 lines · 18.0 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2013-2020, 2024 Ludovic Courtès <[email protected]>
3;;; Copyright © 2016 Mark H Weaver <[email protected]>
4;;; Copyright © 2016 Jan Nieuwenhuizen <[email protected]>
5;;; Copyright © 2017, 2019 Mathieu Othacehe <[email protected]>
6;;; Copyright © 2019, 2020 Tobias Geerinckx-Rice <[email protected]>
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
23;;; Commentary:
24;;;
25;;; Tools to build initial RAM disks (initrd's) for Linux-Libre, and in
26;;; particular initrd's that run Guile.
27;;;
28;;; Code:
29
30(define-module (gnu system linux-initrd)
31 #:use-module (guix deprecation)
32 #:use-module (guix gexp)
33 #:use-module (guix utils)
34 #:use-module ((guix store)
35 #:select (%store-prefix))
36 #:use-module ((guix derivations)
37 #:select (derivation->output-path))
38 #:use-module (guix modules)
39 #:use-module (guix packages)
40 #:use-module (gnu packages compression)
41 #:use-module (gnu packages disk)
42 #:use-module (gnu packages linux)
43 #:use-module (gnu packages file-systems)
44 #:use-module (gnu packages guile)
45 #:use-module ((gnu packages xorg)
46 #:select (console-setup xkeyboard-config))
47 #:use-module ((gnu packages make-bootstrap)
48 #:select (%guile-static-initrd))
49 #:use-module (gnu system)
50 #:use-module (gnu system file-systems)
51 #:use-module (gnu system mapped-devices)
52 #:use-module (gnu system keyboard)
53 #:use-module (ice-9 match)
54 #:use-module (ice-9 regex)
55 #:use-module (ice-9 vlist)
56 #:use-module (srfi srfi-1)
57 #:use-module (srfi srfi-26)
58 #:export (expression->initrd
59 base-initrd-modules
60 raw-initrd
61 file-system-packages
62 file-system-modules
63 base-initrd))
64
65
66(define* (expression->initrd exp
67 #:key
68 (guile %guile-static-initrd)
69 (gzip gzip)
70 (name "guile-initrd")
71 (system (%current-system)))
72 "Return as a file-like object a Linux initrd (a gzipped cpio archive)
73containing GUILE and that evaluates EXP, a G-expression, upon booting. All
74the derivations referenced by EXP are automatically copied to the initrd."
75
76 ;; General Linux overview in `Documentation/early-userspace/README' and
77 ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'.
78
79 (define init
80 (program-file "init" exp #:guile guile))
81
82 (define (import-module? module)
83 ;; Since we don't use deduplication support in 'populate-store', don't
84 ;; import (guix store deduplication) and its dependencies, which includes
85 ;; Guile-Gcrypt. That way we can run tests with '--bootstrap'.
86 (and (guix-module-name? module)
87 (not (equal? module '(guix store deduplication)))))
88
89 (define builder
90 ;; Do not use "guile-zlib" extension here, otherwise it would drag the
91 ;; non-static "zlib" package to the initrd closure. It is not needed
92 ;; anyway because the modules are stored uncompressed within the initrd.
93 (with-imported-modules (source-module-closure
94 '((gnu build linux-initrd))
95 #:select? import-module?)
96 #~(begin
97 (use-modules (gnu build linux-initrd))
98
99 (mkdir #$output)
100
101 ;; The guile used in the initrd must be present in the store, so
102 ;; that module loading works once the root is switched.
103 ;;
104 ;; To ensure that is the case, add an explicit reference to the
105 ;; guile package used in the initrd to the output.
106 ;;
107 ;; This fixes guix-patches bug #28399, "Fix mysql activation, and
108 ;; add a basic test".
109 (call-with-output-file (string-append #$ output "/references")
110 (lambda (port)
111 (simple-format port "~A\n" #$guile)))
112
113 (build-initrd (string-append #$output "/initrd.cpio.gz")
114 #:guile #$guile
115 #:init #$init
116 ;; Copy everything INIT refers to into the initrd.
117 #:references-graphs '("closure")
118 #:gzip (string-append #+gzip "/bin/gzip")))))
119
120 (file-append (computed-file name builder
121 #:options
122 `(#:references-graphs (("closure" ,init))))
123 "/initrd.cpio.gz"))
124
125(define (flat-linux-module-directory linux modules)
126 "Return a flat directory containing the Linux kernel modules listed in
127MODULES and taken from LINUX."
128 (define imported-modules
129 (source-module-closure '((gnu build linux-modules)
130 (guix build utils))))
131
132 (define build-exp
133 (with-imported-modules imported-modules
134 (with-extensions (list guile-zlib guile-zstd)
135 #~(begin
136 (use-modules (gnu build linux-modules)
137 (guix build utils)
138 (rnrs io ports)
139 (srfi srfi-1)
140 (srfi srfi-26)
141 (ice-9 match))
142
143 (define module-dir
144 (string-append #$linux "/lib/modules"))
145
146 (define builtin-modules
147 (match (find-files module-dir (lambda (file stat)
148 (string=? (basename file)
149 "modules.builtin")))
150 ((file . _)
151 (call-with-input-file file
152 (lambda (port)
153 (map file-name->module-name
154 (string-tokenize (get-string-all port))))))
155 (_
156 '())))
157
158 (define modules-to-lookup
159 (remove (lambda (module)
160 (member (normalize-module-name module)
161 ;; Normalized by `file-name->module-name'.
162 builtin-modules))
163 '#$modules))
164
165 (define modules
166 (let* ((lookup (cut find-module-file module-dir <>))
167 (modules (map lookup modules-to-lookup)))
168 (append modules
169 (recursive-module-dependencies
170 modules
171 #:lookup-module lookup))))
172
173 (define (maybe-uncompress file)
174 ;; If FILE is a compressed module, uncompress it, as the initrd
175 ;; is already gzipped as a whole.
176 (cond
177 ((string-contains file ".ko.gz")
178 (invoke #+(file-append gzip "/bin/gunzip") file))
179 ((string-contains file ".ko.zst")
180 (invoke #+(file-append zstd "/bin/zstd") "-d" file))))
181
182 (mkdir #$output)
183 (for-each (lambda (module)
184 (let ((out-module
185 (string-append #$output "/"
186 (basename module))))
187 (format #t "copying '~a'...~%" module)
188 (copy-file module out-module)
189 (maybe-uncompress out-module)))
190 (delete-duplicates modules))
191
192 ;; Hyphen or underscore? This database tells us.
193 (write-module-name-database #$output)))))
194
195 (computed-file "linux-modules" build-exp))
196
197(define* (raw-initrd file-systems
198 #:key
199 (linux linux-libre)
200 (linux-modules '())
201 (pre-mount #t)
202 (mapped-devices '())
203 (keyboard-layout #f)
204 (helper-packages '())
205 qemu-networking?
206 volatile-root?
207 (on-error 'debug))
208 "Return as a file-like object a raw initrd, with kernel
209modules taken from LINUX. FILE-SYSTEMS is a list of file-systems to be
210mounted by the initrd, possibly in addition to the root file system specified
211on the kernel command line via 'root'. LINUX-MODULES is a list of kernel
212modules to be loaded at boot time. MAPPED-DEVICES is a list of device
213mappings to realize before FILE-SYSTEMS are mounted. PRE-MOUNT is a
214G-expression to evaluate before realizing MAPPED-DEVICES.
215HELPER-PACKAGES is a list of packages to be copied in the initrd. It may include
216e2fsck/static or other packages needed by the initrd to check root partition.
217
218When true, KEYBOARD-LAYOUT is a <keyboard-layout> record denoting the desired
219console keyboard layout. This is done before MAPPED-DEVICES are set up and
220before FILE-SYSTEMS are mounted such that, should the user need to enter a
221passphrase or use the REPL, this happens using the intended keyboard layout.
222
223When QEMU-NETWORKING? is true, set up networking with the standard QEMU
224parameters.
225
226When VOLATILE-ROOT? is true, the root file system is writable but any changes
227to it are lost.
228
229ON-ERROR is passed to 'call-with-error-handling'; it determines what happens
230upon error."
231 (define device-mapping-commands
232 ;; List of gexps to open the mapped devices.
233 (map (lambda (md)
234 (let* ((source (mapped-device-source md))
235 (targets (mapped-device-targets md))
236 (type (mapped-device-type md))
237 (open (mapped-device-kind-open type)))
238 (apply open source targets
239 (mapped-device-arguments md))))
240 mapped-devices))
241
242 (define file-system-scan-commands
243 ;; File systems like btrfs need help to assemble multi-device file systems
244 ;; but do not use manually-specified <mapped-devices>.
245 (let ((file-system-types (map file-system-type file-systems)))
246 (if (member "btrfs" file-system-types)
247 ;; Ignore errors: if the system manages to boot anyway, the better.
248 #~((system* (string-append #$btrfs-progs/static "/bin/btrfs")
249 "device" "scan"))
250 #~())))
251
252 (define kodir
253 (flat-linux-module-directory linux linux-modules))
254
255 (expression->initrd
256 (with-imported-modules (source-module-closure
257 '((gnu build linux-boot)
258 (guix build utils)
259 (guix build bournish)
260 (gnu system file-systems)
261 (gnu build file-systems)))
262 #~(begin
263 (use-modules (gnu build linux-boot)
264 (gnu system file-systems)
265 ((guix build utils) #:hide (delete))
266 (guix build bournish) ;add the 'bournish' meta-command
267 (srfi srfi-1) ;for lvm-device-mapping
268 (srfi srfi-26)
269
270 ;; Load extra modules needed by the mapped device code.
271 #$@(append-map (compose mapped-device-kind-modules
272 mapped-device-type)
273 mapped-devices))
274
275 (with-output-to-port (%make-void-port "w")
276 (lambda ()
277 (set-path-environment-variable "PATH" '("bin" "sbin")
278 '#$helper-packages)))
279
280 (parameterize ((current-warning-port (%make-void-port "w")))
281 (boot-system #:mounts
282 (map spec->file-system
283 '#$(map file-system->spec file-systems))
284 #:pre-mount (lambda ()
285 (and #$pre-mount
286 #$@device-mapping-commands
287 #$@file-system-scan-commands))
288 #:linux-modules '#$linux-modules
289 #:linux-module-directory '#$kodir
290 #:keymap-file #+(and=> keyboard-layout
291 keyboard-layout->console-keymap)
292 #:qemu-guest-networking? #$qemu-networking?
293 #:volatile-root? '#$volatile-root?
294 #:on-error '#$on-error))))
295 #:name "raw-initrd"))
296
297(define* (file-system-packages file-systems #:key (volatile-root? #f))
298 "Return the list of statically-linked, stripped packages to check
299FILE-SYSTEMS."
300 `(,@(if (find (lambda (fs)
301 (string-prefix? "ext" (file-system-type fs)))
302 file-systems)
303 (list e2fsck/static)
304 '())
305 ,@(if (find (lambda (fs)
306 (string-suffix? "fat" (file-system-type fs)))
307 file-systems)
308 (list fatfsck/static)
309 '())
310 ,@(if (find (file-system-type-predicate "bcachefs") file-systems)
311 (list bcachefs/static)
312 '())
313 ,@(if (find (file-system-type-predicate "btrfs") file-systems)
314 (list btrfs-progs/static)
315 '())
316 ,@(if (find (file-system-type-predicate "erofs") file-systems)
317 (list erofs-utils/static)
318 '())
319 ,@(if (find (file-system-type-predicate "jfs") file-systems)
320 (list jfs_fsck/static)
321 '())
322 ,@(if (find (file-system-type-predicate "ntfs") file-systems)
323 (list ntfsfix/static)
324 '())
325 ,@(if (find (file-system-type-predicate "f2fs") file-systems)
326 (list f2fs-fsck/static)
327 '())
328 ,@(if (find (file-system-type-predicate "xfs") file-systems)
329 (list xfs-repair/static)
330 '())))
331
332(define-syntax vhash ;TODO: factorize
333 (syntax-rules (=>)
334 "Build a vhash with the given key/value mappings."
335 ((_)
336 vlist-null)
337 ((_ (key others ... => value) rest ...)
338 (vhash-cons key value
339 (vhash (others ... => value) rest ...)))
340 ((_ (=> value) rest ...)
341 (vhash rest ...))))
342
343(define-syntax lookup-procedure
344 (syntax-rules (else)
345 "Return a procedure that lookups keys in the given dictionary."
346 ((_ mapping ... (else default))
347 (let ((table (vhash mapping ...)))
348 (lambda (key)
349 (match (vhash-assoc key table)
350 (#f default)
351 ((key . value) value)))))))
352
353(define file-system-type-modules
354 ;; Given a file system type, return the list of modules it needs.
355 (lookup-procedure ("cifs" => '("md4" "ecb" "cifs"))
356 ("9p" => '("9p" "9pnet_virtio"))
357 ("bcachefs" => '("bcachefs"))
358 ("btrfs" => '("btrfs"))
359 ("iso9660" => '("isofs"))
360 ("jfs" => '("jfs"))
361 ("f2fs" => '("f2fs" "crc32_cryptoapi"))
362 ("xfs" => '("xfs"))
363 (else '())))
364
365(define (file-system-modules file-systems)
366 "Return the list of Linux modules needed to mount FILE-SYSTEMS."
367 (append-map (compose file-system-type-modules file-system-type)
368 file-systems))
369
370(define-deprecated/public-alias %base-initrd-modules
371 (base-initrd-modules linux-libre))
372
373(define* (base-initrd-modules
374 kernel
375 #:optional
376 (system (or (and=> (%current-target-system)
377 gnu-triplet->nix-system)
378 (%current-system))))
379 "Return a list of modules tailored to KERNEL for SYSTEM to include in the
380initrd by default."
381 (define (modules package)
382 (assoc-ref (package-properties package) 'base-initrd-modules))
383
384 (or (assoc-ref (or (modules kernel) (modules linux-libre))
385 system)
386 ;; Either SYSTEM is not supported by KERNEL, or KERNEL is the Hurd.
387 '()))
388
389(define* (base-initrd file-systems
390 #:key
391 (linux linux-libre)
392 (linux-modules '())
393 (mapped-devices '())
394 (keyboard-layout #f)
395 qemu-networking?
396 volatile-root?
397 (extra-modules '()) ;deprecated
398 (on-error 'debug))
399 "Return as a file-like object a generic initrd, with kernel
400modules taken from LINUX. FILE-SYSTEMS is a list of file-systems to be
401mounted by the initrd, possibly in addition to the root file system specified
402on the kernel command line via 'root'. MAPPED-DEVICES is a list of device
403mappings to realize before FILE-SYSTEMS are mounted.
404
405When true, KEYBOARD-LAYOUT is a <keyboard-layout> record denoting the desired
406console keyboard layout. This is done before MAPPED-DEVICES are set up and
407before FILE-SYSTEMS are mounted such that, should the user need to enter a
408passphrase or use the REPL, this happens using the intended keyboard layout.
409
410QEMU-NETWORKING? and VOLATILE-ROOT? behaves as in raw-initrd.
411
412The initrd is automatically populated with all the kernel modules necessary
413for FILE-SYSTEMS and for the given options. Additional kernel
414modules can be listed in LINUX-MODULES. They will be added to the initrd, and
415loaded at boot time in the order in which they appear."
416 (define linux-modules*
417 ;; Modules added to the initrd and loaded from the initrd.
418 `(,@linux-modules
419 ,@(file-system-modules file-systems)
420 ,@(if volatile-root?
421 '("overlay")
422 '())
423 ,@extra-modules))
424
425 (define helper-packages
426 (append (file-system-packages file-systems
427 #:volatile-root? volatile-root?)
428 (if keyboard-layout
429 (list loadkeys-static)
430 '())))
431
432 (raw-initrd file-systems
433 #:linux linux
434 #:linux-modules linux-modules*
435 #:mapped-devices mapped-devices
436 #:helper-packages helper-packages
437 #:keyboard-layout keyboard-layout
438 #:qemu-networking? qemu-networking?
439 #:volatile-root? volatile-root?
440 #:on-error on-error))
441
442;;; linux-initrd.scm ends here