[bug#41143] [PATCH v2 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.
---
 gnu/services/base.scm         |  3 ++-
 gnu/system.scm                | 11 +++++-----
 gnu/system/linux-initrd.scm   |  2 +-
 gnu/system/mapped-devices.scm | 40 ++++++++++++++++++++++++++++-------
 4 files changed, 41 insertions(+), 15 deletions(-)

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..db02059a26 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -196,7 +196,7 @@ upon error."
     ;; List of gexps to open the mapped devices.
     (map (lambda (md)
            (let* ((source (mapped-device-source md))
-                  (target (mapped-device-target md))
+                  (target (mapped-device-targets md))
                   (type   (mapped-device-type md))
                   (open   (mapped-device-kind-open type)))
              (open source target)))
diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm
index 31c50c4e40..8622418fcf 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?
@@ -100,7 +124,7 @@
      (($ <mapped-device> source target
                          ($ <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 target "-")))))
        (requirement '(udev))
        (documentation "Map a device node using Linux's device mapper.")
        (start #~(lambda () #$(open source target)))
@@ -198,12 +222,12 @@ option of @command{guix system}.\n")
                                 (error "LUKS partition not found" source))
                             source)
 
-                        #$target)))))
+                        #$(car target))))))
 
 (define (close-luks-device source target)
   "Return a gexp that closes TARGET, a LUKS device."
   #~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
-                    "close" #$target)))
+                    "close" #$(car target))))
 
 (define* (check-luks-device md #:key
                             needed-for-boot?
@@ -259,12 +283,12 @@ TARGET (e.g., \"/dev/md0\"), using 'mdadm'."
       ;; 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))))
+                    "--assemble" #$(car target) sources))))
 
 (define (close-raid-device sources target)
   "Return a gexp that stops the RAID device TARGET."
   #~(zero? (system* #$(file-append mdadm-static "/sbin/mdadm")
-                    "--stop" #$target)))
+                    "--stop" #$(car target))))
 
 (define raid-device-mapping
   ;; The type of RAID mapped devices.
-- 
2.28.0