blob: 1efc34abed16757ce2c87cd0b8193969ca416e1a (
plain) (
blame)
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
|
(define-module (sigils system mapped-devices)
#:use-module (guix gexp)
#:use-module ((guix modules) #:hide (file-name->module-name))
#:use-module (gnu system uuid)
#:autoload (gnu build file-systems) (find-partition-by-luks-uuid)
#:autoload (gnu packages cryptsetup) (cryptsetup-static)
#:use-module (ice-9 match)
#:export (luks-device-mapping-with-options))
;;;
;;; Common device mappings.
;;;
(define* (open-luks-device source targets #:key key-file allow-discards?)
"Return a gexp that maps SOURCE to TARGET as a LUKS device, using
'cryptsetup'."
(with-imported-modules (source-module-closure
'((gnu build file-systems)
(guix build utils))) ;; For mkdir-p
(match targets
((target)
#~(let ((source #$(if (uuid? source)
(uuid-bytevector source)
source))
(keyfile #$key-file))
;; Create '/run/cryptsetup/' if it does not exist, as device locking
;; is mandatory for LUKS2.
(mkdir-p "/run/cryptsetup/")
;; Use 'cryptsetup-static', not 'cryptsetup', to avoid pulling the
;; whole world inside the initrd (for when we're in an initrd).
;; 'cryptsetup open' requires standard input t #f)o be a tty to allow
;; for interaction but shepherd sets standard input to /dev/null;
;; thus, explicitly request a tty.
(let ((partition
;; 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)))
;; We want to fallback to the password unlock if the keyfile fails.
(or (and keyfile
(zero? (system*/tty
#$(file-append cryptsetup-static "/sbin/cryptsetup")
"open" "--type" "luks" (if allow-discards? "--allow-discards")
"--key-file" keyfile
partition #$target)))
(zero? (system*/tty
#$(file-append cryptsetup-static "/sbin/cryptsetup")
"open" "--type" "luks" (if allow-discards? "--allow-discards")
partition #$target)))))))))
(define* (luks-device-mapping-with-options #:key key-file allow-discards?)
"Return a luks-device-mapping object with open modified to pass the arguments
into the open-luks-device procedure."
((@@ (gnu system mapped-devices) mapped-device-kind)
(inherit (@@ (gnu system mapped-devices) luks-device-mapping))
(open (λ (source targets)
(open-luks-device source targets
#:key-file key-file
#:allow-discards? allow-discards?)))))
|
