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

From: Jan Nieuwenhuizen <[email-masked]>
Date: Thu, 11 Jun 2020 23:57:06 +0200

Ludovic Courtès writes:

Hello,

> That was fast!  :-)

Yeah...we need this, right ;)

> "Jan (janneke) Nieuwenhuizen" <[email-masked]> skribis:
>
>> 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.
>
> Weird.
>
>> 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.
>
> […]
>
>> +@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.
>
> “… support for running GNU/Hurd in a virtual machine (VM).  The virtual
> machine is a Shepherd service that can be controlled with commands such
> as:
>
> @example
> herd stop hurd-vm
> @end example
>
> The given GNU/Hurd operating system configuration is cross-compiled.”

Nice, thanks!

> Nitpick: I’d call it “hurd-vm”, because it runs a Hurd VM.  :-)

Done!

> It’s a volatile VM, due to the use of ‘-snapshot’, right?

By default: Yes.  That seemed more ready-to-use.  A stateful VM image
would need to an out-of-store, writable copy.  You can actually do that
and modify the hurd-vm-configuration.

> (The Hurd actually has “sub-Hurds”¹ and “neighborhurds”².  I wonder if
> it’s our duty to coin another term… a guesthurd? a visithurd?)
>
> ¹ https://www.gnu.org/software/hurd/hurd/subhurd.html
> ² https://www.gnu.org/software/hurd/hurd/neighborhurd.html

Oh, that's cool!  Associating along from the neighborhurd pun, what
about a "childhurd" (as a pun on childhood -- only needed while the Hurd
is growing up)?

"herd start childhurd" -- hmm?  In the updated patch, I still have
hurd-vm.  If we do our duty and coin "childhurd", should I just
s/hurd-vm/childhurd/g ?

>> +(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
>       ^
> In general, procedures should talk to the user-provided store and never
> open a new connection.  They should also never call ‘build-derivations’
> explicitly, the only exception so far being the graft implementation.
>
> So you can drop ‘with-store’ here, and then:
>
>> +    (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))))
>
> Mathieu, can we make ‘find-image’ non-monadic?  It really shouldn’t be
> because it doesn’t interact with the store.  It can take an optional
> ‘system’ parameter if we want.

It seems that "just works".  I've made that change in a separate patch
(attached).

> So, assuming ‘find-image’ is non-monadic, the code above becomes
> something like:
>
>   (system-image
>     (image (inherit base-image)
>            (size image-size)
>            (operating-system
>             (with-parameters ((%current-target-system "i586-pc-gnu"))
>               os))))

Hmm...I don't think that I understand.  This

--8<---------------cut here---------------start------------->8---
(define* (disk-image os #:key (image-size 'guess) target)
  "Return a disk-image for OS with size IMAGE-SIZE, built for TARGET."
  (let ((base-image (find-image "ext2")))
    (system-image
     (image (inherit base-image)
            (size image-size)
            (operating-system
              (with-parameters ((%current-target-system target))
                os))))))

--8<---------------cut here---------------end--------------->8---

gives

--8<---------------cut here---------------start------------->8---
$ ~/src/guix/master/pre-inst-env guix system build dundal.scm
%default-substitute-urls:("https://ci.guix.gnu.org")
Backtrace:
In ice-9/boot-9.scm:
  1736:10  4 (with-exception-handler _ _ #:unwind? _ #:unwind-for-type _)
In unknown file:
           3 (apply-smob/0 #<thunk 7f4ce92e3980>)
In ice-9/boot-9.scm:
    718:2  2 (call-with-prompt _ _ #<procedure default-prompt-handler (k proc)>)
In ice-9/eval.scm:
    619:8  1 (_ #(#(#<directory (guile-user) 7f4ce8f05f00>)))
In guix/ui.scm:
  1945:12  0 (run-guix-command _ . _)

guix/ui.scm:1945:12: In procedure run-guix-command:
In procedure operating-system-file-systems: Wrong type argument: #<<parameterized> bindings: ((#<<parameter> 7f4ce7c23740 proc: #<procedure 7f4ce7c28200 at ice-9/boot-9.scm:1299:5 () | (x)>> #<procedure 7f4cd32f83c0 at gnu/services/virtualization.scm:806:14 ()>)) thunk: #<procedure 7f4cd32f8340 at gnu/services/virtualization.scm:806:14 ()>>
--8<---------------cut here---------------end--------------->8---

...I could do with some help here.

>> +(define %hurd-in-vm-operating-system
[..]
>> +  (operating-system
>> +               (service openssh-service-type
>> +                        (openssh-configuration
>> +                         (openssh openssh-sans-x)
[..]
>> +               %base-services/hurd))))
>
> I understand the need to factorize useful configs, but IMO it doesn’t
> belong here.  So I’d just leave it out.  There’s already
> ‘%hurd-default-operating-system’ that does the heavy lifting anyway.

Sure, removed!  Users will most probably want to add an openssh server
using openssh-sans-x; but I guess that's something for a blog post or
cookbook then.

>> +(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.")))
>
> Being pedantic: s|the GNU Hurd|GNU/Hurd|.  :-)
>
> Otherwise looks great to me, thank you!

Great; thanks...find two new patches attached.

Janneke

>From b01b8d2a46a6a04cb8f09d74c06cbbc82878f070 Mon Sep 17 00:00:00 2001
From: "Jan (janneke) Nieuwenhuizen" <[email-masked]>
Date: Thu, 11 Jun 2020 22:52:12 +0200
Subject: [PATCH v2 1/2] image: Make 'find-image' non-monadic.

* gnu/system/image.scm (find-image): Make non-monadic.
* gnu/tests/install.scm (run-install): Update caller.
* guix/scripts/system.scm (perform-action): Likewise.
---
 gnu/system/image.scm    | 21 ++++++++++-----------
 gnu/tests/install.scm   |  5 +++--
 guix/scripts/system.scm |  3 ++-
 3 files changed, 15 insertions(+), 14 deletions(-)

diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index a0e6bf31f1..66a9f6b335 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2020 Mathieu Othacehe <[email-masked]>
+;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <[email-masked]>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -551,16 +552,14 @@ image, depending on IMAGE format."
   "Find and return an image that could match the given FILE-SYSTEM-TYPE.  This
 is useful to adapt to interfaces written before the addition of the <image>
 record."
-  (mlet %store-monad ((target (current-target-system)))
-    (mbegin %store-monad
-      (return
-       (match file-system-type
-         ("iso9660" iso9660-image)
-         (_ (cond
-             ((and target
-                   (hurd-triplet? target))
-              hurd-disk-image)
-             (else
-              efi-disk-image))))))))
+  (let ((target (%current-target-system)))
+    (match file-system-type
+      ("iso9660" iso9660-image)
+      (_ (cond
+          ((and target
+                (hurd-triplet? target))
+           hurd-disk-image)
+          (else
+           efi-disk-image))))))
 
 ;;; image.scm ends here
diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm
index 6bd8c7d3d2..d18e33179f 100644
--- a/gnu/tests/install.scm
+++ b/gnu/tests/install.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2017, 2019 Tobias Geerinckx-Rice <[email-masked]>
 ;;; Copyright © 2020 Mathieu Othacehe <[email-masked]>
 ;;; Copyright © 2020 Danny Milosavljevic <[email-masked]>
+;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <[email-masked]>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -228,8 +229,8 @@ packages defined in installation-os."
   (mlet* %store-monad ((_      (set-grafting #f))
                        (system (current-system))
                        (target (operating-system-derivation target-os))
-                       (base-image (find-image
-                                    installation-disk-image-file-system-type))
+                       (base-image -> (find-image
+                                       installation-disk-image-file-system-type))
 
                        ;; Since the installation system has no network access,
                        ;; we cheat a little bit by adding TARGET to its GC
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 3d7aa77cb7..fc92b9f07b 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -5,6 +5,7 @@
 ;;; Copyright © 2017, 2019 Mathieu Othacehe <[email-masked]>
 ;;; Copyright © 2018 Ricardo Wurmus <[email-masked]>
 ;;; Copyright © 2019 Christopher Baines <[email-masked]>
+;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <[email-masked]>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -801,7 +802,7 @@ static checks."
       (check-initrd-modules os)))
 
   (mlet* %store-monad
-      ((image     (find-image file-system-type))
+      ((image ->  (find-image file-system-type))
        (sys       (system-derivation-for-action os image action
                                                 #:file-system-type file-system-type
                                                 #:image-size image-size
-- 
Jan Nieuwenhuizen <[email-masked]> | GNU LilyPond http://lilypond.org
Freelance IT http://JoyofSource.com | Avatar® http://AvatarAcademy.com

>From e5bdf050f628cc7ea1b6bc4ccdcfeb757429820f Mon Sep 17 00:00:00 2001
From: "Jan (janneke) Nieuwenhuizen" <[email-masked]>
Date: Wed, 10 Jun 2020 00:10:28 +0200
Subject: [PATCH v2 2/2] services: Add 'hurd-vm service-type'.

* gnu/services/virtualization.scm (disk-image, hurd-in-vm-shepherd-service,
hurd-vm-disk-image): New procedures.
(hurd-in-vm-service-type): New variable.
(<hurd-in-vm-configuration>): New record type.
* doc/guix.texi (Virtualization Services): Document it.
---
 doc/guix.texi                       |  66 +++++++++++++++++
 gnu/services/virtualization.scm     | 110 ++++++++++++++++++++++++++--
 gnu/system/examples/bare-bones.tmpl |   8 +-
 3 files changed, 176 insertions(+), 8 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 15e077a41c..2c924e5313 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -24583,6 +24583,72 @@ 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-vm} provides support for running GNU/Hurd in a
+virtual machine (VM).  The virtual machine is a Shepherd service that
+can be controlled with commands such as:
+
+@example
+herd stop hurd-vm
+@end example
+
+The given GNU/Hurd operating system configuration is cross-compiled.
+
+@defvr {Scheme Variable} hurd-vm-service-type
+This is the type of the Hurd in a Virtual Machine service.  Its value
+must be a @code{hurd-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-vm-service-type
+         (hurd-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-vm-configuration
+The data type representing the configuration for
+@code{hurd-vm-service-type}.
+
+@table @asis
+@item @code{os} (default: @var{%hurd-default-operating-system})
+The operating system to instantiate.
+
+@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..f2a5e7200e 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 <[email-masked]>
 ;;; Copyright © 2018 Ludovic Courtès <[email-masked]>
+;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <[email-masked]>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -18,24 +19,40 @@
 ;;; 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-configuration
+            hurd-vm-service-type
+
+            libvirt-configuration
             libvirt-service-type
             virtlog-configuration
             virtlog-service-type
@@ -773,3 +790,82 @@ 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."
+  (let ((base-image (find-image "ext2")))
+    (system-image
+     (image (inherit base-image)
+            (size image-size)
+            (operating-system
+              (with-parameters ((%current-target-system target))
+                os))))))
+
+(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-default-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))
+        (target (and (not (%current-target-system)) "i586-pc-gnu")))
+    (disk-image os #:target target #:image-size disk-size)))
+
+(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.")
+      (provision '(hurd-vm))
+      (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.")))
diff --git a/gnu/system/examples/bare-bones.tmpl b/gnu/system/examples/bare-bones.tmpl
index 1035ab1d60..1d4f7743ab 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-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)))
-- 
Jan Nieuwenhuizen <[email-masked]> | GNU LilyPond http://lilypond.org
Freelance IT http://JoyofSource.com | Avatar® http://AvatarAcademy.com

-- 
Jan Nieuwenhuizen <[email-masked]> | GNU LilyPond http://lilypond.org
Freelance IT http://JoyofSource.com | Avatar® http://AvatarAcademy.com