summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2019-03-26 23:06:51 +0100
committerLudovic Courtès <ludo@gnu.org>2019-03-27 11:54:05 +0100
commit50247be5f4633a4c3446cddbd3515d027853ec0d (patch)
treedbdba53956b62e1a9490b9eda8899bec2651d0c8
parent54043bf23f9b1a012f26082f57286862c5029865 (diff)
installer: Produce an 'initrd-modules' field if needed.
* gnu/installer/parted.scm (root-user-partition?): New procedure. (bootloader-configuration): Use it. (user-partition-missing-modules, initrd-configuration): New procedures. (user-partitions->configuration): Call 'initrd-configuration'.o * gnu/installer.scm (not-config?): Rename to... (module-to-import?): ... this. Add cases to exclude non-installer and non-build (gnu …) modules. (installer-program)[installer-builder]: Add GUIX to the extension list.
-rw-r--r--gnu/installer.scm20
-rw-r--r--gnu/installer/parted.scm45
2 files changed, 51 insertions, 14 deletions
diff --git a/gnu/installer.scm b/gnu/installer.scm
index 02f26eead3..584ca3842f 100644
--- a/gnu/installer.scm
+++ b/gnu/installer.scm
@@ -43,13 +43,17 @@
#:use-module (srfi srfi-1)
#:export (installer-program))
-(define not-config?
- ;; Select (guix …) and (gnu …) modules, except (guix config).
+(define module-to-import?
+ ;; Return true for modules that should be imported. For (gnu system …) and
+ ;; (gnu packages …) modules, we simply add the whole 'guix' package via
+ ;; 'with-extensions' (to avoid having to rebuild it all), which is why these
+ ;; modules are excluded here.
(match-lambda
(('guix 'config) #f)
- (('guix rest ...) #t)
- (('gnu rest ...) #t)
- (rest #f)))
+ (('gnu 'installer _ ...) #t)
+ (('gnu 'build _ ...) #t)
+ (('guix 'build _ ...) #t)
+ (_ #f)))
(define* (build-compiled-file name locale-builder)
"Return a file-like object that evalutes the gexp LOCALE-BUILDER and store
@@ -296,13 +300,15 @@ selected keymap."
"gnu/installer"))
(define installer-builder
+ ;; Note: Include GUIX as an extension to get all the (gnu system …), (gnu
+ ;; packages …), etc. modules.
(with-extensions (list guile-gcrypt guile-newt
guile-parted guile-bytestructures
- guile-json)
+ guile-json guile-git guix)
(with-imported-modules `(,@(source-module-closure
`(,@modules
(guix build utils))
- #:select? not-config?)
+ #:select? module-to-import?)
((guix config) => ,(make-config.scm)))
#~(begin
(use-modules (gnu installer record)
diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm
index b9eaa79458..7cc2217cbe 100644
--- a/gnu/installer/parted.scm
+++ b/gnu/installer/parted.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2019 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -24,6 +25,10 @@
#:use-module ((gnu build file-systems)
#:select (read-partition-uuid
read-luks-partition-uuid))
+ #:use-module ((gnu build linux-modules)
+ #:select (missing-modules))
+ #:use-module ((gnu system linux-initrd)
+ #:select (%base-initrd-modules))
#:use-module (guix build syscalls)
#:use-module (guix build utils)
#:use-module (guix records)
@@ -1243,15 +1248,16 @@ from (gnu system mapped-devices) and return it."
(target ,label)
(type luks-device-mapping))))
+(define (root-user-partition? partition)
+ "Return true if PARTITION is the root partition."
+ (let ((mount-point (user-partition-mount-point partition)))
+ (and mount-point
+ (string=? mount-point "/"))))
+
(define (bootloader-configuration user-partitions)
"Return the bootloader configuration field for USER-PARTITIONS."
- (let* ((root-partition
- (find (lambda (user-partition)
- (let ((mount-point
- (user-partition-mount-point user-partition)))
- (and mount-point
- (string=? mount-point "/"))))
- user-partitions))
+ (let* ((root-partition (find root-user-partition?
+ user-partitions))
(root-partition-disk (user-partition-disk-file-name root-partition)))
`((bootloader-configuration
,@(if (efi-installation?)
@@ -1264,6 +1270,30 @@ from (gnu system mapped-devices) and return it."
;; <operating-system> right above.
(keyboard-layout keyboard-layout)))))
+(define (user-partition-missing-modules user-partitions)
+ "Return the list of kernel modules missing from the default set of kernel
+modules to access USER-PARTITIONS."
+ (let ((devices (filter user-partition-crypt-label user-partitions))
+ (root (find root-user-partition? user-partitions)))
+ (delete-duplicates
+ (append-map (lambda (device)
+ (catch 'system-error
+ (lambda ()
+ (missing-modules device %base-initrd-modules))
+ (const '())))
+ (delete-duplicates
+ (map user-partition-file-name
+ (cons root devices)))))))
+
+(define (initrd-configuration user-partitions)
+ "Return an 'initrd-modules' field with everything needed for
+USER-PARTITIONS, or return nothing."
+ (match (user-partition-missing-modules user-partitions)
+ (()
+ '())
+ ((modules ...)
+ `((initrd-modules ',modules)))))
+
(define (user-partitions->configuration user-partitions)
"Return the configuration field for USER-PARTITIONS."
(let* ((swap-user-partitions (find-swap-user-partitions user-partitions))
@@ -1271,6 +1301,7 @@ from (gnu system mapped-devices) and return it."
(encrypted-partitions
(filter user-partition-crypt-label user-partitions)))
`((bootloader ,@(bootloader-configuration user-partitions))
+ ,@(initrd-configuration user-partitions)
,@(if (null? swap-devices)
'()
`((swap-devices (list ,@swap-devices))))