[bug#41143] [PATCH v3 1/2] mapped-devices: Allow target to be list of strings.

[Mikhail Tsykalov <tsymsh@gmail.com>]

* 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.
---
 doc/guix.texi                 |   3 +
 gnu/services/base.scm         |   3 +-
 gnu/system.scm                |  11 ++-
 gnu/system/linux-initrd.scm   |  10 +-
 gnu/system/mapped-devices.scm | 174 ++++++++++++++++++++--------------
 5 files changed, 119 insertions(+), 82 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 79c79b6a96..02b92a9b69 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -12735,6 +12735,9 @@ specifying @code{"my-partition"} leads to the creation of
 the @code{"/dev/mapper/my-partition"} device.
 For RAID devices of type @code{raid-device-mapping}, the full device name
 such as @code{"/dev/md0"} needs to be given.
+@item targets
+This list of strings specifies names of the resulting mapped devices in case
+there are several. The format is identical to @var{target}.
 
 @item type
 This must be a @code{mapped-device-kind} object, which specifies how
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 04bc991356..4aa14ebf99 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -291,7 +291,8 @@ FILE-SYSTEM."
 (define (mapped-device->shepherd-service-name md)
   "Return the symbol that denotes the shepherd service of MD, a <mapped-device>."
   (symbol-append 'device-mapping-
-                 (string->symbol (mapped-device-target md))))
+                 (string->symbol (string-join
+                                  (mapped-device-targets md) "-"))))
 
 (define dependency->shepherd-service-name
   (match-lambda
diff --git a/gnu/system.scm b/gnu/system.scm
index bdb696fe2e..1bb812256f 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -444,9 +444,9 @@ marked as 'needed-for-boot'."
     (let ((device (file-system-device fs)))
       (if (string? device)                        ;title is 'device
           (filter (lambda (md)
-                    (string=? (string-append "/dev/mapper/"
-                                             (mapped-device-target md))
-                              device))
+                    (any (cut string=? device <>)
+                         (map (cut string-append "/dev/mapper" <>)
+                              (mapped-device-targets md))))
                   (operating-system-mapped-devices os))
           '())))
 
@@ -466,11 +466,12 @@ marked as 'needed-for-boot'."
 
 (define (mapped-device-users device file-systems)
   "Return the subset of FILE-SYSTEMS that use DEVICE."
-  (let ((target (string-append "/dev/mapper/" (mapped-device-target device))))
+  (let ((targets (map (cut string-append "/dev/mapper/" <>)
+                      (mapped-device-targets device))))
     (filter (lambda (fs)
               (or (member device (file-system-dependencies fs))
                   (and (string? (file-system-device fs))
-                       (string=? (file-system-device fs) target))))
+                       (any (cut string=? (file-system-device fs) <>) targets))))
             file-systems)))
 
 (define (operating-system-user-mapped-devices os)
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index b8a30c0abc..3e2f1282cc 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -195,11 +195,11 @@ upon error."
   (define device-mapping-commands
     ;; List of gexps to open the mapped devices.
     (map (lambda (md)
-           (let* ((source (mapped-device-source md))
-                  (target (mapped-device-target md))
-                  (type   (mapped-device-type md))
-                  (open   (mapped-device-kind-open type)))
-             (open source target)))
+           (let* ((source  (mapped-device-source md))
+                  (targets (mapped-device-targets md))
+                  (type    (mapped-device-type md))
+                  (open    (mapped-device-kind-open type)))
+             (open source targets)))
          mapped-devices))
 
   (define kodir
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.
-- 
2.20.1