04/05: install: Enable "cryptodisk" handling in GRUB.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit f7f292d359e0eb77617f4ecf6b3164f868ec1784
Author: Ludovic Courtès <address@hidden>
Date:   Wed Nov 23 20:59:13 2016 +0100

    install: Enable "cryptodisk" handling in GRUB.
    
    This allows 'grub-install' to do the right thing when / or /boot is a
    LUKS-encrypted partition.
    
    Fixes <http://bugs.gnu.org/21843>.
    
    * gnu/build/install.scm (install-grub): Add 'setenv' to set
    'GRUB_ENABLE_CRYPTODISK'.
    (wait-for-screen-text): New test.
    * gnu/tests/base.scm (run-basic-test): Add #:initialization parameter
    and honor it.
    * gnu/tests/install.scm (%encrypted-root-os)[kernel-arguments]: Remove.
    (%encrypted-root-installation-script): Pass '--uuid' to 'cryptsetup
    luksFormat'.  Remove 'sed' invocation.
    (enter-luks-passphrase): New procedure.
    (%test-encrypted-os)[value]: Pass #:initialization to 'run-basic-test'.
---
 gnu/build/install.scm    |    5 ++++
 gnu/build/marionette.scm |   19 +++++++++++++
 gnu/tests/base.scm       |   13 +++++++--
 gnu/tests/install.scm    |   66 ++++++++++++++++++++++++++++++++++++++--------
 4 files changed, 90 insertions(+), 13 deletions(-)

diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index 3d1594e..5c2b356 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -46,6 +46,11 @@ Note that the caller must make sure that GRUB.CFG is 
registered as a GC root
 so that the fonts, background images, etc. referred to by GRUB.CFG are not
 GC'd."
   (install-grub-config grub.cfg mount-point)
+
+  ;; Tell 'grub-install' that there might be a LUKS-encrypted /boot or root
+  ;; partition.
+  (setenv "GRUB_ENABLE_CRYPTODISK" "y")
+
   (unless (zero? (system* "grub-install" "--no-floppy"
                           "--boot-directory"
                           (string-append mount-point "/boot")
diff --git a/gnu/build/marionette.scm b/gnu/build/marionette.scm
index 8070b6b..506d6da 100644
--- a/gnu/build/marionette.scm
+++ b/gnu/build/marionette.scm
@@ -27,6 +27,7 @@
             marionette-eval
             marionette-control
             marionette-screen-text
+            wait-for-screen-text
             %qwerty-us-keystrokes
             marionette-type))
 
@@ -204,6 +205,24 @@ this by invoking OCRAD (file name for GNU Ocrad's command)"
       (lambda ()
         (false-if-exception (delete-file image))))))
 
+(define* (wait-for-screen-text marionette predicate
+                               #:key (timeout 30) (ocrad "ocrad"))
+  "Wait for TIMEOUT seconds or until the screen text on MARIONETTE matches
+PREDICATE, whichever comes first.  Raise an error when TIMEOUT is exceeded."
+  (define start
+    (car (gettimeofday)))
+
+  (define end
+    (+ start timeout))
+
+  (let loop ()
+    (if (> (car (gettimeofday)) end)
+        (error "'wait-for-screen-text' timeout" predicate)
+        (or (predicate (marionette-screen-text marionette #:ocrad ocrad))
+            (begin
+              (sleep 1)
+              (loop))))))
+
 (define %qwerty-us-keystrokes
   ;; Maps "special" characters to their keystrokes.
   '((#\newline . "ret")
diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm
index 3be1c55..86242d9 100644
--- a/gnu/tests/base.scm
+++ b/gnu/tests/base.scm
@@ -67,10 +67,16 @@
                  %base-user-accounts))))
 
 
-(define* (run-basic-test os command #:optional (name "basic"))
+(define* (run-basic-test os command #:optional (name "basic")
+                         #:key initialization)
   "Return a derivation called NAME that tests basic features of the OS started
 using COMMAND, a gexp that evaluates to a list of strings.  Compare some
-properties of running system to what's declared in OS, an <operating-system>."
+properties of running system to what's declared in OS, an <operating-system>.
+
+When INITIALIZATION is true, it must be a one-argument procedure that is
+passed a gexp denoting the marionette, and it must return gexp that is
+inserted before the first test.  This is used to introduce an extra
+initialization step, such as entering a LUKS passphrase."
   (define test
     (with-imported-modules '((gnu build marionette))
       #~(begin
@@ -88,6 +94,9 @@ properties of running system to what's declared in OS, an 
<operating-system>."
 
           (test-begin "basic")
 
+          #$(and initialization
+                 (initialization #~marionette))
+
           (test-assert "uname"
             (match (marionette-eval '(uname) marionette)
               (#("Linux" host-name version _ architecture)
diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm
index 98f8649..ecf1ac1 100644
--- a/gnu/tests/install.scm
+++ b/gnu/tests/install.scm
@@ -24,6 +24,7 @@
   #:use-module (gnu system install)
   #:use-module (gnu system vm)
   #:use-module ((gnu build vm) #:select (qemu-command))
+  #:use-module (gnu packages ocr)
   #:use-module (gnu packages qemu)
   #:use-module (gnu packages package-management)
   #:use-module (guix store)
@@ -398,17 +399,20 @@ by 'mdadm'.")
     (locale "en_US.UTF-8")
 
     (bootloader (grub-configuration (device "/dev/vdb")))
-    (kernel-arguments '("console=ttyS0"))
+
+    ;; Note: Do not pass "console=ttyS0" so we can use our passphrase prompt
+    ;; detection logic in 'enter-luks-passphrase'.
+
+    (mapped-devices (list (mapped-device
+                           (source (uuid 
"12345678-1234-1234-1234-123456789abc"))
+                           (target "the-root-device")
+                           (type luks-device-mapping))))
     (file-systems (cons (file-system
                           (device "/dev/mapper/the-root-device")
                           (title 'device)
                           (mount-point "/")
                           (type "ext4"))
                         %base-file-systems))
-    (mapped-devices (list (mapped-device
-                           (source "REPLACE-WITH-LUKS-UUID")
-                           (target "the-root-device")
-                           (type luks-device-mapping))))
     (users (cons (user-account
                   (name "charlie")
                   (group "users")
@@ -435,7 +439,8 @@ parted --script /dev/vdb mklabel gpt \\
   mkpart primary ext2 3M 1G \\
   set 1 boot on \\
   set 1 bios_grub on
-echo -n thepassphrase | cryptsetup luksFormat -q /dev/vdb2 -
+echo -n thepassphrase | \\
+  cryptsetup luksFormat --uuid=12345678-1234-1234-1234-123456789abc -q 
/dev/vdb2 -
 echo -n thepassphrase | \\
   cryptsetup open --type luks --key-file - /dev/vdb2 the-root-device
 mkfs.ext4 -L my-root /dev/mapper/the-root-device
@@ -443,15 +448,53 @@ mount LABEL=my-root /mnt
 herd start cow-store /mnt
 mkdir /mnt/etc
 cp /etc/target-config.scm /mnt/etc/config.scm
-cat /mnt/etc/config
-luks_uuid=`cryptsetup luksUUID /dev/vdb2`
-sed -i /mnt/etc/config.scm \\
-    -e \"s/\\\"REPLACE-WITH-LUKS-UUID\\\"/(uuid \\\"$luks_uuid\\\")/g\"
 guix system build /mnt/etc/config.scm
 guix system init /mnt/etc/config.scm /mnt --no-substitutes
 sync
 reboot\n")
 
+(define (enter-luks-passphrase marionette)
+  "Return a gexp to be inserted in the basic system test running on MARIONETTE
+to enter the LUKS passphrase."
+  (let ((ocrad (file-append ocrad "/bin/ocrad")))
+    #~(begin
+        (define (passphrase-prompt? text)
+          (string-contains (pk 'screen-text text) "Enter pass"))
+
+        (define (bios-boot-screen? text)
+          ;; Return true if TEXT corresponds to the boot screen, before GRUB's
+          ;; menu.
+          (string-prefix? "SeaBIOS" text))
+
+        (test-assert "enter LUKS passphrase for GRUB"
+          (begin
+            ;; At this point we have no choice but to use OCR to determine
+            ;; when the passphrase should be entered.
+            (wait-for-screen-text #$marionette passphrase-prompt?
+                                  #:ocrad #$ocrad)
+            (marionette-type "thepassphrase\n" #$marionette)
+
+            ;; Now wait until we leave the boot screen.  This is necessary so
+            ;; we can then be sure we match the "Enter passphrase" prompt from
+            ;; 'cryptsetup', in the initrd.
+            (wait-for-screen-text #$marionette (negate bios-boot-screen?)
+                                  #:ocrad #$ocrad
+                                  #:timeout 20)))
+
+        (test-assert "enter LUKS passphrase for the initrd"
+          (begin
+            ;; XXX: Here we use OCR as well but we could instead use QEMU
+            ;; '-serial stdio' and run it in an input pipe,
+            (wait-for-screen-text #$marionette passphrase-prompt?
+                                  #:ocrad #$ocrad
+                                  #:timeout 60)
+            (marionette-type "thepassphrase\n" #$marionette)
+
+            ;; Take a screenshot for debugging purposes.
+            (marionette-control (string-append "screendump " #$output
+                                               "/post-initrd-passphrase.ppm")
+                                #$marionette))))))
+
 (define %test-encrypted-os
   (system-test
    (name "encrypted-root-os")
@@ -465,6 +508,7 @@ build (current-guix) and then store a couple of full system 
images.")
                                                #:script
                                                
%encrypted-root-installation-script))
                          (command (qemu-command/writable-image image)))
-      (run-basic-test %encrypted-root-os command "encrypted-root-os")))))
+      (run-basic-test %encrypted-root-os command "encrypted-root-os"
+                      #:initialization enter-luks-passphrase)))))
 
 ;;; install.scm ends here