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   #:export (marionette?
  25             make-marionette
  26             marionette-eval
  27             marionette-control
  28             %qwerty-us-keystrokes
  29             marionette-type))
  30
  31 ;;; Commentary:
  32 ;;;
  33 ;;; Instrumentation tools for QEMU virtual machines (VMs).  A "marionette" is
  34 ;;; essentially a VM (a QEMU instance) with its monitor connected to a
  35 ;;; Unix-domain socket, and with a REPL inside the guest listening on a
  36 ;;; virtual console, which is itself connected to the host via a Unix-domain
  37 ;;; socket--these are the marionette's strings, connecting it to the almighty
  38 ;;; puppeteer.
  39 ;;;
  40 ;;; Code:
  41
  42 (define-record-type <marionette>
  43   (marionette command pid monitor repl)
  44   marionette?
  45   (command    marionette-command)                 ;list of strings
  46   (pid        marionette-pid)                     ;integer
  47   (monitor    marionette-monitor)                 ;port
  48   (repl       %marionette-repl))                  ;promise of a port
  49
  50 (define-syntax-rule (marionette-repl marionette)
  51   (force (%marionette-repl marionette)))
  52
  53 (define* (wait-for-monitor-prompt port #:key (quiet? #t))
  54   "Read from PORT until we have seen all of QEMU's monitor prompt.  When
  55 QUIET? is false, the monitor's output is written to the current output port."
  56   (define full-prompt
  57     (string->list "(qemu) "))
  58
  59   (let loop ((prompt full-prompt)
  60              (matches '())
  61              (prefix  '()))
  62     (match prompt
  63       (()
  64        ;; It's useful to set QUIET? so we don't display the echo of our own
  65        ;; commands.
  66        (unless quiet?
  67          (for-each (lambda (line)
  68                      (format #t "qemu monitor: ~a~%" line))
  69                    (string-tokenize (list->string (reverse prefix))
  70                                     (char-set-complement (char-set #\newline))))))
  71       ((chr rest ...)
  72        (let ((read (read-char port)))
  73          (cond ((eqv? read chr)
  74                 (loop rest (cons read matches) prefix))
  75                ((eof-object? read)
  76                 (error "EOF while waiting for QEMU monitor prompt"
  77                        (list->string (reverse prefix))))
  78                (else
  79                 (loop full-prompt
  80                       '()
  81                       (cons read (append matches prefix))))))))))
  82
  83 (define* (make-marionette command
  84                           #:key (socket-directory "/tmp") (timeout 20))
  85   "Return a QEMU marionette--i.e., a virtual machine with open connections to the
  86 QEMU monitor and to the guest's backdoor REPL."
  87   (define (file->sockaddr file)
  88     (make-socket-address AF_UNIX
  89                          (string-append socket-directory "/" file)))
  90
  91   (define extra-options
  92     (list "-nographic"
  93           "-monitor" (string-append "unix:" socket-directory "/monitor")
  94           "-chardev" (string-append "socket,id=repl,path=" socket-directory
  95                                     "/repl")
  96           "-device" "virtio-serial"
  97           "-device" "virtconsole,chardev=repl"))
  98
  99   (define (accept* port)
 100     (match (select (list port) '() (list port) timeout)
 101       (((port) () ())
 102        (accept port))
 103       (_
 104        (error "timeout in 'accept'" port))))
 105
 106   (let ((monitor (socket AF_UNIX SOCK_STREAM 0))
 107         (repl    (socket AF_UNIX SOCK_STREAM 0)))
 108     (bind monitor (file->sockaddr "monitor"))
 109     (listen monitor 1)
 110     (bind repl (file->sockaddr "repl"))
 111     (listen repl 1)
 112
 113     (match (primitive-fork)
 114       (0
 115        (catch #t
 116          (lambda ()
 117            (close monitor)
 118            (close repl)
 119            (match command
 120              ((program . args)
 121               (apply execl program program
 122                      (append args extra-options)))))
 123          (lambda (key . args)
 124            (print-exception (current-error-port)
 125                             (stack-ref (make-stack #t) 1)
 126                             key args)
 127            (primitive-exit 1))))
 128       (pid
 129        (format #t "QEMU runs as PID ~a~%" pid)
 130
 131        (match (accept* monitor)
 132          ((monitor-conn . _)
 133           (display "connected to QEMU's monitor\n")
 134           (close-port monitor)
 135           (wait-for-monitor-prompt monitor-conn)
 136           (display "read QEMU monitor prompt\n")
 137
 138           (marionette (append command extra-options) pid
 139                       monitor-conn
 140
 141                       ;; The following 'accept' call connects immediately, but
 142                       ;; we don't know whether the guest has connected until
 143                       ;; we actually receive the 'ready' message.
 144                       (match (accept* repl)
 145                         ((repl-conn . addr)
 146                          (display "connected to guest REPL\n")
 147                          (close-port repl)
 148                          ;; Delay reception of the 'ready' message so that the
 149                          ;; caller can already send monitor commands.
 150                          (delay
 151                            (match (read repl-conn)
 152                              ('ready
 153                               (display "marionette is ready\n")
 154                               repl-conn))))))))))))
 155
 156 (define (marionette-eval exp marionette)
 157   "Evaluate EXP in MARIONETTE's backdoor REPL.  Return the result."
 158   (match marionette
 159     (($ <marionette> command pid monitor (= force repl))
 160      (write exp repl)
 161      (newline repl)
 162      (read repl))))
 163
 164 (define (marionette-control command marionette)
 165   "Run COMMAND in the QEMU monitor of MARIONETTE.  COMMAND is a string such as
 166 \"sendkey ctrl-alt-f1\" or \"screendump foo.ppm\" (info \"(qemu-doc)
 167 pcsys_monitor\")."
 168   (match marionette
 169     (($ <marionette> _ _ monitor)
 170      (display command monitor)
 171      (newline monitor)
 172      (wait-for-monitor-prompt monitor))))
 173
 174 (define %qwerty-us-keystrokes
 175   ;; Maps "special" characters to their keystrokes.
 176   '((#\newline . "ret")
 177     (#\space . "spc")
 178     (#\- . "minus")
 179     (#\+ . "shift-equal")
 180     (#\* . "shift-8")
 181     (#\= . "equal")
 182     (#\? . "shift-slash")
 183     (#\[ . "bracket_left")
 184     (#\] . "bracket_right")
 185     (#\( . "shift-9")
 186     (#\) . "shift-0")
 187     (#\/ . "slash")
 188     (#\< . "less")
 189     (#\> . "shift-less")
 190     (#\. . "dot")
 191     (#\, . "comma")
 192     (#\; . "semicolon")
 193     (#\bs . "backspace")
 194     (#\tab . "tab")))
 195
 196 (define* (string->keystroke-commands str
 197                                      #:optional
 198                                      (keystrokes
 199                                       %qwerty-us-keystrokes))
 200   "Return a list of QEMU monitor commands to send the keystrokes corresponding
 201 to STR.  KEYSTROKES is an alist specifying a mapping from characters to
 202 keystrokes."
 203   (string-fold-right (lambda (chr result)
 204                        (cons (string-append "sendkey "
 205                                             (or (assoc-ref keystrokes chr)
 206                                                 (string chr)))
 207                              result))
 208                      '()
 209                      str))
 210
 211 (define* (marionette-type str marionette
 212                           #:key (keystrokes %qwerty-us-keystrokes))
 213   "Type STR on MARIONETTE's keyboard, using the KEYSTROKES alist to map characters
 214 to actual keystrokes."
 215   (for-each (cut marionette-control <> marionette)
 216             (string->keystroke-commands str keystrokes)))
 217
 218 ;;; marionette.scm ends here