1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
|
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2017 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)
#:use-module (guix i18n)
#:use-module ((guix utils)
#:select (source-properties->location
&error-location))
#:use-module (gnu services)
#:use-module (gnu services shepherd)
#:use-module (gnu system uuid)
#:use-module ((gnu system linux-initrd)
#:select (check-device-initrd-modules))
#:autoload (gnu build file-systems) (find-partition-by-luks-uuid)
#:autoload (gnu packages cryptsetup) (cryptsetup-static)
#:autoload (gnu packages linux) (mdadm-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)
#:export (mapped-device
mapped-device?
mapped-device-source
mapped-device-target
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
luks-device-mapping
raid-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
(target mapped-device-target) ;string
(type mapped-device-type) ;<mapped-device-kind>
(location mapped-device-location
(default (current-source-location)) (innate)))
(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))))
;;;
;;; Device mapping as a Shepherd service.
;;;
(define device-mapping-service-type
(shepherd-service-type
'device-mapping
(match-lambda
(($ <mapped-device> source target
($ <mapped-device-type> open close))
(shepherd-service
(provision (list (symbol-append 'device-mapping- (string->symbol target))))
(requirement '(udev))
(documentation "Map a device node using Linux's device mapper.")
(start #~(lambda () #$(open source target)))
(stop #~(lambda _ (not #$(close source target))))
(respawn? #f))))))
(define (device-mapping-service mapped-device)
"Return a service that sets up @var{mapped-device}."
(service device-mapping-service-type mapped-device))
;;;
;;; Common device mappings.
;;;
(define (open-luks-device source target)
"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)
"Return a gexp that closes TARGET, a LUKS device."
#~(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 (condition
(&message
(message (format #f (G_ "no LUKS partition with UUID '~a'")
(uuid->string source))))
(&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 target)
"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)
"Return a gexp that stops the RAID device 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)))
;;; mapped-devices.scm ends here
|