bug#21843: Generated grub.cfg does not support encrypted roots

[Ludovic Courtès]

Andreas Enge <address@hidden> skribis:

> What is needed are the following two lines at the beginning of grub.cfg:
>
> insmod luks
> cryptomount -u 1aa...

The attached patch does exactly that when the ‘mapped-device’ source is
a UUID, as is the case with the modified bare-bones.tmpl example:

diff --git a/gnu/system.scm b/gnu/system.scm
index 768ca9c..da41ba6 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -210,6 +210,16 @@ as 'needed-for-boot'."
                  (string=? (file-system-device fs) target)))
           file-systems)))
 
+(define (file-system-mapped-device file-system devices)
+  "Return the mapped-device among DEVICES that backs FILE-SYSTEM, or #f."
+  (and (eq? 'device (file-system-title file-system))
+       (string-prefix? "/dev/mapper/" (file-system-device file-system))
+       (let ((name (string-drop (file-system-device file-system)
+                                (string-length "/dev/mapper/"))))
+         (find (lambda (md)
+                 (string=? (mapped-device-target md) name))
+               devices))))
+
 (define (operating-system-user-mapped-devices os)
   "Return the subset of mapped devices that can be installed in
 user-land--i.e., those not needed during boot."
@@ -674,6 +684,15 @@ listed in OS.  The C library expects to find it under
   "Return the file system that contains the store of OS."
   (store-file-system (operating-system-file-systems os)))
 
+(define (grub-config-for-store-file-system os)
+  (let ((md (file-system-mapped-device (operating-system-store-file-system os)
+                                       (operating-system-mapped-devices os))))
+    (if md
+        (let* ((type (mapped-device-type md))
+               (grub (mapped-device-kind-grub type)))
+          (grub (mapped-device-source md) (mapped-device-target md)))
+        '())))
+
 (define* (operating-system-grub.cfg os #:optional (old-entries '()))
   "Return the GRUB configuration file for OS.  Use OLD-ENTRIES to populate the
 \"old entries\" menu."
@@ -694,7 +713,8 @@ listed in OS.  The C library expects to find it under
                                    #~(string-append "--load=" #$system
                                                     "/boot")
                                    (operating-system-kernel-arguments os)))
-                           (initrd #~(string-append #$system "/initrd"))))))
+                           (initrd #~(string-append #$system "/initrd"))
+                           (extra-lines (grub-config-for-store-file-system 
os))))))
     (grub-configuration-file (operating-system-bootloader os)
                              store-fs entries
                              #:old-entries old-entries)))
diff --git a/gnu/system/examples/bare-bones.tmpl 
b/gnu/system/examples/bare-bones.tmpl
index 87e8d1e..b85593d 100644
--- a/gnu/system/examples/bare-bones.tmpl
+++ b/gnu/system/examples/bare-bones.tmpl
@@ -13,9 +13,13 @@
   ;; Assuming /dev/sdX is the target hard disk, and "my-root" is
   ;; the label of the target root file system.
   (bootloader (grub-configuration (device "/dev/sdX")))
+  (mapped-devices (list (mapped-device
+                         (source (uuid "cb67fc72-0d54-4c88-9d4b-b225f30b0f44"))
+                         (target "foo")
+                         (type luks-device-mapping))))
   (file-systems (cons (file-system
-                        (device "my-root")
-                        (title 'label)
+                        (device "/dev/mapper/foo")
+                        (title 'device)
                         (mount-point "/")
                         (type "ext4"))
                       %base-file-systems))
diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm
index 45b46ca..60cc044 100644
--- a/gnu/system/grub.scm
+++ b/gnu/system/grub.scm
@@ -114,7 +114,9 @@
   (linux           menu-entry-linux)
   (linux-arguments menu-entry-linux-arguments
                    (default '()))          ; list of string-valued gexps
-  (initrd          menu-entry-initrd))     ; file name of the initrd as a gexp
+  (initrd          menu-entry-initrd)      ; file name of the initrd as a gexp
+  (extra-lines     menu-entry-extra-lines  ; list of string-valued gexps
+                   (default '())))
 
 
 ;;;
@@ -253,13 +255,14 @@ corresponding to old generations of the system."
 
   (define entry->gexp
     (match-lambda
-     (($ <menu-entry> label linux arguments initrd)
-      #~(format port "menuentry ~s {
+      (($ <menu-entry> label linux arguments initrd extra-lines)
+      #~(format port "menuentry ~s {~{~%  ~a~}
   ~a
   linux ~a/~a ~a
   initrd ~a
 }~%"
                 #$label
+                (list address@hidden)
                 #$(grub-root-search store-fs
                                     #~(string-append #$linux "/"
                                                      #$linux-image-name))
@@ -268,22 +271,25 @@ corresponding to old generations of the system."
 
   (mlet %store-monad ((sugar (eye-candy config store-fs system #~port)))
     (define builder
-      #~(call-with-output-file #$output
-          (lambda (port)
-            #$sugar
-            (format port "
+      #~(begin
+          (use-modules (ice-9 format))
+
+          (call-with-output-file #$output
+            (lambda (port)
+              #$sugar
+              (format port "
 set default=~a
 set timeout=~a~%"
-                    #$(grub-configuration-default-entry config)
-                    #$(grub-configuration-timeout config))
-            #$@(map entry->gexp all-entries)
+                      #$(grub-configuration-default-entry config)
+                      #$(grub-configuration-timeout config))
+              #$@(map entry->gexp all-entries)
 
-            #$@(if (pair? old-entries)
-                   #~((format port "
+              #$@(if (pair? old-entries)
+                     #~((format port "
 submenu \"GNU system, old configurations...\" {~%")
-                      #$@(map entry->gexp old-entries)
-                      (format port "}~%"))
-                   #~()))))
+                        #$@(map entry->gexp old-entries)
+                        (format port "}~%"))
+                     #~())))))
 
     (gexp->derivation "grub.cfg" builder)))
 
diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm
index 450b473..ddb6c8d 100644
--- a/gnu/system/mapped-devices.scm
+++ b/gnu/system/mapped-devices.scm
@@ -22,7 +22,11 @@
   #:use-module (gnu services)
   #:use-module (gnu services shepherd)
   #:autoload   (gnu packages cryptsetup) (cryptsetup)
+  #:autoload   (gnu build file-systems) (uuid->string)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match)
   #:export (mapped-device
             mapped-device?
@@ -34,6 +38,7 @@
             mapped-device-kind?
             mapped-device-kind-open
             mapped-device-kind-close
+            mapped-device-kind-grub
 
             device-mapping-service-type
             device-mapping-service
@@ -59,7 +64,9 @@
   mapped-device-kind?
   (open      mapped-device-kind-open)             ;source target -> gexp
   (close     mapped-device-kind-close             ;source target -> gexp
-             (default (const #~(const #f)))))
+             (default (const #~(const #f))))
+  (grub      mapped-device-kind-grub              ;source target -> gexp list
+             (default #f)))                       ;| #f
 
 
 ;;;
@@ -121,10 +128,21 @@
   #~(zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup")
                     "close" #$target)))
 
+(define (grub-luks-device source target)
+  (if (bytevector? source)
+      (list "insmod luks"
+            (string-append "cryptomount -u " (uuid->string source)))
+      (raise
+       (condition
+        (&message
+         (message (format #f "LUKS mapped-device source must be a UUID: ~s"
+                          source)))))))
+
 (define luks-device-mapping
   ;; The type of LUKS mapped devices.
   (mapped-device-kind
    (open open-luks-device)
-   (close close-luks-device)))
+   (close close-luks-device)
+   (grub grub-luks-device)))
 
 ;;; mapped-devices.scm ends here

A good way to test it (not as root!) is:

--8<---------------cut here---------------start------------->8---
$ ./pre-inst-env guix system reconfigure gnu/system/examples/bare-bones.tmpl
/gnu/store/fm8lbh7r3j05bkd6kbnc9xwph6rmy0rz-system
/gnu/store/9l0dfdxj7ybck63r9zrgnxbyryn6f0kh-grub.cfg
/gnu/store/myrc5cinlhpj2yilhzv5y0szz2ax2i6z-grub-2.00
guix system: error: symlink: Mankas permeso: 
"/var/guix/profiles/system-192-link"
--8<---------------cut here---------------end--------------->8---

The generated grub.cfg whose name appears above has this entry:

--8<---------------cut here---------------start------------->8---
menuentry "GNU with Linux-Libre 4.5.2 (beta)" {
  insmod luks
  cryptomount -u cb67fc72-0d54-4c88-9d4b-b225f30b0f44
  search --file --set 
/gnu/store/dd2qbz6a5pszwnzay3s8mm9yim531nz0-linux-libre-4.5.2/bzImage
  linux /gnu/store/dd2qbz6a5pszwnzay3s8mm9yim531nz0-linux-libre-4.5.2/bzImage 
--root=/dev/mapper/foo 
--system=/gnu/store/fm8lbh7r3j05bkd6kbnc9xwph6rmy0rz-system 
--load=/gnu/store/fm8lbh7r3j05bkd6kbnc9xwph6rmy0rz-system/boot
  initrd /gnu/store/fm8lbh7r3j05bkd6kbnc9xwph6rmy0rz-system/initrd
}
--8<---------------cut here---------------end--------------->8---

Now, I haven’t tested this in reality and would appreciate help here.

We may have to add the patch to ‘guix-devel’ in (gnu packages
package-management) to test it.

Ludo’.