diff options
Diffstat (limited to 'sigils')
| -rw-r--r-- | sigils/system/mapped-devices.scm | 92 |
1 files changed, 92 insertions, 0 deletions
diff --git a/sigils/system/mapped-devices.scm b/sigils/system/mapped-devices.scm new file mode 100644 index 0000000..ac5c001 --- /dev/null +++ b/sigils/system/mapped-devices.scm @@ -0,0 +1,92 @@ +(define-module (sigils system mapped-devices) + #:use-module (guix gexp) + ;; #:use-module (guix records) + ;; #:use-module ((guix modules) #:hide (file-name->module-name)) + ;; #:use-module (guix i18n) + ;; #:use-module ((guix diagnostics) + ;; #:select (source-properties->location + ;; formatted-message + ;; &fix-hint + ;; &error-location)) + ;; #:use-module (guix deprecation) + ;; #: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) + ;; (missing-modules) + ;; #:autoload (gnu packages cryptsetup) (cryptsetup-static) + ;; #:autoload (gnu packages linux) (mdadm-static lvm2-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) + ;; #:use-module (ice-9 format) + #: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?))))) |