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
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
|
;;; 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, 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)
#:use-module (guix i18n)
#:use-module ((guix utils)
#:select (source-properties->location
&fix-hint
&error-location))
#: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)
(device-module-aliases matching-modules known-module-aliases
normalize-module-name)
#: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
check-device-initrd-modules ;XXX: needs a better place
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))
;;;
;;; 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 aliases
;; Attempt to load 'modules.alias' from the current kernel, assuming we're
;; on GuixSD, and assuming that corresponds to the kernel we'll be
;; installing. Skip the whole thing if that file cannot be read.
(catch 'system-error
(lambda ()
(known-module-aliases))
(const #f)))
(when aliases
(let ((modules (delete-duplicates
(append-map (cut matching-modules <> aliases)
(device-module-aliases device))))
;; Module names (not file names) are supposed to use underscores
;; instead of hyphens. MODULES is a list of module names, whereas
;; LINUX-MODULES is file names without '.ko', so normalize them.
(provided (map normalize-module-name linux-modules)))
(unless (every (cut member <> provided) modules)
(raise (condition
(&message
(message (format #f (G_ "you may need these modules \
in the initrd for ~a:~{ ~a~}")
device modules)))
(&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\n")
modules)))
(&error-location
(location (source-properties->location location)))))))))
;;;
;;; 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
|