diff options
| -rw-r--r-- | doc/guix.texi | 3 | ||||
| -rw-r--r-- | gnu/services/base.scm | 3 | ||||
| -rw-r--r-- | gnu/system.scm | 11 | ||||
| -rw-r--r-- | gnu/system/linux-initrd.scm | 10 | ||||
| -rw-r--r-- | gnu/system/mapped-devices.scm | 174 |
5 files changed, 119 insertions, 82 deletions
diff --git a/doc/guix.texi b/doc/guix.texi index c5a88b15fa..13fb4b1531 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -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 diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 029df5ac16..3fc4d5f885 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -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 diff --git a/gnu/system.scm b/gnu/system.scm index b257ea0385..fcf3310fa3 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -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) 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. |