| 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 |