;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014-2022, 2024-2025 Ludovic Courtès ;;; Copyright © 2016 Andreas Enge ;;; Copyright © 2017, 2018 Mark H Weaver ;;; Copyright © 2024 Tomas Volf <~@wolfsden.cz> ;;; ;;; 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 . (define-module (gnu 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 optargs) #:use-module (ice-9 format) #:export (%mapped-device mapped-device mapped-device? mapped-device-source mapped-device-target mapped-device-targets mapped-device-type mapped-device-arguments mapped-device-location mapped-device-kind mapped-device-kind? mapped-device-kind-open mapped-device-kind-close mapped-device-kind-modules mapped-device-kind-check device-mapping-service-type device-mapping-service check-device-initrd-modules ;XXX: needs a better place luks-device-mapping luks-device-mapping-with-options raid-device-mapping lvm-device-mapping)) ;;; Commentary: ;;; ;;; This module supports "device mapping", a concept implemented by Linux's ;;; device-mapper. ;;; ;;; Code: (define-record-type* %mapped-device make-mapped-device mapped-device? (source mapped-device-source) ;string | list of strings (targets mapped-device-targets) ;list of strings (type mapped-device-type) ; (arguments mapped-device-arguments ;list passed to open/close/check (default '())) (location mapped-device-location (default (current-source-location)) (innate))) (define-syntax mapped-device-compatibility-helper (syntax-rules (target) ((_ () (fields ...)) (%mapped-device fields ...)) ((_ ((target exp) rest ...) (others ...)) (%mapped-device others ... (targets (list exp)) rest ...)) ((_ (field rest ...) (others ...)) (mapped-device-compatibility-helper (rest ...) (others ... field))))) (define-syntax-rule (mapped-device fields ...) "Build an record, automatically converting 'target' field specifications to 'targets'." (mapped-device-compatibility-helper (fields ...) ())) (define-deprecated (mapped-device-target md) mapped-device-targets (car (mapped-device-targets md))) (define-record-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)))) (modules mapped-device-kind-modules ;list of module names (default '())) (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 (($ source targets ($ open close modules) arguments) (shepherd-service (provision (list (symbol-append 'device-mapping- (string->symbol (string-join targets "-"))))) (requirement '(udev)) (documentation "Map a device node using Linux's device mapper.") (start #~(lambda () #$(apply open source targets arguments))) (stop #~(lambda _ (not #$(apply close source targets arguments)))) (modules (append %default-modules modules)) (respawn? #f)))) (description "Map a device node using Linux's device mapper."))) (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 missing ;; Attempt to determine missing modules. (catch 'system-error (lambda () (missing-modules device linux-modules)) ;; If we can't do that (e.g., EPERM), skip the whole thing. (const '()))) (unless (null? missing) ;; Note: What we suggest here is a list of module names (e.g., ;; "usb_storage"), not file names (e.g., "usb-storage.ko"). This is ;; OK because we have machinery that accepts both the hyphen and the ;; underscore version. (raise (make-compound-condition (formatted-message (G_ "you may need these modules \ in the initrd for ~a:~{ ~a~}") device missing) (condition (&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 If you think this diagnostic is inaccurate, use the @option{--skip-checks} option of @command{guix system}.\n") missing)))) (condition (&error-location (location (source-properties->location location)))))))) ;;; ;;; Common device mappings. ;;; (define* (open-luks-device source targets #:key key-file allow-discards? (extra-options '())) "Return a gexp that maps SOURCE to TARGET as a LUKS device, using 'cryptsetup'. When ALLOW-DISCARDS? is true, the use of discard (TRIM) requests is allowed for the underlying device. EXTRA-OPTIONS is a list of additional options to be passed to the 'cryptsetup open' command." (with-imported-modules (source-module-closure '((gnu build file-systems) (guix base16) (guix build utils))) ;; For mkdir-p (match targets ((target) #~(begin (use-modules (guix base16)) (let ((source #$(if (uuid? source) (uuid-bytevector source) source)) (keyfile #$key-file)) (define (luks-script-lookup-key partition) "Parse /etc/luks_script and return the master key as a bytevector for PARTITION. Throw to 'luks-script-error with a message string if the file is missing, the partition UUID cannot be read, or no matching entry is found." (let ((script-file "/etc/luks_script")) (unless (file-exists? script-file) (throw 'luks-script-error (format #f "~a not found, skipping" script-file))) (let ((part-uuid-hex (or (and=> (read-luks-partition-uuid partition) bytevector->base16-string) (throw 'luks-script-error (format #f "could not read UUID from ~a" partition))))) (call-with-input-file script-file (lambda (port) (let loop ((line (read-line port))) (when (eof-object? line) (throw 'luks-script-error (format #f "no matching UUID ~a in ~a" part-uuid-hex script-file))) (match (string-tokenize line) (((or "luks_mount" "luks2_mount") script-uuid _ ... hex-key) (if (string-ci=? (string-delete #\- script-uuid) part-uuid-hex) (base16-string->bytevector hex-key) (loop (read-line port)))) (_ (loop (read-line port)))))))))) (define (open-luks-with-volume-key cryptsetup-program key-bv partition target extra-open-flags) "Open LUKS device PARTITION as TARGET using volume key KEY-BV. Return the exit status of cryptsetup. KEY-BV is securely wiped and the temporary key file removed regardless of outcome." (let ((key-file "/run/.luks-master-key")) (dynamic-wind (const #t) (lambda () (call-with-port (open-file key-file "wb") (lambda (p) (put-bytevector p key-bv))) (chmod key-file #o400) (apply system*/tty cryptsetup-program "open" "--type" "luks" "--volume-key-file" key-file (append extra-open-flags (list partition target)))) (lambda () (bytevector-fill! key-bv 0) (when (file-exists? key-file) (delete-file key-file)))))) (define (try-luks-script-master-key cryptsetup-program partition target extra-open-flags) "Try to open LUKS device PARTITION as TARGET using a master key from /etc/luks_script (injected by GRUB). EXTRA-OPEN-FLAGS is a list of additional flags to pass to 'cryptsetup open' (e.g., \"--allow-discards\"). Return #t on success, #f if /etc/luks_script does not exist or the UUID does not match. Any other error (parse failure, cryptsetup failure) is NOT caught--it will be visible so bugs cannot hide." (catch 'luks-script-error (lambda () (let* ((key-bv (luks-script-lookup-key partition)) (status (open-luks-with-volume-key cryptsetup-program key-bv partition target extra-open-flags))) (if (zero? status) (begin (format (current-error-port) "luks-master-key: unlocked ~a as ~a~%" partition target) #t) (begin (format (current-error-port) "luks-master-key: cryptsetup failed (status ~a) for ~a~%" status partition) #f)))) (lambda (key msg . rest) (format (current-error-port) "luks-master-key: ~a~%" msg) #f))) ;; 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 to 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))) (let ((cryptsetup #$(file-append cryptsetup-static "/sbin/cryptsetup")) (cryptsetup-flags (cons* "open" "--type" "luks" (append (if #$allow-discards? '("--allow-discards") '()) '#$extra-options (list partition #$target))))) ;; Try the GRUB-provided LUKS master key first (from ;; /etc/luks_script, injected into the initrd via GRUB's ;; newc: mechanism). This avoids prompting for the password ;; a second time when GRUB already decrypted the same LUKS ;; volume. Fall back to keyfile or interactive password on ;; any failure. (or (try-luks-script-master-key cryptsetup partition #$target (append (if #$allow-discards? '("--allow-discards") '()) '#$extra-options)) ;; We want to fallback to the password unlock if the ;; keyfile fails. (and keyfile (zero? (apply system*/tty cryptsetup "--key-file" keyfile cryptsetup-flags))) (zero? (apply system*/tty cryptsetup cryptsetup-flags))))))))))) (define* (close-luks-device source targets #:rest _) "Return a gexp that closes TARGET, a LUKS device." (match targets ((target) #~(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))) (let-keywords (mapped-device-arguments md) #t ((extra-options '()) key-file allow-discards) (unless (list? extra-options) (raise (make-compound-condition (formatted-message (G_ "invalid value ~s for #:extra-options \ argument of `open-luks-device'") extra-options) (condition (&error-location (location (source-properties->location location)))))))) (or (not (zero? (getuid))) (if (uuid? source) (match (find-partition-by-luks-uuid (uuid-bytevector source)) (#f (raise (make-compound-condition (formatted-message (G_ "no LUKS partition with UUID '~a'") (uuid->string source)) (condition (&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) (modules '((rnrs bytevectors) ;bytevector? (rnrs io ports) ;put-bytevector (ice-9 match) ;match (ice-9 rdelim) ;read-line ((gnu build file-systems) #:select (find-partition-by-luks-uuid read-luks-partition-uuid system*/tty)))))) (define-deprecated (luks-device-mapping-with-options #:key key-file allow-discards?) mapped-device-arguments "Return a luks-device-mapping object with open modified to pass the arguments into the open-luks-device procedure." (mapped-device-kind (inherit luks-device-mapping) (open (λ (source targets) (open-luks-device source targets #:key-file key-file #:allow-discards? allow-discards?))))) (define (open-raid-device sources targets) "Return a gexp that assembles SOURCES (a list of devices) to the RAID device TARGET (e.g., \"/dev/md0\"), using 'mdadm'." (match targets ((target) #~(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 targets) "Return a gexp that stops the RAID device TARGET." (match targets ((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))) (define (open-lvm-device source targets) #~(and (zero? (system* #$(file-append lvm2-static "/sbin/lvm") "vgchange" "--activate" "ay" #$source)) ; /dev/mapper nodes are usually created by udev, but udev may be unavailable at the time we run this. So we create them here. (zero? (system* #$(file-append lvm2-static "/sbin/lvm") "vgscan" "--mknodes")) (every file-exists? (map (lambda (file) (string-append "/dev/mapper/" file)) '#$targets)))) (define (close-lvm-device source targets) #~(zero? (system* #$(file-append lvm2-static "/sbin/lvm") "vgchange" "--activate" "n" #$source))) (define lvm-device-mapping (mapped-device-kind (open open-lvm-device) (close close-lvm-device) (modules '((srfi srfi-1))))) ;;; mapped-devices.scm ends here