X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/d422cbb3d6a1cc7e4553a2335b113475a05d68ad..4ac9db0d75edcacb3a0c98659620cfea3c1e1993:/gnu/system/linux-initrd.scm diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 983c6d81c8..c6ba9bb560 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, 2018 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, 2020 Tobias Geerinckx-Rice ;;; ;;; This file is part of GNU Guix. ;;; @@ -30,11 +31,15 @@ #: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) @@ -57,7 +62,7 @@ (define* (expression->initrd exp #:key - (guile %guile-static-stripped) + (guile %guile-3.0-static-stripped) (gzip gzip) (name "guile-initrd") (system (%current-system))) @@ -71,9 +76,20 @@ the derivations referenced by EXP are automatically copied to the initrd." (define init (program-file "init" exp #:guile guile)) + (define (import-module? module) + ;; Since we don't use deduplication support in 'populate-store', don't + ;; import (guix store deduplication) and its dependencies, which includes + ;; Guile-Gcrypt. That way we can run tests with '--bootstrap'. + (and (guix-module-name? module) + (not (equal? module '(guix store deduplication))))) + (define builder + ;; Do not use "guile-zlib" extension here, otherwise it would drag the + ;; non-static "zlib" package to the initrd closure. It is not needed + ;; anyway because the modules are stored uncompressed within the initrd. (with-imported-modules (source-module-closure - '((gnu build linux-initrd))) + '((gnu build linux-initrd)) + #:select? import-module?) #~(begin (use-modules (gnu build linux-initrd)) @@ -96,7 +112,7 @@ the derivations referenced by EXP are automatically copied to the initrd." #: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"))))) (file-append (computed-file name builder #:options @@ -106,31 +122,49 @@ the derivations referenced by EXP are automatically copied to the initrd." (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 - '((gnu build linux-modules))) - #~(begin - (use-modules (gnu build linux-modules) - (srfi srfi-1) - (srfi srfi-26)) + (define imported-modules + (source-module-closure '((gnu build linux-modules) + (guix build utils)))) - (define module-dir - (string-append #$linux "/lib/modules")) - - (define modules - (let* ((lookup (cut find-module-file module-dir <>)) - (modules (map lookup '#$modules))) - (append modules - (recursive-module-dependencies modules - #:lookup-module lookup)))) - - (mkdir #$output) - (for-each (lambda (module) - (format #t "copying '~a'...~%" module) - (copy-file module - (string-append #$output "/" - (basename module)))) - (delete-duplicates modules))))) + (define build-exp + (with-imported-modules imported-modules + (with-extensions (list guile-zlib) + #~(begin + (use-modules (gnu build linux-modules) + (guix build utils) + (srfi srfi-1) + (srfi srfi-26)) + + (define module-dir + (string-append #$linux "/lib/modules")) + + (define modules + (let* ((lookup (cut find-module-file module-dir <>)) + (modules (map lookup '#$modules))) + (append modules + (recursive-module-dependencies + modules + #:lookup-module lookup)))) + + (define (maybe-uncompress file) + ;; If FILE is a compressed module, uncompress it, as the initrd + ;; is already gzipped as a whole. + (cond + ((string-contains file ".ko.gz") + (invoke #+(file-append gzip "/bin/gunzip") file)))) + + (mkdir #$output) + (for-each (lambda (module) + (let ((out-module + (string-append #$output "/" + (basename module)))) + (format #t "copying '~a'...~%" module) + (copy-file module out-module) + (maybe-uncompress out-module))) + (delete-duplicates modules)) + + ;; Hyphen or underscore? This database tells us. + (write-module-name-database #$output))))) (computed-file "linux-modules" build-exp)) @@ -139,6 +173,7 @@ MODULES and taken from LINUX." (linux linux-libre) (linux-modules '()) (mapped-devices '()) + (keyboard-layout #f) (helper-packages '()) qemu-networking? volatile-root? @@ -152,6 +187,11 @@ 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. @@ -163,11 +203,11 @@ upon error." (define device-mapping-commands ;; List of gexps to open the mapped devices. (map (lambda (md) - (let* ((source (mapped-device-source md)) - (target (mapped-device-target md)) - (type (mapped-device-type md)) - (open (mapped-device-kind-open type))) - (open source target))) + (let* ((source (mapped-device-source md)) + (targets (mapped-device-targets md)) + (type (mapped-device-type md)) + (open (mapped-device-kind-open type))) + (open source targets))) mapped-devices)) (define kodir @@ -183,8 +223,9 @@ upon error." #~(begin (use-modules (gnu build linux-boot) (gnu system file-systems) - (guix build utils) + ((guix build utils) #:hide (delete)) (guix build bournish) ;add the 'bournish' meta-command + (srfi srfi-1) ;for lvm-device-mapping (srfi srfi-26) ;; FIXME: The following modules are for @@ -199,16 +240,19 @@ upon error." (set-path-environment-variable "PATH" '("bin" "sbin") '#$helper-packages))) - (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 - #:qemu-guest-networking? #$qemu-networking? - #:volatile-root? '#$volatile-root? - #:on-error '#$on-error))) + (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)) @@ -224,8 +268,17 @@ FILE-SYSTEMS." file-systems) (list fatfsck/static) '()) + ,@(if (find (file-system-type-predicate "bcachefs") file-systems) + (list bcachefs-tools/static) + '()) ,@(if (find (file-system-type-predicate "btrfs") file-systems) (list btrfs-progs/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 @@ -253,8 +306,11 @@ FILE-SYSTEMS." ;; Given a file system type, return the list of modules it needs. (lookup-procedure ("cifs" => '("md4" "ecb" "cifs")) ("9p" => '("9p" "9pnet_virtio")) + ("bcachefs" => '("bcachefs")) ("btrfs" => '("btrfs")) ("iso9660" => '("isofs")) + ("jfs" => '("jfs")) + ("f2fs" => '("f2fs" "crc32_generic")) (else '()))) (define (file-system-modules file-systems) @@ -262,7 +318,10 @@ FILE-SYSTEMS." (append-map (compose file-system-type-modules file-system-type) file-systems)) -(define* (default-initrd-modules #:optional (system (%current-system))) +(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. @@ -290,6 +349,7 @@ FILE-SYSTEMS." (linux linux-libre) (linux-modules '()) (mapped-devices '()) + (keyboard-layout #f) qemu-networking? volatile-root? (extra-modules '()) ;deprecated @@ -300,6 +360,11 @@ 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. +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. + QEMU-NETWORKING? and VOLATILE-ROOT? behaves as in raw-initrd. The initrd is automatically populated with all the kernel modules necessary @@ -316,13 +381,18 @@ loaded at boot time in the order in which they appear." ,@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* #:mapped-devices mapped-devices #:helper-packages helper-packages + #:keyboard-layout keyboard-layout #:qemu-networking? qemu-networking? #:volatile-root? volatile-root? #:on-error on-error))