;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
;; Released under the GNU General Public License, version 3 or later.

(use-modules (ice-9 match)
             (gnu system vm)
             (gnu system install)
             (guix)
             (guix ui)
             (gnu packages virtualization))


(define O_CLOEXEC                                 ;missing in Guile 3.0.2
  #o02000000)

(define wait-for-monitor-prompt
  (@@ (gnu build marionette) wait-for-monitor-prompt))

(define (spawn command)
  (match (primitive-fork)
    (0   (dynamic-wind
           (const #t)
           (lambda ()
             (apply execl (car command) command))
           (lambda ()
             (primitive-_exit 42))))
    (pid pid)))

(define (shoot-movie)
  (mlet* %store-monad ((image (system-disk-image installation-os
                                                 #:disk-image-size 'guess))
                       (qemu  (lower-object qemu))
                       (_     (built-derivations (list qemu image))))
    (define disk
      (begin
        (system* (string-append (derivation->output-path qemu)
                                "/bin/qemu-img")
                 "create" "-f" "qcow2" "/tmp/disk.img" "2G")
        "/tmp/disk.img"))

    (define command
      (list (string-append (derivation->output-path qemu)
                           "/bin/qemu-system-x86_64")
            "-enable-kvm" "-m" "512"
            "-drive"
            (string-append "file="
                           (pk (derivation->output-path image))
                           ",if=virtio,cache=writeback,readonly")
            "-monitor" "unix:/tmp/monitor"
            "-drive" "file=/tmp/disk.img,if=virtio"
            "-snapshot"))

    (define monitor
      (socket AF_UNIX SOCK_STREAM 0))

    (bind monitor AF_UNIX "/tmp/monitor")
    (listen monitor 1)
    (fcntl monitor F_SETFL
           (logior O_CLOEXEC (fcntl monitor F_GETFL)))

    (let ((pid (spawn command)))
      (match (accept monitor)
        ((sock . _)
         (wait-for-monitor-prompt sock #:quiet? #f)
         (let loop ((n 0))
           (format sock "screendump /tmp/qemu-movie-~4,48d.ppm~%" n)
           (force-output sock)
           (wait-for-monitor-prompt sock #:quiet? #f)
           (usleep 200000)
           (loop (+ 1 n))))))))

(false-if-exception (delete-file "/tmp/monitor"))

(with-build-handler (build-notifier)
  (with-store store
    (run-with-store store (shoot-movie))))