02/05: marionette: Add 'marionette-screen-text' using OCR.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit fe933833504c90eb40b0d2c71847675b31c142b4
Author: Ludovic Courtès <address@hidden>
Date:   Wed Nov 23 13:56:42 2016 +0100

    marionette: Add 'marionette-screen-text' using OCR.
    
    * gnu/build/marionette.scm (marionette-screen-text): New procedure.
    * gnu/tests/base.scm (run-basic-test)["screen text"]: New test.
---
 gnu/build/marionette.scm |   33 +++++++++++++++++++++++++++++++++
 gnu/tests/base.scm       |   16 ++++++++++++++++
 2 files changed, 49 insertions(+)

diff --git a/gnu/build/marionette.scm b/gnu/build/marionette.scm
index 70b737f..8070b6b 100644
--- a/gnu/build/marionette.scm
+++ b/gnu/build/marionette.scm
@@ -21,10 +21,12 @@
   #: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
             %qwerty-us-keystrokes
             marionette-type))
 
@@ -171,6 +173,37 @@ 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 %qwerty-us-keystrokes
   ;; Maps "special" characters to their keystrokes.
   '((#\newline . "ret")
diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm
index 9a26530..3be1c55 100644
--- a/gnu/tests/base.scm
+++ b/gnu/tests/base.scm
@@ -31,6 +31,8 @@
   #:use-module (gnu services mcron)
   #:use-module (gnu services shepherd)
   #:use-module (gnu services networking)
+  #:use-module (gnu packages imagemagick)
+  #:use-module (gnu packages ocr)
   #:use-module (guix gexp)
   #:use-module (guix store)
   #:use-module (guix monads)
@@ -241,6 +243,20 @@ info --version")
                                   marionette)
               (file-exists? "tty1.ppm")))
 
+          (test-assert "screen text"
+            (let ((text (marionette-screen-text marionette
+                                                #:ocrad
+                                                #$(file-append ocrad
+                                                               "/bin/ocrad"))))
+              ;; Check whether the welcome message and shell prompt are
+              ;; displayed.  Note: OCR confuses "y" and "V" for instance, so
+              ;; we cannot reliably match the whole text.
+              (and (string-contains text "This is the GNU")
+                   (string-contains text
+                                    (string-append
+                                     "root@"
+                                     #$(operating-system-host-name os))))))
+
           (test-end)
           (exit (= (test-runner-fail-count (test-runner-current)) 0)))))