projects/guix·blob java-team · refs

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