mapped-devices: Allow target to be list of strings.

* gnu/system/mapped-devices.scm (<mapped-device>): Rename constructor to
%mapped-device.
[target]: Remove field.
[targets]: New field. Adjust users.
(mapped-device-compatibility-helper, mapped-device): New macros.
(mapped-device-target): New deprecated procedure.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>

1 files changed, 103 insertions, 71 deletions

diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm
index 31c50c4e40..8b5aec983d 100644
--- a/gnu/system/mapped-devices.scm
+++ b/gnu/system/mapped-devices.scm
@@ -28,6 +28,7 @@
                           formatted-message
                           &fix-hint
                           &error-location))
+  #:use-module (guix deprecation)
   #:use-module (gnu services)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system uuid)
@@ -42,10 +43,12 @@
   #:use-module (srfi srfi-35)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
-  #:export (mapped-device
+  #:export (%mapped-device
+            mapped-device
             mapped-device?
             mapped-device-source
             mapped-device-target
+            mapped-device-targets
             mapped-device-type
             mapped-device-location
 
@@ -70,15 +73,36 @@
 ;;;
 ;;; Code:
 
-(define-record-type* <mapped-device> mapped-device
+(define-record-type* <mapped-device> %mapped-device
   make-mapped-device
   mapped-device?
   (source    mapped-device-source)                ;string | list of strings
-  (target    mapped-device-target)                ;string
+  (targets   mapped-device-targets)               ;list of strings
   (type      mapped-device-type)                  ;<mapped-device-kind>
   (location  mapped-device-location
              (default (current-source-location)) (innate)))
 
+(define-syntax mapped-device-compatibility-helper
+  (syntax-rules (target)
+    ((_ () (fields ...))
+     (%mapped-device fields ...))
+    ((_ ((target exp) rest ...) (others ...))
+     (%mapped-device others ...
+                      (targets (list exp))
+                      rest ...))
+    ((_ (field rest ...) (others ...))
+     (mapped-device-compatibility-helper (rest ...)
+                                         (others ... field)))))
+
+(define-syntax-rule (mapped-device fields ...)
+  "Build an <mapped-device> record, automatically converting 'target' field
+specifications to 'targets'."
+  (mapped-device-compatibility-helper (fields ...) ()))
+
+(define-deprecated (mapped-device-target md)
+  mapped-device-targets
+  (car (mapped-device-targets md)))
+
 (define-record-type* <mapped-device-type> mapped-device-kind
   make-mapped-device-kind
   mapped-device-kind?
@@ -97,14 +121,14 @@
   (shepherd-service-type
    'device-mapping
    (match-lambda
-     (($ <mapped-device> source target
+     (($ <mapped-device> source targets
                          ($ <mapped-device-type> open close))
       (shepherd-service
-       (provision (list (symbol-append 'device-mapping- (string->symbol target))))
+       (provision (list (symbol-append 'device-mapping- (string->symbol (string-join targets "-")))))
        (requirement '(udev))
        (documentation "Map a device node using Linux's device mapper.")
-       (start #~(lambda () #$(open source target)))
-       (stop #~(lambda _ (not #$(close source target))))
+       (start #~(lambda () #$(open source targets)))
+       (stop #~(lambda _ (not #$(close source targets))))
        (respawn? #f))))))
 
 (define (device-mapping-service mapped-device)
@@ -162,48 +186,52 @@ option of @command{guix system}.\n")
 ;;; Common device mappings.
 ;;;
 
-(define (open-luks-device source target)
+(define (open-luks-device source targets)
   "Return a gexp that maps SOURCE to TARGET as a LUKS device, using
 'cryptsetup'."
   (with-imported-modules (source-module-closure
                           '((gnu build file-systems)))
-    #~(let ((source #$(if (uuid? source)
-                          (uuid-bytevector source)
-                          source)))
-        ;; XXX: 'use-modules' should be at the top level.
-        (use-modules (rnrs bytevectors)           ;bytevector?
-                     ((gnu build file-systems)
-                      #:select (find-partition-by-luks-uuid)))
-
-        ;; Use 'cryptsetup-static', not 'cryptsetup', to avoid pulling the
-        ;; whole world inside the initrd (for when we're in an initrd).
-        (zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
-                        "open" "--type" "luks"
-
-                        ;; Note: We cannot use the "UUID=source" syntax here
-                        ;; because 'cryptsetup' implements it by searching the
-                        ;; udev-populated /dev/disk/by-id directory but udev may
-                        ;; be unavailable at the time we run this.
-                        (if (bytevector? source)
-                            (or (let loop ((tries-left 10))
-                                  (and (positive? tries-left)
-                                       (or (find-partition-by-luks-uuid source)
-                                           ;; If the underlying partition is
-                                           ;; not found, try again after
-                                           ;; waiting a second, up to ten
-                                           ;; times.  FIXME: This should be
-                                           ;; dealt with in a more robust way.
-                                           (begin (sleep 1)
-                                                  (loop (- tries-left 1))))))
-                                (error "LUKS partition not found" source))
-                            source)
-
-                        #$target)))))
-
-(define (close-luks-device source target)
+    (match targets
+      ((target)
+       #~(let ((source #$(if (uuid? source)
+                             (uuid-bytevector source)
+                             source)))
+           ;; XXX: 'use-modules' should be at the top level.
+           (use-modules (rnrs bytevectors) ;bytevector?
+                        ((gnu build file-systems)
+                         #:select (find-partition-by-luks-uuid)))
+
+           ;; Use 'cryptsetup-static', not 'cryptsetup', to avoid pulling the
+           ;; whole world inside the initrd (for when we're in an initrd).
+           (zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
+                           "open" "--type" "luks"
+
+                           ;; Note: We cannot use the "UUID=source" syntax here
+                           ;; because 'cryptsetup' implements it by searching the
+                           ;; udev-populated /dev/disk/by-id directory but udev may
+                           ;; be unavailable at the time we run this.
+                           (if (bytevector? source)
+                               (or (let loop ((tries-left 10))
+                                     (and (positive? tries-left)
+                                          (or (find-partition-by-luks-uuid source)
+                                              ;; If the underlying partition is
+                                              ;; not found, try again after
+                                              ;; waiting a second, up to ten
+                                              ;; times.  FIXME: This should be
+                                              ;; dealt with in a more robust way.
+                                              (begin (sleep 1)
+                                                     (loop (- tries-left 1))))))
+                                   (error "LUKS partition not found" source))
+                               source)
+
+                           #$target)))))))
+
+(define (close-luks-device source targets)
   "Return a gexp that closes TARGET, a LUKS device."
-  #~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
-                    "close" #$target)))
+  (match targets
+    ((target)
+     #~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
+                       "close" #$target)))))
 
 (define* (check-luks-device md #:key
                             needed-for-boot?
@@ -235,36 +263,40 @@ option of @command{guix system}.\n")
    (close close-luks-device)
    (check check-luks-device)))
 
-(define (open-raid-device sources target)
+(define (open-raid-device sources targets)
   "Return a gexp that assembles SOURCES (a list of devices) to the RAID device
 TARGET (e.g., \"/dev/md0\"), using 'mdadm'."
-  #~(let ((sources '#$sources)
-
-          ;; XXX: We're not at the top level here.  We could use a
-          ;; non-top-level 'use-modules' form but that doesn't work when the
-          ;; code is eval'd, like the Shepherd does.
-          (every   (@ (srfi srfi-1) every))
-          (format  (@ (ice-9 format) format)))
-      (let loop ((attempts 0))
-        (unless (every file-exists? sources)
-          (when (> attempts 20)
-            (error "RAID devices did not show up; bailing out"
-                   sources))
-
-          (format #t "waiting for RAID source devices~{ ~a~}...~%"
-                  sources)
-          (sleep 1)
-          (loop (+ 1 attempts))))
-
-      ;; Use 'mdadm-static' rather than 'mdadm' to avoid pulling its whole
-      ;; closure (80 MiB) in the initrd when a RAID device is needed for boot.
-      (zero? (apply system* #$(file-append mdadm-static "/sbin/mdadm")
-                    "--assemble" #$target sources))))
-
-(define (close-raid-device sources target)
+  (match targets
+    ((target)
+     #~(let ((sources '#$sources)
+
+             ;; XXX: We're not at the top level here.  We could use a
+             ;; non-top-level 'use-modules' form but that doesn't work when the
+             ;; code is eval'd, like the Shepherd does.
+             (every   (@ (srfi srfi-1) every))
+             (format  (@ (ice-9 format) format)))
+         (let loop ((attempts 0))
+           (unless (every file-exists? sources)
+             (when (> attempts 20)
+               (error "RAID devices did not show up; bailing out"
+                      sources))
+
+             (format #t "waiting for RAID source devices~{ ~a~}...~%"
+                     sources)
+             (sleep 1)
+             (loop (+ 1 attempts))))
+
+         ;; Use 'mdadm-static' rather than 'mdadm' to avoid pulling its whole
+         ;; closure (80 MiB) in the initrd when a RAID device is needed for boot.
+         (zero? (apply system* #$(file-append mdadm-static "/sbin/mdadm")
+                       "--assemble" #$target sources))))))
+
+(define (close-raid-device sources targets)
   "Return a gexp that stops the RAID device TARGET."
-  #~(zero? (system* #$(file-append mdadm-static "/sbin/mdadm")
-                    "--stop" #$target)))
+  (match targets
+    ((target)
+     #~(zero? (system* #$(file-append mdadm-static "/sbin/mdadm")
+                       "--stop" #$target)))))
 
 (define raid-device-mapping
   ;; The type of RAID mapped devices.