guix: system: Add `--label' option.

[jackhill/guix/guix.git] / gnu / system / mapped-devices.scm

diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm
index 279d521..31c50c4 100644 (file)
--- a/gnu/system/mapped-devices.scm
+++ b/gnu/system/mapped-devices.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Andreas Enge <andreas@enge.fr>
-;;; Copyright © 2017 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2017, 2018 Mark H Weaver <mhw@netris.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -21,10 +21,11 @@
 (define-module (gnu system mapped-devices)
   #:use-module (guix gexp)
   #:use-module (guix records)
-  #:use-module (guix modules)
+  #:use-module ((guix modules) #:hide (file-name->module-name))
   #:use-module (guix i18n)
-  #:use-module ((guix utils)
+  #:use-module ((guix diagnostics)
                 #:select (source-properties->location
+                          formatted-message
                           &fix-hint
                           &error-location))
   #:use-module (gnu services)
@@ -32,7 +33,7 @@
   #: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)
+                 (missing-modules)
   #:autoload   (gnu packages cryptsetup) (cryptsetup-static)
   #:autoload   (gnu packages linux) (mdadm-static)
   #:use-module (srfi srfi-1)
@@ -40,6 +41,7 @@
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
   #:export (mapped-device
             mapped-device?
             mapped-device-source
@@ -117,27 +119,27 @@
 (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."
-  (define aliases
-    ;; Attempt to load 'modules.alias' from the current kernel, assuming we're
-    ;; on GuixSD, and assuming that corresponds to the kernel we'll be
-    ;; installing.  Skip the whole thing if that file cannot be read.
+  (define missing
+    ;; Attempt to determine missing modules.
     (catch 'system-error
       (lambda ()
-        (known-module-aliases))
-      (const #f)))
-
-  (when aliases
-    (let ((modules (delete-duplicates
-                    (append-map (cut matching-modules <> aliases)
-                                (device-module-aliases device)))))
-      (unless (every (cute member <> linux-modules) modules)
-        (raise (condition
-                (&message
-                 (message (format #f (G_ "you may need these modules \
+        (missing-modules device linux-modules))
+
+      ;; If we can't do that (e.g., EPERM), skip the whole thing.
+      (const '())))
+
+  (unless (null? missing)
+    ;; Note: What we suggest here is a list of module names (e.g.,
+    ;; "usb_storage"), not file names (e.g., "usb-storage.ko").  This is
+    ;; OK because we have machinery that accepts both the hyphen and the
+    ;; underscore version.
+    (raise (make-compound-condition
+            (formatted-message (G_ "you may need these modules \
 in the initrd for ~a:~{ ~a~}")
-                                  device modules)))
-                (&fix-hint
-                 (hint (format #f (G_ "Try adding them to the
+                               device missing)
+            (condition
+             (&fix-hint
+              (hint (format #f (G_ "Try adding them to the
 @code{initrd-modules} field of your @code{operating-system} declaration, along
 these lines:
 
@@ -146,10 +148,14 @@ these lines:
    ;; @dots{}
    (initrd-modules (append (list~{ ~s~})
                            %base-initrd-modules)))
-@end example\n")
-                               modules)))
-                (&error-location
-                 (location (source-properties->location location)))))))))
+@end example
+
+If you think this diagnostic is inaccurate, use the @option{--skip-checks}
+option of @command{guix system}.\n")
+                            missing))))
+            (condition
+             (&error-location
+              (location (source-properties->location location))))))))
 
 \f
 ;;;
@@ -211,13 +217,13 @@ these lines:
         (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)))))))
+               (raise (make-compound-condition
+                       (formatted-message (G_ "no LUKS partition with UUID '~a'")
+                                          (uuid->string source))
+                       (condition
+                        (&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)))))