gnu: texlive-union: Export and formally deprecate. - guix

diff options

author	Ludovic Courtès <ludo@gnu.org>	2021-07-18 19:57:35 +0200
committer	Ludovic Courtès <ludo@gnu.org>	2021-07-18 19:57:35 +0200
commit	f186365aee5a894e3cc26fa64af573e264c38ff6 (patch)
tree	9aa1258fe08ca2ce3b7596f56a299c248d55e4de /tests/monads.scm
parent	0e47fcced442d8e7c1b05184fdc1c14f10ed04ec (diff)
download	guix-f186365aee5a894e3cc26fa64af573e264c38ff6.tar.gz guix-f186365aee5a894e3cc26fa64af573e264c38ff6.zip

gnu: texlive-union: Export and formally deprecate.

This is a followup to 04a0b1e09abce99857e7930336421ca6d15ae630. * gnu/packages/tex.scm (texlive-union): Define using 'define-deprecated/alias' and export.

Diffstat (limited to 'tests/monads.scm')

0 files changed, 0 insertions, 0 deletions

108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu build marionette)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)
  #:use-module (rnrs io ports)
  #:use-module (ice-9 match)
  #:export (marionette?
            make-marionette
            marionette-eval
            marionette-control
            %qwerty-us-keystrokes
            marionette-type))

;;; Commentary:
;;;
;;; Instrumentation tools for QEMU virtual machines (VMs).  A "marionette" is
;;; essentially a VM (a QEMU instance) with its monitor connected to a
;;; Unix-domain socket, and with a REPL inside the guest listening on a
;;; virtual console, which is itself connected to the host via a Unix-domain
;;; socket--these are the marionette's strings, connecting it to the almighty
;;; puppeteer.
;;;
;;; Code:

(define-record-type <marionette>
  (marionette command pid monitor repl)
  marionette?
  (command    marionette-command)                 ;list of strings
  (pid        marionette-pid)                     ;integer
  (monitor    marionette-monitor)                 ;port
  (repl       marionette-repl))                   ;port

(define* (wait-for-monitor-prompt port #:key (quiet? #t))
  "Read from PORT until we have seen all of QEMU's monitor prompt.  When
QUIET? is false, the monitor's output is written to the current output port."
  (define full-prompt
    (string->list "(qemu) "))

  (let loop ((prompt full-prompt)
             (matches '())
             (prefix  '()))
    (match prompt
      (()
       ;; It's useful to set QUIET? so we don't display the echo of our own
       ;; commands.
       (unless quiet?
         (for-each (lambda (line)
                     (format #t "qemu monitor: ~a~%" line))
                   (string-tokenize (list->string (reverse prefix))
                                    (char-set-complement (char-set #\newline))))))
      ((chr rest ...)
       (let ((read (read-char port)))
         (cond ((eqv? read chr)
                (loop rest (cons read matches) prefix))
               ((eof-object? read)
                (error "EOF while waiting for QEMU monitor prompt"
                       (list->string (reverse prefix))))
               (else
                (loop full-prompt
                      '()
                      (cons read (append matches prefix))))))))))

(define* (make-marionette command
                          #:key (socket-directory "/tmp") (timeout 20))
  "Return a QEMU marionette--i.e., a virtual machine with open connections to the
QEMU monitor and to the guest's backdoor REPL."
  (define (file->sockaddr file)
    (make-socket-address AF_UNIX
                         (string-append socket-directory "/" file)))

  (define extra-options
    (list "-nographic"
          "-monitor" (string-append "unix:" socket-directory "/monitor")
          "-chardev" (string-append "socket,id=repl,path=" socket-directory
                                    "/repl")
          "-device" "virtio-serial"
          "-device" "virtconsole,chardev=repl"))

  (let ((monitor (socket AF_UNIX SOCK_STREAM 0))
        (repl    (socket AF_UNIX SOCK_STREAM 0)))
    (bind monitor (file->sockaddr "monitor"))
    (listen monitor 1)
    (bind repl (file->sockaddr "repl"))
    (listen repl 1)

    (match (primitive-fork)
      (0
       (catch #t
         (lambda ()
           (close monitor)
           (close repl)
           (match command
             ((program . args)
              (apply execl program program
                     (append args extra-options)))))
         (lambda (key . args)
           (print-exception (current-error-port)
                            (stack-ref (make-stack #t) 1)
                            key args)
           (primitive-exit 1))))
      (pid
       (format #t "QEMU runs as PID ~a~%" pid)
       (sigaction SIGALRM
         (lambda (signum)
           (display "time is up!\n")              ;FIXME: break
           #t))
       (alarm timeout)

       (match (accept monitor)
         ((monitor-conn . _)
          (display "connected to QEMU's monitor\n")
          (close-port monitor)
          (wait-for-monitor-prompt monitor-conn)
          (display "read QEMU monitor prompt\n")
          (match (accept repl)
            ((repl-conn . addr)
             (display "connected to guest REPL\n")
             (close-port repl)
             (match (read repl-conn)
               ('ready
                (alarm 0)
                (sigaction SIGALRM SIG_DFL)
                (display "marionette is ready\n")
                (marionette (append command extra-options) pid
                            monitor-conn repl-conn)))))))))))

(define (marionette-eval exp marionette)
  "Evaluate EXP in MARIONETTE's backdoor REPL.  Return the result."
  (match marionette
    (($ <marionette> command pid monitor repl)
     (write exp repl)
     (newline repl)
     (read repl))))

(define (marionette-control command marionette)
  "Run COMMAND in the QEMU monitor of MARIONETTE.  COMMAND is a string such as
\"sendkey ctrl-alt-f1\" or \"screendump foo.ppm\" (info \"(qemu-doc)
pcsys_monitor\")."
  (match marionette
    (($ <marionette> _ _ monitor)
     (display command monitor)
     (newline monitor)
     (wait-for-monitor-prompt monitor))))

(define %qwerty-us-keystrokes
  ;; Maps "special" characters to their keystrokes.
  '((#\newline . "ret")
    (#\space . "spc")
    (#\- . "minus")
    (#\+ . "shift-equal")
    (#\* . "shift-8")
    (#\= . "equal")
    (#\? . "shift-slash")
    (#\[ . "bracket_left")
    (#\] . "bracket_right")
    (#\( . "shift-9")
    (#\) . "shift-0")
    (#\/ . "slash")
    (#\< . "less")
    (#\> . "shift-less")
    (#\. . "dot")
    (#\, . "comma")
    (#\; . "semicolon")
    (#\bs . "backspace")
    (#\tab . "tab")))

(define* (string->keystroke-commands str
                                     #:optional
                                     (keystrokes
                                      %qwerty-us-keystrokes))
  "Return a list of QEMU monitor commands to send the keystrokes corresponding
to STR.  KEYSTROKES is an alist specifying a mapping from characters to
keystrokes."
  (string-fold-right (lambda (chr result)
                       (cons (string-append "sendkey "
                                            (or (assoc-ref keystrokes chr)
                                                (string chr)))
                             result))
                     '()
                     str))

(define* (marionette-type str marionette
                          #:key (keystrokes %qwerty-us-keystrokes))
  "Type STR on MARIONETTE's keyboard, using the KEYSTROKES alist to map characters
to actual keystrokes."
  (for-each (cut marionette-control <> marionette)
            (string->keystroke-commands str keystrokes)))

;;; marionette.scm ends here


context:
space:
mode: