#!/bin/sh
#| -*- scheme -*-
exec csi -s $0 "$@"
|#

(import (chicken base)
        (chicken format)
        (chicken string)
        (chicken pathname)
        (chicken process)
        (chicken process-context))

(define (usage #!optional exit-code)
  (let* ((port (if (and exit-code (not (zero? exit-code)))
                   (current-error-port)
                   (current-output-port)))
         (prog (pathname-strip-directory (program-name)))
         (msg #<#EOF
Usage: #prog [<options>] [<qemu params>] <disk>

<options>:
-mem <size>        RAM size in MB.  Default=2048.
-iso <file>        Path to an iso file to boot from.
-cpus <num>        Number of CPUs to use. Default=2.
-port <port>       SSH port. Default=2222.
-headless          Headless mode.
-nonet             Disable networking.
-vda <disk image>  Path to an extra disk image.
-emulator <emu>    Emulator and arguments to use.  Default: kvm -cpu host.

EOF
))
    (fprintf port msg)
    (when exit-code (exit exit-code))))

(define (die! fmt . args)
  (apply fprintf (cons (current-error-port)
                       (cons (string-append fmt "\n")
                             args)))
  (exit 1))

(define default-emulator "kvm -cpu host") ;; x86-64

(define (run-kvm cpus ram disk port headless? network?
                 #!key iso
                       vda
                       (qemu-params '())
                       emulator)
  (let ((cmd
         (string-append
          (or emulator default-emulator)
          (sprintf " -smp ~a" cpus)
          (sprintf " -m ~a" ram)
          (sprintf " -hda ~a" disk)
          " "
          (if network?
              (sprintf
               (string-append
                "-netdev user,id=net0,ipv6=off,hostfwd=tcp::~a-:22"
                " -device e1000,netdev=net0")
               port)
              "-nic none")
          " "
          (if headless?
              "-display none"
              "-vga std")
          (if iso
              (sprintf " -boot d -cdrom ~a" (qs iso))
              "")
          (if vda
              (sprintf " -drive file=~a,format=qcow2,if=virtio" (qs vda))
              "")
          (if (null? qemu-params)
              ""
              (string-intersperse qemu-params))
          )))
    (print cmd)
    (system* cmd)))

(let ((args (command-line-arguments)))
  (when (null? args)
    (usage 1))

  (when (or (member "-h" args)
            (member "-help" args)
            (member "--help" args))
    (usage 0))

  (let ((disk #f)
        (iso #f)
        (cpus 2)
        (ram 2048)  ;; 2GiB
        (port 2222)
        (headless? #f)
        (network? #t)
        (vda #f)
        (qemu-params '())
        (emulator #f))
    (let loop ((args args))
      (unless (null? args)
        (let ((arg (car args)))
          (cond ((string=? arg "-cpus")
                 (if (null? (cdr args))
                     (die! "-cpus: missing argument.")
                     (begin
                       (set! cpus (cadr args))
                       (loop (cddr args)))))
                ((string=? arg "-mem")
                 (if (null? (cdr args))
                     (die! "-mem: missing argument.")
                     (begin
                       (set! ram (cadr args))
                       (loop (cddr args)))))
                ((string=? arg "-port")
                 (if (null? (cdr args))
                     (die! "-port: missing argument.")
                     (begin
                       (set! port (cadr args))
                       (loop (cddr args)))))
                ((string=? arg "-iso")
                 (if (null? (cdr args))
                     (die! "-iso: missing argument.")
                     (begin
                       (set! iso (cadr args))
                       (loop (cddr args)))))
                ((string=? arg "-vda")
                 (if (null? (cdr args))
                     (die! "-vda: missing argument.")
                     (begin
                       (set! vda (cadr args))
                       (loop (cddr args)))))
                ((string=? arg "-emulator")
                 (if (null? (cdr args))
                     (die! "-emulator: missing argument.")
                     (begin
                       (set! emulator (cadr args))
                       (loop (cddr args)))))
                ((string=? arg "-headless")
                 (set! headless? #t)
                 (loop (cdr args)))
                ((string=? arg "-nonet")
                 (set! network? #f)
                 (loop (cdr args)))
                (else
                 (if (null? (cdr args))
                     (set! disk arg)
                     (begin
                       (set! qemu-params (append qemu-params (list arg)))
                       (loop (cdr args)))))))))

    (unless disk
      (usage 1))

    (run-kvm cpus ram disk port headless? network?
             iso: iso
             vda: vda
             qemu-params: qemu-params
             emulator: emulator)))