From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp1 ([2001:41d0:2:4a6f::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms11 with LMTPS id QA8xG+EbpV/oagAA0tVLHw (envelope-from ) for ; Fri, 06 Nov 2020 09:48:17 +0000 Received: from aspmx1.migadu.com ([2001:41d0:2:4a6f::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp1 with LMTPS id kE33FuEbpV+nQQAAbx9fmQ (envelope-from ) for ; Fri, 06 Nov 2020 09:48:17 +0000 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by aspmx1.migadu.com (Postfix) with ESMTPS id E1BCA940237 for ; Fri, 6 Nov 2020 09:48:16 +0000 (UTC) Received: from localhost ([::1]:51706 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1kayLv-0005p2-R6 for larch@yhetil.org; Fri, 06 Nov 2020 04:48:15 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]:40804) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1kayLi-0005oJ-TQ for guix-patches@gnu.org; Fri, 06 Nov 2020 04:48:02 -0500 Received: from debbugs.gnu.org ([209.51.188.43]:43589) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1kayLi-0002fK-Jp for guix-patches@gnu.org; Fri, 06 Nov 2020 04:48:02 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1kayLi-0002LC-Gt for guix-patches@gnu.org; Fri, 06 Nov 2020 04:48:02 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#41143] [PATCH v3 1/2] mapped-devices: Allow target to be list of strings. Resent-From: Mikhail Tsykalov Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Fri, 06 Nov 2020 09:48:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 41143 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: ludo@gnu.org Cc: 41143@debbugs.gnu.org, Mikhail Tsykalov Received: via spool by 41143-submit@debbugs.gnu.org id=B41143.16046560708971 (code B ref 41143); Fri, 06 Nov 2020 09:48:02 +0000 Received: (at 41143) by debbugs.gnu.org; 6 Nov 2020 09:47:50 +0000 Received: from localhost ([127.0.0.1]:55134 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1kayLV-0002KV-PZ for submit@debbugs.gnu.org; Fri, 06 Nov 2020 04:47:50 -0500 Received: from mail-lf1-f45.google.com ([209.85.167.45]:39435) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1kayLS-0002K9-Lz for 41143@debbugs.gnu.org; Fri, 06 Nov 2020 04:47:47 -0500 Received: by mail-lf1-f45.google.com with SMTP id 184so1048277lfd.6 for <41143@debbugs.gnu.org>; Fri, 06 Nov 2020 01:47:46 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20161025; h=from:to:cc:subject:date:message-id:in-reply-to:references :mime-version:content-transfer-encoding; bh=xm0Kj1RatIR0SRekR+dxHaH2y5bX+eLdjhSOdsHMLJ4=; b=YLItB5ZKVIFY4PEMM3QKXXkdegeQ9m+3fXZeQYqeQXHQSJM/y44t336urFe5X70hX5 SI0uwEDlDuZLpkzIfTmB13a727UPcgepi0QNSWYlEO3zIvqXxOVhpMOvypvQXxI/vpUv xdv9tr1CDRT3TqrppxKnHjZzUb1XA2kuIYDZ7NkOl4UcMa4QCs3FgeCC1sw5JTh/sQ5h FGnOA/WE3wqrqVZiUEyy5tpOEynVXY/hSRrL3ijgdDBOElGvnUFWzAxJCcaSU84WIlE5 3dmyuOvmRdt9u7Ge7XQKcLkYxpWwDgYc2Rmz1tg8E/r/IjmDd14BzNp5WM4XfR3aIR6f qLSg== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20161025; h=x-gm-message-state:from:to:cc:subject:date:message-id:in-reply-to :references:mime-version:content-transfer-encoding; bh=xm0Kj1RatIR0SRekR+dxHaH2y5bX+eLdjhSOdsHMLJ4=; b=QI/HDyy4/0Vklk3SgrnZfdbpnAmkfvplYOnEnxYK31wnuMW1dMkg8VQDtKgAD90XW1 1EbLROfTuQlxPRAXuRQeG7ERzZbis22AjaF9mFdFEjaf3Td6fN5q+f8V3Q3BuaW6Tb6v hRy/mJQ+UGfCYy7PyKBiAPZYJXMQg2N2Uo65Q+qI7Wsw6WN/m6ZFJROhf2Nen5ZTm8FW F2jm9C7WcMVcl9Ke3KX9RpmybtzqvMMBfMy1aNfkKWy19RogEUN/sMJKPT0XDGRwpax6 3Onm63oFsoitS2URxl2cppb6n2ECaqmoW7EAFUqWJKQNeebMxDFaOkNIy2Wwh4/jtgkX ImuA== X-Gm-Message-State: AOAM533qZH+xRZCGbddkD523l2/6kMlITqmuE6/G9vxm4K+TfxAMHtIA +0GOybjt4yQHO054JZXroZg= X-Google-Smtp-Source: ABdhPJxxXgit0zgOKHobnQZQfZoTurmQIPNV/ch+kuzoaLZbJcUMot3c37bn2lrXMCmJueFc+wCkiQ== X-Received: by 2002:a19:34b:: with SMTP id 72mr610759lfd.120.1604656060426; Fri, 06 Nov 2020 01:47:40 -0800 (PST) Received: from akiha.sknt.ru ([88.201.200.148]) by smtp.googlemail.com with ESMTPSA id f9sm88496ljg.53.2020.11.06.01.47.39 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Fri, 06 Nov 2020 01:47:39 -0800 (PST) From: Mikhail Tsykalov Date: Fri, 6 Nov 2020 12:47:37 +0300 Message-Id: <20201106094738.132011-1-tsymsh@gmail.com> X-Mailer: git-send-email 2.20.1 In-Reply-To: <87o8kc5e2w.fsf@gnu.org> References: <87o8kc5e2w.fsf@gnu.org> MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Spam-Score: 0.0 (/) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-Spam-Score: -1.0 (-) X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+larch=yhetil.org@gnu.org Sender: "Guix-patches" X-Scanner: ns3122888.ip-94-23-21.eu Authentication-Results: aspmx1.migadu.com; dkim=fail (headers rsa verify failed) header.d=gmail.com header.s=20161025 header.b=YLItB5ZK; dmarc=fail reason="SPF not aligned (relaxed)" header.from=gmail.com (policy=none); spf=pass (aspmx1.migadu.com: domain of guix-patches-bounces@gnu.org designates 209.51.188.17 as permitted sender) smtp.mailfrom=guix-patches-bounces@gnu.org X-Spam-Score: 5.09 X-TUID: Mcbjtl9HMOYq * gnu/system/mapped-devices.scm (): 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 ." (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 +(define-record-type* %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) ; (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 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-kind make-mapped-device-kind mapped-device-kind? @@ -97,14 +121,14 @@ (shepherd-service-type 'device-mapping (match-lambda - (($ source target + (($ source targets ($ 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