05/05: guix system: Check for the lack of modules in the initrd.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 424cea8083a4cee63290c80235aed61bd12affb1
Author: Ludovic Courtès <address@hidden>
Date:   Tue Feb 27 14:55:43 2018 +0100

    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'.
---
 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 dbeb0d34..5ceb5e6 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 <address@hidden>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2016 Andreas Enge <address@hidden>
 ;;; Copyright © 2017 Mark H Weaver <address@hidden>
 ;;;
@@ -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 999ffb0..ff322ec 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