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>master
Mikhail Tsykalov
Ludovic Courtès
parent
0a1da4652d
commit
788df2ecd6
|
|
@ -13780,6 +13780,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
|
||||
|
|
|
|||
|
|
@ -298,7 +298,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
|
||||
|
|
|
|||
|
|
@ -475,9 +475,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))
|
||||
'())))
|
||||
|
||||
|
|
@ -497,11 +497,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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
(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"
|
||||
;; 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)
|
||||
;; 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)))))
|
||||
#$target)))))))
|
||||
|
||||
(define (close-luks-device 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)
|
||||
(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))
|
||||
;; 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))))
|
||||
(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))))
|
||||
;; 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)
|
||||
(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.
|
||||
|
|
|
|||
Reference in New Issue