[bug#52882] [PATCH] gnu: system: Add crypt-key field for mapped filesystems

[chayleaf]

From: chayleaf <chayleaf@protonmail.com>

This is a patch that adds a new field for mapped-filesystem that allows
one to specify the LUKS encryption key via G-Expressions.
An example use case is using a key stored on an external device.

Sorry if I made a mistake anywhere, I'm new to both Lisp and mailing
lists.

* gnu/system/mapped-devices.scm (mapped-device-kind):
Add crypt-key field.
(open-luks-device): Use crypt-key as the encryption key if it's
provided.
* gnu/system/linux-initrd.scm (raw-initrd)[device-mapping-commands]:
Utilize the crypt-key field.
* doc/guix.texi (Mapped Devices): Add crypt-key to mapped-device docs.

Signed-off-by: chayleaf <chayleaf@pavluk.org>
---
 doc/guix.texi                 |  7 ++++
 gnu/system/linux-initrd.scm   | 11 ++---
 gnu/system/mapped-devices.scm | 77 +++++++++++++++++++++++------------
 3 files changed, 63 insertions(+), 32 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index ebfcfee7f7..22495b0cbd 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -15125,6 +15125,13 @@ there are several.  The format is identical to 
@var{target}.
 @item type
 This must be a @code{mapped-device-kind} object, which specifies how
 @var{source} is mapped to @var{target}.
+
+@item crypt-key
+A G-Expression (see @pxref{G-Expressions}) or a bytevector to be used as the
+encryption key for this device.  If none is specified, the user will be asked
+to enter their passphrase.  It can be used for fetching the key from an
+external device or avoiding to enter the passhprase two times with encrypted
+@code{/boot}.
 @end table
 @end deftp
 
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index c78dd09205..36700d91ae 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -203,11 +203,12 @@ (define* (raw-initrd file-systems
   (define device-mapping-commands
     ;; List of gexps to open the mapped devices.
     (map (lambda (md)
-           (let* ((source  (mapped-device-source md))
-                  (targets (mapped-device-targets md))
-                  (type    (mapped-device-type md))
-                  (open    (mapped-device-kind-open type)))
-             (open source targets)))
+           (let* ((source    (mapped-device-source md))
+                  (targets   (mapped-device-targets md))
+                  (type      (mapped-device-type md))
+                  (crypt-key (mapped-device-crypt-key md))
+                  (open      (mapped-device-kind-open type)))
+             (open source targets #:crypt-key crypt-key)))
          mapped-devices))
 
   (define file-system-scan-commands
diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm
index 96a381d5fe..4f680b71fe 100644
--- a/gnu/system/mapped-devices.scm
+++ b/gnu/system/mapped-devices.scm
@@ -50,6 +50,7 @@ (define-module (gnu system mapped-devices)
             mapped-device-target
             mapped-device-targets
             mapped-device-type
+            mapped-device-crypt-key
             mapped-device-location
 
             mapped-device-kind
@@ -80,6 +81,8 @@ (define-record-type* <mapped-device> %mapped-device
   (source    mapped-device-source)                ;string | list of strings
   (targets   mapped-device-targets)               ;list of strings
   (type      mapped-device-type)                  ;<mapped-device-kind>
+  (crypt-key mapped-device-crypt-key              ;bytevector | gexp
+             (default (const #f)))
   (location  mapped-device-location
              (default (current-source-location)) (innate)))
 
@@ -107,7 +110,7 @@ (define-deprecated (mapped-device-target md)
 (define-record-type* <mapped-device-type> mapped-device-kind
   make-mapped-device-kind
   mapped-device-kind?
-  (open      mapped-device-kind-open)             ;source target -> gexp
+  (open      mapped-device-kind-open)             ;source target #:key 
(crypt-key #f) -> gexp
   (close     mapped-device-kind-close             ;source target -> gexp
              (default (const #~(const #f))))
   (check     mapped-device-kind-check             ;source -> Boolean
@@ -188,7 +191,10 @@ (define missing
 ;;; Common device mappings.
 ;;;
 
-(define (open-luks-device source targets)
+(define* (open-luks-device source targets #:key
+                                  (crypt-key #f)
+                                  #:allow-other-keys
+                                  #:rest rest)
   "Return a gexp that maps SOURCE to TARGET as a LUKS device, using
 'cryptsetup'."
   (with-imported-modules (source-module-closure
@@ -200,7 +206,9 @@ (define (open-luks-device source targets)
                              (uuid-bytevector source)
                              source)))
            ;; XXX: 'use-modules' should be at the top level.
-           (use-modules (rnrs bytevectors) ;bytevector?
+           (use-modules (ice-9 binary-ports) ;put-bytevector
+                        (ice-9 popen) ;open-pipe*
+                        (rnrs bytevectors) ;bytevector?
                         ((gnu build file-systems)
                          #:select (find-partition-by-luks-uuid))
                         ((guix build utils) #:select (mkdir-p)))
@@ -211,28 +219,37 @@ (define (open-luks-device source targets)
 
            ;; Use 'cryptsetup-static', not 'cryptsetup', to avoid pulling the
            ;; whole world inside the initrd (for when we're in an initrd).
-           (zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
-                           "open" "--type" "luks"
-
-                           ;; 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)
-
-                           #$target)))))))
+           (let ((crypt-key #$crypt-key)
+                 (cryptsetup-cmdline (list #$(file-append cryptsetup-static 
"/sbin/cryptsetup")
+                                           "open" "--type" "luks"
+
+                                           ;; 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)
+
+                                           #$target)))
+               (or (and (bytevector? crypt-key)
+                        (let ((port (apply open-pipe*
+                                           (cons OPEN_WRITE
+                                                 (append cryptsetup-cmdline
+                                                         (list "--key-file" 
"-"))))))
+                          (put-bytevector port crypt-key)
+                          (zero? (status:exit-val (close-pipe port)))))
+                   (zero? (apply system* cryptsetup-cmdline)))))))))
 
 (define (close-luks-device source targets)
   "Return a gexp that closes TARGET, a LUKS device."
@@ -271,7 +288,10 @@ (define luks-device-mapping
    (close close-luks-device)
    (check check-luks-device)))
 
-(define (open-raid-device sources targets)
+(define* (open-raid-device sources targets #:key
+                                   (crypt-key #f)
+                                   #:allow-other-keys
+                                   #:rest rest)
   "Return a gexp that assembles SOURCES (a list of devices) to the RAID device
 TARGET (e.g., \"/dev/md0\"), using 'mdadm'."
   (match targets
@@ -312,7 +332,10 @@ (define raid-device-mapping
    (open open-raid-device)
    (close close-raid-device)))
 
-(define (open-lvm-device source targets)
+(define* (open-lvm-device source targets #:key
+                                 (crypt-key #f)
+                                 #:allow-other-keys
+                                 #:rest rest)
   #~(and
      (zero? (system* #$(file-append lvm2-static "/sbin/lvm")
                      "vgchange" "--activate" "ay" #$source))
-- 
2.34.1