Merge remote-tracking branch 'origin/master' into core-updates

 Conflicts:
	doc/guix.texi
	gnu/local.mk
	gnu/packages/admin.scm
	gnu/packages/base.scm
	gnu/packages/chromium.scm
	gnu/packages/compression.scm
	gnu/packages/databases.scm
	gnu/packages/diffoscope.scm
	gnu/packages/freedesktop.scm
	gnu/packages/gnome.scm
	gnu/packages/gnupg.scm
	gnu/packages/guile.scm
	gnu/packages/inkscape.scm
	gnu/packages/llvm.scm
	gnu/packages/openldap.scm
	gnu/packages/pciutils.scm
	gnu/packages/ruby.scm
	gnu/packages/samba.scm
	gnu/packages/sqlite.scm
	gnu/packages/statistics.scm
	gnu/packages/syndication.scm
	gnu/packages/tex.scm
	gnu/packages/tls.scm
	gnu/packages/version-control.scm
	gnu/packages/xml.scm
	guix/build-system/copy.scm
	guix/scripts/home.scm

7 files changed, 282 insertions, 66 deletions

diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm
index 10c9045740..eea2233563 100644
--- a/gnu/build/activation.scm
+++ b/gnu/build/activation.scm
@@ -363,9 +363,14 @@ second element is the name it should appear at, such as:
   "Tell the kernel to look for device firmware under DIRECTORY.  This
 mechanism bypasses udev: it allows Linux to handle firmware loading directly
 by itself, without having to resort to a \"user helper\"."
-  (call-with-output-file "/sys/module/firmware_class/parameters/path"
-    (lambda (port)
-      (display directory port))))
+
+  ;; If the kernel was built without firmware loading support, this file
+  ;; does not exist.  Do nothing in that case.
+  (let ((firmware-path "/sys/module/firmware_class/parameters/path"))
+    (when (file-exists? firmware-path)
+      (call-with-output-file firmware-path
+        (lambda (port)
+          (display directory port))))))
 
 (define (activate-ptrace-attach)
   "Allow users to PTRACE_ATTACH their own processes.
diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index 0ed5dc5671..66ca22d6ea 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -899,6 +899,10 @@ caught and lead to a warning and #f as the result."
                  (format (current-error-port)
                          "warning: failed to read from device '~a'~%" device)
                  #f)
+                ((= EMEDIUMTYPE errno)            ;inaccessible, like DRBD secondaries
+                 (format (current-error-port)
+                         "warning: failed to open device '~a'~%" device)
+                 #f)
                 (else
                  (apply throw args))))))))
 
@@ -1123,7 +1127,7 @@ corresponds to the symbols listed in FLAGS."
       (('read-only rest ...)
        (logior MS_RDONLY (loop rest)))
       (('bind-mount rest ...)
-       (logior MS_BIND (loop rest)))
+       (logior MS_REC (logior MS_BIND (loop rest))))
       (('no-suid rest ...)
        (logior MS_NOSUID (loop rest)))
       (('no-dev rest ...)
@@ -1132,6 +1136,8 @@ corresponds to the symbols listed in FLAGS."
        (logior MS_NOEXEC (loop rest)))
       (('no-atime rest ...)
        (logior MS_NOATIME (loop rest)))
+      (('no-diratime rest ...)
+       (logior MS_NODIRATIME (loop rest)))
       (('strict-atime rest ...)
        (logior MS_STRICTATIME (loop rest)))
       (('lazy-time rest ...)
diff --git a/gnu/build/hurd-boot.scm b/gnu/build/hurd-boot.scm
index ad3c50d61e..abcf0304c2 100644
--- a/gnu/build/hurd-boot.scm
+++ b/gnu/build/hurd-boot.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020-2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -127,6 +127,9 @@ set."
 
 (define (translated? file-name)
   "Return true if a translator is installed on FILE-NAME."
+  ;; On GNU/Hurd, 'getxattr' in glibc opens the file without O_NOTRANS, and
+  ;; then, for "gnu.translator", it calls 'file_get_translator', resulting in
+  ;; EOPNOTSUPP (conversely, 'showtrans' opens the file with O_NOTRANS).
   (if (string-contains %host-type "linux-gnu")
       (passive-translator-xattr? file-name)
       (passive-translator-installed? file-name)))
@@ -191,7 +194,7 @@ set."
       ("proc"                    ("/hurd/procfs" "--stat-mode=444"))))
 
   (define devices
-    '(("dev/full"    ("/hurd/null"     "--full")            #o666)
+    `(("dev/full"    ("/hurd/null"     "--full")            #o666)
       ("dev/null"    ("/hurd/null")                         #o666)
       ("dev/random"  ("/hurd/random"   "--seed-file" "/var/lib/random-seed")
                                                             #o644)
@@ -210,31 +213,34 @@ set."
       ;; 'fd_to_filename' in libc expects it.
       ("dev/fd"      ("/hurd/magic"    "--directory" "fd")  #o555)
 
-      ("dev/tty1"    ("/hurd/term"     "/dev/tty1" "hurdio" "/dev/vcs/1/console")
-                                                            #o666)
-      ("dev/tty2"    ("/hurd/term"     "/dev/tty2" "hurdio" "/dev/vcs/2/console")
-                                                            #o666)
-      ("dev/tty3"    ("/hurd/term"     "/dev/tty3" "hurdio" "/dev/vcs/3/console")
-                                                            #o666)
-
-      ("dev/ptyp0"   ("/hurd/term"     "/dev/ptyp0" "pty-master" "/dev/ttyp0")
-                                                            #o666)
-      ("dev/ptyp1"   ("/hurd/term"     "/dev/ptyp1" "pty-master" "/dev/ttyp1")
-                                                            #o666)
-      ("dev/ptyp2"   ("/hurd/term"     "/dev/ptyp2" "pty-master" "/dev/ttyp2")
-                                                            #o666)
-
-      ("dev/ttyp0"   ("/hurd/term"     "/dev/ttyp0" "pty-slave" "/dev/ptyp0")
-                                                            #o666)
-      ("dev/ttyp1"   ("/hurd/term"     "/dev/ttyp1" "pty-slave" "/dev/ptyp1")
-                                                            #o666)
-      ("dev/ttyp2"   ("/hurd/term"     "/dev/ttyp2" "pty-slave" "/dev/ptyp2")
-                                                            #o666)))
+      ;; Create a number of ttys; syslogd writes to tty12 by default.
+      ;; FIXME: Creating /dev/tty12 leads the console client to switch to
+      ;; tty12 when syslogd starts, which is confusing for users.  Thus, do
+      ;; not create tty12.
+      ,@(map (lambda (n)
+               (let ((n (number->string n)))
+                 `(,(string-append "dev/tty" n)
+                   ("/hurd/term" ,(string-append "/dev/tty" n)
+                    "hurdio" ,(string-append "/dev/vcs/" n "/console"))
+                   #o666)))
+             (iota 11 1))
+
+      ,@(append-map (lambda (n)
+                      (let ((n (number->string n)))
+                        `((,(string-append "dev/ptyp" n)
+                           ("/hurd/term" ,(string-append "/dev/ptyp" n)
+                            "pty-master" ,(string-append "/dev/ttyp" n))
+                           #o666)
+
+                          (,(string-append "dev/ttyp" n)
+                           ("/hurd/term" ,(string-append "/dev/ttyp" n)
+                            "pty-slave" ,(string-append "/dev/ptyp" n))
+                           #o666))))
+                    (iota 10 0))))
 
   (for-each scope-set-translator servers)
   (mkdir* "dev/vcs/1")
   (mkdir* "dev/vcs/2")
-  (mkdir* "dev/vcs/2")
   (rename-file (scope "dev/console") (scope "dev/console-"))
   (for-each scope-set-translator devices)
 
diff --git a/gnu/build/image.scm b/gnu/build/image.scm
index 2327cfbb45..65a0373980 100644
--- a/gnu/build/image.scm
+++ b/gnu/build/image.scm
@@ -111,7 +111,10 @@ turn doesn't take any constant overhead into account, force a 1-MiB minimum."
                            (if (eq? size 'guess)
                                (estimate-partition-size root)
                                size))
-                    (if (member 'esp flags) (list "-S" "1024") '()))
+                    ;; u-boot in particular needs the formatted block
+                    ;; size and the physical block size to be equal.
+                    ;; TODO: What about 4k blocks?
+                    (if (member 'esp flags) (list "-S" "512") '()))
     (for-each (lambda (file)
                 (unless (member file '("." ".."))
                   (invoke "mcopy" "-bsp" "-i" target
diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index f5c8407b89..d4982650c1 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2020, 2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -56,19 +57,24 @@ that the fonts, background images, etc. referred to by BOOTCFG are not GC'd."
 (define* (evaluate-populate-directive directive target
                                       #:key
                                       (default-gid 0)
-                                      (default-uid 0))
+                                      (default-uid 0)
+                                      (error-on-dangling-symlink? #t))
   "Evaluate DIRECTIVE, an sexp describing a file or directory to create under
 directory TARGET.  DEFAULT-UID and DEFAULT-GID are the default UID and GID in
 the context of the caller.  If the directive matches those defaults then,
-'chown' won't be run."
+'chown' won't be run.  When ERROR-ON-DANGLING-SYMLINK? is true, abort with an
+error when a dangling symlink would be created."
+  (define target* (if (string-suffix? "/" target)
+                      target
+                      (string-append target "/")))
   (let loop ((directive directive))
     (catch 'system-error
       (lambda ()
         (match directive
           (('directory name)
-           (mkdir-p (string-append target name)))
+           (mkdir-p (string-append target* name)))
           (('directory name uid gid)
-           (let ((dir (string-append target name)))
+           (let ((dir (string-append target* name)))
              (mkdir-p dir)
              ;; If called from a context without "root" permissions, "chown"
              ;; to root will fail.  In that case, do not try to run "chown"
@@ -78,27 +84,38 @@ the context of the caller.  If the directive matches those defaults then,
                  (chown dir uid gid))))
           (('directory name uid gid mode)
            (loop `(directory ,name ,uid ,gid))
-           (chmod (string-append target name) mode))
+           (chmod (string-append target* name) mode))
           (('file name)
-           (call-with-output-file (string-append target name)
+           (call-with-output-file (string-append target* name)
              (const #t)))
           (('file name (? string? content))
-           (call-with-output-file (string-append target name)
+           (call-with-output-file (string-append target* name)
              (lambda (port)
                (display content port))))
           ((new '-> old)
-           (let try ()
-             (catch 'system-error
-               (lambda ()
-                 (symlink old (string-append target new)))
-               (lambda args
-                 ;; When doing 'guix system init' on the current '/', some
-                 ;; symlinks may already exists.  Override them.
-                 (if (= EEXIST (system-error-errno args))
-                     (begin
-                       (delete-file (string-append target new))
-                       (try))
-                     (apply throw args))))))))
+           (let ((new* (string-append target* new)))
+             (let try ()
+               (catch 'system-error
+                 (lambda ()
+                   (when error-on-dangling-symlink?
+                     ;; When the symbolic link points to a relative path,
+                     ;; checking if its target exists must be done relatively
+                     ;; to the link location.
+                     (unless (if (string-prefix? "/" old)
+                                 (file-exists? old)
+                                 (with-directory-excursion (dirname new*)
+                                   (file-exists? old)))
+                       (error (format #f "symlink `~a' points to nonexistent \
+file `~a'" new* old))))
+                   (symlink old new*))
+                 (lambda args
+                   ;; When doing 'guix system init' on the current '/', some
+                   ;; symlinks may already exists.  Override them.
+                   (if (= EEXIST (system-error-errno args))
+                       (begin
+                         (delete-file new*)
+                         (try))
+                       (apply throw args)))))))))
       (lambda args
         ;; Usually we can only get here when installing to an existing root,
         ;; as with 'guix system init foo.scm /'.
@@ -142,7 +159,10 @@ STORE."
 includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM.
 EXTRAS is a list of directives appended to the built-in directives to populate
 TARGET."
-  (for-each (cut evaluate-populate-directive <> target)
+  ;; It's expected that some symbolic link targets do not exist yet, so do not
+  ;; error on dangling links.
+  (for-each (cut evaluate-populate-directive <> target
+                 #:error-on-dangling-symlink? #f)
             (append (directives (%store-directory)) extras))
 
   ;; Add system generation 1.
@@ -262,12 +282,31 @@ disk."
     (mount "/.rw-store" (%store-directory) "" MS_MOVE)
     (rmdir "/.rw-store")))
 
+(define (umount* directory)
+  "Unmount DIRECTORY, but retry a few times upon EBUSY."
+  (let loop ((attempts 5))
+    (catch 'system-error
+      (lambda ()
+        (umount directory))
+      (lambda args
+        (if (and (= EBUSY (system-error-errno args))
+                 (> attempts 0))
+            (begin
+              (sleep 1)
+              (loop (- attempts 1)))
+            (apply throw args))))))
+
 (define (unmount-cow-store target backing-directory)
   "Unmount copy-on-write store."
   (let ((tmp-dir "/remove"))
     (mkdir-p tmp-dir)
     (mount (%store-directory) tmp-dir "" MS_MOVE)
-    (umount tmp-dir)
+
+    ;; We might get EBUSY at this point, possibly because of lingering
+    ;; processes with open file descriptors.  Use 'umount*' to retry upon
+    ;; EBUSY, leaving a bit of time.  See <https://issues.guix.gnu.org/59884>.
+    (umount* tmp-dir)
+
     (rmdir tmp-dir)
     (delete-file-recursively
      (string-append target backing-directory))))
diff --git a/gnu/build/linux-modules.scm b/gnu/build/linux-modules.scm
index 053720574b..3b1f512663 100644
--- a/gnu/build/linux-modules.scm
+++ b/gnu/build/linux-modules.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2016, 2018, 2019, 2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2018 Danny Milosavljevic <dannym@scratchpost.org>
 ;;;
@@ -28,6 +28,7 @@
   #:use-module (rnrs io ports)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 ftw)
@@ -50,6 +51,17 @@
             load-linux-module*
             load-linux-modules-from-directory
 
+            pci-devices
+            pci-device?
+            pci-device-vendor
+            pci-device-id
+            pci-device-class
+            pci-device-module-alias
+            storage-pci-device?
+            network-pci-device?
+            display-pci-device?
+            load-pci-device-database
+
             current-module-debugging-port
 
             device-module-aliases
@@ -429,6 +441,127 @@ key such as 'MAJOR or 'DEVTYPE and each cdr is the corresponding value."
       (line
        (loop (cons (key=value->pair line) result))))))
 
+;; PCI device known to the Linux kernel.
+(define-immutable-record-type <pci-device>
+  (pci-device vendor device class module-alias)
+  pci-device?
+  (vendor       pci-device-vendor)                ;integer
+  (device       pci-device-id)                    ;integer
+  (class        pci-device-class)                 ;integer
+  (module-alias pci-device-module-alias))         ;string | #f
+
+(define (pci-device-class-predicate mask bits)
+  (lambda (device)
+    "Return true if DEVICE has the chosen class."
+    (= (logand mask (pci-device-class device)) bits)))
+
+(define storage-pci-device?                   ;"Mass storage controller" class
+  (pci-device-class-predicate #xff0000 #x010000))
+(define network-pci-device?                       ;"Network controller" class
+  (pci-device-class-predicate #xff0000 #x020000))
+(define display-pci-device?                       ;"Display controller" class
+  (pci-device-class-predicate #xff0000 #x030000))
+
+(define (pci-devices)
+  "Return the list of PCI devices of the system (<pci-device> records)."
+  (define (read-hex port)
+    (let ((line (read-line port)))
+      (and (string? line)
+           (string-prefix? "0x" line)
+           (string->number (string-drop line 2) 16))))
+
+  (filter-map (lambda (directory)
+                (define properties
+                  (call-with-input-file (string-append directory "/uevent")
+                    read-uevent))
+                (define vendor
+                  (call-with-input-file (string-append directory "/vendor")
+                    read-hex))
+                (define device
+                  (call-with-input-file (string-append directory "/device")
+                    read-hex))
+                (define class
+                  (call-with-input-file (string-append directory "/class")
+                    read-hex))
+
+                (pci-device vendor device class
+                            (assq-ref properties 'MODALIAS)))
+              (find-files "/sys/bus/pci/devices"
+                          #:stat lstat)))
+
+(define (read-pci-device-database port)
+  "Parse the 'pci.ids' database that ships with the pciutils package and is
+maintained at <https://pci-ids.ucw.cz/>."
+  (define (comment? str)
+    (string-prefix? "#" (string-trim str)))
+  (define (blank? str)
+    (string-null? (string-trim-both str)))
+  (define (device? str)
+    (eqv? #\tab (string-ref str 0)))
+  (define (subvendor? str)
+    (string-prefix? "\t\t" str))
+  (define (class? str)
+    (string-prefix? "C " str))
+  (define (parse-id-line str)
+    (let* ((str   (string-trim-both str))
+           (space (string-index str char-set:whitespace)))
+      (values (string->number (string-take str space) 16)
+              (string-trim (string-drop str (+ 1 space))))))
+  (define (finish vendor vendor-id devices table)
+    (fold (lambda (device table)
+            (match device
+              ((device-id . name)
+               (vhash-consv (logior (ash vendor-id 16) device-id)
+                            (cons vendor name)
+                            table))))
+          table
+          devices))
+
+  (let loop ((table vlist-null)
+             (vendor-id #f)
+             (vendor #f)
+             (devices '()))
+    (match (read-line port)
+      ((? eof-object?)
+       (let ((table (if (and vendor vendor-id)
+                        (finish vendor vendor-id devices table)
+                        table)))
+         (lambda (vendor device)
+           (match (vhash-assv (logior (ash vendor 16) device) table)
+             (#f
+              (values #f #f))
+             ((_ . (vendor . name))
+              (values vendor name))))))
+      ((? comment?)
+       (loop table vendor-id vendor devices))
+      ((? blank?)
+       (loop table vendor-id vendor devices))
+      ((? subvendor?)                             ;currently ignored
+       (loop table vendor-id vendor devices))
+      ((? class?)                                 ;currently ignored
+       (loop table vendor-id vendor devices))
+      ((? device? line)
+       (let-values (((id name) (parse-id-line line)))
+         (loop table vendor-id vendor
+               (if (and vendor-id vendor)         ;class or device?
+                   (alist-cons id name devices)
+                   devices))))
+      (line
+       (let ((table (if (and vendor vendor-id)
+                        (finish vendor vendor-id devices table)
+                        table)))
+         (let-values (((vendor-id vendor) (parse-id-line line)))
+           (loop table vendor-id vendor '())))))))
+
+(define (load-pci-device-database file)
+  "Read the 'pci.ids' database at FILE (get it from the pciutils package or
+from <https://pci-ids.ucw.cz/>) and return a lookup procedure that takes a PCI
+vendor ID and a device ID (two integers) and returns the vendor name and
+device name as two values."
+  (let ((port (open-file file "r0")))
+    (call-with-gzip-input-port port
+      read-pci-device-database)))
+
 (define (device-module-aliases device)
   "Return the list of module aliases required by DEVICE, a /dev file name, as
 in this example:
diff --git a/gnu/build/marionette.scm b/gnu/build/marionette.scm
index 5ebf783892..b8fba61d06 100644
--- a/gnu/build/marionette.scm
+++ b/gnu/build/marionette.scm
@@ -22,18 +22,19 @@
   #: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)
   #:use-module (ice-9 regex)
   #:export (marionette?
+            marionette-pid
             make-marionette
             marionette-eval
             wait-for-file
             wait-for-tcp-port
             wait-for-unix-socket
             marionette-control
-            marionette-screen-text
             wait-for-screen-text
             %qwerty-us-keystrokes
             marionette-type
@@ -312,40 +313,61 @@ 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
                                #:key
                                (ocr "ocrad")
-                               (timeout 30))
+                               (timeout 30)
+                               pre-action
+                               post-action)
   "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.  If
+PRE-ACTION is provided, it should be a thunk to call before each OCR attempt.
+Likewise for POST-ACTION, except it runs at the end of a successful OCR."
   (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* ((_ (and (procedure? pre-action) (pre-action)))
+               (text screendump (marionette-screen-text marionette #:ocr ocr))
+               (_ (and (procedure? post-action) (post-action)))
+               (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.
@@ -367,8 +389,10 @@ PREDICATE, whichever comes first.  Raise an error when TIMEOUT is exceeded."
     (#\> . "shift-dot")
     (#\. . "dot")
     (#\, . "comma")
+    (#\: . "shift-semicolon")
     (#\; . "semicolon")
     (#\' . "apostrophe")
+    (#\! . "shift-1")
     (#\" . "shift-apostrophe")
     (#\` . "grave_accent")
     (#\bs . "backspace")