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.
This commit is contained in:
Ludovic Courtès 2019-03-26 23:06:51 +01:00
parent 54043bf23f
commit 50247be5f4
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 51 additions and 14 deletions

View file

@ -43,13 +43,17 @@ (define-module (gnu installer)
#: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 @@ (define modules
"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)

View file

@ -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 @@ (define-module (gnu installer parted)
#: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 @@ (define (user-partition->mapped-device user-partition)
(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 @@ (define (bootloader-configuration user-partitions)
;; <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 @@ (define (user-partitions->configuration user-partitions)
(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))))