From: Jan Nieuwenhuizen <janneke@gnu.org>
To: Mathieu Othacehe <othacehe@gnu.org>
Cc: "Ludovic Courtès" <ludo@gnu.org>, 41785@debbugs.gnu.org
Subject: [bug#41785] [PATCH v4] services: Add 'hurd-in-vm service-type'.
Date: Sun, 14 Jun 2020 14:10:45 +0200 [thread overview]
Message-ID: <878sgpg856.fsf_-_@gnu.org> (raw)
In-Reply-To: <87eeqknf4d.fsf@gnu.org> (Jan Nieuwenhuizen's message of "Fri, 12 Jun 2020 23:33:38 +0200")
[-- Attachment #1: Type: text/plain, Size: 2149 bytes --]
Jan Nieuwenhuizen writes:
Hello,
> we have now something "that works" for the Hurd.
Hmm...that was too fast; apparently I fooled myself last Friday.
Anyway, I found it! Using this
--8<---------------cut here---------------start------------->8---
(define (hurd-vm-disk-image config)
"Return a disk-image for the Hurd according to CONFIG."
(with-parameters ((%current-target-system "i586-pc-gnu"))
(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))))))
--8<---------------cut here---------------end--------------->8---
almost worked...but it goes wrong cross-building the services.
In gnu/services/shepherd.scm's scm->go, we were bitten by
--8<---------------cut here---------------start------------->8---
(define (scm->go file)
;; FIXME: %current-target-system may not be bound <https://bugs.gnu.org/29296>
(let ((target (%current-target-system)))
(with-extensions (list shepherd)
--8<---------------cut here---------------end--------------->8---
...but we now have let-system; so using
--8<---------------cut here---------------start------------->8---
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")
--8<---------------cut here---------------end--------------->8---
produces a working hurd-vm service!
New patch attached, I intend to push to master once rebased, all the
tests pass, etc. ;-)
Phew, thank you!
Greetings,
Janneke
[-- Attachment #2: v4-0001-services-Add-hurd-vm-service-type.patch --]
[-- Type: text/x-patch, Size: 11067 bytes --]
From ef424afa4bc83a3e7fc7ff2ac831de02c2022c73 Mon Sep 17 00:00:00 2001
From: "Jan (janneke) Nieuwenhuizen" <janneke@gnu.org>
Date: Wed, 10 Jun 2020 00:10:28 +0200
Subject: [PATCH v4] 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.
---
doc/guix.texi | 83 +++++++++++++++++++++
gnu/services/shepherd.scm | 3 +-
gnu/services/virtualization.scm | 125 ++++++++++++++++++++++++++++++--
3 files changed, 202 insertions(+), 9 deletions(-)
diff --git a/doc/guix.texi b/doc/guix.texi
index 15e077a41c..ed36d5014b 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -24583,6 +24583,89 @@ 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), a so-called ``Childhurd''. The virtual machine is
+a Shepherd service that can be controlled with commands such as:
+
+@example
+herd start hurd-vm
+herd stop childhurd
+@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-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
+
+Note that by default the VM image is volatile, i.e., once stopped the
+contents are lost. If you want a stateful image instead, override the
+configuration's @code{image} and @code{options} without
+the @code{--snapshot} flag using something along these lines:
+
+@lisp
+(service hurd-vm-service-type
+ (hurd-vm-configuration
+ (image (const "/out/of/store/writable/hurd.img"))
+ (options '("--device" "rtl8139,netdev=net0"
+ "--netdev"
+ "user,id=net0,hostfwd=tcp:127.0.0.1:20022-:2222"))))
+@end lisp
+
@node Version Control Services
@subsection Version Control Services
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..98b94f7464 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,96 @@ 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.")))
+
+\f
+;;;
+;;; 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."
+ (with-parameters ((%current-target-system "i586-pc-gnu"))
+ (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.")))
--
Jan Nieuwenhuizen <janneke@gnu.org> | GNU LilyPond http://lilypond.org
Freelance IT http://JoyofSource.com | Avatar® http://AvatarAcademy.com
[-- Attachment #3: Type: text/plain, Size: 152 bytes --]
--
Jan Nieuwenhuizen <janneke@gnu.org> | GNU LilyPond http://lilypond.org
Freelance IT http://JoyofSource.com | Avatar® http://AvatarAcademy.com
next prev parent reply other threads:[~2020-06-14 12:11 UTC|newest]
Thread overview: 35+ messages / expand[flat|nested] mbox.gz Atom feed top
2020-06-10 8:54 [bug#41785] [PATCH] DRAFT services: Add 'hurd-in-vm service-type' Jan (janneke) Nieuwenhuizen
2020-06-10 11:34 ` Mathieu Othacehe
2020-06-11 19:43 ` Ludovic Courtès
2020-06-11 19:59 ` Jan Nieuwenhuizen
2020-06-11 20:01 ` Marius Bakke
2020-06-12 6:39 ` Jan Nieuwenhuizen
2020-06-12 10:51 ` Diego Nicola Barbato
2020-06-13 7:30 ` Jan Nieuwenhuizen
2020-06-11 19:59 ` Ludovic Courtès
2020-06-11 21:57 ` Jan Nieuwenhuizen
2020-06-12 6:46 ` Jan Nieuwenhuizen
2020-06-12 14:45 ` Ludovic Courtès
2020-06-12 21:33 ` Jan Nieuwenhuizen
2020-06-12 15:04 ` Mathieu Othacehe
2020-06-12 21:33 ` Jan Nieuwenhuizen
2020-06-14 12:10 ` Jan Nieuwenhuizen [this message]
2020-06-14 12:44 ` [bug#41785] [PATCH v4] " Mathieu Othacehe
2020-06-14 13:18 ` Jan Nieuwenhuizen
2020-06-14 15:52 ` Mathieu Othacehe
2020-06-14 16:22 ` Mathieu Othacehe
2020-06-14 16:42 ` bug#41785: " Jan Nieuwenhuizen
2020-06-12 14:42 ` [bug#41785] [PATCH] DRAFT " Mathieu Othacehe
2020-06-12 15:39 ` Ludovic Courtès
2020-06-12 21:42 ` [bug#41785] [PATCH v3 1/2] image: Make 'find-image' non-monadic Jan (janneke) Nieuwenhuizen
2020-06-12 21:42 ` [bug#41785] [PATCH v3 2/2] services: Add 'hurd-vm service-type' Jan (janneke) Nieuwenhuizen
2020-06-13 12:49 ` Mathieu Othacehe
2020-06-13 13:10 ` Jan Nieuwenhuizen
2020-06-13 14:35 ` Ludovic Courtès
2020-06-13 15:01 ` Mathieu Othacehe
2020-06-13 10:56 ` [bug#41785] [PATCH v3 1/2] image: Make 'find-image' non-monadic Mathieu Othacehe
2020-06-13 13:05 ` Jan Nieuwenhuizen
2020-06-14 12:37 ` Mathieu Othacehe
2020-06-14 13:12 ` Jan Nieuwenhuizen
2020-06-14 13:32 ` Jan Nieuwenhuizen
2020-06-14 15:44 ` Mathieu Othacehe
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://guix.gnu.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=878sgpg856.fsf_-_@gnu.org \
--to=janneke@gnu.org \
--cc=41785@debbugs.gnu.org \
--cc=ludo@gnu.org \
--cc=othacehe@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).