code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
;;;
;;; 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)
  #:use-module (ice-9 popen)
  #:export (marionette?
            make-marionette
            marionette-eval
            wait-for-file
            wait-for-tcp-port
            wait-for-unix-socket
            marionette-control
            marionette-screen-text
            wait-for-screen-text
            %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))                  ;promise of a port

(define-syntax-rule (marionette-repl marionette)
  (force (%marionette-repl marionette)))

(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")

          ;; See
          ;; <http://www.linux-kvm.org/page/VMchannel_Requirements#Invocation>.
          "-device" "virtio-serial"
          "-device" "virtserialport,chardev=repl,name=org.gnu.guix.port.0"))

  (define (accept* port)
    (match (select (list port) '() (list port) timeout)
      (((port) () ())
       (accept port))
      (_
       (error "timeout in 'accept'" port))))

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

       (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")

          (marionette (append command extra-options) pid
                      monitor-conn

                      ;; The following 'accept' call connects immediately, but
                      ;; we don't know whether the guest has connected until
                      ;; we actually receive the 'ready' message.
                      (match (accept* repl)
                        ((repl-conn . addr)
                         (display "connected to guest REPL\n")
                         (close-port repl)
                         ;; Delay reception of the 'ready' message so that the
                         ;; caller can already send monitor commands.
                         (delay
                           (match (read repl-conn)
                             ('ready
                              (display "marionette is ready\n")
                              repl-conn))))))))))))

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

(define* (wait-for-file file marionette
                        #:key (timeout 10) (read 'read))
  "Wait until FILE exists in MARIONETTE; READ its content and return it.  If
FILE has not shown up after TIMEOUT seconds, raise an error."
  (match (marionette-eval
          `(let loop ((i ,timeout))
             (cond ((file-exists? ,file)
                    (cons 'success (call-with-input-file ,file ,read)))
                   ((> i 0)
                    (sleep 1)
                    (loop (- i 1)))
                   (else
                    'failure)))
          marionette)
    (('success . result)
     result)
    ('failure
     (error "file didn't show up" file))))

(define* (wait-for-tcp-port port marionette
                            #:key (timeout 20))
  "Wait for up to TIMEOUT seconds for PORT to accept connections in
MARIONETTE.  Raise an error on failure."
  ;; Note: The 'connect' loop has to run within the guest because, when we
  ;; forward ports to the host, connecting to the host never raises
  ;; ECONNREFUSED.
  (match (marionette-eval
          `(begin
             (let ((sock (socket PF_INET SOCK_STREAM 0)))
               (let loop ((i 0))
                 (catch 'system-error
                   (lambda ()
                     (connect sock AF_INET INADDR_LOOPBACK ,port)
                     'success)
                   (lambda args
                     (if (< i ,timeout)
                         (begin
                           (sleep 1)
                           (loop (+ 1 i)))
                         'failure))))))
          marionette)
    ('success #t)
    ('failure
     (error "nobody's listening on port" port))))

(define* (wait-for-unix-socket file-name marionette
                                #:key (timeout 20))
  "Wait for up to TIMEOUT seconds for FILE-NAME, a Unix domain socket, to
accept connections in MARIONETTE.  Raise an error on failure."
  (match (marionette-eval
          `(begin
             (let ((sock (socket PF_UNIX SOCK_STREAM 0)))
               (let loop ((i 0))
                 (catch 'system-error
                   (lambda ()
                     (connect sock AF_UNIX ,file-name)
                     'success)
                   (lambda args
                     (if (< i ,timeout)
                         (begin
                           (sleep 1)
                           (loop (+ 1 i)))
                         'failure))))))
          marionette)
    ('success #t)
    ('failure
     (error "nobody's listening on unix domain socket" file-name))))

(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)
     ;; The "quit" command terminates QEMU immediately, with no output.
     (unless (string=? command "quit") (wait-for-monitor-prompt monitor)))))

(define* (marionette-screen-text marionette
                                 #:key
                                 (ocrad "ocrad"))
  "Take a screenshot of MARIONETTE, perform optical character
recognition (OCR), and return the text read from the screen as a string.  Do
this by invoking OCRAD (file name for GNU Ocrad's command)"
  (define (random-file-name)
    (string-append "/tmp/marionette-screenshot-"
                   (number->string (random (expt 2 32)) 16)
                   ".ppm"))

  (let ((image (random-file-name)))
    (dynamic-wind
      (const #t)
      (lambda ()
        (marionette-control (string-append "screendump " image)
                            marionette)

        ;; Tell Ocrad to invert the image colors (make it black on white) and
        ;; to scale the image up, which significantly improves the quality of
        ;; the result.  In spite of this, be aware that OCR confuses "y" and
        ;; "V" and sometimes erroneously introduces white space.
        (let* ((pipe (open-pipe* OPEN_READ ocrad
                                 "-i" "-s" "10" image))
               (text (get-string-all pipe)))
          (unless (zero? (close-pipe pipe))
            (error "'ocrad' failed" ocrad))
          text))
      (lambda ()
        (false-if-exception (delete-file image))))))

(define* (wait-for-screen-text marionette predicate
                               #:key (timeout 30) (ocrad "ocrad"))
  "Wait for TIMEOUT seconds or until the screen text on MARIONETTE matches
PREDICATE, whichever comes first.  Raise an error when TIMEOUT is exceeded."
  (define start
    (car (gettimeofday)))

  (define end
    (+ start timeout))

  (let loop ()
    (if (> (car (gettimeofday)) end)
        (error "'wait-for-screen-text' timeout" predicate)
        (or (predicate (marionette-screen-text marionette #:ocrad ocrad))
            (begin
              (sleep 1)
              (loop))))))

(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")
    (#\' . "apostrophe")
    (#\" . "shift-apostrophe")
    (#\` . "grave_accent")
    (#\bs . "backspace")
    (#\tab . "tab")))

(define (character->keystroke chr keystrokes)
  "Return the keystroke for CHR according to the keyboard layout defined by
KEYSTROKES."
  (if (char-set-contains? char-set:upper-case chr)
      (string-append "shift-" (string (char-downcase chr)))
      (or (assoc-ref keystrokes chr)
          (string chr))))

(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 "
                              (character->keystroke chr keystrokes))
                             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


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2018 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 shepherd)
  #:use-module (gnu system file-systems)
  #:use-module (gnu build linux-container)
  #:use-module (guix build utils)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:export (make-forkexec-constructor/container))

;;; Commentary:
;;;
;;; This module provides extensions to the GNU Shepherd.  In particular, it
;;; provides a helper to start services in a container.
;;;
;;; Code:

(define (clean-up file)
  (when file
    (catch 'system-error
      (lambda ()
        (delete-file file))
      (lambda args
        (unless (= ENOENT (system-error-errno args))
          (apply throw args))))))

(define-syntax-rule (catch-system-error exp)
  (catch 'system-error
    (lambda ()
      exp)
    (const #f)))

(define (default-namespaces args)
  ;; Most daemons are here to talk to the network, and most of them expect to
  ;; run under a non-zero UID.
  (fold delq %namespaces '(net user)))

(define* (default-mounts #:key (namespaces (default-namespaces '())))
  (define (tmpfs directory)
    (file-system
      (device "none")
      (mount-point directory)
      (type "tmpfs")
      (check? #f)))

  (define accounts
    ;; This is for processes in the default user namespace but living in a
    ;; different mount namespace, so that they can lookup users.
    (list (file-system-mapping
           (source "/etc/passwd") (target source))
          (file-system-mapping
           (source "/etc/group") (target source))))

  (define nscd-socket
    (file-system-mapping
     (source "/var/run/nscd") (target source)
     (writable? #t)))

  (append (cons (tmpfs "/tmp") %container-file-systems)
          (let ((mappings `(,@(if (memq 'net namespaces)
                                  '()
                                  (cons nscd-socket
                                        %network-file-mappings))
                            ,@(if (and (memq 'mnt namespaces)
                                       (not (memq 'user namespaces)))
                                  accounts
                                  '())
                            ,%store-mapping)))    ;XXX: coarse-grain
            (map file-system-mapping->bind-mount
                 (filter (lambda (mapping)
                           (file-exists? (file-system-mapping-source mapping)))
                         mappings)))))

;; XXX: Lazy-bind the Shepherd to avoid a compile-time dependency.
(module-autoload! (current-module)
                  '(shepherd service) '(read-pid-file exec-command))

(define* (read-pid-file/container pid pid-file #:key (max-delay 5))
  "Read PID-FILE in the container namespaces of PID, which exists in a
separate mount and PID name space.  Return the \"outer\" PID. "
  (match (container-excursion* pid
           (lambda ()
             (read-pid-file pid-file
                            #:max-delay max-delay)))
    (#f
     (catch-system-error (kill pid SIGTERM))
     #f)
    ((? integer? container-pid)
     ;; XXX: When COMMAND is started in a separate PID namespace, its
     ;; PID is always 1, but that's not what Shepherd needs to know.
     pid)))

(define* (make-forkexec-constructor/container command
                                              #:key
                                              (namespaces
                                               (default-namespaces args))
                                              (mappings '())
                                              (user #f)
                                              (group #f)
                                              (log-file #f)
                                              pid-file
                                              (pid-file-timeout 5)
                                              (directory "/")
                                              (environment-variables
                                               (environ))
                                              #:rest args)
  "This is a variant of 'make-forkexec-constructor' that starts COMMAND in
NAMESPACES, a list of Linux namespaces such as '(mnt ipc).  MAPPINGS is the
list of <file-system-mapping> to make in the case of a separate mount
namespace, in addition to essential bind-mounts such /proc."
  (define container-directory
    (match command
      ((program _  ...)
       (string-append "/var/run/containers/" (basename program)))))

  (define auto-mappings
    `(,@(if log-file
            (list (file-system-mapping
                   (source log-file)
                   (target source)
                   (writable? #t)))
            '())))

  (define mounts
    (append (map file-system-mapping->bind-mount
                 (append auto-mappings mappings))
            (default-mounts #:namespaces namespaces)))

  (lambda args
    (mkdir-p container-directory)

    (when log-file
      ;; Create LOG-FILE so we can map it in the container.
      (unless (file-exists? log-file)
        (call-with-output-file log-file (const #t))))

    (let ((pid (run-container container-directory
                              mounts namespaces 1
                              (lambda ()
                                (mkdir-p "/var/run")
                                (clean-up pid-file)
                                (clean-up log-file)

                                (exec-command command
                                              #:user user
                                              #:group group
                                              #:log-file log-file
                                              #:directory directory
                                              #:environment-variables
                                              environment-variables)))))
      (if pid-file
          (if (or (memq 'mnt namespaces) (memq 'pid namespaces))
              (read-pid-file/container pid pid-file
                                       #:max-delay pid-file-timeout)
              (read-pid-file pid-file #:max-delay pid-file-timeout))
          pid))))

;; Local Variables:
;; eval: (put 'container-excursion* 'scheme-indent-function 1)
;; End:

;;; shepherd.scm ends here

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Andy Wingo <wingo@igalia.com>
;;;
;;; 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 svg)
  #:use-module (rsvg)
  #:use-module (cairo)
  #:use-module (srfi srfi-11)
  #:export (svg->png))

(define* (downscaled-surface surface
                             #:key
                             source-width source-height
                             width height)
  "Return a new rendering context where SURFACE is scaled to WIDTH x HEIGHT."
  (let ((cr (cairo-create (cairo-image-surface-create 'argb32
                                                      width height))))
    (cairo-scale cr (/ width source-width) (/ height source-height))
    (cairo-set-source-surface cr surface 0 0)
    (cairo-pattern-set-filter (cairo-get-source cr) 'best)
    (cairo-rectangle cr 0 0 source-width source-height)
    (cairo-fill cr)
    cr))

(define* (svg->png in-svg out-png
                   #:key width height)
  "Render the file at IN-SVG as a PNG file in OUT-PNG.  When WIDTH and HEIGHT
are provided, use them as the dimensions of OUT-PNG; otherwise preserve the
dimensions of IN-SVG."
  (define svg
    (rsvg-handle-new-from-file in-svg))

  (let-values (((origin-width origin-height em ex)
                (rsvg-handle-get-dimensions svg)))
    (let* ((surf (cairo-image-surface-create 'argb32
                                             origin-width origin-height))
           (cr   (cairo-create surf)))
      (rsvg-handle-render-cairo svg cr)
      (cairo-surface-flush surf)
      (let ((cr (if (and width height
                         (not (= width origin-width))
                         (not (= height origin-height)))
                    (downscaled-surface surf
                                        #:source-width origin-width
                                        #:source-height origin-height
                                        #:width width
                                        #:height height)
                    cr)))
        (cairo-surface-write-to-png (cairo-get-target cr) out-png)))))

;;; svg.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
;;;
;;; 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 vm)
  #:use-module (guix build utils)
  #:use-module (guix build store-copy)
  #:use-module (guix build syscalls)
  #:use-module ((guix store database) #:select (reset-timestamps))
  #:use-module (gnu build linux-boot)
  #:use-module (gnu build install)
  #:use-module (gnu system uuid)
  #:use-module (guix records)
  #:use-module ((guix combinators) #:select (fold2))
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 popen)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)
  #:export (qemu-command
            load-in-linux-vm
            format-partition

            partition
            partition?
            partition-device
            partition-size
            partition-file-system
            partition-label
            partition-flags
            partition-initializer

            estimated-partition-size
            root-partition-initializer
            initialize-partition-table
            initialize-hard-disk
            make-iso9660-image))

;;; Commentary:
;;;
;;; This module provides supporting code to run virtual machines and build
;;; virtual machine images using QEMU.
;;;
;;; Code:

(define* (qemu-command #:optional (system %host-type))
  "Return the default name of the QEMU command for SYSTEM."
  (let ((cpu (substring system 0
                        (string-index system #\-))))
    (string-append "qemu-system-"
                   (if (string-match "^i[3456]86$" cpu)
                       "i386"
                       cpu))))

(define* (load-in-linux-vm builder
                           #:key
                           output
                           (qemu (qemu-command)) (memory-size 512)
                           linux initrd
                           make-disk-image?
                           single-file-output?
                           target-arm32?
                           (disk-image-size (* 100 (expt 2 20)))
                           (disk-image-format "qcow2")
                           (references-graphs '()))
  "Run BUILDER, a Scheme file, into a VM running LINUX with INITRD, and copy
the result to OUTPUT.  If SINGLE-FILE-OUTPUT? is true, copy a single file from
/xchg to OUTPUT.  Otherwise, copy the contents of /xchg to a new directory
OUTPUT.

When MAKE-DISK-IMAGE? is true, OUTPUT will contain a VM image of
DISK-IMAGE-SIZE bytes resulting from the execution of BUILDER, which may
access it via /dev/hda.

REFERENCES-GRAPHS can specify a list of reference-graph files as produced by
the #:references-graphs parameter of 'derivation'."

  (define arch-specific-flags
    `(;; On ARM, a machine has to be specified. Use "virt" machine to avoid
      ;; hardware limits imposed by other machines.
      ,@(if target-arm32? '("-M" "virt") '())

      ;; Only enable kvm if we see /dev/kvm exists.  This allows users without
      ;; hardware virtualization to still use these commands.  KVM support is
      ;; still buggy on some ARM32 boards. Do not use it even if available.
      ,@(if (and (file-exists? "/dev/kvm")
                 (not target-arm32?)

                 ;; XXX: 32-bit 'qemu-system-i386 -enable-kvm' segfaults on
                 ;; x86_64 hosts running Linux-libre 4.17:
                 ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=31380#18> and
                 ;; <https://lists.gnu.org/archive/html/qemu-devel/2018-07/msg01166.html>.
                 (not (string-suffix? "-i386" qemu)))
            '("-enable-kvm")
            '())

      ;; Pass "panic=1" so that the guest dies upon error.
      "-append"
      ,(string-append "panic=1 --load=" builder

                      ;; The serial port name differs between emulated
                      ;; architectures/machines.
                      " console="
                      (if target-arm32? "ttyAMA0" "ttyS0"))

      ;; NIC is not supported on ARM "virt" machine, so use a user mode
      ;; network stack instead.
      ,@(if target-arm32?
            '("-device" "virtio-net-pci,netdev=mynet"
              "-netdev" "user,id=mynet")
            '("-net" "nic,model=virtio"))))

  (when make-disk-image?
    (format #t "creating ~a image of ~,2f MiB...~%"
            disk-image-format (/ disk-image-size (expt 2 20)))
    (force-output)
    (invoke "qemu-img" "create" "-f" disk-image-format output
             (number->string disk-image-size)))

  (mkdir "xchg")
  (mkdir "tmp")

  (match references-graphs
    ((graph-files ...)
     ;; Copy the reference-graph files under xchg/ so EXP can access it.
     (map (lambda (file)
            (copy-file file (string-append "xchg/" file)))
          graph-files))
    (_ #f))

  (apply invoke qemu "-nographic" "-no-reboot"
         "-m" (number->string memory-size)
         "-object" "rng-random,filename=/dev/urandom,id=guixsd-vm-rng"
         "-device" "virtio-rng-pci,rng=guixsd-vm-rng"
         "-virtfs"
         (string-append "local,id=store_dev,path="
                        (%store-directory)
                        ",security_model=none,mount_tag=store")
         "-virtfs"
         (string-append "local,id=xchg_dev,path=xchg"
                        ",security_model=none,mount_tag=xchg")
         "-virtfs"
         ;; Some programs require more space in /tmp than is normally
         ;; available in the guest.  Accommodate such programs by sharing a
         ;; temporary directory.
         (string-append "local,id=tmp_dev,path=tmp"
                        ",security_model=none,mount_tag=tmp")
         "-kernel" linux
         "-initrd" initrd
         (append
          (if make-disk-image?
              `("-device" "virtio-blk,drive=myhd"
                "-drive" ,(string-append "if=none,file=" output
                                         ",format=" disk-image-format
                                         ",id=myhd"))
              '())
          arch-specific-flags))

  ;; When MAKE-DISK-IMAGE? is true, the image is in OUTPUT already.
  (unless make-disk-image?
    (if single-file-output?
        (let ((graph? (lambda (name stat)
                        (member (basename name) references-graphs))))
          (match (find-files "xchg" (negate graph?))
            ((result)
             (copy-file result output))
            (x
             (error "did not find a single result file" x))))
        (begin
          (mkdir output)
          (copy-recursively "xchg" output)))))

;;;
;;; Partitions.
;;;

(define-record-type* <partition> partition make-partition
  partition?
  (device      partition-device (default #f))
  (size        partition-size)
  (file-system partition-file-system (default "ext4"))
  (label       partition-label (default #f))
  (uuid        partition-uuid (default #f))
  (flags       partition-flags (default '()))
  (initializer partition-initializer (default (const #t))))

(define (estimated-partition-size graphs)
  "Return the estimated size of a partition that can store the store items
given by GRAPHS, a list of file names produced by #:references-graphs."
  ;; Simply add a 25% overhead.
  (round (* 1.25 (closure-size graphs))))

(define* (initialize-partition-table device partitions
                                     #:key
                                     (label-type "msdos")
                                     (offset (expt 2 20)))
  "Create on DEVICE a partition table of type LABEL-TYPE, containing the given
PARTITIONS (a list of <partition> objects), starting at OFFSET bytes.  On
success, return PARTITIONS with their 'device' field changed to reflect their
actual /dev name based on DEVICE."
  (define (partition-options part offset index)
    (cons* "mkpart" "primary" "ext2"
           (format #f "~aB" offset)
           (format #f "~aB" (+ offset (partition-size part)))
           (append-map (lambda (flag)
                         (list "set" (number->string index)
                               (symbol->string flag) "on"))
                       (partition-flags part))))

  (define (options partitions offset)
    (let loop ((partitions partitions)
               (offset     offset)
               (index      1)
               (result     '()))
      (match partitions
        (()
         (concatenate (reverse result)))
        ((head tail ...)
         (loop tail
               ;; Leave one sector (512B) between partitions to placate
               ;; Parted.
               (+ offset 512 (partition-size head))
               (+ 1 index)
               (cons (partition-options head offset index)
                     result))))))

  (format #t "creating partition table with ~a partitions (~a)...\n"
          (length partitions)
          (string-join (map (compose (cut string-append <> " MiB")
                                     number->string
                                     (lambda (size)
                                       (round (/ size (expt 2. 20))))
                                     partition-size)
                            partitions)
                       ", "))
  (apply invoke "parted" "--script"
         device "mklabel" label-type
         (options partitions offset))

  ;; Set the 'device' field of each partition.
  (reverse
   (fold2 (lambda (part result index)
            (values (cons  (partition
                            (inherit part)
                            (device (string-append device
                                                   (number->string index))))
                           result)
                    (+ 1 index)))
          '()
          1
          partitions)))

(define MS_BIND 4096)                             ; <sys/mounts.h> again!

(define* (create-ext-file-system partition type
                                 #:key label uuid)
  "Create an ext-family file system of TYPE on PARTITION.  If LABEL is true,
use that as the volume name.  If UUID is true, use it as the partition UUID."
  (format #t "creating ~a partition... ~@[label: ~s~] ~@[uuid: ~s~]\n"
          type label (and uuid (uuid->string uuid)))
  (apply invoke (string-append "mkfs." type)
         "-F" partition
         `(,@(if label
                 `("-L" ,label)
                 '())
           ,@(if uuid
                 `("-U" ,(uuid->string uuid))
                 '()))))

(define* (create-fat-file-system partition
                                 #:key label uuid)
  "Create a FAT file system on PARTITION.  The number of File Allocation Tables
will be determined based on file system size.  If LABEL is true, use that as the
volume name."
  ;; FIXME: UUID is ignored!
  (format #t "creating FAT partition...\n")
  (apply invoke "mkfs.fat" partition
         (if label `("-n" ,label) '())))

(define* (format-partition partition type
                           #:key label uuid)
  "Create a file system TYPE on PARTITION.  If LABEL is true, use that as the
volume name."
  (cond ((string-prefix? "ext" type)
         (create-ext-file-system partition type #:label label #:uuid uuid))
        ((or (string-prefix? "fat" type) (string= "vfat" type))
         (create-fat-file-system partition #:label label #:uuid uuid))
        (else (error "Unsupported file system."))))

(define (initialize-partition partition)
  "Format PARTITION, a <partition> object with a non-#f 'device' field, mount
it, run its initializer, and unmount it."
  (let ((target "/fs"))
   (format-partition (partition-device partition)
                     (partition-file-system partition)
                     #:label (partition-label partition)
                     #:uuid (partition-uuid partition))
   (mkdir-p target)
   (mount (partition-device partition) target
          (partition-file-system partition))

   ((partition-initializer partition) target)

   (umount target)
   partition))

(define* (root-partition-initializer #:key (closures '())
                                     copy-closures?
                                     (register-closures? #t)
                                     system-directory
                                     (deduplicate? #t))
  "Return a procedure to initialize a root partition.

If REGISTER-CLOSURES? is true, register all of CLOSURES in the partition's
store.  If DEDUPLICATE? is true, then also deduplicate files common to
CLOSURES and the rest of the store when registering the closures.  If
COPY-CLOSURES? is true, copy all of CLOSURES to the partition.
SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation."
  (lambda (target)
    (define target-store
      (string-append target (%store-directory)))

    (when copy-closures?
      ;; Populate the store.
      (populate-store (map (cut string-append "/xchg/" <>) closures)
                      target))

    ;; Populate /dev.
    (make-essential-device-nodes #:root target)

    ;; Optionally, register the inputs in the image's store.
    (when register-closures?
      (unless copy-closures?
        ;; XXX: 'register-closure' wants to palpate the things it registers, so
        ;; bind-mount the store on the target.
        (mkdir-p target-store)
        (mount (%store-directory) target-store "" MS_BIND))

      (display "registering closures...\n")
      (for-each (lambda (closure)
                  (register-closure target
                                    (string-append "/xchg/" closure)
                                    #:reset-timestamps? copy-closures?
                                    #:deduplicate? deduplicate?))
                closures)
      (unless copy-closures?
        (umount target-store)))

    ;; Add the non-store directories and files.
    (display "populating...\n")
    (populate-root-file-system system-directory target)

    ;; 'register-closure' resets timestamps and everything, so no need to do it
    ;; once more in that case.
    (unless register-closures?
      (reset-timestamps target))))

(define (register-bootcfg-root target bootcfg)
  "On file system TARGET, register BOOTCFG as a GC root."
  (let ((directory (string-append target "/var/guix/gcroots")))
    (mkdir-p directory)
    (symlink bootcfg (string-append directory "/bootcfg"))))

(define (install-efi grub esp config-file)
  "Write a self-contained GRUB EFI loader to the mounted ESP using CONFIG-FILE."
  (let* ((system %host-type)
         ;; Hard code the output location to a well-known path recognized by
         ;; compliant firmware. See "3.5.1.1 Removable Media Boot Behaviour":
         ;; http://www.uefi.org/sites/default/files/resources/UEFI%20Spec%202_6.pdf
         (grub-mkstandalone (string-append grub "/bin/grub-mkstandalone"))
         (efi-directory (string-append esp "/EFI/BOOT"))
         ;; Map grub target names to boot file names.
         (efi-targets (cond ((string-prefix? "x86_64" system)
                             '("x86_64-efi" . "BOOTX64.EFI"))
                            ((string-prefix? "i686" system)
                             '("i386-efi" . "BOOTIA32.EFI"))
                            ((string-prefix? "armhf" system)
                             '("arm-efi" . "BOOTARM.EFI"))
                            ((string-prefix? "aarch64" system)
                             '("arm64-efi" . "BOOTAA64.EFI")))))
    ;; grub-mkstandalone requires a TMPDIR to prepare the firmware image.
    (setenv "TMPDIR" esp)

    (mkdir-p efi-directory)
    (invoke grub-mkstandalone "-O" (car efi-targets)
            "-o" (string-append efi-directory "/"
                                (cdr efi-targets))
            ;; Graft the configuration file onto the image.
            (string-append "boot/grub/grub.cfg=" config-file))))

(define* (make-iso9660-image grub config-file os-drv target
                             #:key (volume-id "GuixSD_image") (volume-uuid #f)
                             register-closures? (closures '()))
  "Given a GRUB package, creates an iso image as TARGET, using CONFIG-FILE as
GRUB configuration and OS-DRV as the stuff in it."
  (define grub-mkrescue
    (string-append grub "/bin/grub-mkrescue"))

  (define target-store
    (string-append "/tmp/root" (%store-directory)))

  (define items
    ;; The store items to add to the image.
    (delete-duplicates
     (append-map (lambda (closure)
                   (map store-info-item
                        (call-with-input-file (string-append "/xchg/" closure)
                          read-reference-graph)))
                 closures)))

  (populate-root-file-system os-drv "/tmp/root")
  (mount (%store-directory) target-store "" MS_BIND)

  (when register-closures?
    (display "registering closures...\n")
    (for-each (lambda (closure)
                (register-closure
                 "/tmp/root"
                 (string-append "/xchg/" closure)

                 ;; TARGET-STORE is a read-only bind-mount so we shouldn't try
                 ;; to modify it.
                 #:deduplicate? #f
                 #:reset-timestamps? #f))
              closures)
    (register-bootcfg-root "/tmp/root" config-file))

  (let ((pipe
         (apply open-pipe* OPEN_WRITE
                grub-mkrescue "-o" target
                (string-append "boot/grub/grub.cfg=" config-file)
                "etc=/tmp/root/etc"
                "var=/tmp/root/var"
                "run=/tmp/root/run"
                ;; /mnt is used as part of the installation
                ;; process, as the mount point for the target
                ;; file system, so create it.
                "mnt=/tmp/root/mnt"
                "-path-list" "-"
                "--"
                "-volid" (string-upcase volume-id)
                (if volume-uuid
                    `("-volume_date" "uuid"
                      ,(string-filter (lambda (value)
                                        (not (char=? #\- value)))
                                      (iso9660-uuid->string
                                       volume-uuid)))
                    `()))))
    ;; Pass lines like 'gnu/store/…-x=/gnu/store/…-x' corresponding to the
    ;; '-path-list -' option.
    (for-each (lambda (item)
                (format pipe "~a=~a~%"
                        (string-drop item 1) item))
              items)
    (unless (zero? (close-pipe pipe))
      (error "oh, my! grub-mkrescue failed" grub-mkrescue))))

(define* (initialize-hard-disk device
                               #:key
                               bootloader-package
                               bootcfg
                               bootcfg-location
                               bootloader-installer
                               (grub-efi #f)
                               (partitions '()))
  "Initialize DEVICE as a disk containing all the <partition> objects listed
in PARTITIONS, and using BOOTCFG as its bootloader configuration file.

Each partition is initialized by calling its 'initializer' procedure,
passing it a directory name where it is mounted."

  (define (partition-bootable? partition)
    "Return the first partition found with the boot flag set."
    (member 'boot (partition-flags partition)))

  (define (partition-esp? partition)
    "Return the first EFI System Partition."
    (member 'esp (partition-flags partition)))

  (let* ((partitions (initialize-partition-table device partitions))
         (root       (find partition-bootable? partitions))
         (esp        (find partition-esp? partitions))
         (target     "/fs"))
    (unless root
      (error "no bootable partition specified" partitions))

    (for-each initialize-partition partitions)

    (display "mounting root partition...\n")
    (mkdir-p target)
    (mount (partition-device root) target (partition-file-system root))
    (install-boot-config bootcfg bootcfg-location target)
    (when bootloader-installer
      (display "installing bootloader...\n")
      (bootloader-installer bootloader-package device target))

    (when esp
      ;; Mount the ESP somewhere and install GRUB UEFI image.
      (let ((mount-point (string-append target "/boot/efi"))
            (grub-config (string-append target "/tmp/grub-standalone.cfg")))
        (display "mounting EFI system partition...\n")
        (mkdir-p mount-point)
        (mount (partition-device esp) mount-point
               (partition-file-system esp))

        ;; Create a tiny configuration file telling the embedded grub
        ;; where to load the real thing.
        ;; XXX This is quite fragile, and can prevent the image from booting
        ;; when there's more than one volume with this label present.
        ;; Reproducible almost-UUIDs could reduce the risk (not eliminate it).
        (call-with-output-file grub-config
          (lambda (port)
            (format port
                    "insmod part_msdos~@
                    search --set=root --label GuixSD_image~@
                    configfile /boot/grub/grub.cfg~%")))

        (display "creating EFI firmware image...")
        (install-efi grub-efi mount-point grub-config)
        (display "done.\n")

        (delete-file grub-config)
        (umount mount-point)))

    ;; Register BOOTCFG as a GC root.
    (register-bootcfg-root target bootcfg)

    (umount target)))

;;; vm.scm ends here