[jackhill/guix/guix.git] / gnu / system / mapped-devices.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2017, 2018 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu system mapped-devices)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module ((guix modules) #:hide (file-name->module-name))
  #:use-module (guix i18n)
  #:use-module ((guix diagnostics)
                #:select (source-properties->location
                          formatted-message
                          &fix-hint
                          &error-location))
  #:use-module (guix deprecation)
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module (gnu system uuid)
  #:autoload   (gnu build file-systems) (find-partition-by-luks-uuid)
  #:autoload   (gnu build linux-modules)
                 (missing-modules)
  #:autoload   (gnu packages cryptsetup) (cryptsetup-static)
  #:autoload   (gnu packages linux) (mdadm-static lvm2-static)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:export (%mapped-device
            mapped-device
            mapped-device?
            mapped-device-source
            mapped-device-target
            mapped-device-targets
            mapped-device-type
            mapped-device-location

            mapped-device-kind
            mapped-device-kind?
            mapped-device-kind-open
            mapped-device-kind-close
            mapped-device-kind-check

            device-mapping-service-type
            device-mapping-service

            check-device-initrd-modules           ;XXX: needs a better place

            luks-device-mapping
            raid-device-mapping
            lvm-device-mapping))

;;; Commentary:
;;;
;;; This module supports "device mapping", a concept implemented by Linux's
;;; device-mapper.
;;;
;;; Code:

(define-record-type* <mapped-device> %mapped-device
  make-mapped-device
  mapped-device?
  (source    mapped-device-source)                ;string | list of strings
  (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?
  (open      mapped-device-kind-open)             ;source target -> gexp
  (close     mapped-device-kind-close             ;source target -> gexp
             (default (const #~(const #f))))
  (check     mapped-device-kind-check             ;source -> Boolean
             (default (const #t))))

\f
;;;
;;; Device mapping as a Shepherd service.
;;;

(define device-mapping-service-type
  (shepherd-service-type
   'device-mapping
   (match-lambda
     (($ <mapped-device> source targets
                         ($ <mapped-device-type> open close))
      (shepherd-service
       (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 targets)))
       (stop #~(lambda _ (not #$(close source targets))))
       (respawn? #f))))
   (description "Map a device node using Linux's device mapper.")))

(define (device-mapping-service mapped-device)
  "Return a service that sets up @var{mapped-device}."
  (service device-mapping-service-type mapped-device))

\f
;;;
;;; Static checks.
;;;

(define (check-device-initrd-modules device linux-modules location)
  "Raise an error if DEVICE needs modules beyond LINUX-MODULES to operate.
DEVICE must be a \"/dev\" file name."
  (define missing
    ;; Attempt to determine missing modules.
    (catch 'system-error
      (lambda ()
        (missing-modules device linux-modules))

      ;; If we can't do that (e.g., EPERM), skip the whole thing.
      (const '())))

  (unless (null? missing)
    ;; Note: What we suggest here is a list of module names (e.g.,
    ;; "usb_storage"), not file names (e.g., "usb-storage.ko").  This is
    ;; OK because we have machinery that accepts both the hyphen and the
    ;; underscore version.
    (raise (make-compound-condition
            (formatted-message (G_ "you may need these modules \
in the initrd for ~a:~{ ~a~}")
                               device missing)
            (condition
             (&fix-hint
              (hint (format #f (G_ "Try adding them to the
@code{initrd-modules} field of your @code{operating-system} declaration, along
these lines:

@example
 (operating-system
   ;; @dots{}
   (initrd-modules (append (list~{ ~s~})
                           %base-initrd-modules)))
@end example

If you think this diagnostic is inaccurate, use the @option{--skip-checks}
option of @command{guix system}.\n")
                            missing))))
            (condition
             (&error-location
              (location (source-properties->location location))))))))

\f
;;;
;;; Common device mappings.
;;;

(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)))
    (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."
  (match targets
    ((target)
     #~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
                       "close" #$target)))))

(define* (check-luks-device md #:key
                            needed-for-boot?
                            (initrd-modules '())
                            #:allow-other-keys
                            #:rest rest)
  "Ensure the source of MD is valid."
  (let ((source   (mapped-device-source md))
        (location (mapped-device-location md)))
    (or (not (zero? (getuid)))
        (if (uuid? source)
            (match (find-partition-by-luks-uuid (uuid-bytevector source))
              (#f
               (raise (make-compound-condition
                       (formatted-message (G_ "no LUKS partition with UUID '~a'")
                                          (uuid->string source))
                       (condition
                        (&error-location
                         (location (source-properties->location
                                    (mapped-device-location md))))))))
              ((? string? device)
               (check-device-initrd-modules device initrd-modules location)))
            (check-device-initrd-modules source initrd-modules location)))))

(define luks-device-mapping
  ;; The type of LUKS mapped devices.
  (mapped-device-kind
   (open open-luks-device)
   (close close-luks-device)
   (check check-luks-device)))

(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'."
  (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."
  (match targets
    ((target)
     #~(zero? (system* #$(file-append mdadm-static "/sbin/mdadm")
                       "--stop" #$target)))))

(define raid-device-mapping
  ;; The type of RAID mapped devices.
  (mapped-device-kind
   (open open-raid-device)
   (close close-raid-device)))

(define (open-lvm-device source targets)
  #~(and
     (zero? (system* #$(file-append lvm2-static "/sbin/lvm")
                     "vgchange" "--activate" "ay" #$source))
     ; /dev/mapper nodes are usually created by udev, but udev may be unavailable at the time we run this. So we create them here.
     (zero? (system* #$(file-append lvm2-static "/sbin/lvm")
                     "vgscan" "--mknodes"))
     (every file-exists? (map (lambda (file) (string-append "/dev/mapper/" file))
                              '#$targets))))


(define (close-lvm-device source targets)
  #~(zero? (system* #$(file-append lvm2-static "/sbin/lvm")
                    "vgchange" "--activate" "n" #$source)))

(define lvm-device-mapping
  (mapped-device-kind
   (open open-lvm-device)
   (close close-lvm-device)))

;;; mapped-devices.scm ends here
Commit	Line	Data
060d62a7	1	;;; GNU Guix --- Functional package management for GNU
0d22fc8d	2	;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
97c8aef1	3	;;; Copyright © 2016 Andreas Enge <andreas@enge.fr>
3e5783e2	4	;;; Copyright © 2017, 2018 Mark H Weaver <mhw@netris.org>
060d62a7 LC	5	;;;
	6	;;; This file is part of GNU Guix.
	7	;;;
	8	;;; GNU Guix is free software; you can redistribute it and/or modify it
	9	;;; under the terms of the GNU General Public License as published by
	10	;;; the Free Software Foundation; either version 3 of the License, or (at
	11	;;; your option) any later version.
	12	;;;
	13	;;; GNU Guix is distributed in the hope that it will be useful, but
	14	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	15	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	16	;;; GNU General Public License for more details.
	17	;;;
	18	;;; You should have received a copy of the GNU General Public License
	19	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	20
	21	(define-module (gnu system mapped-devices)
374f14c2	22	#:use-module (guix gexp)
060d62a7	23	#:use-module (guix records)
d2a1cf45	24	#:use-module ((guix modules) #:hide (file-name->module-name))
42ff7d3b	25	#:use-module (guix i18n)
f9a8dd05	26	#:use-module ((guix diagnostics)
42ff7d3b	27	#:select (source-properties->location
d51bfe24	28	formatted-message
8ab10c19	29	&fix-hint
42ff7d3b	30	&error-location))
788df2ec	31	#:use-module (guix deprecation)
1ea507bc LC	32	#:use-module (gnu services)
1ea507bc LC	33	#:use-module (gnu services shepherd)
9b336338	34	#:use-module (gnu system uuid)
42ff7d3b	35	#:autoload (gnu build file-systems) (find-partition-by-luks-uuid)
8ab10c19	36	#:autoload (gnu build linux-modules)
4cd386af	37	(missing-modules)
b7d408ec	38	#:autoload (gnu packages cryptsetup) (cryptsetup-static)
a9a2fdaa	39	#:autoload (gnu packages linux) (mdadm-static lvm2-static)
ffba7d49	40	#:use-module (srfi srfi-1)
424cea80	41	#:use-module (srfi srfi-26)
42ff7d3b LC	42	#:use-module (srfi srfi-34)
42ff7d3b LC	43	#:use-module (srfi srfi-35)
1ea507bc	44	#:use-module (ice-9 match)
db170ee9	45	#:use-module (ice-9 format)
788df2ec MT	46	#:export (%mapped-device
788df2ec MT	47	mapped-device
060d62a7 LC	48	mapped-device?
	49	mapped-device-source
	50	mapped-device-target
788df2ec	51	mapped-device-targets
060d62a7	52	mapped-device-type
4ca90ff5	53	mapped-device-location
060d62a7 LC	54
	55	mapped-device-kind
	56	mapped-device-kind?
	57	mapped-device-kind-open
374f14c2	58	mapped-device-kind-close
4ca90ff5	59	mapped-device-kind-check
374f14c2	60
1ea507bc LC	61	device-mapping-service-type
	62	device-mapping-service
	63
8ab10c19 LC	64	check-device-initrd-modules ;XXX: needs a better place
8ab10c19 LC	65
97c8aef1	66	luks-device-mapping
a9a2fdaa MT	67	raid-device-mapping
a9a2fdaa MT	68	lvm-device-mapping))
060d62a7 LC	69
	70	;;; Commentary:
	71	;;;
	72	;;; This module supports "device mapping", a concept implemented by Linux's
	73	;;; device-mapper.
	74	;;;
	75	;;; Code:
	76
788df2ec	77	(define-record-type* <mapped-device> %mapped-device
060d62a7 LC	78	make-mapped-device
060d62a7 LC	79	mapped-device?
d6d1cea6	80	(source mapped-device-source) ;string \| list of strings
788df2ec	81	(targets mapped-device-targets) ;list of strings
4ca90ff5 LC	82	(type mapped-device-type) ;<mapped-device-kind>
	83	(location mapped-device-location
	84	(default (current-source-location)) (innate)))
060d62a7	85
788df2ec MT	86	(define-syntax mapped-device-compatibility-helper
	87	(syntax-rules (target)
	88	((_ () (fields ...))
	89	(%mapped-device fields ...))
	90	((_ ((target exp) rest ...) (others ...))
	91	(%mapped-device others ...
	92	(targets (list exp))
	93	rest ...))
	94	((_ (field rest ...) (others ...))
	95	(mapped-device-compatibility-helper (rest ...)
	96	(others ... field)))))
	97
	98	(define-syntax-rule (mapped-device fields ...)
	99	"Build an <mapped-device> record, automatically converting 'target' field
	100	specifications to 'targets'."
	101	(mapped-device-compatibility-helper (fields ...) ()))
	102
	103	(define-deprecated (mapped-device-target md)
	104	mapped-device-targets
	105	(car (mapped-device-targets md)))
	106
060d62a7 LC	107	(define-record-type* <mapped-device-type> mapped-device-kind
	108	make-mapped-device-kind
	109	mapped-device-kind?
	110	(open mapped-device-kind-open) ;source target -> gexp
	111	(close mapped-device-kind-close ;source target -> gexp
4ca90ff5 LC	112	(default (const #~(const #f))))
	113	(check mapped-device-kind-check ;source -> Boolean
	114	(default (const #t))))
060d62a7	115
374f14c2	116	\f
1ea507bc LC	117	;;;
	118	;;; Device mapping as a Shepherd service.
	119	;;;
	120
	121	(define device-mapping-service-type
	122	(shepherd-service-type
	123	'device-mapping
	124	(match-lambda
788df2ec	125	(($ <mapped-device> source targets
4da8c19e	126	($ <mapped-device-type> open close))
1ea507bc	127	(shepherd-service
788df2ec	128	(provision (list (symbol-append 'device-mapping- (string->symbol (string-join targets "-")))))
1ea507bc LC	129	(requirement '(udev))
1ea507bc LC	130	(documentation "Map a device node using Linux's device mapper.")
788df2ec MT	131	(start #~(lambda () #$(open source targets)))
788df2ec MT	132	(stop #~(lambda _ (not #$(close source targets))))
0d22fc8d LC	133	(respawn? #f))))
0d22fc8d LC	134	(description "Map a device node using Linux's device mapper.")))
1ea507bc	135
4da8c19e LC	136	(define (device-mapping-service mapped-device)
	137	"Return a service that sets up @var{mapped-device}."
	138	(service device-mapping-service-type mapped-device))
1ea507bc LC	139
1ea507bc LC	140	\f
8ab10c19 LC	141	;;;
	142	;;; Static checks.
	143	;;;
	144
	145	(define (check-device-initrd-modules device linux-modules location)
	146	"Raise an error if DEVICE needs modules beyond LINUX-MODULES to operate.
	147	DEVICE must be a \"/dev\" file name."
4cd386af LC	148	(define missing
4cd386af LC	149	;; Attempt to determine missing modules.
8ab10c19 LC	150	(catch 'system-error
8ab10c19 LC	151	(lambda ()
4cd386af LC	152	(missing-modules device linux-modules))
	153
	154	;; If we can't do that (e.g., EPERM), skip the whole thing.
	155	(const '())))
	156
	157	(unless (null? missing)
	158	;; Note: What we suggest here is a list of module names (e.g.,
	159	;; "usb_storage"), not file names (e.g., "usb-storage.ko"). This is
	160	;; OK because we have machinery that accepts both the hyphen and the
	161	;; underscore version.
d51bfe24 LC	162	(raise (make-compound-condition
d51bfe24 LC	163	(formatted-message (G_ "you may need these modules \
8ab10c19	164	in the initrd for ~a:~{ ~a~}")
d51bfe24 LC	165	device missing)
	166	(condition
	167	(&fix-hint
	168	(hint (format #f (G_ "Try adding them to the
8ab10c19 LC	169	@code{initrd-modules} field of your @code{operating-system} declaration, along
	170	these lines:
	171
	172	@example
	173	(operating-system
	174	;; @dots{}
	175	(initrd-modules (append (list~{ ~s~})
	176	%base-initrd-modules)))
88600acc LC	177	@end example
	178
	179	If you think this diagnostic is inaccurate, use the @option{--skip-checks}
	180	option of @command{guix system}.\n")
d51bfe24 LC	181	missing))))
	182	(condition
	183	(&error-location
	184	(location (source-properties->location location))))))))
8ab10c19 LC	185
8ab10c19 LC	186	\f
374f14c2 LC	187	;;;
	188	;;; Common device mappings.
	189	;;;
	190
788df2ec	191	(define (open-luks-device source targets)
374f14c2 LC	192	"Return a gexp that maps SOURCE to TARGET as a LUKS device, using
374f14c2 LC	193	'cryptsetup'."
239c6e27 LC	194	(with-imported-modules (source-module-closure
239c6e27 LC	195	'((gnu build file-systems)))
788df2ec MT	196	(match targets
	197	((target)
	198	#~(let ((source #$(if (uuid? source)
	199	(uuid-bytevector source)
	200	source)))
	201	;; XXX: 'use-modules' should be at the top level.
	202	(use-modules (rnrs bytevectors) ;bytevector?
	203	((gnu build file-systems)
	204	#:select (find-partition-by-luks-uuid)))
	205
	206	;; Use 'cryptsetup-static', not 'cryptsetup', to avoid pulling the
	207	;; whole world inside the initrd (for when we're in an initrd).
	208	(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
	209	"open" "--type" "luks"
	210
	211	;; Note: We cannot use the "UUID=source" syntax here
	212	;; because 'cryptsetup' implements it by searching the
	213	;; udev-populated /dev/disk/by-id directory but udev may
	214	;; be unavailable at the time we run this.
	215	(if (bytevector? source)
	216	(or (let loop ((tries-left 10))
	217	(and (positive? tries-left)
	218	(or (find-partition-by-luks-uuid source)
	219	;; If the underlying partition is
	220	;; not found, try again after
	221	;; waiting a second, up to ten
	222	;; times. FIXME: This should be
	223	;; dealt with in a more robust way.
	224	(begin (sleep 1)
	225	(loop (- tries-left 1))))))
	226	(error "LUKS partition not found" source))
	227	source)
	228
	229	#$target)))))))
	230
	231	(define (close-luks-device source targets)
374f14c2	232	"Return a gexp that closes TARGET, a LUKS device."
788df2ec MT	233	(match targets
	234	((target)
	235	#~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
	236	"close" #$target)))))
374f14c2	237
424cea80 LC	238	(define* (check-luks-device md #:key
	239	needed-for-boot?
	240	(initrd-modules '())
	241	#:allow-other-keys
	242	#:rest rest)
42ff7d3b	243	"Ensure the source of MD is valid."
424cea80 LC	244	(let ((source (mapped-device-source md))
	245	(location (mapped-device-location md)))
	246	(or (not (zero? (getuid)))
	247	(if (uuid? source)
	248	(match (find-partition-by-luks-uuid (uuid-bytevector source))
	249	(#f
d51bfe24 LC	250	(raise (make-compound-condition
	251	(formatted-message (G_ "no LUKS partition with UUID '~a'")
	252	(uuid->string source))
	253	(condition
	254	(&error-location
	255	(location (source-properties->location
	256	(mapped-device-location md))))))))
424cea80 LC	257	((? string? device)
	258	(check-device-initrd-modules device initrd-modules location)))
	259	(check-device-initrd-modules source initrd-modules location)))))
42ff7d3b	260
374f14c2 LC	261	(define luks-device-mapping
	262	;; The type of LUKS mapped devices.
	263	(mapped-device-kind
	264	(open open-luks-device)
42ff7d3b LC	265	(close close-luks-device)
42ff7d3b LC	266	(check check-luks-device)))
374f14c2	267
788df2ec	268	(define (open-raid-device sources targets)
7f8ad82b LC	269	"Return a gexp that assembles SOURCES (a list of devices) to the RAID device
7f8ad82b LC	270	TARGET (e.g., \"/dev/md0\"), using 'mdadm'."
788df2ec MT	271	(match targets
	272	((target)
	273	#~(let ((sources '#$sources)
	274
	275	;; XXX: We're not at the top level here. We could use a
	276	;; non-top-level 'use-modules' form but that doesn't work when the
	277	;; code is eval'd, like the Shepherd does.
	278	(every (@ (srfi srfi-1) every))
	279	(format (@ (ice-9 format) format)))
	280	(let loop ((attempts 0))
	281	(unless (every file-exists? sources)
	282	(when (> attempts 20)
	283	(error "RAID devices did not show up; bailing out"
	284	sources))
	285
	286	(format #t "waiting for RAID source devices~{ ~a~}...~%"
	287	sources)
	288	(sleep 1)
	289	(loop (+ 1 attempts))))
	290
	291	;; Use 'mdadm-static' rather than 'mdadm' to avoid pulling its whole
	292	;; closure (80 MiB) in the initrd when a RAID device is needed for boot.
	293	(zero? (apply system* #$(file-append mdadm-static "/sbin/mdadm")
	294	"--assemble" #$target sources))))))
	295
	296	(define (close-raid-device sources targets)
97c8aef1	297	"Return a gexp that stops the RAID device TARGET."
788df2ec MT	298	(match targets
	299	((target)
	300	#~(zero? (system* #$(file-append mdadm-static "/sbin/mdadm")
	301	"--stop" #$target)))))
97c8aef1 AE	302
	303	(define raid-device-mapping
	304	;; The type of RAID mapped devices.
	305	(mapped-device-kind
	306	(open open-raid-device)
	307	(close close-raid-device)))
	308
a9a2fdaa MT	309	(define (open-lvm-device source targets)
	310	#~(and
	311	(zero? (system* #$(file-append lvm2-static "/sbin/lvm")
	312	"vgchange" "--activate" "ay" #$source))
	313	; /dev/mapper nodes are usually created by udev, but udev may be unavailable at the time we run this. So we create them here.
	314	(zero? (system* #$(file-append lvm2-static "/sbin/lvm")
	315	"vgscan" "--mknodes"))
	316	(every file-exists? (map (lambda (file) (string-append "/dev/mapper/" file))
	317	'#$targets))))
	318
	319
	320	(define (close-lvm-device source targets)
	321	#~(zero? (system* #$(file-append lvm2-static "/sbin/lvm")
	322	"vgchange" "--activate" "n" #$source)))
	323
	324	(define lvm-device-mapping
	325	(mapped-device-kind
	326	(open open-lvm-device)
	327	(close close-lvm-device)))
	328
060d62a7	329	;;; mapped-devices.scm ends here