Merge branch 'master' into staging

4 files changed, 112 insertions, 23 deletions

diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index 0d55e91978..431b287d0c 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -464,6 +464,27 @@ form:
 DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f;
 FLAGS must be a list of symbols.  CHECK? is a Boolean indicating whether to
 run a file system check."
+
+  (define (mount-nfs source mount-point type flags options)
+    (let* ((idx (string-rindex source #\:))
+           (host-part (string-take source idx))
+           ;; Strip [] from around host if present
+           (host (match (string-split host-part (string->char-set "[]"))
+                 (("" h "") h)
+                 ((h) h)))
+           (aa (match (getaddrinfo host "nfs") ((x . _) x)))
+           (sa (addrinfo:addr aa))
+           (inet-addr (inet-ntop (sockaddr:fam sa)
+                                 (sockaddr:addr sa))))
+
+      ;; Mounting an NFS file system requires passing the address
+      ;; of the server in the addr= option
+      (mount source mount-point type flags
+             (string-append "addr="
+                            inet-addr
+                            (if options
+                                (string-append "," options)
+                                "")))))
   (match spec
     ((source title mount-point type (flags ...) options check?)
      (let ((source      (canonicalize-device-spec source title))
@@ -481,7 +502,11 @@ run a file system check."
              (call-with-output-file mount-point (const #t)))
            (mkdir-p mount-point))
 
-       (mount source mount-point type flags options)
+       (cond
+        ((string-prefix? "nfs" type)
+         (mount-nfs source mount-point type flags options))
+        (else
+         (mount source mount-point type flags options)))
 
        ;; For read-only bind mounts, an extra remount is needed, as per
        ;; <http://lwn.net/Articles/281157/>, which still applies to Linux 4.0.
diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index 3d1594e203..5c2b35632d 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 d36e1c8d09..506d6da420 100644
--- a/gnu/build/marionette.scm
+++ b/gnu/build/marionette.scm
@@ -21,10 +21,13 @@
   #:use-module (srfi srfi-26)
   #:use-module (rnrs io ports)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 popen)
   #:export (marionette?
             make-marionette
             marionette-eval
             marionette-control
+            marionette-screen-text
+            wait-for-screen-text
             %qwerty-us-keystrokes
             marionette-type))
 
@@ -45,7 +48,10 @@
   (command    marionette-command)                 ;list of strings
   (pid        marionette-pid)                     ;integer
   (monitor    marionette-monitor)                 ;port
-  (repl       marionette-repl))                   ;port
+  (repl       %marionette-repl))                  ;promise of a port
+
+(define-syntax-rule (marionette-repl marionette)
+  (force (%marionette-repl marionette)))
 
 (define* (wait-for-monitor-prompt port #:key (quiet? #t))
   "Read from PORT until we have seen all of QEMU's monitor prompt.  When
@@ -131,21 +137,29 @@ QEMU monitor and to the guest's backdoor REPL."
           (close-port monitor)
           (wait-for-monitor-prompt monitor-conn)
           (display "read QEMU monitor prompt\n")
-          (match (accept* repl)
-            ((repl-conn . addr)
-             (display "connected to guest REPL\n")
-             (close-port repl)
-             (match (read repl-conn)
-               ('ready
-                (alarm 0)
-                (display "marionette is ready\n")
-                (marionette (append command extra-options) pid
-                            monitor-conn repl-conn)))))))))))
+
+          (marionette (append command extra-options) pid
+                      monitor-conn
+
+                      ;; The following 'accept' call connects immediately, but
+                      ;; we don't know whether the guest has connected until
+                      ;; we actually receive the 'ready' message.
+                      (match (accept* repl)
+                        ((repl-conn . addr)
+                         (display "connected to guest REPL\n")
+                         (close-port repl)
+                         ;; Delay reception of the 'ready' message so that the
+                         ;; caller can already send monitor commands.
+                         (delay
+                           (match (read repl-conn)
+                             ('ready
+                              (display "marionette is ready\n")
+                              repl-conn))))))))))))
 
 (define (marionette-eval exp marionette)
   "Evaluate EXP in MARIONETTE's backdoor REPL.  Return the result."
   (match marionette
-    (($ <marionette> command pid monitor repl)
+    (($ <marionette> command pid monitor (= force repl))
      (write exp repl)
      (newline repl)
      (read repl))))
@@ -160,6 +174,55 @@ pcsys_monitor\")."
      (newline monitor)
      (wait-for-monitor-prompt monitor))))
 
+(define* (marionette-screen-text marionette
+                                 #:key
+                                 (ocrad "ocrad"))
+  "Take a screenshot of MARIONETTE, perform optical character
+recognition (OCR), and return the text read from the screen as a string.  Do
+this by invoking OCRAD (file name for GNU Ocrad's command)"
+  (define (random-file-name)
+    (string-append "/tmp/marionette-screenshot-"
+                   (number->string (random (expt 2 32)) 16)
+                   ".ppm"))
+
+  (let ((image (random-file-name)))
+    (dynamic-wind
+      (const #t)
+      (lambda ()
+        (marionette-control (string-append "screendump " image)
+                            marionette)
+
+        ;; Tell Ocrad to invert the image colors (make it black on white) and
+        ;; to scale the image up, which significantly improves the quality of
+        ;; the result.  In spite of this, be aware that OCR confuses "y" and
+        ;; "V" and sometimes erroneously introduces white space.
+        (let* ((pipe (open-pipe* OPEN_READ ocrad
+                                 "-i" "-s" "10" image))
+               (text (get-string-all pipe)))
+          (unless (zero? (close-pipe pipe))
+            (error "'ocrad' failed" ocrad))
+          text))
+      (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/build/vm.scm b/gnu/build/vm.scm
index cc5cf45362..60ee18ebe0 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -79,12 +79,9 @@ it via /dev/hda.
 
 REFERENCES-GRAPHS can specify a list of reference-graph files as produced by
 the #:references-graphs parameter of 'derivation'."
-  (define image-file
-    (string-append "image." disk-image-format))
-
   (when make-disk-image?
     (unless (zero? (system* "qemu-img" "create" "-f" disk-image-format
-                            image-file
+                            output
                             (number->string disk-image-size)))
       (error "qemu-img failed")))
 
@@ -115,7 +112,7 @@ the #:references-graphs parameter of 'derivation'."
                                            builder)
                   (append
                    (if make-disk-image?
-                       `("-drive" ,(string-append "file=" image-file
+                       `("-drive" ,(string-append "file=" output
                                                   ",if=virtio"))
                        '())
                    ;; Only enable kvm if we see /dev/kvm exists.
@@ -126,11 +123,10 @@ the #:references-graphs parameter of 'derivation'."
                        '()))))
     (error "qemu failed" qemu))
 
-  (if make-disk-image?
-      (copy-file image-file output)
-      (begin
-        (mkdir output)
-        (copy-recursively "xchg" output))))
+  ;; When MAKE-DISK-IMAGE? is true, the image is in OUTPUT already.
+  (unless make-disk-image?
+    (mkdir output)
+    (copy-recursively "xchg" output)))
 
 
 ;;;