[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[bug#41143] [PATCH v3 1/2] mapped-devices: Allow target to be list of st
|
From: |
Mikhail Tsykalov |
|
Subject: |
[bug#41143] [PATCH v3 1/2] mapped-devices: Allow target to be list of strings. |
|
Date: |
Fri, 6 Nov 2020 12:47:37 +0300 |
* 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