gnu/build/marionette.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (gnu build marionette)
  20   #:use-module (srfi srfi-9)
  21   #:use-module (srfi srfi-26)
  22   #:use-module (rnrs io ports)
  23   #:use-module (ice-9 match)
  24   #:use-module (ice-9 popen)
  25   #:export (marionette?
  26             make-marionette
  27             marionette-eval
  28             marionette-control
  29             marionette-screen-text
  30             wait-for-screen-text
  31             %qwerty-us-keystrokes
  32             marionette-type))
  33
  34 ;;; Commentary:
  35 ;;;
  36 ;;; Instrumentation tools for QEMU virtual machines (VMs).  A "marionette" is
  37 ;;; essentially a VM (a QEMU instance) with its monitor connected to a
  38 ;;; Unix-domain socket, and with a REPL inside the guest listening on a
  39 ;;; virtual console, which is itself connected to the host via a Unix-domain
  40 ;;; socket--these are the marionette's strings, connecting it to the almighty
  41 ;;; puppeteer.
  42 ;;;
  43 ;;; Code:
  44
  45 (define-record-type <marionette>
  46   (marionette command pid monitor repl)
  47   marionette?
  48   (command    marionette-command)                 ;list of strings
  49   (pid        marionette-pid)                     ;integer
  50   (monitor    marionette-monitor)                 ;port
  51   (repl       %marionette-repl))                  ;promise of a port
  52
  53 (define-syntax-rule (marionette-repl marionette)
  54   (force (%marionette-repl marionette)))
  55
  56 (define* (wait-for-monitor-prompt port #:key (quiet? #t))
  57   "Read from PORT until we have seen all of QEMU's monitor prompt.  When
  58 QUIET? is false, the monitor's output is written to the current output port."
  59   (define full-prompt
  60     (string->list "(qemu) "))
  61
  62   (let loop ((prompt full-prompt)
  63              (matches '())
  64              (prefix  '()))
  65     (match prompt
  66       (()
  67        ;; It's useful to set QUIET? so we don't display the echo of our own
  68        ;; commands.
  69        (unless quiet?
  70          (for-each (lambda (line)
  71                      (format #t "qemu monitor: ~a~%" line))
  72                    (string-tokenize (list->string (reverse prefix))
  73                                     (char-set-complement (char-set #\newline))))))
  74       ((chr rest ...)
  75        (let ((read (read-char port)))
  76          (cond ((eqv? read chr)
  77                 (loop rest (cons read matches) prefix))
  78                ((eof-object? read)
  79                 (error "EOF while waiting for QEMU monitor prompt"
  80                        (list->string (reverse prefix))))
  81                (else
  82                 (loop full-prompt
  83                       '()
  84                       (cons read (append matches prefix))))))))))
  85
  86 (define* (make-marionette command
  87                           #:key (socket-directory "/tmp") (timeout 20))
  88   "Return a QEMU marionette--i.e., a virtual machine with open connections to the
  89 QEMU monitor and to the guest's backdoor REPL."
  90   (define (file->sockaddr file)
  91     (make-socket-address AF_UNIX
  92                          (string-append socket-directory "/" file)))
  93
  94   (define extra-options
  95     (list "-nographic"
  96           "-monitor" (string-append "unix:" socket-directory "/monitor")
  97           "-chardev" (string-append "socket,id=repl,path=" socket-directory
  98                                     "/repl")
  99           "-device" "virtio-serial"
 100           "-device" "virtconsole,chardev=repl"))
 101
 102   (define (accept* port)
 103     (match (select (list port) '() (list port) timeout)
 104       (((port) () ())
 105        (accept port))
 106       (_
 107        (error "timeout in 'accept'" port))))
 108
 109   (let ((monitor (socket AF_UNIX SOCK_STREAM 0))
 110         (repl    (socket AF_UNIX SOCK_STREAM 0)))
 111     (bind monitor (file->sockaddr "monitor"))
 112     (listen monitor 1)
 113     (bind repl (file->sockaddr "repl"))
 114     (listen repl 1)
 115
 116     (match (primitive-fork)
 117       (0
 118        (catch #t
 119          (lambda ()
 120            (close monitor)
 121            (close repl)
 122            (match command
 123              ((program . args)
 124               (apply execl program program
 125                      (append args extra-options)))))
 126          (lambda (key . args)
 127            (print-exception (current-error-port)
 128                             (stack-ref (make-stack #t) 1)
 129                             key args)
 130            (primitive-exit 1))))
 131       (pid
 132        (format #t "QEMU runs as PID ~a~%" pid)
 133
 134        (match (accept* monitor)
 135          ((monitor-conn . _)
 136           (display "connected to QEMU's monitor\n")
 137           (close-port monitor)
 138           (wait-for-monitor-prompt monitor-conn)
 139           (display "read QEMU monitor prompt\n")
 140
 141           (marionette (append command extra-options) pid
 142                       monitor-conn
 143
 144                       ;; The following 'accept' call connects immediately, but
 145                       ;; we don't know whether the guest has connected until
 146                       ;; we actually receive the 'ready' message.
 147                       (match (accept* repl)
 148                         ((repl-conn . addr)
 149                          (display "connected to guest REPL\n")
 150                          (close-port repl)
 151                          ;; Delay reception of the 'ready' message so that the
 152                          ;; caller can already send monitor commands.
 153                          (delay
 154                            (match (read repl-conn)
 155                              ('ready
 156                               (display "marionette is ready\n")
 157                               repl-conn))))))))))))
 158
 159 (define (marionette-eval exp marionette)
 160   "Evaluate EXP in MARIONETTE's backdoor REPL.  Return the result."
 161   (match marionette
 162     (($ <marionette> command pid monitor (= force repl))
 163      (write exp repl)
 164      (newline repl)
 165      (read repl))))
 166
 167 (define (marionette-control command marionette)
 168   "Run COMMAND in the QEMU monitor of MARIONETTE.  COMMAND is a string such as
 169 \"sendkey ctrl-alt-f1\" or \"screendump foo.ppm\" (info \"(qemu-doc)
 170 pcsys_monitor\")."
 171   (match marionette
 172     (($ <marionette> _ _ monitor)
 173      (display command monitor)
 174      (newline monitor)
 175      (wait-for-monitor-prompt monitor))))
 176
 177 (define* (marionette-screen-text marionette
 178                                  #:key
 179                                  (ocrad "ocrad"))
 180   "Take a screenshot of MARIONETTE, perform optical character
 181 recognition (OCR), and return the text read from the screen as a string.  Do
 182 this by invoking OCRAD (file name for GNU Ocrad's command)"
 183   (define (random-file-name)
 184     (string-append "/tmp/marionette-screenshot-"
 185                    (number->string (random (expt 2 32)) 16)
 186                    ".ppm"))
 187
 188   (let ((image (random-file-name)))
 189     (dynamic-wind
 190       (const #t)
 191       (lambda ()
 192         (marionette-control (string-append "screendump " image)
 193                             marionette)
 194
 195         ;; Tell Ocrad to invert the image colors (make it black on white) and
 196         ;; to scale the image up, which significantly improves the quality of
 197         ;; the result.  In spite of this, be aware that OCR confuses "y" and
 198         ;; "V" and sometimes erroneously introduces white space.
 199         (let* ((pipe (open-pipe* OPEN_READ ocrad
 200                                  "-i" "-s" "10" image))
 201                (text (get-string-all pipe)))
 202           (unless (zero? (close-pipe pipe))
 203             (error "'ocrad' failed" ocrad))
 204           text))
 205       (lambda ()
 206         (false-if-exception (delete-file image))))))
 207
 208 (define* (wait-for-screen-text marionette predicate
 209                                #:key (timeout 30) (ocrad "ocrad"))
 210   "Wait for TIMEOUT seconds or until the screen text on MARIONETTE matches
 211 PREDICATE, whichever comes first.  Raise an error when TIMEOUT is exceeded."
 212   (define start
 213     (car (gettimeofday)))
 214
 215   (define end
 216     (+ start timeout))
 217
 218   (let loop ()
 219     (if (> (car (gettimeofday)) end)
 220         (error "'wait-for-screen-text' timeout" predicate)
 221         (or (predicate (marionette-screen-text marionette #:ocrad ocrad))
 222             (begin
 223               (sleep 1)
 224               (loop))))))
 225
 226 (define %qwerty-us-keystrokes
 227   ;; Maps "special" characters to their keystrokes.
 228   '((#\newline . "ret")
 229     (#\space . "spc")
 230     (#\- . "minus")
 231     (#\+ . "shift-equal")
 232     (#\* . "shift-8")
 233     (#\= . "equal")
 234     (#\? . "shift-slash")
 235     (#\[ . "bracket_left")
 236     (#\] . "bracket_right")
 237     (#\( . "shift-9")
 238     (#\) . "shift-0")
 239     (#\/ . "slash")
 240     (#\< . "less")
 241     (#\> . "shift-less")
 242     (#\. . "dot")
 243     (#\, . "comma")
 244     (#\; . "semicolon")
 245     (#\bs . "backspace")
 246     (#\tab . "tab")))
 247
 248 (define* (string->keystroke-commands str
 249                                      #:optional
 250                                      (keystrokes
 251                                       %qwerty-us-keystrokes))
 252   "Return a list of QEMU monitor commands to send the keystrokes corresponding
 253 to STR.  KEYSTROKES is an alist specifying a mapping from characters to
 254 keystrokes."
 255   (string-fold-right (lambda (chr result)
 256                        (cons (string-append "sendkey "
 257                                             (or (assoc-ref keystrokes chr)
 258                                                 (string chr)))
 259                              result))
 260                      '()
 261                      str))
 262
 263 (define* (marionette-type str marionette
 264                           #:key (keystrokes %qwerty-us-keystrokes))
 265   "Type STR on MARIONETTE's keyboard, using the KEYSTROKES alist to map characters
 266 to actual keystrokes."
 267   (for-each (cut marionette-control <> marionette)
 268             (string->keystroke-commands str keystrokes)))
 269
 270 ;;; marionette.scm ends here