X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/6d9a859038b33c1bde35df915f101b58774bce06..7a0bf3d5337d2662b0e4cdb8c9f8b5162c401d23:/gnu/system/linux-initrd.scm diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 5a7aec5c87..0971ec29e2 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -1,8 +1,9 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2016 Mark H Weaver ;;; Copyright © 2016 Jan Nieuwenhuizen -;;; Copyright © 2017 Mathieu Othacehe +;;; Copyright © 2017, 2019 Mathieu Othacehe +;;; Copyright © 2019 Tobias Geerinckx-Rice ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,8 +21,6 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu system linux-initrd) - #:use-module (guix monads) - #:use-module (guix store) #:use-module (guix gexp) #:use-module (guix utils) #:use-module ((guix store) @@ -32,16 +31,22 @@ #:use-module (gnu packages compression) #:use-module (gnu packages disk) #:use-module (gnu packages linux) + #:use-module (gnu packages file-systems) #:use-module (gnu packages guile) + #:use-module ((gnu packages xorg) + #:select (console-setup xkeyboard-config)) #:use-module ((gnu packages make-bootstrap) - #:select (%guile-static-stripped)) + #:select (%guile-3.0-static-stripped)) #:use-module (gnu system file-systems) #:use-module (gnu system mapped-devices) + #:use-module (gnu system keyboard) #:use-module (ice-9 match) #:use-module (ice-9 regex) + #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (expression->initrd + %base-initrd-modules raw-initrd file-system-packages base-initrd)) @@ -57,11 +62,11 @@ (define* (expression->initrd exp #:key - (guile %guile-static-stripped) + (guile %guile-3.0-static-stripped) (gzip gzip) (name "guile-initrd") (system (%current-system))) - "Return a derivation that builds a Linux initrd (a gzipped cpio archive) + "Return as a file-like object a Linux initrd (a gzipped cpio archive) containing GUILE and that evaluates EXP, a G-expression, upon booting. All the derivations referenced by EXP are automatically copied to the initrd." @@ -78,49 +83,48 @@ the derivations referenced by EXP are automatically copied to the initrd." (use-modules (gnu build linux-initrd)) (mkdir #$output) - (build-initrd (string-append #$output "/initrd") + + ;; The guile used in the initrd must be present in the store, so + ;; that module loading works once the root is switched. + ;; + ;; To ensure that is the case, add an explicit reference to the + ;; guile package used in the initrd to the output. + ;; + ;; This fixes guix-patches bug #28399, "Fix mysql activation, and + ;; add a basic test". + (call-with-output-file (string-append #$ output "/references") + (lambda (port) + (simple-format port "~A\n" #$guile))) + + (build-initrd (string-append #$output "/initrd.cpio.gz") #:guile #$guile #:init #$init ;; Copy everything INIT refers to into the initrd. #:references-graphs '("closure") - #:gzip (string-append #$gzip "/bin/gzip"))))) + #:gzip (string-append #+gzip "/bin/gzip"))))) - (gexp->derivation name builder - #:references-graphs `(("closure" ,init)))) + (file-append (computed-file name builder + #:options + `(#:references-graphs (("closure" ,init)))) + "/initrd.cpio.gz")) (define (flat-linux-module-directory linux modules) "Return a flat directory containing the Linux kernel modules listed in MODULES and taken from LINUX." (define build-exp (with-imported-modules (source-module-closure - '((guix build utils) - (gnu build linux-modules))) + '((gnu build linux-modules))) #~(begin - (use-modules (ice-9 match) (ice-9 regex) + (use-modules (gnu build linux-modules) (srfi srfi-1) - (guix build utils) - (gnu build linux-modules)) - - (define (string->regexp str) - ;; Return a regexp that matches STR exactly. - (string-append "^" (regexp-quote str) "$")) + (srfi srfi-26)) (define module-dir (string-append #$linux "/lib/modules")) - (define (lookup module) - (let ((name (ensure-dot-ko module))) - (match (find-files module-dir (string->regexp name)) - ((file) - file) - (() - (error "module not found" name module-dir)) - ((_ ...) - (error "several modules by that name" - name module-dir))))) - (define modules - (let ((modules (map lookup '#$modules))) + (let* ((lookup (cut find-module-file module-dir <>)) + (modules (map lookup '#$modules))) (append modules (recursive-module-dependencies modules #:lookup-module lookup)))) @@ -131,7 +135,10 @@ MODULES and taken from LINUX." (copy-file module (string-append #$output "/" (basename module)))) - (delete-duplicates modules))))) + (delete-duplicates modules)) + + ;; Hyphen or underscore? This database tells us. + (write-module-name-database #$output)))) (computed-file "linux-modules" build-exp)) @@ -140,10 +147,12 @@ MODULES and taken from LINUX." (linux linux-libre) (linux-modules '()) (mapped-devices '()) + (keyboard-layout #f) (helper-packages '()) qemu-networking? - volatile-root?) - "Return a monadic derivation that builds a raw initrd, with kernel + volatile-root? + (on-error 'debug)) + "Return as a file-like object a raw initrd, with kernel modules taken from LINUX. FILE-SYSTEMS is a list of file-systems to be mounted by the initrd, possibly in addition to the root file system specified on the kernel command line via '--root'. LINUX-MODULES is a list of kernel @@ -152,10 +161,19 @@ mappings to realize before FILE-SYSTEMS are mounted. HELPER-PACKAGES is a list of packages to be copied in the initrd. It may include e2fsck/static or other packages needed by the initrd to check root partition. +When true, KEYBOARD-LAYOUT is a record denoting the desired +console keyboard layout. This is done before MAPPED-DEVICES are set up and +before FILE-SYSTEMS are mounted such that, should the user need to enter a +passphrase or use the REPL, this happens using the intended keyboard layout. + When QEMU-NETWORKING? is true, set up networking with the standard QEMU parameters. + When VOLATILE-ROOT? is true, the root file system is writable but any changes -to it are lost." +to it are lost. + +ON-ERROR is passed to 'call-with-error-handling'; it determines what happens +upon error." (define device-mapping-commands ;; List of gexps to open the mapped devices. (map (lambda (md) @@ -174,10 +192,12 @@ to it are lost." '((gnu build linux-boot) (guix build utils) (guix build bournish) + (gnu system file-systems) (gnu build file-systems))) #~(begin (use-modules (gnu build linux-boot) - (guix build utils) + (gnu system file-systems) + ((guix build utils) #:hide (delete)) (guix build bournish) ;add the 'bournish' meta-command (srfi srfi-26) @@ -193,13 +213,19 @@ to it are lost." (set-path-environment-variable "PATH" '("bin" "sbin") '#$helper-packages))) - (boot-system #:mounts '#$(map file-system->spec file-systems) - #:pre-mount (lambda () - (and #$@device-mapping-commands)) - #:linux-modules '#$linux-modules - #:linux-module-directory '#$kodir - #:qemu-guest-networking? #$qemu-networking? - #:volatile-root? '#$volatile-root?))) + (parameterize ((current-warning-port (%make-void-port "w"))) + (boot-system #:mounts + (map spec->file-system + '#$(map file-system->spec file-systems)) + #:pre-mount (lambda () + (and #$@device-mapping-commands)) + #:linux-modules '#$linux-modules + #:linux-module-directory '#$kodir + #:keymap-file #+(and=> keyboard-layout + keyboard-layout->console-keymap) + #:qemu-guest-networking? #$qemu-networking? + #:volatile-root? '#$volatile-root? + #:on-error '#$on-error)))) #:name "raw-initrd")) (define* (file-system-packages file-systems #:key (volatile-root? #f)) @@ -218,92 +244,126 @@ FILE-SYSTEMS." ,@(if (find (file-system-type-predicate "btrfs") file-systems) (list btrfs-progs/static) '()) - ,@(if volatile-root? - (list unionfs-fuse/static) + ,@(if (find (file-system-type-predicate "jfs") file-systems) + (list jfs_fsck/static) + '()) + ,@(if (find (file-system-type-predicate "f2fs") file-systems) + (list f2fs-fsck/static) '()))) +(define-syntax vhash ;TODO: factorize + (syntax-rules (=>) + "Build a vhash with the given key/value mappings." + ((_) + vlist-null) + ((_ (key others ... => value) rest ...) + (vhash-cons key value + (vhash (others ... => value) rest ...))) + ((_ (=> value) rest ...) + (vhash rest ...)))) + +(define-syntax lookup-procedure + (syntax-rules (else) + "Return a procedure that lookups keys in the given dictionary." + ((_ mapping ... (else default)) + (let ((table (vhash mapping ...))) + (lambda (key) + (match (vhash-assoc key table) + (#f default) + ((key . value) value))))))) + +(define file-system-type-modules + ;; Given a file system type, return the list of modules it needs. + (lookup-procedure ("cifs" => '("md4" "ecb" "cifs")) + ("9p" => '("9p" "9pnet_virtio")) + ("btrfs" => '("btrfs")) + ("iso9660" => '("isofs")) + ("jfs" => '("jfs")) + ("f2fs" => '("f2fs" "crc32_generic")) + (else '()))) + +(define (file-system-modules file-systems) + "Return the list of Linux modules needed to mount FILE-SYSTEMS." + (append-map (compose file-system-type-modules file-system-type) + file-systems)) + +(define* (default-initrd-modules + #:optional + (system (or (%current-target-system) + (%current-system)))) + "Return the list of modules included in the initrd by default." + (define virtio-modules + ;; Modules for Linux para-virtualized devices, for use in QEMU guests. + '("virtio_pci" "virtio_balloon" "virtio_blk" "virtio_net" + "virtio_console" "virtio-rng")) + + `("ahci" ;for SATA controllers + "usb-storage" "uas" ;for the installation image etc. + "usbhid" "hid-generic" "hid-apple" ;keyboards during early boot + "dm-crypt" "xts" "serpent_generic" "wp512" ;for encrypted root partitions + "nls_iso8859-1" ;for `mkfs.fat`, et.al + ,@(if (string-match "^(x86_64|i[3-6]86)-" system) + '("pata_acpi" "pata_atiixp" ;for ATA controllers + "isci") ;for SAS controllers like Intel C602 + '()) + + ,@virtio-modules)) + +(define-syntax %base-initrd-modules + ;; This more closely matches our naming convention. + (identifier-syntax (default-initrd-modules))) + (define* (base-initrd file-systems #:key (linux linux-libre) + (linux-modules '()) (mapped-devices '()) + (keyboard-layout #f) qemu-networking? volatile-root? - (virtio? #t) - (extra-modules '())) - "Return a monadic derivation that builds a generic initrd, with kernel + (extra-modules '()) ;deprecated + (on-error 'debug)) + "Return as a file-like object a generic initrd, with kernel modules taken from LINUX. FILE-SYSTEMS is a list of file-systems to be mounted by the initrd, possibly in addition to the root file system specified on the kernel command line via '--root'. MAPPED-DEVICES is a list of device mappings to realize before FILE-SYSTEMS are mounted. -QEMU-NETWORKING? and VOLATILE-ROOT? behaves as in raw-initrd. +When true, KEYBOARD-LAYOUT is a record denoting the desired +console keyboard layout. This is done before MAPPED-DEVICES are set up and +before FILE-SYSTEMS are mounted such that, should the user need to enter a +passphrase or use the REPL, this happens using the intended keyboard layout. -When VIRTIO? is true, load additional modules so the initrd can -be used as a QEMU guest with the root file system on a para-virtualized block -device. +QEMU-NETWORKING? and VOLATILE-ROOT? behaves as in raw-initrd. The initrd is automatically populated with all the kernel modules necessary -for FILE-SYSTEMS and for the given options. However, additional kernel -modules can be listed in EXTRA-MODULES. They will be added to the initrd, and +for FILE-SYSTEMS and for the given options. Additional kernel +modules can be listed in LINUX-MODULES. They will be added to the initrd, and loaded at boot time in the order in which they appear." - (define virtio-modules - ;; Modules for Linux para-virtualized devices, for use in QEMU guests. - '("virtio_pci" "virtio_balloon" "virtio_blk" "virtio_net" - "virtio_console")) - - (define cifs-modules - ;; Modules needed to mount CIFS file systems. - '("md4" "ecb" "cifs")) - - (define virtio-9p-modules - ;; Modules for the 9p paravirtualized file system. - '("9p" "9pnet_virtio")) - - (define (file-system-type-predicate type) - (lambda (fs) - (string=? (file-system-type fs) type))) - - (define linux-modules + (define linux-modules* ;; Modules added to the initrd and loaded from the initrd. - `("ahci" ;for SATA controllers - "usb-storage" "uas" ;for the installation image etc. - "usbhid" "hid-generic" "hid-apple" ;keyboards during early boot - "dm-crypt" "xts" "serpent_generic" "wp512" ;for encrypted root partitions - "nvme" ;for new SSD NVMe devices - "nls_iso8859-1" ;for `mkfs.fat`, et.al - ,@(if (string-match "^(x86_64|i[3-6]86)-" (%current-system)) - '("pata_acpi" "pata_atiixp" ;for ATA controllers - "isci") ;for SAS controllers like Intel C602 - '()) - ,@(if (or virtio? qemu-networking?) - virtio-modules - '()) - ,@(if (find (file-system-type-predicate "cifs") file-systems) - cifs-modules - '()) - ,@(if (find (file-system-type-predicate "9p") file-systems) - virtio-9p-modules - '()) - ,@(if (find (file-system-type-predicate "btrfs") file-systems) - '("btrfs") - '()) - ,@(if (find (file-system-type-predicate "iso9660") file-systems) - '("isofs") - '()) + `(,@linux-modules + ,@(file-system-modules file-systems) ,@(if volatile-root? - '("fuse") + '("overlay") '()) ,@extra-modules)) (define helper-packages - (file-system-packages file-systems #:volatile-root? volatile-root?)) + (append (file-system-packages file-systems + #:volatile-root? volatile-root?) + (if keyboard-layout + (list loadkeys-static) + '()))) (raw-initrd file-systems #:linux linux - #:linux-modules linux-modules + #:linux-modules linux-modules* #:mapped-devices mapped-devices #:helper-packages helper-packages + #:keyboard-layout keyboard-layout #:qemu-networking? qemu-networking? - #:volatile-root? volatile-root?)) + #:volatile-root? volatile-root? + #:on-error on-error)) ;;; linux-initrd.scm ends here