From 61590e3ef27817ec687ce33e6cf395c266b2b461 Mon Sep 17 00:00:00 2001
From: Christopher Allan Webber <cwebber@dustycloud.org>
Date: Mon, 3 Aug 2015 16:33:52 -0500
Subject: [PATCH] redir-ports test

---
 gnu/machines.scm  |  6 ++++--
 gnu/system/vm.scm | 13 +++++++++++++
 2 files changed, 17 insertions(+), 2 deletions(-)

diff --git a/gnu/machines.scm b/gnu/machines.scm
index a02f668..e676e62 100644
--- a/gnu/machines.scm
+++ b/gnu/machines.scm
@@ -97,7 +97,8 @@
              (gnu services networking))
 
 (define* (local-vm #:key (ip-address "10.0.2.10")
-                   (disk-image-size (* 32 (expt 2 20))))
+                   (disk-image-size (* 32 (expt 2 20)))
+                   (redir-ports '()))
   (platform
    (name "local-vm")
    (description "Local QEMU/KVM platform")
@@ -115,7 +116,8 @@
     (lambda (os)
       (mlet %store-monad
           ((vm-script (system-qemu-image/shared-store-script
-                       os #:disk-image-size disk-image-size)))
+                       os #:disk-image-size disk-image-size
+                       #:redir-ports redir-ports)))
         (mbegin %store-monad
           (built-derivations (list vm-script))
           (return (derivation-output-path
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index fcc61b3..2bc5696 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -471,6 +471,7 @@ with '-virtfs' options for the host file systems listed in SHARED-FS."
                                                 (graphic? #t)
                                                 (mappings '())
                                                 full-boot?
+                                                (redir-ports '())
                                                 (disk-image-size
                                                  (* (if full-boot? 500 15)
                                                     (expt 2 20))))
@@ -503,7 +504,19 @@ exec " #$qemu "/bin/" #$(qemu-command (%current-system))
             -initrd " #$os-drv "/initrd \
             -append \"" #$(if graphic? "" "console=ttyS0 ")
             "--system=" #$os-drv " --load=" #$os-drv "/boot --root=/dev/vda1 "
+            #$@(map (lambda (x)
+                      (let ((build-redir
+                             (lambda (host-port guest-port)
+                               (format #f " -redir tcp:~a::~a "
+                                       host-port guest-port))))
+                        (match x
+                          ((host-port guest-port)
+                           (build-redir host-port guest-port))
+                          (port
+                           (build-redir port port)))))
+                    redir-ports)
             (string-join (list #+@(operating-system-kernel-arguments os))) "\" "))
+
 #$(common-qemu-options image
                        (map file-system-mapping-source
                             (cons %store-mapping mappings)))
-- 
2.1.4