projects/guix·blob mpd-fix-groups · refs

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