;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
#: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
+ wait-for-file
marionette-control
+ marionette-screen-text
+ wait-for-screen-text
%qwerty-us-keystrokes
marionette-type))
(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
"-monitor" (string-append "unix:" socket-directory "/monitor")
"-chardev" (string-append "socket,id=repl,path=" socket-directory
"/repl")
+
+ ;; See
+ ;; <http://www.linux-kvm.org/page/VMchannel_Requirements#Invocation>.
"-device" "virtio-serial"
- "-device" "virtconsole,chardev=repl"))
+ "-device" "virtserialport,chardev=repl,name=org.gnu.guix.port.0"))
+
+ (define (accept* port)
+ (match (select (list port) '() (list port) timeout)
+ (((port) () ())
+ (accept port))
+ (_
+ (error "timeout in 'accept'" port))))
(let ((monitor (socket AF_UNIX SOCK_STREAM 0))
(repl (socket AF_UNIX SOCK_STREAM 0)))
(primitive-exit 1))))
(pid
(format #t "QEMU runs as PID ~a~%" pid)
- (sigaction SIGALRM
- (lambda (signum)
- (display "time is up!\n") ;FIXME: break
- #t))
- (alarm timeout)
- (match (accept monitor)
+ (match (accept* monitor)
((monitor-conn . _)
(display "connected to QEMU's monitor\n")
(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)
- (sigaction SIGALRM SIG_DFL)
- (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))))
+(define* (wait-for-file file marionette
+ #:key (timeout 10) (read 'read))
+ "Wait until FILE exists in MARIONETTE; READ its content and return it. If
+FILE has not shown up after TIMEOUT seconds, raise an error."
+ (match (marionette-eval
+ `(let loop ((i ,timeout))
+ (cond ((file-exists? ,file)
+ (cons 'success (call-with-input-file ,file ,read)))
+ ((> i 0)
+ (sleep 1)
+ (loop (- i 1)))
+ (else
+ 'failure)))
+ marionette)
+ (('success . result)
+ result)
+ ('failure
+ (error "file didn't show up" file))))
+
(define (marionette-control command marionette)
"Run COMMAND in the QEMU monitor of MARIONETTE. COMMAND is a string such as
\"sendkey ctrl-alt-f1\" or \"screendump foo.ppm\" (info \"(qemu-doc)
(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")
(#\. . "dot")
(#\, . "comma")
(#\; . "semicolon")
+ (#\' . "apostrophe")
+ (#\" . "shift-apostrophe")
+ (#\` . "grave_accent")
(#\bs . "backspace")
(#\tab . "tab")))
+(define (character->keystroke chr keystrokes)
+ "Return the keystroke for CHR according to the keyboard layout defined by
+KEYSTROKES."
+ (if (char-set-contains? char-set:upper-case chr)
+ (string-append "shift-" (string (char-downcase chr)))
+ (or (assoc-ref keystrokes chr)
+ (string chr))))
+
(define* (string->keystroke-commands str
#:optional
(keystrokes
to STR. KEYSTROKES is an alist specifying a mapping from characters to
keystrokes."
(string-fold-right (lambda (chr result)
- (cons (string-append "sendkey "
- (or (assoc-ref keystrokes chr)
- (string chr)))
+ (cons (string-append
+ "sendkey "
+ (character->keystroke chr keystrokes))
result))
'()
str))
HCoop / jackhill / guix / guix.git / blobdiff