guix system: Check for the lack of modules in the initrd.
* guix/scripts/system.scm (check-mapped-devices): Take an OS instead of a list of <mapped-device>. Pass #:needed-for-boot? and #:initrd-modules to CHECK. (check-initrd-modules): New procedure. (perform-action): Move 'check-mapped-devices' call first. Add call to 'check-initrd-modules'. * gnu/system/mapped-devices.scm (check-device-initrd-modules): New procedure. (check-luks-device): Add #:initrd-modules and #:needed-for-boot?. Use them to call 'check-device-initrd-modules'.
This commit is contained in:
Ludovic Courtès
parent
bc499b113a
commit
424cea8083
|
|
@ -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>
|
||||
;;;
|
||||
|
|
@ -30,9 +30,12 @@
|
|||
#:use-module (gnu services shepherd)
|
||||
#:use-module (gnu system uuid)
|
||||
#:autoload (gnu build file-systems) (find-partition-by-luks-uuid)
|
||||
#:autoload (gnu build linux-modules)
|
||||
(device-module-aliases matching-modules)
|
||||
#: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,43 @@
|
|||
#~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
|
||||
"close" #$target)))
|
||||
|
||||
(define (check-luks-device md)
|
||||
(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."
|
||||
(let ((modules (delete-duplicates
|
||||
(append-map matching-modules
|
||||
(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)))
|
||||
(&error-location
|
||||
(location (source-properties->location location))))))))
|
||||
|
||||
(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))
|
||||
(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)))))))))
|
||||
(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.
|
||||
|
|
|
|||
|
|
@ -41,6 +41,10 @@
|
|||
#:use-module (gnu build install)
|
||||
#:autoload (gnu build file-systems)
|
||||
(find-partition-by-label find-partition-by-uuid)
|
||||
#:autoload (gnu build linux-modules)
|
||||
(device-module-aliases matching-modules)
|
||||
#:autoload (gnu system linux-initrd)
|
||||
(base-initrd default-initrd-modules)
|
||||
#:use-module (gnu system)
|
||||
#:use-module (gnu bootloader)
|
||||
#:use-module (gnu system file-systems)
|
||||
|
|
@ -624,21 +628,61 @@ any, are available. Raise an error if they're not."
|
|||
;; Better be safe than sorry.
|
||||
(exit 1))))
|
||||
|
||||
(define (check-mapped-devices mapped-devices)
|
||||
(define (check-mapped-devices os)
|
||||
"Check that each of MAPPED-DEVICES is valid according to the 'check'
|
||||
procedure of its type."
|
||||
(define boot-mapped-devices
|
||||
(operating-system-boot-mapped-devices os))
|
||||
|
||||
(define (needed-for-boot? md)
|
||||
(memq md boot-mapped-devices))
|
||||
|
||||
(define initrd-modules
|
||||
(operating-system-initrd-modules os))
|
||||
|
||||
(for-each (lambda (md)
|
||||
(let ((check (mapped-device-kind-check
|
||||
(mapped-device-type md))))
|
||||
;; We expect CHECK to raise an exception with a detailed
|
||||
;; '&message' if something goes wrong, but handle the case
|
||||
;; where it just returns #f.
|
||||
(unless (check md)
|
||||
(leave (G_ "~a: invalid '~a' mapped device~%")
|
||||
(location->string
|
||||
;; '&message' if something goes wrong.
|
||||
(check md
|
||||
#:needed-for-boot? (needed-for-boot? md)
|
||||
#:initrd-modules initrd-modules)))
|
||||
(operating-system-mapped-devices os)))
|
||||
|
||||
(define (check-initrd-modules os)
|
||||
"Check that modules needed by 'needed-for-boot' file systems in OS are
|
||||
available in the initrd. Note that mapped devices are responsible for
|
||||
checking this by themselves in their 'check' procedure."
|
||||
(define (file-system-/dev fs)
|
||||
(let ((device (file-system-device fs)))
|
||||
(match (file-system-title fs)
|
||||
('device device)
|
||||
('uuid (find-partition-by-uuid device))
|
||||
('label (find-partition-by-label device)))))
|
||||
|
||||
(define (check-device device location)
|
||||
(let ((modules (delete-duplicates
|
||||
(append-map matching-modules
|
||||
(device-module-aliases device)))))
|
||||
(unless (every (cute member <> (operating-system-initrd-modules os))
|
||||
modules)
|
||||
(raise (condition
|
||||
(&message
|
||||
(message (format #f (G_ "you need these modules \
|
||||
in the initrd for ~a:~{ ~a~}")
|
||||
device modules)))
|
||||
(&error-location (location location)))))))
|
||||
|
||||
(define file-systems
|
||||
(filter file-system-needed-for-boot?
|
||||
(operating-system-file-systems os)))
|
||||
|
||||
(for-each (lambda (fs)
|
||||
(check-device (file-system-/dev fs)
|
||||
(source-properties->location
|
||||
(mapped-device-location md)))))))
|
||||
mapped-devices))
|
||||
(file-system-location fs))))
|
||||
file-systems))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
@ -730,9 +774,10 @@ output when building a system derivation, such as a disk image."
|
|||
;; instantiating a broken configuration. Assume that we can only check if
|
||||
;; running as root.
|
||||
(when (memq action '(init reconfigure))
|
||||
(check-mapped-devices os)
|
||||
(when (zero? (getuid))
|
||||
(check-file-system-availability (operating-system-file-systems os)))
|
||||
(check-mapped-devices (operating-system-mapped-devices os)))
|
||||
(check-file-system-availability (operating-system-file-systems os))
|
||||
(check-initrd-modules os)))
|
||||
|
||||
(mlet* %store-monad
|
||||
((sys (system-derivation-for-action os action
|
||||
|
|
|
|||
Loading…
Reference in New Issue