bug#42252: Not possible to reliably port forward with "guix system vm" anymore

[Christopher Lemmer Webber <cwebber@dustycloud.org>]

[-- Attachment #1: Type: text/plain, Size: 418 bytes --]

Christopher Lemmer Webber writes:

> Christopher Lemmer Webber writes:
>
>>   guix system vm config.scm --hostfwd=tcp::10022-:22 --hostfwd=tcp::8888-:80
>>
>> kind of ugly, but it could work.  WDYT?
>
> Kind of uglier, but more versatile:
>
>   guix system vm config.scm --nic=user,model=virtio-net-pci,hostfwd=tcp::10022-:22,hostfwd=tcp::8888-:80

Here's a patch that implements just that.  Seems to work fine here!


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-guix-system-Add-nic-option-for-vm-subcommand.patch --]
[-- Type: text/x-patch, Size: 7676 bytes --]

From b008aad5d00fb6a87eb5a03d1849d6f52fb2307d Mon Sep 17 00:00:00 2001
From: Christopher Lemmer Webber <cwebber@dustycloud.org>
Date: Tue, 7 Jul 2020 18:13:29 -0400
Subject: [PATCH] guix system: Add --nic option for 'vm' subcommand.

This allows passing in explicit options for the qemu -nic keyword argument
for use in port forwarding, etc.

* (show-help, %options, process-action): Add and use command line
  argument of --nic for `guix system vm' and pass along appropriately.
  guix/scripts/system.scm (system-derivation-for-action):
  (perform-action): Define and use #:nic-options keyword.
* gnu/system/vm.scm (common-qemu-options)
  (system-qemu-image/shared-store-script): Likewise.
  (default-nic-options): New variable.
* doc/guix.texi (Running Guix in a VM): Use --nic argument in system vm port
  forwarding example.
---
 doc/guix.texi           |  2 +-
 gnu/system/vm.scm       | 16 ++++++++++++----
 guix/scripts/system.scm | 18 ++++++++++++++----
 3 files changed, 27 insertions(+), 9 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 992bc303bb..4e76eb832a 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -28315,7 +28315,7 @@ To enable SSH inside a VM you need to add an SSH server like
 22 by default, to the host.  You can do this with
 
 @example
-`guix system vm config.scm` -nic user,model=virtio-net-pci,hostfwd=tcp::10022-:22
+`guix system vm config.scm --nic=user,model=virtio-net-pci,hostfwd=tcp::10022-:22`
 @end example
 
 To connect to the VM you can run
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index f2b6b71b4d..78f89f6568 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -803,7 +803,11 @@ bootloader refers to: OS kernel, initrd, bootloader data, etc."
               #:register-closures? #f
               #:copy-inputs? full-boot?))
 
-(define* (common-qemu-options image shared-fs)
+(define default-nic-options
+  "user,model=virtio-net-pci")
+
+(define* (common-qemu-options image shared-fs
+                              #:key nic-options)
   "Return the a string-value gexp with the common QEMU options to boot IMAGE,
 with '-virtfs' options for the host file systems listed in SHARED-FS."
 
@@ -819,7 +823,9 @@ with '-virtfs' options for the host file systems listed in SHARED-FS."
             '())
 
      "-no-reboot"
-     "-nic" "user,model=virtio-net-pci"
+
+     ;; Construct -nic while forwarding all --hostfwd=... options
+     "-nic" #$(or nic-options default-nic-options)
      "-object" "rng-random,filename=/dev/urandom,id=guixsd-vm-rng"
      "-device" "virtio-rng-pci,rng=guixsd-vm-rng"
 
@@ -840,7 +846,8 @@ with '-virtfs' options for the host file systems listed in SHARED-FS."
                                                 (disk-image-size
                                                  (* (if full-boot? 500 70)
                                                     (expt 2 20)))
-                                                (options '()))
+                                                (options '())
+                                                (nic-options #f))
   "Return a derivation that builds a script to run a virtual machine image of
 OS that shares its store with the host.  The virtual machine runs with
 MEMORY-SIZE MiB of memory.
@@ -874,7 +881,8 @@ it is mostly useful when FULL-BOOT?  is true."
                                 (string-join #$kernel-arguments " "))))
               #$@(common-qemu-options image
                                       (map file-system-mapping-source
-                                           (cons %store-mapping mappings)))
+                                           (cons %store-mapping mappings))
+                                      #:nic-options nic-options)
               "-m " (number->string #$memory-size)
               #$@options))
 
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 61eeec622b..32cea9b184 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -684,7 +684,7 @@ checking this by themselves in their 'check' procedure."
 (define* (system-derivation-for-action os base-image action
                                        #:key image-size file-system-type
                                        full-boot? container-shared-network?
-                                       mappings)
+                                       mappings nic-options)
   "Return as a monadic value the derivation for OS according to ACTION."
   (case action
     ((build init reconfigure)
@@ -703,7 +703,8 @@ checking this by themselves in their 'check' procedure."
                                             (if full-boot?
                                                 image-size
                                                 (* 70 (expt 2 20)))
-                                            #:mappings mappings))
+                                            #:mappings mappings
+                                            #:nic-options nic-options))
     ((disk-image)
      (lower-object
       (system-image
@@ -764,6 +765,7 @@ and TARGET arguments."
                          use-substitutes? bootloader-target target
                          image-size file-system-type full-boot?
                          container-shared-network?
+                         nic-options
                          (mappings '())
                          (gc-root #f))
   "Perform ACTION for OS.  INSTALL-BOOTLOADER? specifies whether to install
@@ -819,7 +821,8 @@ static checks."
                                                 #:image-size image-size
                                                 #:full-boot? full-boot?
                                                 #:container-shared-network? container-shared-network?
-                                                #:mappings mappings))
+                                                #:mappings mappings
+                                                #:nic-options nic-options))
 
        ;; For 'init' and 'reconfigure', always build BOOTCFG, even if
        ;; --no-bootloader is passed, because we then use it as a GC root.
@@ -965,6 +968,8 @@ Some ACTIONS support additional ARGS.\n"))
       --share=SPEC       for 'vm', share host file system according to SPEC"))
   (display (G_ "
       --expose=SPEC      for 'vm', expose host file system according to SPEC"))
+  (display (G_ "
+      --nic=NIC-OPTIONS  for 'fm', set the value passed to qemu's -nic option"))
   (display (G_ "
   -N, --network          for 'container', allow containers to access the network"))
   (display (G_ "
@@ -1014,6 +1019,10 @@ Some ACTIONS support additional ARGS.\n"))
                  (lambda (opt name arg result)
                    (alist-cons 'image-size (size->number arg)
                                result)))
+         (option '("nic") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'nic-options arg
+                               result)))
          (option '(#\N "network") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'container-shared-network? #t result)))
@@ -1172,7 +1181,8 @@ resulting from command-line parsing."
                                #:install-bootloader? bootloader?
                                #:target target-file
                                #:bootloader-target bootloader-target
-                               #:gc-root (assoc-ref opts 'gc-root)))))
+                               #:gc-root (assoc-ref opts 'gc-root)
+                               #:nic-options (assoc-ref opts 'nic-options)))))
           #:target target
           #:system system)))
     (warn-about-disk-space)))
-- 
2.26.2