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 dbeb0d3..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 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,21 +21,27 @@
 (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)
   #: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)
+                 (missing-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)
+  #:use-module (ice-9 format)
   #:export (mapped-device
             mapped-device?
             mapped-device-source
@@ -52,6 +58,8 @@
             device-mapping-service-type
             device-mapping-service
 
+            check-device-initrd-modules           ;XXX: needs a better place
+
             luks-device-mapping
             raid-device-mapping))
 
@@ -104,6 +112,52 @@
   (service device-mapping-service-type mapped-device))
 
 \f
+;;;
+;;; Static checks.
+;;;
+
+(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 missing
+    ;; Attempt to determine missing modules.
+    (catch 'system-error
+      (lambda ()
+        (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 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:
+
+@example
+ (operating-system
+   ;; @dots{}
+   (initrd-modules (append (list~{ ~s~})
+                           %base-initrd-modules)))
+@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
 ;;;
 ;;; Common device mappings.
 ;;;
@@ -151,19 +205,28 @@
   #~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
                     "close" #$target)))
 
-(define (check-luks-device md)
+(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 (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)))))
 
 (define luks-device-mapping
   ;; The type of LUKS mapped devices.