From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:50844) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1eqgAn-0004jC-H3 for guix-patches@gnu.org; Tue, 27 Feb 2018 09:24:07 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1eqgAl-00011S-TG for guix-patches@gnu.org; Tue, 27 Feb 2018 09:24:05 -0500 Received: from debbugs.gnu.org ([208.118.235.43]:54925) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1eqgAl-00011O-PK for guix-patches@gnu.org; Tue, 27 Feb 2018 09:24:03 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1eqgAl-0003Pf-Jf for guix-patches@gnu.org; Tue, 27 Feb 2018 09:24:03 -0500 Subject: [bug#30629] [PATCH 5/5] guix system: Check for the lack of modules in the initrd. Resent-Message-ID: From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Tue, 27 Feb 2018 15:22:45 +0100 Message-Id: <20180227142245.12674-6-ludo@gnu.org> In-Reply-To: <20180227142245.12674-1-ludo@gnu.org> References: <20180227142245.12674-1-ludo@gnu.org> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 30629@debbugs.gnu.org * guix/scripts/system.scm (check-mapped-devices): Take an OS instead of a list of . 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'. --- gnu/system/mapped-devices.scm | 53 +++++++++++++++++++++++++--------- 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 dbeb0d343..5ceb5e658 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 +;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2016 Andreas Enge ;;; Copyright © 2017 Mark H Weaver ;;; @@ -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 999ffb010..ff322ec78 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 -- 2.16.2