projects/guix·blob java-team · refs

499 lines · 21.4 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2014-2022, 2024-2025 Ludovic Courtès <[email protected]>
3;;; Copyright © 2016 Andreas Enge <[email protected]>
4;;; Copyright © 2017, 2018 Mark H Weaver <[email protected]>
5;;; Copyright © 2024 Tomas Volf <[email protected]>
6;;;
7;;; This file is part of GNU Guix.
8;;;
9;;; GNU Guix is free software; you can redistribute it and/or modify it
10;;; under the terms of the GNU General Public License as published by
11;;; the Free Software Foundation; either version 3 of the License, or (at
12;;; your option) any later version.
13;;;
14;;; GNU Guix is distributed in the hope that it will be useful, but
15;;; WITHOUT ANY WARRANTY; without even the implied warranty of
16;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;;; GNU General Public License for more details.
18;;;
19;;; You should have received a copy of the GNU General Public License
20;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
21
22(define-module (gnu system mapped-devices)
23 #:use-module (guix gexp)
24 #:use-module (guix records)
25 #:use-module ((guix modules) #:hide (file-name->module-name))
26 #:use-module (guix i18n)
27 #:use-module ((guix diagnostics)
28 #:select (source-properties->location
29 formatted-message
30 &fix-hint
31 &error-location))
32 #:use-module (guix deprecation)
33 #:use-module (gnu services)
34 #:use-module (gnu services shepherd)
35 #:use-module (gnu system uuid)
36 #:autoload (gnu build file-systems) (find-partition-by-luks-uuid)
37 #:autoload (gnu build linux-modules)
38 (missing-modules)
39 #:autoload (gnu packages cryptsetup) (cryptsetup-static)
40 #:autoload (gnu packages linux) (mdadm-static lvm2-static)
41 #:use-module (srfi srfi-1)
42 #:use-module (srfi srfi-26)
43 #:use-module (srfi srfi-34)
44 #:use-module (srfi srfi-35)
45 #:use-module (ice-9 match)
46 #:use-module (ice-9 optargs)
47 #:use-module (ice-9 format)
48 #:export (%mapped-device
49 mapped-device
50 mapped-device?
51 mapped-device-source
52 mapped-device-target
53 mapped-device-targets
54 mapped-device-type
55 mapped-device-arguments
56 mapped-device-location
57
58 mapped-device-kind
59 mapped-device-kind?
60 mapped-device-kind-open
61 mapped-device-kind-close
62 mapped-device-kind-modules
63 mapped-device-kind-check
64
65 device-mapping-service-type
66 device-mapping-service
67
68 check-device-initrd-modules ;XXX: needs a better place
69
70 luks-device-mapping
71 luks-device-mapping-with-options
72 raid-device-mapping
73 lvm-device-mapping))
74
75;;; Commentary:
76;;;
77;;; This module supports "device mapping", a concept implemented by Linux's
78;;; device-mapper.
79;;;
80;;; Code:
81
82(define-record-type* <mapped-device> %mapped-device
83 make-mapped-device
84 mapped-device?
85 (source mapped-device-source) ;string | list of strings
86 (targets mapped-device-targets) ;list of strings
87 (type mapped-device-type) ;<mapped-device-kind>
88 (arguments mapped-device-arguments ;list passed to open/close/check
89 (default '()))
90 (location mapped-device-location
91 (default (current-source-location)) (innate)))
92
93(define-syntax mapped-device-compatibility-helper
94 (syntax-rules (target)
95 ((_ () (fields ...))
96 (%mapped-device fields ...))
97 ((_ ((target exp) rest ...) (others ...))
98 (%mapped-device others ...
99 (targets (list exp))
100 rest ...))
101 ((_ (field rest ...) (others ...))
102 (mapped-device-compatibility-helper (rest ...)
103 (others ... field)))))
104
105(define-syntax-rule (mapped-device fields ...)
106 "Build an <mapped-device> record, automatically converting 'target' field
107specifications to 'targets'."
108 (mapped-device-compatibility-helper (fields ...) ()))
109
110(define-deprecated (mapped-device-target md)
111 mapped-device-targets
112 (car (mapped-device-targets md)))
113
114(define-record-type* <mapped-device-type> mapped-device-kind
115 make-mapped-device-kind
116 mapped-device-kind?
117 (open mapped-device-kind-open) ;source target -> gexp
118 (close mapped-device-kind-close ;source target -> gexp
119 (default (const #~(const #f))))
120 (modules mapped-device-kind-modules ;list of module names
121 (default '()))
122 (check mapped-device-kind-check ;source -> Boolean
123 (default (const #t))))
124
125
126;;;
127;;; Device mapping as a Shepherd service.
128;;;
129
130(define device-mapping-service-type
131 (shepherd-service-type
132 'device-mapping
133 (match-lambda
134 (($ <mapped-device> source targets
135 ($ <mapped-device-type> open close modules)
136 arguments)
137 (shepherd-service
138 (provision (list (symbol-append 'device-mapping- (string->symbol (string-join targets "-")))))
139 (requirement '(udev))
140 (documentation "Map a device node using Linux's device mapper.")
141 (start #~(lambda ()
142 #$(apply open source targets arguments)))
143 (stop #~(lambda _
144 (not #$(apply close source targets arguments))))
145 (modules (append %default-modules modules))
146 (respawn? #f))))
147 (description "Map a device node using Linux's device mapper.")))
148
149(define (device-mapping-service mapped-device)
150 "Return a service that sets up @var{mapped-device}."
151 (service device-mapping-service-type mapped-device))
152
153
154;;;
155;;; Static checks.
156;;;
157
158(define (check-device-initrd-modules device linux-modules location)
159 "Raise an error if DEVICE needs modules beyond LINUX-MODULES to operate.
160DEVICE must be a \"/dev\" file name."
161 (define missing
162 ;; Attempt to determine missing modules.
163 (catch 'system-error
164 (lambda ()
165 (missing-modules device linux-modules))
166
167 ;; If we can't do that (e.g., EPERM), skip the whole thing.
168 (const '())))
169
170 (unless (null? missing)
171 ;; Note: What we suggest here is a list of module names (e.g.,
172 ;; "usb_storage"), not file names (e.g., "usb-storage.ko"). This is
173 ;; OK because we have machinery that accepts both the hyphen and the
174 ;; underscore version.
175 (raise (make-compound-condition
176 (formatted-message (G_ "you may need these modules \
177in the initrd for ~a:~{ ~a~}")
178 device missing)
179 (condition
180 (&fix-hint
181 (hint (format #f (G_ "Try adding them to the
182@code{initrd-modules} field of your @code{operating-system} declaration, along
183these lines:
184
185@example
186 (operating-system
187 ;; @dots{}
188 (initrd-modules (append (list~{ ~s~})
189 %base-initrd-modules)))
190@end example
191
192If you think this diagnostic is inaccurate, use the @option{--skip-checks}
193option of @command{guix system}.\n")
194 missing))))
195 (condition
196 (&error-location
197 (location (source-properties->location location))))))))
198
199
200;;;
201;;; Common device mappings.
202;;;
203
204(define* (open-luks-device source targets
205 #:key key-file allow-discards? (extra-options '()))
206 "Return a gexp that maps SOURCE to TARGET as a LUKS device, using
207'cryptsetup'. When ALLOW-DISCARDS? is true, the use of discard (TRIM)
208requests is allowed for the underlying device. EXTRA-OPTIONS is a list of
209additional options to be passed to the 'cryptsetup open' command."
210 (with-imported-modules (source-module-closure
211 '((gnu build file-systems)
212 (guix base16)
213 (guix build utils))) ;; For mkdir-p
214 (match targets
215 ((target)
216 #~(begin
217 (use-modules (guix base16))
218
219 (let ((source #$(if (uuid? source)
220 (uuid-bytevector source)
221 source))
222 (keyfile #$key-file))
223
224 (define (luks-script-lookup-key partition)
225 "Parse /etc/luks_script and return the master key as a
226bytevector for PARTITION. Throw to 'luks-script-error with a message
227string if the file is missing, the partition UUID cannot be read, or
228no matching entry is found."
229 (let ((script-file "/etc/luks_script"))
230 (unless (file-exists? script-file)
231 (throw 'luks-script-error
232 (format #f "~a not found, skipping"
233 script-file)))
234 (let ((part-uuid-hex
235 (or (and=> (read-luks-partition-uuid partition)
236 bytevector->base16-string)
237 (throw 'luks-script-error
238 (format #f
239 "could not read UUID from ~a"
240 partition)))))
241 (call-with-input-file script-file
242 (lambda (port)
243 (let loop ((line (read-line port)))
244 (when (eof-object? line)
245 (throw 'luks-script-error
246 (format #f
247 "no matching UUID ~a in ~a"
248 part-uuid-hex script-file)))
249 (match (string-tokenize line)
250 (((or "luks_mount" "luks2_mount")
251 script-uuid _ ... hex-key)
252 (if (string-ci=? (string-delete #\- script-uuid)
253 part-uuid-hex)
254 (base16-string->bytevector hex-key)
255 (loop (read-line port))))
256 (_ (loop (read-line port))))))))))
257
258 (define (open-luks-with-volume-key cryptsetup-program key-bv
259 partition target
260 extra-open-flags)
261 "Open LUKS device PARTITION as TARGET using volume key KEY-BV.
262Return the exit status of cryptsetup. KEY-BV is securely wiped and
263the temporary key file removed regardless of outcome."
264 (let ((key-file "/run/.luks-master-key"))
265 (dynamic-wind
266 (const #t)
267 (lambda ()
268 (call-with-port (open-file key-file "wb")
269 (lambda (p) (put-bytevector p key-bv)))
270 (chmod key-file #o400)
271 (apply system*/tty cryptsetup-program
272 "open" "--type" "luks"
273 "--volume-key-file" key-file
274 (append extra-open-flags
275 (list partition target))))
276 (lambda ()
277 (bytevector-fill! key-bv 0)
278 (when (file-exists? key-file)
279 (delete-file key-file))))))
280
281 (define (try-luks-script-master-key cryptsetup-program
282 partition target
283 extra-open-flags)
284 "Try to open LUKS device PARTITION as TARGET using a master key
285from /etc/luks_script (injected by GRUB). EXTRA-OPEN-FLAGS is a list of
286additional flags to pass to 'cryptsetup open' (e.g., \"--allow-discards\").
287Return #t on success, #f if /etc/luks_script does not exist or the UUID
288does not match. Any other error (parse failure, cryptsetup failure) is
289NOT caught--it will be visible so bugs cannot hide."
290 (catch 'luks-script-error
291 (lambda ()
292 (let* ((key-bv (luks-script-lookup-key partition))
293 (status (open-luks-with-volume-key
294 cryptsetup-program key-bv
295 partition target extra-open-flags)))
296 (if (zero? status)
297 (begin
298 (format (current-error-port)
299 "luks-master-key: unlocked ~a as ~a~%"
300 partition target)
301 #t)
302 (begin
303 (format (current-error-port)
304 "luks-master-key: cryptsetup failed (status ~a) for ~a~%"
305 status partition)
306 #f))))
307 (lambda (key msg . rest)
308 (format (current-error-port)
309 "luks-master-key: ~a~%" msg)
310 #f)))
311
312 ;; Create '/run/cryptsetup/' if it does not exist, as device locking
313 ;; is mandatory for LUKS2.
314 (mkdir-p "/run/cryptsetup/")
315
316 ;; Use 'cryptsetup-static', not 'cryptsetup', to avoid pulling the
317 ;; whole world inside the initrd (for when we're in an initrd).
318 ;; 'cryptsetup open' requires standard input to be a tty to allow
319 ;; for interaction but shepherd sets standard input to /dev/null;
320 ;; thus, explicitly request a tty.
321 (let ((partition
322 ;; Note: We cannot use the "UUID=source" syntax here
323 ;; because 'cryptsetup' implements it by searching the
324 ;; udev-populated /dev/disk/by-id directory but udev may
325 ;; be unavailable at the time we run this.
326 (if (bytevector? source)
327 (or (let loop ((tries-left 10))
328 (and (positive? tries-left)
329 (or (find-partition-by-luks-uuid source)
330 ;; If the underlying partition is
331 ;; not found, try again after
332 ;; waiting a second, up to ten
333 ;; times. FIXME: This should be
334 ;; dealt with in a more robust way.
335 (begin (sleep 1)
336 (loop (- tries-left 1))))))
337 (error "LUKS partition not found" source))
338 source)))
339 (let ((cryptsetup #$(file-append cryptsetup-static
340 "/sbin/cryptsetup"))
341 (cryptsetup-flags (cons*
342 "open" "--type" "luks"
343 (append
344 (if #$allow-discards?
345 '("--allow-discards")
346 '())
347 '#$extra-options
348 (list partition #$target)))))
349 ;; Try the GRUB-provided LUKS master key first (from
350 ;; /etc/luks_script, injected into the initrd via GRUB's
351 ;; newc: mechanism). This avoids prompting for the password
352 ;; a second time when GRUB already decrypted the same LUKS
353 ;; volume. Fall back to keyfile or interactive password on
354 ;; any failure.
355 (or (try-luks-script-master-key cryptsetup partition #$target
356 (append
357 (if #$allow-discards?
358 '("--allow-discards")
359 '())
360 '#$extra-options))
361 ;; We want to fallback to the password unlock if the
362 ;; keyfile fails.
363 (and keyfile
364 (zero? (apply system*/tty cryptsetup
365 "--key-file" keyfile cryptsetup-flags)))
366 (zero? (apply system*/tty cryptsetup
367 cryptsetup-flags)))))))))))
368
369(define* (close-luks-device source targets #:rest _)
370 "Return a gexp that closes TARGET, a LUKS device."
371 (match targets
372 ((target)
373 #~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
374 "close" #$target)))))
375
376(define* (check-luks-device md #:key
377 needed-for-boot?
378 (initrd-modules '())
379 #:allow-other-keys
380 #:rest rest)
381 "Ensure the source of MD is valid."
382 (let ((source (mapped-device-source md))
383 (location (mapped-device-location md)))
384 (let-keywords (mapped-device-arguments md) #t
385 ((extra-options '())
386 key-file allow-discards)
387 (unless (list? extra-options)
388 (raise (make-compound-condition
389 (formatted-message (G_ "invalid value ~s for #:extra-options \
390argument of `open-luks-device'")
391 extra-options)
392 (condition
393 (&error-location
394 (location (source-properties->location location))))))))
395 (or (not (zero? (getuid)))
396 (if (uuid? source)
397 (match (find-partition-by-luks-uuid (uuid-bytevector source))
398 (#f
399 (raise (make-compound-condition
400 (formatted-message (G_ "no LUKS partition with UUID '~a'")
401 (uuid->string source))
402 (condition
403 (&error-location
404 (location (source-properties->location
405 (mapped-device-location md))))))))
406 ((? string? device)
407 (check-device-initrd-modules device initrd-modules location)))
408 (check-device-initrd-modules source initrd-modules location)))))
409
410(define luks-device-mapping
411 ;; The type of LUKS mapped devices.
412 (mapped-device-kind
413 (open open-luks-device)
414 (close close-luks-device)
415 (check check-luks-device)
416 (modules '((rnrs bytevectors) ;bytevector?
417 (rnrs io ports) ;put-bytevector
418 (ice-9 match) ;match
419 (ice-9 rdelim) ;read-line
420 ((gnu build file-systems)
421 #:select (find-partition-by-luks-uuid
422 read-luks-partition-uuid
423 system*/tty))))))
424
425(define-deprecated (luks-device-mapping-with-options #:key
426 key-file allow-discards?)
427 mapped-device-arguments
428 "Return a luks-device-mapping object with open modified to pass the arguments
429into the open-luks-device procedure."
430 (mapped-device-kind
431 (inherit luks-device-mapping)
432 (open (λ (source targets)
433 (open-luks-device source targets
434 #:key-file key-file
435 #:allow-discards? allow-discards?)))))
436
437(define (open-raid-device sources targets)
438 "Return a gexp that assembles SOURCES (a list of devices) to the RAID device
439TARGET (e.g., \"/dev/md0\"), using 'mdadm'."
440 (match targets
441 ((target)
442 #~(let ((sources '#$sources)
443
444 ;; XXX: We're not at the top level here. We could use a
445 ;; non-top-level 'use-modules' form but that doesn't work when the
446 ;; code is eval'd, like the Shepherd does.
447 (every (@ (srfi srfi-1) every))
448 (format (@ (ice-9 format) format)))
449 (let loop ((attempts 0))
450 (unless (every file-exists? sources)
451 (when (> attempts 20)
452 (error "RAID devices did not show up; bailing out"
453 sources))
454
455 (format #t "waiting for RAID source devices~{ ~a~}...~%"
456 sources)
457 (sleep 1)
458 (loop (+ 1 attempts))))
459
460 ;; Use 'mdadm-static' rather than 'mdadm' to avoid pulling its whole
461 ;; closure (80 MiB) in the initrd when a RAID device is needed for boot.
462 (zero? (apply system* #$(file-append mdadm-static "/sbin/mdadm")
463 "--assemble" #$target sources))))))
464
465(define (close-raid-device sources targets)
466 "Return a gexp that stops the RAID device TARGET."
467 (match targets
468 ((target)
469 #~(zero? (system* #$(file-append mdadm-static "/sbin/mdadm")
470 "--stop" #$target)))))
471
472(define raid-device-mapping
473 ;; The type of RAID mapped devices.
474 (mapped-device-kind
475 (open open-raid-device)
476 (close close-raid-device)))
477
478(define (open-lvm-device source targets)
479 #~(and
480 (zero? (system* #$(file-append lvm2-static "/sbin/lvm")
481 "vgchange" "--activate" "ay" #$source))
482 ; /dev/mapper nodes are usually created by udev, but udev may be unavailable at the time we run this. So we create them here.
483 (zero? (system* #$(file-append lvm2-static "/sbin/lvm")
484 "vgscan" "--mknodes"))
485 (every file-exists? (map (lambda (file) (string-append "/dev/mapper/" file))
486 '#$targets))))
487
488
489(define (close-lvm-device source targets)
490 #~(zero? (system* #$(file-append lvm2-static "/sbin/lvm")
491 "vgchange" "--activate" "n" #$source)))
492
493(define lvm-device-mapping
494 (mapped-device-kind
495 (open open-lvm-device)
496 (close close-lvm-device)
497 (modules '((srfi srfi-1)))))
498
499;;; mapped-devices.scm ends here