gnu/build/marionette.scm

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