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   (define (accept* port)
  97     (match (select (list port) '() (list port) timeout)
  98       (((port) () ())
  99        (accept port))
 100       (_
 101        (error "timeout in 'accept'" port))))
 102
 103   (let ((monitor (socket AF_UNIX SOCK_STREAM 0))
 104         (repl    (socket AF_UNIX SOCK_STREAM 0)))
 105     (bind monitor (file->sockaddr "monitor"))
 106     (listen monitor 1)
 107     (bind repl (file->sockaddr "repl"))
 108     (listen repl 1)
 109
 110     (match (primitive-fork)
 111       (0
 112        (catch #t
 113          (lambda ()
 114            (close monitor)
 115            (close repl)
 116            (match command
 117              ((program . args)
 118               (apply execl program program
 119                      (append args extra-options)))))
 120          (lambda (key . args)
 121            (print-exception (current-error-port)
 122                             (stack-ref (make-stack #t) 1)
 123                             key args)
 124            (primitive-exit 1))))
 125       (pid
 126        (format #t "QEMU runs as PID ~a~%" pid)
 127
 128        (match (accept* monitor)
 129          ((monitor-conn . _)
 130           (display "connected to QEMU's monitor\n")
 131           (close-port monitor)
 132           (wait-for-monitor-prompt monitor-conn)
 133           (display "read QEMU monitor prompt\n")
 134           (match (accept* repl)
 135             ((repl-conn . addr)
 136              (display "connected to guest REPL\n")
 137              (close-port repl)
 138              (match (read repl-conn)
 139                ('ready
 140                 (alarm 0)
 141                 (display "marionette is ready\n")
 142                 (marionette (append command extra-options) pid
 143                             monitor-conn repl-conn)))))))))))
 144
 145 (define (marionette-eval exp marionette)
 146   "Evaluate EXP in MARIONETTE's backdoor REPL.  Return the result."
 147   (match marionette
 148     (($ <marionette> command pid monitor repl)
 149      (write exp repl)
 150      (newline repl)
 151      (read repl))))
 152
 153 (define (marionette-control command marionette)
 154   "Run COMMAND in the QEMU monitor of MARIONETTE.  COMMAND is a string such as
 155 \"sendkey ctrl-alt-f1\" or \"screendump foo.ppm\" (info \"(qemu-doc)
 156 pcsys_monitor\")."
 157   (match marionette
 158     (($ <marionette> _ _ monitor)
 159      (display command monitor)
 160      (newline monitor)
 161      (wait-for-monitor-prompt monitor))))
 162
 163 (define %qwerty-us-keystrokes
 164   ;; Maps "special" characters to their keystrokes.
 165   '((#\newline . "ret")
 166     (#\space . "spc")
 167     (#\- . "minus")
 168     (#\+ . "shift-equal")
 169     (#\* . "shift-8")
 170     (#\= . "equal")
 171     (#\? . "shift-slash")
 172     (#\[ . "bracket_left")
 173     (#\] . "bracket_right")
 174     (#\( . "shift-9")
 175     (#\) . "shift-0")
 176     (#\/ . "slash")
 177     (#\< . "less")
 178     (#\> . "shift-less")
 179     (#\. . "dot")
 180     (#\, . "comma")
 181     (#\; . "semicolon")
 182     (#\bs . "backspace")
 183     (#\tab . "tab")))
 184
 185 (define* (string->keystroke-commands str
 186                                      #:optional
 187                                      (keystrokes
 188                                       %qwerty-us-keystrokes))
 189   "Return a list of QEMU monitor commands to send the keystrokes corresponding
 190 to STR.  KEYSTROKES is an alist specifying a mapping from characters to
 191 keystrokes."
 192   (string-fold-right (lambda (chr result)
 193                        (cons (string-append "sendkey "
 194                                             (or (assoc-ref keystrokes chr)
 195                                                 (string chr)))
 196                              result))
 197                      '()
 198                      str))
 199
 200 (define* (marionette-type str marionette
 201                           #:key (keystrokes %qwerty-us-keystrokes))
 202   "Type STR on MARIONETTE's keyboard, using the KEYSTROKES alist to map characters
 203 to actual keystrokes."
 204   (for-each (cut marionette-control <> marionette)
 205             (string->keystroke-commands str keystrokes)))
 206
 207 ;;; marionette.scm ends here