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))                   ;port
  49
  50 (define* (wait-for-monitor-prompt port #:key (quiet? #t))
  51   "Read from PORT until we have seen all of QEMU's monitor prompt.  When
  52 QUIET? is false, the monitor's output is written to the current output port."
  53   (define full-prompt
  54     (string->list "(qemu) "))
  55
  56   (let loop ((prompt full-prompt)
  57              (matches '())
  58              (prefix  '()))
  59     (match prompt
  60       (()
  61        ;; It's useful to set QUIET? so we don't display the echo of our own
  62        ;; commands.
  63        (unless quiet?
  64          (for-each (lambda (line)
  65                      (format #t "qemu monitor: ~a~%" line))
  66                    (string-tokenize (list->string (reverse prefix))
  67                                     (char-set-complement (char-set #\newline))))))
  68       ((chr rest ...)
  69        (let ((read (read-char port)))
  70          (cond ((eqv? read chr)
  71                 (loop rest (cons read matches) prefix))
  72                ((eof-object? read)
  73                 (error "EOF while waiting for QEMU monitor prompt"
  74                        (list->string (reverse prefix))))
  75                (else
  76                 (loop full-prompt
  77                       '()
  78                       (cons read (append matches prefix))))))))))
  79
  80 (define* (make-marionette command
  81                           #:key (socket-directory "/tmp") (timeout 20))
  82   "Return a QEMU marionette--i.e., a virtual machine with open connections to the
  83 QEMU monitor and to the guest's backdoor REPL."
  84   (define (file->sockaddr file)
  85     (make-socket-address AF_UNIX
  86                          (string-append socket-directory "/" file)))
  87
  88   (define extra-options
  89     (list "-nographic"
  90           "-monitor" (string-append "unix:" socket-directory "/monitor")
  91           "-chardev" (string-append "socket,id=repl,path=" socket-directory
  92                                     "/repl")
  93           "-device" "virtio-serial"
  94           "-device" "virtconsole,chardev=repl"))
  95
  96   (let ((monitor (socket AF_UNIX SOCK_STREAM 0))
  97         (repl    (socket AF_UNIX SOCK_STREAM 0)))
  98     (bind monitor (file->sockaddr "monitor"))
  99     (listen monitor 1)
 100     (bind repl (file->sockaddr "repl"))
 101     (listen repl 1)
 102
 103     (match (primitive-fork)
 104       (0
 105        (catch #t
 106          (lambda ()
 107            (close monitor)
 108            (close repl)
 109            (match command
 110              ((program . args)
 111               (apply execl program program
 112                      (append args extra-options)))))
 113          (lambda (key . args)
 114            (print-exception (current-error-port)
 115                             (stack-ref (make-stack #t) 1)
 116                             key args)
 117            (primitive-exit 1))))
 118       (pid
 119        (format #t "QEMU runs as PID ~a~%" pid)
 120        (sigaction SIGALRM
 121          (lambda (signum)
 122            (display "time is up!\n")              ;FIXME: break
 123            #t))
 124        (alarm timeout)
 125
 126        (match (accept monitor)
 127          ((monitor-conn . _)
 128           (display "connected to QEMU's monitor\n")
 129           (close-port monitor)
 130           (wait-for-monitor-prompt monitor-conn)
 131           (display "read QEMU monitor prompt\n")
 132           (match (accept repl)
 133             ((repl-conn . addr)
 134              (display "connected to guest REPL\n")
 135              (close-port repl)
 136              (match (read repl-conn)
 137                ('ready
 138                 (alarm 0)
 139                 (sigaction SIGALRM SIG_DFL)
 140                 (display "marionette is ready\n")
 141                 (marionette (append command extra-options) pid
 142                             monitor-conn repl-conn)))))))))))
 143
 144 (define (marionette-eval exp marionette)
 145   "Evaluate EXP in MARIONETTE's backdoor REPL.  Return the result."
 146   (match marionette
 147     (($ <marionette> command pid monitor repl)
 148      (write exp repl)
 149      (newline repl)
 150      (read repl))))
 151
 152 (define (marionette-control command marionette)
 153   "Run COMMAND in the QEMU monitor of MARIONETTE.  COMMAND is a string such as
 154 \"sendkey ctrl-alt-f1\" or \"screendump foo.ppm\" (info \"(qemu-doc)
 155 pcsys_monitor\")."
 156   (match marionette
 157     (($ <marionette> _ _ monitor)
 158      (display command monitor)
 159      (newline monitor)
 160      (wait-for-monitor-prompt monitor))))
 161
 162 (define %qwerty-us-keystrokes
 163   ;; Maps "special" characters to their keystrokes.
 164   '((#\newline . "ret")
 165     (#\space . "spc")
 166     (#\- . "minus")
 167     (#\+ . "shift-equal")
 168     (#\* . "shift-8")
 169     (#\= . "equal")
 170     (#\? . "shift-slash")
 171     (#\[ . "bracket_left")
 172     (#\] . "bracket_right")
 173     (#\( . "shift-9")
 174     (#\) . "shift-0")
 175     (#\/ . "slash")
 176     (#\< . "less")
 177     (#\> . "shift-less")
 178     (#\. . "dot")
 179     (#\, . "comma")
 180     (#\; . "semicolon")
 181     (#\bs . "backspace")
 182     (#\tab . "tab")))
 183
 184 (define* (string->keystroke-commands str
 185                                      #:optional
 186                                      (keystrokes
 187                                       %qwerty-us-keystrokes))
 188   "Return a list of QEMU monitor commands to send the keystrokes corresponding
 189 to STR.  KEYSTROKES is an alist specifying a mapping from characters to
 190 keystrokes."
 191   (string-fold-right (lambda (chr result)
 192                        (cons (string-append "sendkey "
 193                                             (or (assoc-ref keystrokes chr)
 194                                                 (string chr)))
 195                              result))
 196                      '()
 197                      str))
 198
 199 (define* (marionette-type str marionette
 200                           #:key (keystrokes %qwerty-us-keystrokes))
 201   "Type STR on MARIONETTE's keyboard, using the KEYSTROKES alist to map characters
 202 to actual keystrokes."
 203   (for-each (cut marionette-control <> marionette)
 204             (string->keystroke-commands str keystrokes)))
 205
 206 ;;; marionette.scm ends here