gnu/build/marionette.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016, 2017, 2018, 2019, 2020 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                      (close-port sock)
 208                      'success)
 209                    (lambda args
 210                      (if (< i ,timeout)
 211                          (begin
 212                            (sleep 1)
 213                            (loop (+ 1 i)))
 214                          'failure))))))
 215           marionette)
 216     ('success #t)
 217     ('failure
 218      (error "nobody's listening on port" port))))
 219
 220 (define* (wait-for-unix-socket file-name marionette
 221                                 #:key (timeout 20))
 222   "Wait for up to TIMEOUT seconds for FILE-NAME, a Unix domain socket, to
 223 accept connections in MARIONETTE.  Raise an error on failure."
 224   (match (marionette-eval
 225           `(begin
 226              (let ((sock (socket PF_UNIX SOCK_STREAM 0)))
 227                (let loop ((i 0))
 228                  (catch 'system-error
 229                    (lambda ()
 230                      (connect sock AF_UNIX ,file-name)
 231                      (close-port sock)
 232                      'success)
 233                    (lambda args
 234                      (if (< i ,timeout)
 235                          (begin
 236                            (sleep 1)
 237                            (loop (+ 1 i)))
 238                          'failure))))))
 239           marionette)
 240     ('success #t)
 241     ('failure
 242      (error "nobody's listening on unix domain socket" file-name))))
 243
 244 (define (marionette-control command marionette)
 245   "Run COMMAND in the QEMU monitor of MARIONETTE.  COMMAND is a string such as
 246 \"sendkey ctrl-alt-f1\" or \"screendump foo.ppm\" (info \"(qemu-doc)
 247 pcsys_monitor\")."
 248   (match marionette
 249     (($ <marionette> _ _ monitor)
 250      (display command monitor)
 251      (newline monitor)
 252      ;; The "quit" command terminates QEMU immediately, with no output.
 253      (unless (string=? command "quit") (wait-for-monitor-prompt monitor)))))
 254
 255 (define* (marionette-screen-text marionette
 256                                  #:key
 257                                  (ocrad "ocrad"))
 258   "Take a screenshot of MARIONETTE, perform optical character
 259 recognition (OCR), and return the text read from the screen as a string.  Do
 260 this by invoking OCRAD (file name for GNU Ocrad's command)"
 261   (define (random-file-name)
 262     (string-append "/tmp/marionette-screenshot-"
 263                    (number->string (random (expt 2 32)) 16)
 264                    ".ppm"))
 265
 266   (let ((image (random-file-name)))
 267     (dynamic-wind
 268       (const #t)
 269       (lambda ()
 270         (marionette-control (string-append "screendump " image)
 271                             marionette)
 272
 273         ;; Tell Ocrad to invert the image colors (make it black on white) and
 274         ;; to scale the image up, which significantly improves the quality of
 275         ;; the result.  In spite of this, be aware that OCR confuses "y" and
 276         ;; "V" and sometimes erroneously introduces white space.
 277         (let* ((pipe (open-pipe* OPEN_READ ocrad
 278                                  "-i" "-s" "10" image))
 279                (text (get-string-all pipe)))
 280           (unless (zero? (close-pipe pipe))
 281             (error "'ocrad' failed" ocrad))
 282           text))
 283       (lambda ()
 284         (false-if-exception (delete-file image))))))
 285
 286 (define* (wait-for-screen-text marionette predicate
 287                                #:key (timeout 30) (ocrad "ocrad"))
 288   "Wait for TIMEOUT seconds or until the screen text on MARIONETTE matches
 289 PREDICATE, whichever comes first.  Raise an error when TIMEOUT is exceeded."
 290   (define start
 291     (car (gettimeofday)))
 292
 293   (define end
 294     (+ start timeout))
 295
 296   (let loop ()
 297     (if (> (car (gettimeofday)) end)
 298         (error "'wait-for-screen-text' timeout" predicate)
 299         (or (predicate (marionette-screen-text marionette #:ocrad ocrad))
 300             (begin
 301               (sleep 1)
 302               (loop))))))
 303
 304 (define %qwerty-us-keystrokes
 305   ;; Maps "special" characters to their keystrokes.
 306   '((#\newline . "ret")
 307     (#\space . "spc")
 308     (#\- . "minus")
 309     (#\+ . "shift-equal")
 310     (#\* . "shift-8")
 311     (#\= . "equal")
 312     (#\? . "shift-slash")
 313     (#\[ . "bracket_left")
 314     (#\] . "bracket_right")
 315     (#\{ . "shift-bracket_left")
 316     (#\} . "shift-bracket_right")
 317     (#\( . "shift-9")
 318     (#\) . "shift-0")
 319     (#\/ . "slash")
 320     (#\< . "shift-comma")
 321     (#\> . "shift-dot")
 322     (#\. . "dot")
 323     (#\, . "comma")
 324     (#\; . "semicolon")
 325     (#\' . "apostrophe")
 326     (#\" . "shift-apostrophe")
 327     (#\` . "grave_accent")
 328     (#\bs . "backspace")
 329     (#\tab . "tab")))
 330
 331 (define (character->keystroke chr keystrokes)
 332   "Return the keystroke for CHR according to the keyboard layout defined by
 333 KEYSTROKES."
 334   (if (char-set-contains? char-set:upper-case chr)
 335       (string-append "shift-" (string (char-downcase chr)))
 336       (or (assoc-ref keystrokes chr)
 337           (string chr))))
 338
 339 (define* (string->keystroke-commands str
 340                                      #:optional
 341                                      (keystrokes
 342                                       %qwerty-us-keystrokes))
 343   "Return a list of QEMU monitor commands to send the keystrokes corresponding
 344 to STR.  KEYSTROKES is an alist specifying a mapping from characters to
 345 keystrokes."
 346   (string-fold-right (lambda (chr result)
 347                        (cons (string-append
 348                               "sendkey "
 349                               (character->keystroke chr keystrokes))
 350                              result))
 351                      '()
 352                      str))
 353
 354 (define* (marionette-type str marionette
 355                           #:key (keystrokes %qwerty-us-keystrokes))
 356   "Type STR on MARIONETTE's keyboard, using the KEYSTROKES alist to map characters
 357 to actual keystrokes."
 358   (for-each (cut marionette-control <> marionette)
 359             (string->keystroke-commands str keystrokes)))
 360
 361 ;;; marionette.scm ends here