diff options
| -rw-r--r-- | gnu/system/mapped-devices.scm | 53 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 67 |
2 files changed, 96 insertions, 24 deletions
diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm index dbeb0d3436..5ceb5e658c 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> ;;; @@ -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)) - (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/guix/scripts/system.scm b/guix/scripts/system.scm index 999ffb010b..ff322ec785 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -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 - (source-properties->location - (mapped-device-location md))))))) - mapped-devices)) + ;; '&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 + (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 |