projects/guix·blob python-team · refs

501 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;;; Commentary:
23;;;
24;;; This module supports "device mapping", a concept implemented by Linux's
25;;; device-mapper.
26;;;
27;;; Code:
28
29(define-module (gnu system mapped-devices)
30 #:use-module (guix gexp)
31 #:use-module (guix records)
32 #:use-module ((guix modules) #:hide (file-name->module-name))
33 #:use-module (guix i18n)
34 #:use-module ((guix diagnostics)
35 #:select (source-properties->location
36 formatted-message
37 &fix-hint
38 &error-location))
39 #:use-module (guix deprecation)
40 #:use-module (gnu services)
41 #:use-module (gnu services shepherd)
42 #:use-module (gnu system uuid)
43 #:autoload (gnu build file-systems) (find-partition-by-luks-uuid)
44 #:autoload (gnu build linux-modules)
45 (missing-modules)
46 #:autoload (gnu packages cryptsetup) (cryptsetup-static)
47 #:autoload (gnu packages linux) (mdadm-static lvm2-static)
48 #:use-module (srfi srfi-1)
49 #:use-module (srfi srfi-26)
50 #:use-module (srfi srfi-34)
51 #:use-module (srfi srfi-35)
52 #:use-module (ice-9 match)
53 #:use-module (ice-9 optargs)
54 #:use-module (ice-9 format)
55 #:export (%mapped-device
56 mapped-device
57 mapped-device?
58 mapped-device-source
59 mapped-device-target
60 mapped-device-targets
61 mapped-device-type
62 mapped-device-arguments
63 mapped-device-location
64
65 mapped-device-kind
66 mapped-device-kind?
67 mapped-device-kind-open
68 mapped-device-kind-close
69 mapped-device-kind-modules
70 mapped-device-kind-check
71
72 device-mapping-service-type
73 device-mapping-service
74
75 check-device-initrd-modules ;XXX: needs a better place
76
77 luks-device-mapping
78 luks-device-mapping-with-options
79 raid-device-mapping
80 lvm-device-mapping))
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
189 (append
190 (list~{ ~s~})
191 (base-initrd-modules (operating-system-kernel this-operating-system)))))
192@end example
193
194If you think this diagnostic is inaccurate, use the @option{--skip-checks}
195option of @command{guix system}.\n")
196 missing))))
197 (condition
198 (&error-location
199 (location (source-properties->location location))))))))
200
201
202;;;
203;;; Common device mappings.
204;;;
205
206(define* (open-luks-device source targets
207 #:key key-file allow-discards? (extra-options '()))
208 "Return a gexp that maps SOURCE to TARGET as a LUKS device, using
209'cryptsetup'. When ALLOW-DISCARDS? is true, the use of discard (TRIM)
210requests is allowed for the underlying device. EXTRA-OPTIONS is a list of
211additional options to be passed to the 'cryptsetup open' command."
212 (with-imported-modules (source-module-closure
213 '((gnu build file-systems)
214 (guix base16)
215 (guix build utils))) ;; For mkdir-p
216 (match targets
217 ((target)
218 #~(begin
219 (use-modules (guix base16))
220
221 (let ((source #$(if (uuid? source)
222 (uuid-bytevector source)
223 source))
224 (keyfile #$key-file))
225
226 (define (luks-script-lookup-key partition)
227 "Parse /etc/luks_script and return the master key as a
228bytevector for PARTITION. Throw to 'luks-script-error with a message
229string if the file is missing, the partition UUID cannot be read, or
230no matching entry is found."
231 (let ((script-file "/etc/luks_script"))
232 (unless (file-exists? script-file)
233 (throw 'luks-script-error
234 (format #f "~a not found, skipping"
235 script-file)))
236 (let ((part-uuid-hex
237 (or (and=> (read-luks-partition-uuid partition)
238 bytevector->base16-string)
239 (throw 'luks-script-error
240 (format #f
241 "could not read UUID from ~a"
242 partition)))))
243 (call-with-input-file script-file
244 (lambda (port)
245 (let loop ((line (read-line port)))
246 (when (eof-object? line)
247 (throw 'luks-script-error
248 (format #f
249 "no matching UUID ~a in ~a"
250 part-uuid-hex script-file)))
251 (match (string-tokenize line)
252 (((or "luks_mount" "luks2_mount")
253 script-uuid _ ... hex-key)
254 (if (string-ci=? (string-delete #\- script-uuid)
255 part-uuid-hex)
256 (base16-string->bytevector hex-key)
257 (loop (read-line port))))
258 (_ (loop (read-line port))))))))))
259
260 (define (open-luks-with-volume-key cryptsetup-program key-bv
261 partition target
262 extra-open-flags)
263 "Open LUKS device PARTITION as TARGET using volume key KEY-BV.
264Return the exit status of cryptsetup. KEY-BV is securely wiped and
265the temporary key file removed regardless of outcome."
266 (let ((key-file "/run/.luks-master-key"))
267 (dynamic-wind
268 (const #t)
269 (lambda ()
270 (call-with-port (open-file key-file "wb")
271 (lambda (p) (put-bytevector p key-bv)))
272 (chmod key-file #o400)
273 (apply system*/tty cryptsetup-program
274 "open" "--type" "luks"
275 "--volume-key-file" key-file
276 (append extra-open-flags
277 (list partition target))))
278 (lambda ()
279 (bytevector-fill! key-bv 0)
280 (when (file-exists? key-file)
281 (delete-file key-file))))))
282
283 (define (try-luks-script-master-key cryptsetup-program
284 partition target
285 extra-open-flags)
286 "Try to open LUKS device PARTITION as TARGET using a master key
287from /etc/luks_script (injected by GRUB). EXTRA-OPEN-FLAGS is a list of
288additional flags to pass to 'cryptsetup open' (e.g., \"--allow-discards\").
289Return #t on success, #f if /etc/luks_script does not exist or the UUID
290does not match. Any other error (parse failure, cryptsetup failure) is
291NOT caught--it will be visible so bugs cannot hide."
292 (catch 'luks-script-error
293 (lambda ()
294 (let* ((key-bv (luks-script-lookup-key partition))
295 (status (open-luks-with-volume-key
296 cryptsetup-program key-bv
297 partition target extra-open-flags)))
298 (if (zero? status)
299 (begin
300 (format (current-error-port)
301 "luks-master-key: unlocked ~a as ~a~%"
302 partition target)
303 #t)
304 (begin
305 (format (current-error-port)
306 "luks-master-key: cryptsetup failed (status ~a) for ~a~%"
307 status partition)
308 #f))))
309 (lambda (key msg . rest)
310 (format (current-error-port)
311 "luks-master-key: ~a~%" msg)
312 #f)))
313
314 ;; Create '/run/cryptsetup/' if it does not exist, as device locking
315 ;; is mandatory for LUKS2.
316 (mkdir-p "/run/cryptsetup/")
317
318 ;; Use 'cryptsetup-static', not 'cryptsetup', to avoid pulling the
319 ;; whole world inside the initrd (for when we're in an initrd).
320 ;; 'cryptsetup open' requires standard input to be a tty to allow
321 ;; for interaction but shepherd sets standard input to /dev/null;
322 ;; thus, explicitly request a tty.
323 (let ((partition
324 ;; Note: We cannot use the "UUID=source" syntax here
325 ;; because 'cryptsetup' implements it by searching the
326 ;; udev-populated /dev/disk/by-id directory but udev may
327 ;; be unavailable at the time we run this.
328 (if (bytevector? source)
329 (or (let loop ((tries-left 10))
330 (and (positive? tries-left)
331 (or (find-partition-by-luks-uuid source)
332 ;; If the underlying partition is
333 ;; not found, try again after
334 ;; waiting a second, up to ten
335 ;; times. FIXME: This should be
336 ;; dealt with in a more robust way.
337 (begin (sleep 1)
338 (loop (- tries-left 1))))))
339 (error "LUKS partition not found" source))
340 source)))
341 (let ((cryptsetup #$(file-append cryptsetup-static
342 "/sbin/cryptsetup"))
343 (cryptsetup-flags (cons*
344 "open" "--type" "luks"
345 (append
346 (if #$allow-discards?
347 '("--allow-discards")
348 '())
349 '#$extra-options
350 (list partition #$target)))))
351 ;; Try the GRUB-provided LUKS master key first (from
352 ;; /etc/luks_script, injected into the initrd via GRUB's
353 ;; newc: mechanism). This avoids prompting for the password
354 ;; a second time when GRUB already decrypted the same LUKS
355 ;; volume. Fall back to keyfile or interactive password on
356 ;; any failure.
357 (or (try-luks-script-master-key cryptsetup partition #$target
358 (append
359 (if #$allow-discards?
360 '("--allow-discards")
361 '())
362 '#$extra-options))
363 ;; We want to fallback to the password unlock if the
364 ;; keyfile fails.
365 (and keyfile
366 (zero? (apply system*/tty cryptsetup
367 "--key-file" keyfile cryptsetup-flags)))
368 (zero? (apply system*/tty cryptsetup
369 cryptsetup-flags)))))))))))
370
371(define* (close-luks-device source targets #:rest _)
372 "Return a gexp that closes TARGET, a LUKS device."
373 (match targets
374 ((target)
375 #~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
376 "close" #$target)))))
377
378(define* (check-luks-device md #:key
379 needed-for-boot?
380 (initrd-modules '())
381 #:allow-other-keys
382 #:rest rest)
383 "Ensure the source of MD is valid."
384 (let ((source (mapped-device-source md))
385 (location (mapped-device-location md)))
386 (let-keywords (mapped-device-arguments md) #t
387 ((extra-options '())
388 key-file allow-discards)
389 (unless (list? extra-options)
390 (raise (make-compound-condition
391 (formatted-message (G_ "invalid value ~s for #:extra-options \
392argument of `open-luks-device'")
393 extra-options)
394 (condition
395 (&error-location
396 (location (source-properties->location location))))))))
397 (or (not (zero? (getuid)))
398 (if (uuid? source)
399 (match (find-partition-by-luks-uuid (uuid-bytevector source))
400 (#f
401 (raise (make-compound-condition
402 (formatted-message (G_ "no LUKS partition with UUID '~a'")
403 (uuid->string source))
404 (condition
405 (&error-location
406 (location (source-properties->location
407 (mapped-device-location md))))))))
408 ((? string? device)
409 (check-device-initrd-modules device initrd-modules location)))
410 (check-device-initrd-modules source initrd-modules location)))))
411
412(define luks-device-mapping
413 ;; The type of LUKS mapped devices.
414 (mapped-device-kind
415 (open open-luks-device)
416 (close close-luks-device)
417 (check check-luks-device)
418 (modules '((rnrs bytevectors) ;bytevector?
419 (rnrs io ports) ;put-bytevector
420 (ice-9 match) ;match
421 (ice-9 rdelim) ;read-line
422 ((gnu build file-systems)
423 #:select (find-partition-by-luks-uuid
424 read-luks-partition-uuid
425 system*/tty))))))
426
427(define-deprecated (luks-device-mapping-with-options #:key
428 key-file allow-discards?)
429 mapped-device-arguments
430 "Return a luks-device-mapping object with open modified to pass the arguments
431into the open-luks-device procedure."
432 (mapped-device-kind
433 (inherit luks-device-mapping)
434 (open (λ (source targets)
435 (open-luks-device source targets
436 #:key-file key-file
437 #:allow-discards? allow-discards?)))))
438
439(define (open-raid-device sources targets)
440 "Return a gexp that assembles SOURCES (a list of devices) to the RAID device
441TARGET (e.g., \"/dev/md0\"), using 'mdadm'."
442 (match targets
443 ((target)
444 #~(let ((sources '#$sources)
445
446 ;; XXX: We're not at the top level here. We could use a
447 ;; non-top-level 'use-modules' form but that doesn't work when the
448 ;; code is eval'd, like the Shepherd does.
449 (every (@ (srfi srfi-1) every))
450 (format (@ (ice-9 format) format)))
451 (let loop ((attempts 0))
452 (unless (every file-exists? sources)
453 (when (> attempts 20)
454 (error "RAID devices did not show up; bailing out"
455 sources))
456
457 (format #t "waiting for RAID source devices~{ ~a~}...~%"
458 sources)
459 (sleep 1)
460 (loop (+ 1 attempts))))
461
462 ;; Use 'mdadm-static' rather than 'mdadm' to avoid pulling its whole
463 ;; closure (80 MiB) in the initrd when a RAID device is needed for boot.
464 (zero? (apply system* #$(file-append mdadm-static "/sbin/mdadm")
465 "--assemble" #$target sources))))))
466
467(define (close-raid-device sources targets)
468 "Return a gexp that stops the RAID device TARGET."
469 (match targets
470 ((target)
471 #~(zero? (system* #$(file-append mdadm-static "/sbin/mdadm")
472 "--stop" #$target)))))
473
474(define raid-device-mapping
475 ;; The type of RAID mapped devices.
476 (mapped-device-kind
477 (open open-raid-device)
478 (close close-raid-device)))
479
480(define (open-lvm-device source targets)
481 #~(and
482 (zero? (system* #$(file-append lvm2-static "/sbin/lvm")
483 "vgchange" "--activate" "ay" #$source))
484 ; /dev/mapper nodes are usually created by udev, but udev may be unavailable at the time we run this. So we create them here.
485 (zero? (system* #$(file-append lvm2-static "/sbin/lvm")
486 "vgscan" "--mknodes"))
487 (every file-exists? (map (lambda (file) (string-append "/dev/mapper/" file))
488 '#$targets))))
489
490
491(define (close-lvm-device source targets)
492 #~(zero? (system* #$(file-append lvm2-static "/sbin/lvm")
493 "vgchange" "--activate" "n" #$source)))
494
495(define lvm-device-mapping
496 (mapped-device-kind
497 (open open-lvm-device)
498 (close close-lvm-device)
499 (modules '((srfi srfi-1)))))
500
501;;; mapped-devices.scm ends here