projects/guix·blob javascript-team · refs

547 lines · 21.1 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2016-2022, 2024 Ludovic Courtès <[email protected]>
3;;; Copyright © 2018 Chris Marusich <[email protected]>
4;;; Copyright © 2022, 2023 Maxim Cournoyer <[email protected]>
5;;; Copyright © 2023 Bruno Victal <[email protected]>
6;;;
7;;; This file is part of GNU Guix.
8;;;
9;;; GNU Guix is free software; you can redistribute it and/or modify it
10;;; under the terms of the GNU General Public License as published by
11;;; the Free Software Foundation; either version 3 of the License, or (at
12;;; your option) any later version.
13;;;
14;;; GNU Guix is distributed in the hope that it will be useful, but
15;;; WITHOUT ANY WARRANTY; without even the implied warranty of
16;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;;; GNU General Public License for more details.
18;;;
19;;; You should have received a copy of the GNU General Public License
20;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;;
24;;; Instrumentation tools for QEMU virtual machines (VMs). A "marionette" is
25;;; essentially a VM (a QEMU instance) with its monitor connected to a
26;;; Unix-domain socket, and with a REPL inside the guest listening on a
27;;; virtual console, which is itself connected to the host via a Unix-domain
28;;; socket--these are the marionette's strings, connecting it to the almighty
29;;; puppeteer.
30;;;
31;;; Code:
32
33(define-module (gnu build marionette)
34 #:use-module (srfi srfi-9)
35 #:use-module (srfi srfi-26)
36 #:use-module (srfi srfi-64)
37 #:use-module (srfi srfi-71)
38 #:use-module (rnrs io ports)
39 #:use-module (ice-9 match)
40 #:use-module (ice-9 popen)
41 #:use-module (ice-9 regex)
42 #:export (marionette?
43 marionette-pid
44 make-marionette
45 marionette-eval
46 wait-for-file
47 wait-for-tcp-port
48 wait-for-unix-socket
49 marionette-control
50 wait-for-screen-text
51 %default-ocrad-arguments
52 %qwerty-us-keystrokes
53 marionette-type
54
55 system-test-runner
56 qemu-command))
57
58(define-record-type <marionette>
59 (marionette command pid monitor repl)
60 marionette?
61 (command marionette-command) ;list of strings
62 (pid marionette-pid) ;integer
63 (monitor marionette-monitor) ;port
64 (repl %marionette-repl)) ;promise of a port
65
66(define-syntax-rule (marionette-repl marionette)
67 (force (%marionette-repl marionette)))
68
69(define* (wait-for-monitor-prompt port #:key (quiet? #t))
70 "Read from PORT until we have seen all of QEMU's monitor prompt. When
71QUIET? is false, the monitor's output is written to the current output port."
72 (define full-prompt
73 (string->list "(qemu) "))
74
75 (let loop ((prompt full-prompt)
76 (matches '())
77 (prefix '()))
78 (match prompt
79 (()
80 ;; It's useful to set QUIET? so we don't display the echo of our own
81 ;; commands.
82 (unless quiet?
83 (for-each (lambda (line)
84 (format #t "qemu monitor: ~a~%" line))
85 (string-tokenize (list->string (reverse prefix))
86 (char-set-complement (char-set #\newline))))))
87 ((chr rest ...)
88 (let ((read (read-char port)))
89 (cond ((eqv? read chr)
90 (loop rest (cons read matches) prefix))
91 ((eof-object? read)
92 (error "EOF while waiting for QEMU monitor prompt"
93 (list->string (reverse prefix))))
94 (else
95 (loop full-prompt
96 '()
97 (cons read (append matches prefix))))))))))
98
99(define* (make-marionette command
100 #:key (socket-directory "/tmp") (timeout 20))
101 "Return a QEMU marionette--i.e., a virtual machine with open connections to the
102QEMU monitor and to the guest's backdoor REPL."
103 (define (file->sockaddr file)
104 (make-socket-address AF_UNIX
105 (string-append socket-directory "/" file)))
106
107 (define extra-options
108 (list "-nographic"
109 "-monitor" (string-append "unix:" socket-directory "/monitor")
110 "-chardev" (string-append "socket,id=repl,path="
111 socket-directory "/repl")
112 "-chardev" (string-append "socket,id=qga,server=on,wait=off,path="
113 socket-directory "/qemu-ga")
114
115 ;; See
116 ;; <http://www.linux-kvm.org/page/VMchannel_Requirements#Invocation>.
117 "-device" "virtio-serial"
118 "-device" "virtserialport,chardev=repl,name=org.gnu.guix.port.0"
119 "-device" "virtserialport,chardev=qga,name=org.qemu.guest_agent.0"))
120
121 (define (accept* port)
122 (match (select (list port) '() (list port) timeout)
123 (((port) () ())
124 (accept port))
125 (_
126 (error "timeout in 'accept'" port))))
127
128 (let ((monitor (socket AF_UNIX SOCK_STREAM 0))
129 (repl (socket AF_UNIX SOCK_STREAM 0)))
130 (bind monitor (file->sockaddr "monitor"))
131 (listen monitor 1)
132 (bind repl (file->sockaddr "repl"))
133 (listen repl 1)
134
135 (match (primitive-fork)
136 (0
137 (catch #t
138 (lambda ()
139 (close monitor)
140 (close repl)
141 (match command
142 ((program . args)
143 (apply execl program program
144 (append args extra-options)))))
145 (lambda (key . args)
146 (print-exception (current-error-port)
147 (stack-ref (make-stack #t) 1)
148 key args)
149 (primitive-exit 1))))
150 (pid
151 (format #t "QEMU runs as PID ~a~%" pid)
152
153 (match (accept* monitor)
154 ((monitor-conn . _)
155 (display "connected to QEMU's monitor\n")
156 (close-port monitor)
157 (wait-for-monitor-prompt monitor-conn)
158 (display "read QEMU monitor prompt\n")
159
160 (marionette (append command extra-options) pid
161 monitor-conn
162
163 ;; The following 'accept' call connects immediately, but
164 ;; we don't know whether the guest has connected until
165 ;; we actually receive the 'ready' message.
166 (match (accept* repl)
167 ((repl-conn . addr)
168 (display "connected to guest REPL\n")
169 (close-port repl)
170 ;; Delay reception of the 'ready' message so that the
171 ;; caller can already send monitor commands.
172 (delay
173 (match (read repl-conn)
174 ('ready
175 (display "marionette is ready\n")
176 repl-conn))))))))))))
177
178(define (marionette-eval exp marionette)
179 "Evaluate EXP in MARIONETTE's backdoor REPL. Return the result."
180 (match marionette
181 (($ <marionette> command pid monitor (= force repl))
182 (write exp repl)
183 (newline repl)
184 (with-exception-handler
185 (lambda (exn)
186 (simple-format
187 (current-error-port)
188 "error reading marionette response: ~A
189 remaining response: ~A\n"
190 exn
191 (get-line repl))
192 (raise-exception exn))
193 (lambda ()
194 (read repl))
195 #:unwind? #t))))
196
197(define* (wait-for-file file marionette
198 #:key (timeout 10) (read 'read))
199 "Wait until FILE exists in MARIONETTE; READ its content and return it. If
200FILE has not shown up after TIMEOUT seconds, raise an error."
201 (match (marionette-eval
202 `(let loop ((i ,timeout))
203 (cond ((file-exists? ,file)
204 (cons 'success
205 (let ((content
206 (call-with-input-file ,file ,read)))
207 (if (eof-object? content)
208 ;; #<eof> can't be read, so convert to the
209 ;; empty string
210 ""
211 content))))
212 ((> i 0)
213 (sleep 1)
214 (loop (- i 1)))
215 (else
216 'failure)))
217 marionette)
218 (('success . result)
219 result)
220 ('failure
221 (error "file didn't show up" file))))
222
223(define* (wait-for-tcp-port port marionette
224 #:key
225 (timeout 20)
226 (peek? #f)
227 (address `(make-socket-address AF_INET
228 INADDR_LOOPBACK
229 ,port)))
230 "Wait for up to TIMEOUT seconds for PORT to accept connections in
231MARIONETTE. ADDRESS must be an expression that returns a socket address,
232typically a call to 'make-socket-address'. When PEEK? is true, attempt to
233read a byte from the socket upon connection; retry if that gives the
234end-of-file object.
235
236Raise an error on failure."
237 ;; Note: The 'connect' loop has to run within the guest because, when we
238 ;; forward ports to the host, connecting to the host never raises
239 ;; ECONNREFUSED.
240 (match (marionette-eval
241 `(let* ((address ,address))
242 (define (open-socket)
243 (socket (sockaddr:fam address) SOCK_STREAM 0))
244
245 (let loop ((sock (open-socket))
246 (i 0))
247 (catch 'system-error
248 (lambda ()
249 (connect sock address)
250 (when ,peek?
251 (let ((byte ((@ (ice-9 binary-ports) lookahead-u8)
252 sock)))
253 (when (eof-object? byte)
254 (close-port sock)
255 (throw 'system-error
256 "wait-for-tcp-port" "~A"
257 (list (strerror ECONNRESET))
258 (list ECONNRESET)))))
259 (close-port sock)
260 'success)
261 (lambda args
262 (if (< i ,timeout)
263 (begin
264 (sleep 1)
265 (loop (if (port-closed? sock)
266 (open-socket)
267 sock)
268 (+ 1 i)))
269 (list 'failure address))))))
270 marionette)
271 ('success #t)
272 (('failure address)
273 (error "nobody's listening on port"
274 (list (inet-ntop (sockaddr:fam address) (sockaddr:addr address))
275 (sockaddr:port address))))))
276
277(define* (wait-for-unix-socket file-name marionette
278 #:key (timeout 20))
279 "Wait for up to TIMEOUT seconds for FILE-NAME, a Unix domain socket, to
280accept connections in MARIONETTE. Raise an error on failure."
281 (match (marionette-eval
282 `(begin
283 (let ((sock (socket PF_UNIX SOCK_STREAM 0)))
284 (let loop ((i 0))
285 (catch 'system-error
286 (lambda ()
287 (connect sock AF_UNIX ,file-name)
288 (close-port sock)
289 'success)
290 (lambda args
291 (if (< i ,timeout)
292 (begin
293 (sleep 1)
294 (loop (+ 1 i)))
295 'failure))))))
296 marionette)
297 ('success #t)
298 ('failure
299 (error "nobody's listening on unix domain socket" file-name))))
300
301(define (marionette-control command marionette)
302 "Run COMMAND in the QEMU monitor of MARIONETTE. COMMAND is a string such as
303\"sendkey ctrl-alt-f1\" or \"screendump foo.ppm\" (info \"(QEMU) QEMU
304Monitor\")."
305 (match marionette
306 (($ <marionette> _ _ monitor)
307 (display command monitor)
308 (newline monitor)
309 ;; The "quit" command terminates QEMU immediately, with no output.
310 (unless (string=? command "quit") (wait-for-monitor-prompt monitor)))))
311
312(define %default-ocrad-arguments
313 '("--invert" "--scale=10"))
314
315(define* (invoke-ocrad-ocr image #:key (ocrad "ocrad")
316 (ocr-arguments %default-ocrad-arguments))
317 "Invoke the OCRAD command on image, and return the recognized text."
318 (let* ((command (string-join `(,ocrad ,@ocr-arguments ,image)))
319 (pipe (open-input-pipe command))
320 (text (get-string-all pipe)))
321 (unless (zero? (close-pipe pipe))
322 (error "'ocrad' failed" ocrad))
323 text))
324
325(define* (invoke-tesseract-ocr image #:key (tesseract "tesseract")
326 (ocr-arguments '()))
327 "Invoke the TESSERACT command on IMAGE, and return the recognized text."
328 (let* ((output-basename (tmpnam))
329 (output-basename* (string-append output-basename ".txt"))
330 (arguments (cons* image output-basename ocr-arguments)))
331 (dynamic-wind
332 (const #t)
333 (lambda ()
334 (let ((exit-val (status:exit-val
335 (apply system* tesseract arguments))))
336 (unless (zero? exit-val)
337 (error "'tesseract' failed" tesseract))
338 (call-with-input-file output-basename* get-string-all)))
339 (lambda ()
340 (false-if-exception (delete-file output-basename))
341 (false-if-exception (delete-file output-basename*))))))
342
343(define* (marionette-screen-text marionette #:key (ocr "ocrad")
344 ocr-arguments)
345 "Take a screenshot of MARIONETTE, perform optical character
346recognition (OCR), and return the text read from the screen as a string, along
347the screen dump image used. Do this by invoking OCR, which should be the file
348name of GNU Ocrad's@command{ocrad} or Tesseract OCR's @command{tesseract}
349command. The screen dump image returned as the second value should be deleted
350if it is not needed."
351 (define image (string-append (tmpnam) ".ppm"))
352 ;; Use the QEMU Monitor to save an image of the screen to the host.
353 (marionette-control (string-append "screendump " image) marionette)
354 ;; Process it via the OCR.
355 (cond
356 ((string-contains ocr "ocrad")
357 (values (invoke-ocrad-ocr image
358 #:ocrad ocr
359 #:ocr-arguments
360 (or ocr-arguments %default-ocrad-arguments))
361 image))
362 ((string-contains ocr "tesseract")
363 (values (invoke-tesseract-ocr image
364 #:tesseract ocr
365 #:ocr-arguments (or ocr-arguments '()))
366 image))
367 (else (error "unsupported ocr command"))))
368
369(define* (wait-for-screen-text marionette predicate
370 #:key
371 (ocr "ocrad")
372 ocr-arguments
373 (timeout 30)
374 pre-action
375 post-action)
376 "Wait for TIMEOUT seconds or until the screen text on MARIONETTE matches
377PREDICATE, whichever comes first. Raise an error when TIMEOUT is exceeded.
378The error contains the recognized text along the preserved file name of the
379screen dump, which is relative to the current working directory. If
380PRE-ACTION is provided, it should be a thunk to call before each OCR attempt.
381Likewise for POST-ACTION, except it runs at the end of a successful OCR."
382 (define start
383 (car (gettimeofday)))
384
385 (define end
386 (+ start timeout))
387
388 (let loop ((last-text #f)
389 (last-screendump #f))
390 (if (> (car (gettimeofday)) end)
391 (let ((screendump-backup (string-drop last-screendump 5)))
392 ;; Move the file from /tmp/fileXXXXXX.pmm to the current working
393 ;; directory, so that it is preserved in the test derivation output.
394 (copy-file last-screendump screendump-backup)
395 (delete-file last-screendump)
396 (error "'wait-for-screen-text' timeout"
397 'ocr-text: last-text
398 'screendump: screendump-backup))
399 (let* ((_ (and (procedure? pre-action) (pre-action)))
400 (text screendump
401 (marionette-screen-text marionette
402 #:ocr ocr
403 #:ocr-arguments ocr-arguments))
404 (_ (and (procedure? post-action) (post-action)))
405 (result (predicate text)))
406 (cond (result
407 (delete-file screendump)
408 result)
409 (else
410 (sleep 1)
411 (loop text screendump)))))))
412
413(define %qwerty-us-keystrokes
414 ;; Maps "special" characters to their keystrokes.
415 '((#\newline . "ret")
416 (#\space . "spc")
417 (#\- . "minus")
418 (#\+ . "shift-equal")
419 (#\* . "shift-8")
420 (#\= . "equal")
421 (#\? . "shift-slash")
422 (#\[ . "bracket_left")
423 (#\] . "bracket_right")
424 (#\{ . "shift-bracket_left")
425 (#\} . "shift-bracket_right")
426 (#\( . "shift-9")
427 (#\) . "shift-0")
428 (#\/ . "slash")
429 (#\< . "shift-comma")
430 (#\> . "shift-dot")
431 (#\. . "dot")
432 (#\, . "comma")
433 (#\: . "shift-semicolon")
434 (#\; . "semicolon")
435 (#\' . "apostrophe")
436 (#\! . "shift-1")
437 (#\" . "shift-apostrophe")
438 (#\` . "grave_accent")
439 (#\bs . "backspace")
440 (#\tab . "tab")))
441
442(define (character->keystroke chr keystrokes)
443 "Return the keystroke for CHR according to the keyboard layout defined by
444KEYSTROKES."
445 (if (char-set-contains? char-set:upper-case chr)
446 (string-append "shift-" (string (char-downcase chr)))
447 (or (assoc-ref keystrokes chr)
448 (string chr))))
449
450(define* (string->keystroke-commands str
451 #:optional
452 (keystrokes
453 %qwerty-us-keystrokes))
454 "Return a list of QEMU monitor commands to send the keystrokes corresponding
455to STR. KEYSTROKES is an alist specifying a mapping from characters to
456keystrokes."
457 (string-fold-right (lambda (chr result)
458 (cons (string-append
459 "sendkey "
460 (character->keystroke chr keystrokes))
461 result))
462 '()
463 str))
464
465(define* (marionette-type str marionette
466 #:key (keystrokes %qwerty-us-keystrokes))
467 "Type STR on MARIONETTE's keyboard, using the KEYSTROKES alist to map characters
468to actual keystrokes."
469 (for-each (cut marionette-control <> marionette)
470 (string->keystroke-commands str keystrokes)))
471
472
473;;;
474;;; Test helper.
475;;;
476
477(define* (system-test-runner #:optional log-directory)
478 "Return a SRFI-64 test runner that calls 'exit' upon 'test-end'. When
479LOG-DIRECTORY is specified, create log file within it."
480 (let ((runner (test-runner-simple)))
481 ;; Log to a file under LOG-DIRECTORY.
482 (test-runner-on-group-begin! runner
483 (let ((on-begin (test-runner-on-group-begin runner)))
484 (lambda (runner suite-name count)
485 (when log-directory
486 (catch 'system-error
487 (lambda ()
488 (mkdir log-directory))
489 (lambda args
490 (unless (= (system-error-errno args) EEXIST)
491 (apply throw args))))
492 (set! test-log-to-file
493 (string-append log-directory "/" suite-name ".log")))
494 (on-begin runner suite-name count))))
495
496 ;; The default behavior on 'test-end' is to only write a line if the test
497 ;; failed. Arrange to also write a line on success.
498 (test-runner-on-test-end! runner
499 (let ((on-end (test-runner-on-test-end runner)))
500 (lambda (runner)
501 (let* ((kind (test-result-ref runner 'result-kind))
502 (results (test-result-alist runner))
503 (test-name (assq-ref results 'test-name)))
504 (unless (memq kind '(fail xpass))
505 (format (current-output-port) "~a: ~a~%"
506 (string-upcase (symbol->string kind))
507 test-name)))
508
509 (on-end runner))))
510
511 ;; On 'test-end', display test results and exit with zero if and only if
512 ;; there were no test failures.
513 (test-runner-on-final! runner
514 (lambda (runner)
515 (let ((success? (= (test-runner-fail-count runner) 0)))
516 (test-on-final-simple runner)
517
518 (when (not success?)
519 (let* ((log-port (test-runner-aux-value runner))
520 (log-file (port-filename log-port)))
521 (format (current-error-port)
522 "\nTests failed, dumping log file '~a'.\n\n"
523 log-file)
524
525 ;; At this point LOG-PORT is not closed yet; flush it.
526 (force-output log-port)
527
528 ;; Brute force to avoid dependency on (guix build utils) for
529 ;; 'dump-port'.
530 (let ((content (call-with-input-file log-file
531 get-bytevector-all)))
532 (put-bytevector (current-error-port) content))))
533
534 (exit success?))))
535 runner))
536
537(define* (qemu-command #:optional (system %host-type))
538 "Return the default name of the QEMU command for SYSTEM."
539 (let ((cpu (substring system 0
540 (string-index system #\-))))
541 (string-append "qemu-system-"
542 (cond
543 ((string-match "^i[3456]86$" cpu) "i386")
544 ((string-match "armhf" cpu) "arm")
545 (else cpu)))))
546
547;;; marionette.scm ends here