system: Allow separated /boot and encrypted root.

* gnu/bootloader/grub.scm (grub-configuration-file): New parameter
store-crypto-devices.
[crypto-devices]: New helper function.
[builder]: Use crypto-devices.
* gnu/machine/ssh.scm (roll-back-managed-host): Use
boot-parameters-store-crypto-devices to provide its contents to the
bootloader configuration generation process.
* gnu/tests/install.scm (%encrypted-root-not-boot-os,
%encrypted-root-not-boot-os): New os declaration.
(%encrypted-root-not-boot-installation-script): New script, whose contents
were initially taken from %encrypted-root-installation-script.
(%test-encrypted-root-not-boot-os): New test.
* gnu/system.scm (define-module): Export
operating-system-bootoader-crypto-devices and
boot-parameters-store-crypto-devices.
(<boot-parameters>): Add field store-crypto-devices.
(read-boot-parameters): Parse store-crypto-devices field.
[uuid-sexp->uuid]: New helper function extracted from
device-sexp->device.
(operating-system-bootloader-crypto-devices): New function.
(operating-system-bootcfg): Use
operating-system-bootloader-crypto-devices to provide its contents to
the bootloader configuration generation process.
(operating-system-boot-parameters): Add store-crypto-devices to the
generated boot-parameters.
(operating-system-boot-parameters-file): Likewise to the file with
the serialized structure.
* guix/scripts/system.scm (reinstall-bootloader): Use
boot-parameters-store-crypto-devices to provide its contents to the
bootloader configuration generation process.
* tests/boot-parameters.scm (%default-store-crypto-devices): New
variable.
(%grub-boot-parameters, test-read-boot-parameters): Use
%default-store-crypto-devices.
(tests store-crypto-devices): New tests.

1 files changed, 57 insertions, 2 deletions

diff --git a/gnu/system.scm b/gnu/system.scm
index fcf3310fa3..c284a18379 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -5,7 +5,7 @@
 ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2019 Meiyo Peng <meiyo.peng@gmail.com>
-;;; Copyright © 2019 Miguel Ángel Arruga Vivas <rosen644835@gmail.com>
+;;; Copyright © 2019, 2020 Miguel Ángel Arruga Vivas <rosen644835@gmail.com>
 ;;; Copyright © 2020 Danny Milosavljevic <dannym@scratchpost.org>
 ;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re>
 ;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
@@ -112,6 +112,7 @@
             operating-system-store-file-system
             operating-system-user-mapped-devices
             operating-system-boot-mapped-devices
+            operating-system-bootloader-crypto-devices
             operating-system-activation-script
             operating-system-user-accounts
             operating-system-shepherd-service-names
@@ -147,6 +148,7 @@
             boot-parameters-root-device
             boot-parameters-bootloader-name
             boot-parameters-bootloader-menu-entries
+            boot-parameters-store-crypto-devices
             boot-parameters-store-device
             boot-parameters-store-directory-prefix
             boot-parameters-store-mount-point
@@ -305,6 +307,8 @@ directly by the user."
   (store-device     boot-parameters-store-device)
   (store-mount-point boot-parameters-store-mount-point)
   (store-directory-prefix boot-parameters-store-directory-prefix)
+  (store-crypto-devices boot-parameters-store-crypto-devices
+                        (default '()))
   (locale           boot-parameters-locale)
   (kernel           boot-parameters-kernel)
   (kernel-arguments boot-parameters-kernel-arguments)
@@ -338,6 +342,13 @@ file system labels."
            (if (string-prefix? "/" device)
                device
                (file-system-label device))))))
+  (define uuid-sexp->uuid
+    (match-lambda
+      (('uuid (? symbol? type) (? bytevector? bv))
+       (bytevector->uuid bv type))
+      (x
+       (warning (G_ "unrecognized uuid ~a at '~a'~%") x (port-filename port))
+       #f)))
 
   (match (read port)
     (('boot-parameters ('version 0)
@@ -411,6 +422,23 @@ file system labels."
           ;; No store found, old format.
           #f)))
 
+      (store-crypto-devices
+       (match (assq 'store rest)
+         (('store . store-data)
+          (match (assq 'crypto-devices store-data)
+            (('crypto-devices (devices ...))
+             (map uuid-sexp->uuid devices))
+            (('crypto-devices dev)
+             (warning (G_ "unrecognized crypto-devices ~S at '~a'~%")
+                      dev (port-filename port))
+             '())
+            (_
+             ;; No crypto-devices found.
+             '())))
+         (_
+          ;; No store found, old format.
+          '())))
+
       (store-mount-point
        (match (assq 'store rest)
          (('store ('device _) ('mount-point mount-point) _ ...)
@@ -525,6 +553,26 @@ from the initrd."
                (any file-system-needed-for-boot? users)))
            devices)))
 
+(define (operating-system-bootloader-crypto-devices os)
+  "Return the subset of mapped devices that the bootloader must open.
+Only devices specified by uuid are supported."
+  (define (valid-crypto-device? dev)
+    (or (uuid? dev)
+        (begin
+          (warning (G_ "\
+mapped-device '~a' may not be mounted by the bootloader.~%")
+                   dev)
+          #f)))
+  (filter-map (match-lambda
+                ((and (= mapped-device-type type)
+                      (= mapped-device-source source))
+                 (and (eq? luks-device-mapping type)
+                      (valid-crypto-device? source)
+                      source))
+                (_ #f))
+              ;; XXX: Ordering is important, we trust the returned one.
+              (operating-system-boot-mapped-devices os)))
+
 (define (device-mapping-services os)
   "Return the list of device-mapping services for OS as a list."
   (map device-mapping-service
@@ -1261,6 +1309,7 @@ a list of <menu-entry>, to populate the \"old entries\" menu."
          (root-fs         (operating-system-root-file-system os))
          (root-device     (file-system-device root-fs))
          (locale          (operating-system-locale os))
+         (crypto-devices  (operating-system-bootloader-crypto-devices os))
          (params          (operating-system-boot-parameters
                            os root-device
                            #:system-kernel-arguments? #t))
@@ -1274,6 +1323,7 @@ a list of <menu-entry>, to populate the \"old entries\" menu."
     (generate-config-file bootloader-conf (list entry)
                           #:old-entries old-entries
                           #:locale locale
+                          #:store-crypto-devices crypto-devices
                           #:store-directory-prefix
 			  (btrfs-store-subvolume-file-name file-systems))))
 
@@ -1313,6 +1363,7 @@ such as '--root' and '--load' to <boot-parameters>."
                                (operating-system-initrd-file os)))
          (store           (operating-system-store-file-system os))
          (file-systems    (operating-system-file-systems os))
+         (crypto-devices  (operating-system-bootloader-crypto-devices os))
          (locale          (operating-system-locale os))
          (bootloader      (bootloader-configuration-bootloader
                            (operating-system-bootloader os)))
@@ -1335,6 +1386,7 @@ such as '--root' and '--load' to <boot-parameters>."
      (locale locale)
      (store-device (ensure-not-/dev (file-system-device store)))
      (store-directory-prefix (btrfs-store-subvolume-file-name file-systems))
+     (store-crypto-devices crypto-devices)
      (store-mount-point (file-system-mount-point store)))))
 
 (define (device->sexp device)
@@ -1393,7 +1445,10 @@ being stored into the \"parameters\" file)."
                       (mount-point #$(boot-parameters-store-mount-point
                                       params))
                       (directory-prefix
-                       #$(boot-parameters-store-directory-prefix params))))
+                       #$(boot-parameters-store-directory-prefix params))
+                      (crypto-devices
+                       #$(map device->sexp
+                              (boot-parameters-store-crypto-devices params)))))
                   #:set-load-path? #f)))
 
 (define-gexp-compiler (operating-system-compiler (os <operating-system>)