services: Add 'hurd-vm service-type'.

* gnu/services/virtualization.scm (hurd-vm-shepherd-service,
hurd-vm-disk-image): New procedures.
(%hurd-vm-operating-system, hurd-vm-service-type): New variables.
(<hurd-vm-configuration>): New record type.
* doc/guix.texi (Virtualization Services): Document it.
* gnu/services/shepherd.scm (scm->go): Use let-system, remove FIXME.  Fixes
fixes cross-building of shepherd modules for the Hurd image.

2 files changed, 118 insertions, 9 deletions

diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm
index 77c4d0a8be..e14ceca231 100644
--- a/gnu/services/shepherd.scm
+++ b/gnu/services/shepherd.scm
@@ -266,8 +266,7 @@ stored."
 (define (scm->go file)
   "Compile FILE, which contains code to be loaded by shepherd's config file,
 and return the resulting '.go' file."
-  ;; FIXME: %current-target-system may not be bound <https://bugs.gnu.org/29296>
-  (let ((target (%current-target-system)))
+  (let-system (system target)
     (with-extensions (list shepherd)
       (computed-file (string-append (basename (scheme-file-name file) ".scm")
                                     ".go")
diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm
index 989e439d5d..4e96607680 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-vm-operating-system
+            hurd-vm-configuration
+            hurd-vm-service-type
+
+            libvirt-configuration
             libvirt-service-type
             virtlog-configuration
             virtlog-service-type
@@ -773,3 +791,95 @@ 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: a Childhurd.
+;;;
+
+(define %hurd-vm-operating-system
+  (operating-system
+    (inherit %hurd-default-operating-system)
+    (host-name "childhurd")
+    (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-vm-configuration>
+  hurd-vm-configuration make-hurd-vm-configuration
+  hurd-vm-configuration?
+  (os          hurd-vm-configuration-os                 ;<operating-system>
+               (default %hurd-vm-operating-system))
+  (qemu        hurd-vm-configuration-qemu               ;<package>
+               (default qemu-minimal))
+  (image       hurd-vm-configuration-image              ;string
+               (thunked)
+               (default (hurd-vm-disk-image this-record)))
+  (disk-size   hurd-vm-configuration-disk-size          ;number or 'guess
+               (default 'guess))
+  (memory-size hurd-vm-configuration-memory-size        ;number
+               (default 512))
+  (options     hurd-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-vm-configuration-os config))
+        (disk-size (hurd-vm-configuration-disk-size config)))
+    (system-image
+     (image
+      (inherit hurd-disk-image)
+      (size disk-size)
+      (operating-system os)))))
+
+(define (hurd-vm-shepherd-service config)
+  "Return a <shepherd-service> for a Hurd in a Virtual Machine with CONFIG."
+
+  (let ((image       (hurd-vm-configuration-image config))
+        (qemu        (hurd-vm-configuration-qemu config))
+        (memory-size (hurd-vm-configuration-memory-size config))
+        (options     (hurd-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: a Childhurd.")
+      (provision '(hurd-vm childhurd))
+      (requirement '(networking))
+      (start #~(make-forkexec-constructor #$vm-command))
+      (stop  #~(make-kill-destructor))))))
+
+(define hurd-vm-service-type
+  (service-type
+   (name 'hurd-vm)
+   (extensions (list (service-extension shepherd-root-service-type
+                                        hurd-vm-shepherd-service)))
+   (default-value (hurd-vm-configuration))
+   (description
+    "Provide a Virtual Machine running the GNU/Hurd.")))