From 4cce84b247b3a7fa2bfd52e49d4ff8e73b78481f Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Date: Mon, 19 Sep 2022 22:06:54 -0400
Subject: marionette: Preserve screen dumps on failures.

This is to make it easier to debug test failures involving
'wait-for-screen-text': the screendump image used for the OCR is now preserved
for inspection when 'wait-for-screen-text' fails.

* gnu/build/marionette.scm (marionette-screen-text): Return the screendump
image file as the second value.  Adjust doc.
(wait-for-screen-text): Add the preserved screendump image file name to the
error message.  Adjust doc.
---
 gnu/build/marionette.scm | 42 +++++++++++++++++++++++++++++-------------
 1 file changed, 29 insertions(+), 13 deletions(-)

(limited to 'gnu/build')

diff --git a/gnu/build/marionette.scm b/gnu/build/marionette.scm
index aba6fb8146..5f8a74717a 100644
--- a/gnu/build/marionette.scm
+++ b/gnu/build/marionette.scm
@@ -22,6 +22,7 @@
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-64)
+  #:use-module (srfi srfi-71)
   #:use-module (rnrs io ports)
   #:use-module (ice-9 match)
   #:use-module (ice-9 popen)
@@ -311,18 +312,20 @@ Monitor\")."
 
 (define* (marionette-screen-text marionette #:key (ocr "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 OCR, which should be the file name of GNU Ocrad's
-@command{ocrad} or Tesseract OCR's @command{tesseract} command."
+recognition (OCR), and return the text read from the screen as a string, along
+the screen dump image used.  Do this by invoking OCR, which should be the file
+name of GNU Ocrad's@command{ocrad} or Tesseract OCR's @command{tesseract}
+command.  The screen dump image returned as the second value should be deleted
+if it is not needed."
   (define image (string-append (tmpnam) ".ppm"))
   ;; Use the QEMU Monitor to save an image of the screen to the host.
   (marionette-control (string-append "screendump " image) marionette)
   ;; Process it via the OCR.
   (cond
    ((string-contains ocr "ocrad")
-    (invoke-ocrad-ocr image #:ocrad ocr))
+    (values (invoke-ocrad-ocr image #:ocrad ocr) image))
    ((string-contains ocr "tesseract")
-    (invoke-tesseract-ocr image #:tesseract ocr))
+    (values (invoke-tesseract-ocr image #:tesseract ocr) image))
    (else (error "unsupported ocr command"))))
 
 (define* (wait-for-screen-text marionette predicate
@@ -330,21 +333,34 @@ this by invoking OCR, which should be the file name of GNU Ocrad's
                                (ocr "ocrad")
                                (timeout 30))
   "Wait for TIMEOUT seconds or until the screen text on MARIONETTE matches
-PREDICATE, whichever comes first.  Raise an error when TIMEOUT is exceeded."
+PREDICATE, whichever comes first.  Raise an error when TIMEOUT is exceeded.
+The error contains the recognized text along the preserved file name of the
+screen dump, which is relative to the current working directory."
   (define start
     (car (gettimeofday)))
 
   (define end
     (+ start timeout))
 
-  (let loop ((last-text #f))
+  (let loop ((last-text #f)
+             (last-screendump #f))
     (if (> (car (gettimeofday)) end)
-        (error "'wait-for-screen-text' timeout" 'ocr-text: last-text)
-        (let ((text (marionette-screen-text marionette #:ocr ocr)))
-          (or (predicate text)
-              (begin
-                (sleep 1)
-                (loop text)))))))
+        (let ((screendump-backup (string-drop last-screendump 5)))
+          ;; Move the file from /tmp/fileXXXXXX.pmm to the current working
+          ;; directory, so that it is preserved in the test derivation output.
+          (copy-file last-screendump screendump-backup)
+          (delete-file last-screendump)
+          (error "'wait-for-screen-text' timeout"
+                 'ocr-text: last-text
+                 'screendump: screendump-backup))
+        (let* ((text screendump (marionette-screen-text marionette #:ocr ocr))
+               (result (predicate text)))
+          (cond (result
+                 (delete-file screendump)
+                 result)
+                (else
+                 (sleep 1)
+                 (loop text screendump)))))))
 
 (define %qwerty-us-keystrokes
   ;; Maps "special" characters to their keystrokes.
-- 
cgit v1.2.3