08/10: mapped-devices: 'luks-device-mapping' checks its source device.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 42ff7d3be642d66ba567f64882a1f2301b1a7bd9
Author: Ludovic Courtès <address@hidden>
Date:   Mon Dec 18 14:58:46 2017 +0100

    mapped-devices: 'luks-device-mapping' checks its source device.
    
    * gnu/system/mapped-devices.scm (check-luks-device): New procedure.
    (luks-device-mapping)[check]: New field.
---
 gnu/system/mapped-devices.scm | 24 +++++++++++++++++++++++-
 1 file changed, 23 insertions(+), 1 deletion(-)

diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm
index 06178ad..dbeb0d34 100644
--- a/gnu/system/mapped-devices.scm
+++ b/gnu/system/mapped-devices.scm
@@ -22,12 +22,19 @@
   #:use-module (guix gexp)
   #:use-module (guix records)
   #:use-module (guix modules)
+  #:use-module (guix i18n)
+  #:use-module ((guix utils)
+                #:select (source-properties->location
+                          &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 packages cryptsetup) (cryptsetup-static)
   #:autoload   (gnu packages linux) (mdadm-static)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (ice-9 match)
   #:export (mapped-device
             mapped-device?
@@ -144,11 +151,26 @@
   #~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
                     "close" #$target)))
 
+(define (check-luks-device md)
+  "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)))))))))
+
 (define luks-device-mapping
   ;; The type of LUKS mapped devices.
   (mapped-device-kind
    (open open-luks-device)
-   (close close-luks-device)))
+   (close close-luks-device)
+   (check check-luks-device)))
 
 (define (open-raid-device sources target)
   "Return a gexp that assembles SOURCES (a list of devices) to the RAID device