[bug#41785] [PATCH] DRAFT services: Add 'hurd-in-vm service-type'.

[Jan (janneke) Nieuwenhuizen]

TODO: Figure-out how to run this hurd VM inside a VM.

Using

--8<---------------cut here---------------start------------->8---
diff --git a/gnu/system/examples/bare-bones.tmpl 
b/gnu/system/examples/bare-bones.tmpl
index 1035ab1d60..40fb354ea4 100644
--- a/gnu/system/examples/bare-bones.tmpl
+++ b/gnu/system/examples/bare-bones.tmpl
@@ -5,6 +5,8 @@
 (use-service-modules networking ssh)
 (use-package-modules screen ssh)

+(use-service-modules hurd virtualization)
+
 (operating-system
   (host-name "komputilo")
   (timezone "Europe/Berlin")
@@ -44,8 +46,12 @@
   ;; Add services to the baseline: a DHCP client and
   ;; an SSH server.
   (services (append (list (service dhcp-client-service-type)
+                          (service hurd-in-vm-service-type)
                           (service openssh-service-type
                                    (openssh-configuration
                                     (openssh openssh-sans-x)
-                                    (port-number 2222))))
+                                    (port-number 2222)
+                                    (permit-root-login #t)
+                                    (allow-empty-passwords? #t)
+                                    (password-authentication? #t))))
                     %base-services)))
diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm
index 441b1eb7e0..e3560b80b7 100644
--- a/gnu/services/virtualization.scm
+++ b/gnu/services/virtualization.scm
@@ -878,7 +878,7 @@ functionality of the kernel Linux.")))
     (define vm-command
       #~(list
          (string-append #$qemu "/bin/qemu-system-i386")
-         #$@(if (file-exists? "/dev/kvm") '("-enable-kvm") '())
+         ;;huh? breaks hurd in bare-bones VM #$@(if (file-exists? "/dev/kvm") 
'("-enable-kvm") '())
          "-m" (number->string #$memory-size)
          #$@options
          #+image))
--8<---------------cut here---------------end--------------->8---

and doing something like

    ./pre-inst-env guix system vm gnu/system/examples/bare-bones.tmpl 
--no-offload
    /gnu/store/96wh3jwsla4p6d4s547mmqxsi4qbbc0r-run-vm.sh -m 2G \
      --device rtl8139,netdev=net0 \
      --netdev 
user,id=net0,hostfwd=tcp:127.0.0.1:10022-:2222,hostfwd=tcp:127.0.0.1:5900-:5900

nicely starts a bare-bones VM with the the hurd-in-vm service inside, but I
cannot seem to connect to the Hurd VM it in any way.  Appending
",hostfwd=tcp:127.0.0.1:20022-:20022" (to directly ssh into the Hurd) even
blocks me from ssh'ing into the GNU/linux host VM.

hurd-in-vm works beautifully when added to my system configuration and
reconfiguring.

* gnu/services/virtualization.scm (disk-image, hurd-in-vm-shepherd-service,
hurd-vm-disk-image): New procedures.
(%hurd-in-vm-operating-system, hurd-in-vm-service-type): New variable.
(<hurd-in-vm-configuration>): New record type.
* doc/guix.texi (Virtualization Services): Document it.
---
 doc/guix.texi                   |  61 ++++++++++++++
 gnu/services/virtualization.scm | 140 ++++++++++++++++++++++++++++++--
 2 files changed, 194 insertions(+), 7 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 15e077a41c..cae77288f4 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -24583,6 +24583,67 @@ Return true if @var{obj} is a platform object.
 Return the name of @var{platform}---a string such as @code{"arm"}.
 @end deffn
 
+
+@subsubheading The Hurd in a Virtual Machine
+
+@cindex @code{hurd}
+@cindex the Hurd
+
+Service @code{hurd-in-vm} provides support for running a Virtual Machine
+with the GNU@tie{}Hurd.
+
+@defvr {Scheme Variable} hurd-in-vm-service-type
+This is the type of the Hurd in a Virtual Machine service.  Its value
+must be a @code{hurd-in-vm-configuration} object, which specifies the
+operating system (@pxref{operating-system Reference}) and the disk size
+for the Hurd Virtual Machine, the QEMU package to use as well as the
+options for running it.
+
+For example:
+
+@lisp
+(service hurd-in-vm-service-type
+         (hurd-in-vm-configuration
+          (disk-size (* 5000 (expt 2 20))) ;5G
+          (memory-size 1024)))             ;1024MiB
+@end lisp
+
+would create a disk image big enough to build GNU@tie{}Hello, with some
+extra memory.
+@end defvr
+
+@deftp {Data Type} hurd-in-vm-configuration
+The data type representing the configuration for
+@code{hurd-in-vm-service-type}.
+
+@table @asis
+@item @code{os} (default: @var{%hurd-in-vm-operating-system})
+The operating system to instantiate.  This default is bare-bones with a
+permissive OpenSSH secure shell daemon listening on port 2222
+(@pxref{Networking Services, @code{openssh-service-type}}).
+
+@item @code{qemu} (default: @code{qemu-minimal})
+The QEMU package to use.
+
+@item @code{image} (default: @var{hurd-vm-disk-image})
+The procedure used to build the disk-image built from this
+configuration.
+
+@item @code{disk-size} (default: @code{'guess})
+The size of the disk image.
+
+@item @code{memory-size} (default: @code{512})
+The memory size of the Virtual Machine in mebibytes.
+
+@item @code{options} (default: @code{'("--device"} 
@code{"rtl8139,netdev=net0"} @
+      @code{"--netdev"} @
+      
@code{"user,id=net0,hostfwd=tcp:127.0.0.1:20022-:2222,hostfwd=tcp:127.0.0.1:25900-:5900"}
 @
+      @code{"--snapshot"} @
+      @code{"--hda")})
+The extra options for running QEMU.
+@end table
+@end deftp
+
 @node Version Control Services
 @subsection Version Control Services
 
diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm
index 989e439d5d..441b1eb7e0 100644
--- a/gnu/services/virtualization.scm
+++ b/gnu/services/virtualization.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 Ryan Moe <ryan.moe@gmail.com>
 ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -18,24 +19,41 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu services virtualization)
-  #:use-module (gnu services)
-  #:use-module (gnu services configuration)
+  #:use-module (gnu bootloader)
+  #:use-module (gnu bootloader grub)
+  #:use-module (gnu image)
+  #:use-module (gnu packages admin)
+  #:use-module (gnu packages ssh)
+  #:use-module (gnu packages virtualization)
   #:use-module (gnu services base)
+  #:use-module (gnu services configuration)
   #:use-module (gnu services dbus)
   #:use-module (gnu services shepherd)
-  #:use-module (gnu system shadow)
+  #:use-module (gnu services ssh)
+  #:use-module (gnu services)
   #:use-module (gnu system file-systems)
-  #:use-module (gnu packages admin)
-  #:use-module (gnu packages virtualization)
-  #:use-module (guix records)
+  #:use-module (gnu system hurd)
+  #:use-module (gnu system image)
+  #:use-module (gnu system shadow)
+  #:use-module (gnu system)
+  #:use-module (guix derivations)
   #:use-module (guix gexp)
+  #:use-module (guix monads)
   #:use-module (guix packages)
+  #:use-module (guix records)
+  #:use-module (guix store)
+  #:use-module (guix utils)
+
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match)
 
-  #:export (libvirt-configuration
+  #:export (%hurd-in-vm-operating-system
+            hurd-in-vm-configuration
+            hurd-in-vm-service-type
+
+            libvirt-configuration
             libvirt-service-type
             virtlog-configuration
             virtlog-service-type
@@ -773,3 +791,111 @@ given QEMU package."
                  "This service supports transparent emulation of binaries
 compiled for other architectures using QEMU and the @code{binfmt_misc}
 functionality of the kernel Linux.")))
+
+
+;;;
+;;; The Hurd in VM service.
+;;;
+
+(define* (disk-image os #:key (image-size 'guess) target)
+  "Return a disk-image for OS with size IMAGE-SIZE, built for TARGET."
+  (with-store store
+    (run-with-store store
+      (let ((file-system-type "ext2"))
+        (mlet* %store-monad
+            ((base-image (find-image file-system-type))
+             (sys        (lower-object
+                          (system-image
+                           (image
+                            (inherit base-image)
+                            (size image-size)
+                            (operating-system os)))))
+             (drvs       (mapm/accumulate-builds lower-object (list sys)))
+             (%          (built-derivations drvs)))
+          (let ((output (derivation->output-path sys)))
+            (return output))))
+      #:target target)))
+
+(define %hurd-in-vm-operating-system
+  (operating-system
+    (inherit %hurd-default-operating-system)
+    (host-name "guixydevel")
+    (timezone "Europe/Amsterdam")
+    (bootloader (bootloader-configuration
+                 (bootloader grub-minimal-bootloader)
+                 (target "/dev/vda")
+                 (timeout 0)))
+    (services (cons*
+               (service openssh-service-type
+                        (openssh-configuration
+                         (openssh openssh-sans-x)
+                         (use-pam? #f)
+                         (port-number 2222)
+                         (permit-root-login #t)
+                         (allow-empty-passwords? #t)
+                         (password-authentication? #t)))
+               %base-services/hurd))))
+
+(define-record-type* <hurd-in-vm-configuration>
+  hurd-in-vm-configuration make-hurd-in-vm-configuration
+  hurd-in-vm-configuration?
+  (os          hurd-in-vm-configuration-os                 ;<operating-system>
+               (default %hurd-in-vm-operating-system))
+  (qemu        hurd-in-vm-configuration-qemu               ;<package>
+               (default qemu-minimal))
+  (image       hurd-in-vm-configuration-image              ;string
+               (thunked)
+               (default (hurd-vm-disk-image this-record)))
+  (disk-size   hurd-in-vm-configuration-disk-size          ;number or 'guess
+               (default 'guess))
+  (memory-size hurd-in-vm-configuration-memory-size        ;number
+               (default 512))
+  (options     hurd-in-vm-configuration-options            ;list of string
+               (default
+                 `("--device" "rtl8139,netdev=net0"
+                   "--netdev" (string-append
+                               "user,id=net0"
+                               ",hostfwd=tcp:127.0.0.1:20022-:2222"
+                               ",hostfwd=tcp:127.0.0.1:25900-:5900")
+                   "--snapshot"
+                   "--hda"))))
+
+(define (hurd-vm-disk-image config)
+  "Return a disk-image for the Hurd according to CONFIG."
+  (let ((os (hurd-in-vm-configuration-os config))
+        (disk-size (hurd-in-vm-configuration-disk-size config))
+        (target (and (not (%current-target-system)) "i586-pc-gnu")))
+    (disk-image os #:target target #:image-size disk-size)))
+
+(define (hurd-in-vm-shepherd-service config)
+  "Return a <shepherd-service> for a Hurd in a Virtual Machine with CONFIG."
+
+  (let ((image       (hurd-in-vm-configuration-image config))
+        (qemu        (hurd-in-vm-configuration-qemu config))
+        (memory-size (hurd-in-vm-configuration-memory-size config))
+        (options     (hurd-in-vm-configuration-options config)))
+
+    (define vm-command
+      #~(list
+         (string-append #$qemu "/bin/qemu-system-i386")
+         #$@(if (file-exists? "/dev/kvm") '("-enable-kvm") '())
+         "-m" (number->string #$memory-size)
+         #$@options
+         #+image))
+
+    (list
+     (shepherd-service
+      (documentation "Run the Hurd in a Virtual Machine.")
+      (provision '(hurd-in-vm))
+      (requirement '(networking))
+      (start #~(make-forkexec-constructor #$vm-command))
+      (stop  #~(make-kill-destructor))))))
+
+(define hurd-in-vm-service-type
+  (service-type
+   (name 'hurd-in-vm)
+   (extensions (list (service-extension shepherd-root-service-type
+                                        hurd-in-vm-shepherd-service)))
+   (default-value (hurd-in-vm-configuration))
+   (description
+    "Provide a Virtual Machine running the GNU Hurd.")))
-- 
Jan Nieuwenhuizen <janneke@gnu.org> | GNU LilyPond http://lilypond.org
Freelance IT http://JoyofSource.com | Avatar® http://AvatarAcademy.com