summaryrefslogtreecommitdiff
path: root/gnu/system
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/system')
-rw-r--r--gnu/system/examples/beaglebone-black.tmpl9
-rw-r--r--gnu/system/install.scm9
-rw-r--r--gnu/system/linux-initrd.scm164
-rw-r--r--gnu/system/mapped-devices.scm38
-rw-r--r--gnu/system/vm.scm24
5 files changed, 154 insertions, 90 deletions
diff --git a/gnu/system/examples/beaglebone-black.tmpl b/gnu/system/examples/beaglebone-black.tmpl
index 4b090e0fb7..97201330c7 100644
--- a/gnu/system/examples/beaglebone-black.tmpl
+++ b/gnu/system/examples/beaglebone-black.tmpl
@@ -15,11 +15,10 @@
(bootloader (bootloader-configuration
(bootloader u-boot-beaglebone-black-bootloader)
(target "/dev/mmcblk1")))
- (initrd (lambda (fs . rest)
- (apply base-initrd fs
- ;; This module is required to mount the sd card.
- #:extra-modules (list "omap_hsmmc")
- rest)))
+
+ ;; This module is required to mount the SD card.
+ (initrd-modules (cons "omap_hsmmc" %base-initrd-modules))
+
(file-systems (cons (file-system
(device "my-root")
(title 'label)
diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index b61660b4b9..97f5abe0b6 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2016 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
@@ -133,7 +133,7 @@ the given target.")
(stop #~(lambda (target)
;; Delete the temporary directory, but leave everything
;; mounted as there may still be processes using it since
- ;; 'user-processes' doesn't depend on us. The 'user-unmount'
+ ;; 'user-processes' doesn't depend on us. The 'user-file-systems'
;; service will unmount TARGET eventually.
(delete-file-recursively
(string-append target #$%backing-directory))))))))
@@ -396,10 +396,7 @@ The bootloader BOOTLOADER is installed to BOOTLOADER-TARGET."
(kernel-arguments
(cons (string-append "console=" tty)
(operating-system-user-kernel-arguments installation-os)))
- (initrd (lambda (fs . rest)
- (apply base-initrd fs
- #:extra-modules extra-modules
- rest)))))
+ (initrd-modules (append extra-modules %base-initrd-modules))))
(define beaglebone-black-installation-os
(embedded-installation-os u-boot-beaglebone-black-bootloader
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index 330438bce4..410484390c 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -24,6 +24,7 @@
#:use-module (guix store)
#:use-module (guix gexp)
#:use-module (guix utils)
+ #:use-module (guix i18n)
#:use-module ((guix store)
#:select (%store-prefix))
#:use-module ((guix derivations)
@@ -37,14 +38,22 @@
#:select (%guile-static-stripped))
#:use-module (gnu system file-systems)
#:use-module (gnu system mapped-devices)
+ #:autoload (gnu build linux-modules)
+ (device-module-aliases matching-modules known-module-aliases)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
+ #:use-module (ice-9 vlist)
+ #:use-module (ice-9 format)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
#:export (expression->initrd
+ %base-initrd-modules
raw-initrd
file-system-packages
- base-initrd))
+ base-initrd
+ check-device-initrd-modules))
;;; Commentary:
@@ -242,14 +251,71 @@ FILE-SYSTEMS."
(list btrfs-progs/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"))
+ (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 (%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"))
+
+ `("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 '())
qemu-networking?
volatile-root?
- (virtio? #t)
- (extra-modules '())
+ (extra-modules '()) ;deprecated
(on-error 'debug))
"Return a monadic derivation that builds a generic initrd, with kernel
modules taken from LINUX. FILE-SYSTEMS is a list of file-systems to be
@@ -259,57 +325,14 @@ mappings to realize before FILE-SYSTEMS are mounted.
QEMU-NETWORKING? and VOLATILE-ROOT? behaves as in raw-initrd.
-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.
-
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
- "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?
'("overlay")
'())
@@ -320,11 +343,48 @@ loaded at boot time in the order in which they appear."
(raw-initrd file-systems
#:linux linux
- #:linux-modules linux-modules
+ #:linux-modules linux-modules*
#:mapped-devices mapped-devices
#:helper-packages helper-packages
#:qemu-networking? qemu-networking?
#:volatile-root? volatile-root?
#:on-error on-error))
+(define (check-device-initrd-modules device linux-modules location)
+ "Raise an error if DEVICE needs modules beyond LINUX-MODULES to operate.
+DEVICE must be a \"/dev\" file name."
+ (define aliases
+ ;; Attempt to load 'modules.alias' from the current kernel, assuming we're
+ ;; on GuixSD, and assuming that corresponds to the kernel we'll be
+ ;; installing. Skip the whole thing if that file cannot be read.
+ (catch 'system-error
+ (lambda ()
+ (known-module-aliases))
+ (const #f)))
+
+ (when aliases
+ (let ((modules (delete-duplicates
+ (append-map (cut matching-modules <> aliases)
+ (device-module-aliases device)))))
+ (unless (every (cute member <> linux-modules) modules)
+ (raise (condition
+ (&message
+ (message (format #f (G_ "you may need these modules \
+in the initrd for ~a:~{ ~a~}")
+ device modules)))
+ (&fix-hint
+ (hint (format #f (G_ "Try adding them to the
+@code{initrd-modules} field of your @code{operating-system} declaration, along
+these lines:
+
+@example
+ (operating-system
+ ;; @dots{}
+ (initrd-modules (append (list~{ ~s~})
+ %base-initrd-modules)))
+@end example\n")
+ modules)))
+ (&error-location
+ (location (source-properties->location location)))))))))
+
;;; linux-initrd.scm ends here
diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm
index dbeb0d3436..e6ac635231 100644
--- a/gnu/system/mapped-devices.scm
+++ b/gnu/system/mapped-devices.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2017 Mark H Weaver <mhw@netris.org>
;;;
@@ -29,10 +29,13 @@
#:use-module (gnu services)
#:use-module (gnu services shepherd)
#:use-module (gnu system uuid)
+ #:use-module ((gnu system linux-initrd)
+ #:select (check-device-initrd-modules))
#:autoload (gnu build file-systems) (find-partition-by-luks-uuid)
#:autoload (gnu packages cryptsetup) (cryptsetup-static)
#:autoload (gnu packages linux) (mdadm-static)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (ice-9 match)
@@ -151,19 +154,28 @@
#~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
"close" #$target)))
-(define (check-luks-device md)
+(define* (check-luks-device md #:key
+ needed-for-boot?
+ (initrd-modules '())
+ #:allow-other-keys
+ #:rest rest)
"Ensure the source of MD is valid."
- (let ((source (mapped-device-source md)))
- (or (not (uuid? source))
- (not (zero? (getuid)))
- (find-partition-by-luks-uuid (uuid-bytevector source))
- (raise (condition
- (&message
- (message (format #f (G_ "no LUKS partition with UUID '~a'")
- (uuid->string source))))
- (&error-location
- (location (source-properties->location
- (mapped-device-location md)))))))))
+ (let ((source (mapped-device-source md))
+ (location (mapped-device-location md)))
+ (or (not (zero? (getuid)))
+ (if (uuid? source)
+ (match (find-partition-by-luks-uuid (uuid-bytevector source))
+ (#f
+ (raise (condition
+ (&message
+ (message (format #f (G_ "no LUKS partition with UUID '~a'")
+ (uuid->string source))))
+ (&error-location
+ (location (source-properties->location
+ (mapped-device-location md)))))))
+ ((? string? device)
+ (check-device-initrd-modules device initrd-modules location)))
+ (check-device-initrd-modules source initrd-modules location)))))
(define luks-device-mapping
;; The type of LUKS mapped devices.
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 345cecedd8..ae8780d2e1 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -30,6 +30,8 @@
#:use-module (guix records)
#:use-module (guix modules)
#:use-module (guix utils)
+ #:use-module (guix hash)
+ #:use-module (guix base32)
#:use-module ((gnu build vm)
#:select (qemu-command))
@@ -143,7 +145,7 @@ made available under the /xchg CIFS share."
(return initrd)
(base-initrd %linux-vm-file-systems
#:linux linux
- #:virtio? #t
+ #:linux-modules %base-initrd-modules
#:qemu-networking? #t))))
(define builder
@@ -512,12 +514,7 @@ of the GNU system as described by OS."
(let ((os (operating-system (inherit os)
- ;; Use an initrd with the whole QEMU shebang.
- (initrd (lambda (file-systems . rest)
- (apply (operating-system-initrd os)
- file-systems
- #:virtio? #t
- rest)))
+ ;; Assume we have an initrd with the whole QEMU shebang.
;; Force our own root file system. Refer to it by UUID so that
;; it works regardless of how the image is used ("qemu -hda",
@@ -549,13 +546,13 @@ of the GNU system as described by OS."
(define (file-system->mount-tag fs)
"Return a 9p mount tag for host file system FS."
- ;; QEMU mount tags cannot contain slashes and cannot start with '_'.
- ;; Compute an identifier that corresponds to the rules.
+ ;; QEMU mount tags must be ASCII, at most 31-byte long, cannot contain
+ ;; slashes, and cannot start with '_'. Compute an identifier that
+ ;; corresponds to the rules.
(string-append "TAG"
- (string-map (match-lambda
- (#\/ #\_)
- (chr chr))
- fs)))
+ (string-drop (bytevector->base32-string
+ (sha1 (string->utf8 fs)))
+ 4)))
(define (mapping->file-system mapping)
"Return a 9p file system that realizes MAPPING."
@@ -614,7 +611,6 @@ environment with the store shared with the host. MAPPINGS is a list of
(apply (operating-system-initrd os)
file-systems
#:volatile-root? #t
- #:virtio? #t
rest)))
;; Disable swap.
generated by cgit v1.2.3 (git 2.46.0) at 2024-08-06 06:19:45 +0000