gnu/build/marionette.scm

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