;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Ryan Moe <ryan.moe@gmail.com>
+;;; Copyright © 2018, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; 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 gdb)
+ #:use-module (gnu packages package-management)
+ #: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 services ssh)
+ #:use-module (gnu services)
+ #:use-module (gnu system file-systems)
+ #:use-module (gnu system hurd)
+ #:use-module (gnu system image)
#:use-module (gnu system shadow)
- #:use-module (gnu packages admin)
- #:use-module (gnu packages virtualization)
- #:use-module (guix records)
+ #:use-module (gnu system)
+ #:use-module (guix derivations)
#:use-module (guix gexp)
+ #:use-module (guix modules)
+ #: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-configuration?
+ hurd-vm-configuration-os
+ hurd-vm-configuration-qemu
+ hurd-vm-configuration-image
+ hurd-vm-configuration-disk-size
+ hurd-vm-configuration-memory-size
+ hurd-vm-configuration-options
+ hurd-vm-configuration-id
+ hurd-vm-configuration-net-options
+ hurd-vm-configuration-secrets
+
+ hurd-vm-disk-image
+ hurd-vm-port
+ hurd-vm-net-options
+ hurd-vm-service-type
+
+ libvirt-configuration
libvirt-service-type
- virtlog-service-type))
+ virtlog-configuration
+ virtlog-service-type
+
+ %qemu-platforms
+ lookup-qemu-platforms
+ qemu-platform?
+ qemu-platform-name
+
+ qemu-binfmt-configuration
+ qemu-binfmt-configuration?
+ qemu-binfmt-service-type))
(define (uglify-field-name field-name)
(let ((str (symbol->string field-name)))
(string "3:remote 4:event")
"Logging filters.
-A filter allows to select a different logging level for a given category
+A filter allows selecting a different logging level for a given category
of logs
The format for a filter is one of:
@itemize
Multiple filters can be defined in a single filters statement, they just
need to be separated by spaces.")
(log-outputs
- (string "3:stderr")
+ (string "3:syslog:libvirtd")
"Logging outputs.
An output is one of the places to save logging information
(provision '(libvirtd))
(start #~(make-forkexec-constructor
(list (string-append #$libvirt "/sbin/libvirtd")
- "-f" #$config-file)))
+ "-f" #$config-file)
+ ;; For finding qemu and ip binaries.
+ #:environment-variables
+ (list (string-append
+ "PATH=/run/current-system/profile/bin:"
+ "/run/current-system/profile/sbin"))))
(stop #~(make-kill-destructor))))))
(define libvirt-service-type
(service-extension polkit-service-type
(compose list libvirt-configuration-libvirt))
(service-extension profile-service-type
- (compose list
- libvirt-configuration-libvirt))
+ (lambda (config)
+ (list
+ (libvirt-configuration-libvirt config)
+ qemu)))
(service-extension activation-service-type
%libvirt-activation)
(service-extension shepherd-root-service-type
(generate-documentation
`((libvirt-configuration ,libvirt-configuration-fields))
'libvirt-configuration))
+
+\f
+;;;
+;;; Transparent QEMU emulation via binfmt_misc.
+;;;
+
+;; Platforms that QEMU can emulate.
+(define-record-type <qemu-platform>
+ (qemu-platform name family magic mask)
+ qemu-platform?
+ (name qemu-platform-name) ;string
+ (family qemu-platform-family) ;string
+ (magic qemu-platform-magic) ;bytevector
+ (mask qemu-platform-mask)) ;bytevector
+
+(define-syntax bv
+ (lambda (s)
+ "Expand the given string into a bytevector."
+ (syntax-case s ()
+ ((_ str)
+ (string? (syntax->datum #'str))
+ (let ((bv (u8-list->bytevector
+ (map char->integer
+ (string->list (syntax->datum #'str))))))
+ bv)))))
+
+;;; The platform descriptions below are taken from
+;;; 'scripts/qemu-binfmt-conf.sh' in QEMU.
+
+(define %i386
+ (qemu-platform "i386" "i386"
+ (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x03\x00")
+ (bv "\xff\xff\xff\xff\xff\xfe\xfe\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))
+
+(define %i486
+ (qemu-platform "i486" "i386"
+ (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x06\x00")
+ (bv "\xff\xff\xff\xff\xff\xfe\xfe\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))
+
+(define %alpha
+ (qemu-platform "alpha" "alpha"
+ (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x26\x90")
+ (bv "\xff\xff\xff\xff\xff\xfe\xfe\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))
+
+(define %arm
+ (qemu-platform "arm" "arm"
+ (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x28\x00")
+ (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))
+
+(define %armeb
+ (qemu-platform "armeb" "arm"
+ (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x28")
+ (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))
+
+(define %sparc
+ (qemu-platform "sparc" "sparc"
+ (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x02")
+ (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))
+
+(define %sparc32plus
+ (qemu-platform "sparc32plus" "sparc"
+ (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x12")
+ (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))
+
+(define %ppc
+ (qemu-platform "ppc" "ppc"
+ (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x14")
+ (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))
+
+(define %ppc64
+ (qemu-platform "ppc64" "ppc"
+ (bv "\x7fELF\x02\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x15")
+ (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))
+
+(define %ppc64le
+ (qemu-platform "ppc64le" "ppcle"
+ (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x15\x00")
+ (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\x00")))
+
+(define %m68k
+ (qemu-platform "m68k" "m68k"
+ (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x04")
+ (bv "\xff\xff\xff\xff\xff\xff\xfe\xfe\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))
+
+;; XXX: We could use the other endianness on a MIPS host.
+(define %mips
+ (qemu-platform "mips" "mips"
+ (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08")
+ (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))
+
+(define %mipsel
+ (qemu-platform "mipsel" "mips"
+ (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08\x00")
+ (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))
+
+(define %mipsn32
+ (qemu-platform "mipsn32" "mips"
+ (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08")
+ (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))
+
+(define %mipsn32el
+ (qemu-platform "mipsn32el" "mips"
+ (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08\x00")
+ (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))
+
+(define %mips64
+ (qemu-platform "mips64" "mips"
+ (bv "\x7fELF\x02\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08")
+ (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))
+
+(define %mips64el
+ (qemu-platform "mips64el" "mips"
+ (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08\x00")
+ (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))
+
+(define %riscv32
+ (qemu-platform "riscv32" "riscv"
+ (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\xf3\x00")
+ (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))
+
+(define %riscv64
+ (qemu-platform "riscv64" "riscv"
+ (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\xf3\x00")
+ (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))
+
+(define %sh4
+ (qemu-platform "sh4" "sh4"
+ (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x2a\x00")
+ (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))
+
+(define %sh4eb
+ (qemu-platform "sh4eb" "sh4"
+ (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x2a")
+ (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))
+
+(define %s390x
+ (qemu-platform "s390x" "s390x"
+ (bv "\x7fELF\x02\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x16")
+ (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))
+
+(define %aarch64
+ (qemu-platform "aarch64" "arm"
+ (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\xb7\x00")
+ (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))
+
+(define %hppa
+ (qemu-platform "hppa" "hppa"
+ (bv "\x7f\x45\x4c\x46\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x0f")
+ (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))
+
+(define %qemu-platforms
+ (list %i386 %i486 %alpha %arm %sparc32plus %ppc %ppc64 %ppc64le %m68k
+ %mips %mipsel %mipsn32 %mipsn32el %mips64 %mips64el
+ %riscv32 %riscv64 %sh4 %sh4eb %s390x %aarch64 %hppa))
+
+(define (lookup-qemu-platforms . names)
+ "Return the list of QEMU platforms that match NAMES--a list of names such as
+\"arm\", \"hppa\", etc."
+ (filter (lambda (platform)
+ (member (qemu-platform-name platform) names))
+ %qemu-platforms))
+
+(define-record-type* <qemu-binfmt-configuration>
+ qemu-binfmt-configuration make-qemu-binfmt-configuration
+ qemu-binfmt-configuration?
+ (qemu qemu-binfmt-configuration-qemu
+ (default qemu))
+ (platforms qemu-binfmt-configuration-platforms
+ (default '())) ;safest default
+ (guix-support? qemu-binfmt-configuration-guix-support?
+ (default #f)))
+
+(define (qemu-platform->binfmt qemu platform)
+ "Return a gexp that evaluates to a binfmt string for PLATFORM, using the
+given QEMU package."
+ (define (bytevector->binfmt-string bv)
+ ;; Return a binfmt-friendly string representing BV. Hex-encode every
+ ;; character, in particular because the doc notes "that you must escape
+ ;; any NUL bytes; parsing halts at the first one".
+ (string-concatenate
+ (map (lambda (n)
+ (string-append "\\x"
+ (string-pad (number->string n 16) 2 #\0)))
+ (bytevector->u8-list bv))))
+
+ (match platform
+ (($ <qemu-platform> name family magic mask)
+ ;; See 'Documentation/binfmt_misc.txt' in the kernel.
+ #~(string-append ":qemu-" #$name ":M::"
+ #$(bytevector->binfmt-string magic)
+ ":" #$(bytevector->binfmt-string mask)
+ ":" #$(file-append qemu "/bin/qemu-" name)
+ ":" ;FLAGS go here
+ ))))
+
+(define %binfmt-mount-point
+ (file-system-mount-point %binary-format-file-system))
+
+(define %binfmt-register-file
+ (string-append %binfmt-mount-point "/register"))
+
+(define qemu-binfmt-shepherd-services
+ (match-lambda
+ (($ <qemu-binfmt-configuration> qemu platforms)
+ (list (shepherd-service
+ (provision '(qemu-binfmt))
+ (documentation "Install binfmt_misc handlers for QEMU.")
+ (requirement '(file-system-/proc/sys/fs/binfmt_misc))
+ (start #~(lambda ()
+ ;; Register the handlers for all of PLATFORMS.
+ (for-each (lambda (str)
+ (call-with-output-file
+ #$%binfmt-register-file
+ (lambda (port)
+ (display str port))))
+ (list
+ #$@(map (cut qemu-platform->binfmt qemu
+ <>)
+ platforms)))
+ #t))
+ (stop #~(lambda (_)
+ ;; Unregister the handlers.
+ (for-each (lambda (name)
+ (let ((file (string-append
+ #$%binfmt-mount-point
+ "/qemu-" name)))
+ (call-with-output-file file
+ (lambda (port)
+ (display "-1" port)))))
+ '#$(map qemu-platform-name platforms))
+ #f)))))))
+
+(define qemu-binfmt-guix-chroot
+ (match-lambda
+ ;; Add QEMU and its dependencies to the guix-daemon chroot so that our
+ ;; binfmt_misc handlers work in the chroot (otherwise 'execve' would fail
+ ;; with ENOENT.)
+ ;;
+ ;; The 'F' flag of binfmt_misc is meant to address this problem by loading
+ ;; the interpreter upfront rather than lazily, but apparently that is
+ ;; insufficient (perhaps it loads the 'qemu-ARCH' binary upfront but looks
+ ;; up its dependencies lazily?).
+ (($ <qemu-binfmt-configuration> qemu platforms guix?)
+ (if guix? (list qemu) '()))))
+
+(define qemu-binfmt-service-type
+ ;; TODO: Make a separate binfmt_misc service out of this?
+ (service-type (name 'qemu-binfmt)
+ (extensions
+ (list (service-extension file-system-service-type
+ (const
+ (list %binary-format-file-system)))
+ (service-extension shepherd-root-service-type
+ qemu-binfmt-shepherd-services)
+ (service-extension guix-service-type
+ qemu-binfmt-guix-chroot)))
+ (default-value (qemu-binfmt-configuration))
+ (description
+ "This service supports transparent emulation of binaries
+compiled for other architectures using QEMU and the @code{binfmt_misc}
+functionality of the kernel Linux.")))
+
+\f
+;;;
+;;; Secrets for guest VMs.
+;;;
+
+(define (secret-service-activation port)
+ "Return an activation snippet that fetches sensitive material at local PORT,
+over TCP. Reboot upon failure."
+ (with-imported-modules '((gnu build secret-service)
+ (guix build utils))
+ #~(begin
+ (use-modules (gnu build secret-service))
+ (let ((sent (secret-service-receive-secrets #$port)))
+ (unless sent
+ (sleep 3)
+ (reboot))))))
+
+(define secret-service-type
+ (service-type
+ (name 'secret-service)
+ (extensions (list (service-extension activation-service-type
+ secret-service-activation)))
+ (description
+ "This service fetches secret key and other sensitive material over TCP at
+boot time. This service is meant to be used by virtual machines (VMs) that
+can only be accessed by their host.")))
+
+(define (secret-service-operating-system os)
+ "Return an operating system based on OS that includes the secret-service,
+that will be listening to receive secret keys on port 1004, TCP."
+ (operating-system
+ (inherit os)
+ ;; Arrange so that the secret service activation snippet shows up before
+ ;; the OpenSSH and Guix activation snippets. That way, we receive OpenSSH
+ ;; and Guix keys before the activation snippets try to generate fresh keys
+ ;; for nothing.
+ (services (append (operating-system-user-services os)
+ (list (service secret-service-type 1004))))))
+
+\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)))
+ (packages (cons* gdb-minimal
+ (operating-system-packages
+ %hurd-default-operating-system)))
+ (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)))
+
+ ;; By default, the secret service introduces a pre-initialized
+ ;; /etc/guix/acl file in the childhurd. Thus, clear
+ ;; 'authorize-key?' so that it's not overridden at activation
+ ;; time.
+ (modify-services %base-services/hurd
+ (guix-service-type config =>
+ (guix-configuration
+ (inherit config)
+ (authorize-key? #f))))))))
+
+(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 `("--snapshot")))
+ (id hurd-vm-configuration-id ;#f or integer [1..]
+ (default #f))
+ (net-options hurd-vm-configuration-net-options ;list of string
+ (thunked)
+ (default (hurd-vm-net-options this-record)))
+ (secret-root hurd-vm-configuration-secret-root ;string
+ (default "/etc/childhurd")))
+
+(define (hurd-vm-disk-image config)
+ "Return a disk-image for the Hurd according to CONFIG. The secret-service
+is added to the OS specified in CONFIG."
+ (let* ((os (secret-service-operating-system
+ (hurd-vm-configuration-os config)))
+ (disk-size (hurd-vm-configuration-disk-size config))
+ (type (lookup-image-type-by-name 'hurd-qcow2))
+ (os->image (image-type-constructor type)))
+ (system-image (os->image os))))
+
+(define (hurd-vm-port config base)
+ "Return the forwarded vm port for this childhurd config."
+ (let ((id (or (hurd-vm-configuration-id config) 0)))
+ (+ base (* 1000 id))))
+(define %hurd-vm-secrets-port 11004)
+(define %hurd-vm-ssh-port 10022)
+(define %hurd-vm-vnc-port 15900)
+
+(define (hurd-vm-net-options config)
+ `("--device" "rtl8139,netdev=net0"
+ "--netdev"
+ ,(string-append "user,id=net0"
+ ",hostfwd=tcp:127.0.0.1:"
+ (number->string (hurd-vm-port config %hurd-vm-secrets-port))
+ "-:1004"
+ ",hostfwd=tcp:127.0.0.1:"
+ (number->string (hurd-vm-port config %hurd-vm-ssh-port))
+ "-:2222"
+ ",hostfwd=tcp:127.0.0.1:"
+ (number->string (hurd-vm-port config %hurd-vm-vnc-port))
+ "-:5900")))
+
+(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))
+ (id (hurd-vm-configuration-id config))
+ (net-options (hurd-vm-configuration-net-options config))
+ (provisions '(hurd-vm childhurd)))
+
+ (define vm-command
+ #~(append (list #$(file-append qemu "/bin/qemu-system-i386")
+ "-m" (number->string #$memory-size)
+ #$@net-options
+ #$@options
+ "--hda" #+image
+
+ ;; Cause the service to be respawned if the guest
+ ;; reboots (it can reboot for instance if it did not
+ ;; receive valid secrets, or if it crashed.)
+ "--no-reboot")
+ (if (file-exists? "/dev/kvm")
+ '("--enable-kvm")
+ '())))
+
+ (list
+ (shepherd-service
+ (documentation "Run the Hurd in a Virtual Machine: a Childhurd.")
+ (provision (if id
+ (map
+ (cute symbol-append <>
+ (string->symbol (number->string id)))
+ provisions)
+ provisions))
+ (requirement '(loopback networking user-processes))
+ (start
+ (with-imported-modules
+ (source-module-closure '((gnu build secret-service)
+ (guix build utils)))
+ #~(lambda ()
+ (let ((pid (fork+exec-command #$vm-command
+ #:user "childhurd"
+ ;; XXX TODO: use "childhurd" after
+ ;; updating Shepherd
+ #:group "kvm"
+ #:environment-variables
+ ;; QEMU tries to write to /var/tmp
+ ;; by default.
+ '("TMPDIR=/tmp")))
+ (port #$(hurd-vm-port config %hurd-vm-secrets-port))
+ (root #$(hurd-vm-configuration-secret-root config)))
+ (catch #t
+ (lambda _
+ ;; XXX: 'secret-service-send-secrets' won't complete until
+ ;; the guest has booted and its secret service server is
+ ;; running, which could take 20+ seconds during which PID 1
+ ;; is stuck waiting.
+ (if (secret-service-send-secrets port root)
+ pid
+ (begin
+ (kill (- pid) SIGTERM)
+ #f)))
+ (lambda (key . args)
+ (kill (- pid) SIGTERM)
+ (apply throw key args)))))))
+ (modules `((gnu build secret-service)
+ (guix build utils)
+ ,@%default-modules))
+ (stop #~(make-kill-destructor))))))
+
+(define %hurd-vm-accounts
+ (list (user-group (name "childhurd") (system? #t))
+ (user-account
+ (name "childhurd")
+ (group "childhurd")
+ (supplementary-groups '("kvm"))
+ (comment "Privilege separation user for the childhurd")
+ (home-directory "/var/empty")
+ (shell (file-append shadow "/sbin/nologin"))
+ (system? #t))))
+
+(define (initialize-hurd-vm-substitutes)
+ "Initialize the Hurd VM's key pair and ACL and store it on the host."
+ (define run
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils)
+ (ice-9 match))
+
+ (define host-key
+ "/etc/guix/signing-key.pub")
+
+ (define host-acl
+ "/etc/guix/acl")
+
+ (match (command-line)
+ ((_ guest-config-directory)
+ (setenv "GUIX_CONFIGURATION_DIRECTORY"
+ guest-config-directory)
+ (invoke #+(file-append guix "/bin/guix") "archive"
+ "--generate-key")
+
+ (when (file-exists? host-acl)
+ ;; Copy the host ACL.
+ (copy-file host-acl
+ (string-append guest-config-directory
+ "/acl")))
+
+ (when (file-exists? host-key)
+ ;; Add the host key to the childhurd's ACL.
+ (let ((key (open-fdes host-key O_RDONLY)))
+ (close-fdes 0)
+ (dup2 key 0)
+ (execl #+(file-append guix "/bin/guix")
+ "guix" "archive" "--authorize"))))))))
+
+ (program-file "initialize-hurd-vm-substitutes" run))
+
+(define (hurd-vm-activation config)
+ "Return a gexp to activate the Hurd VM according to CONFIG."
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils))
+
+ (define secret-directory
+ #$(hurd-vm-configuration-secret-root config))
+
+ (define ssh-directory
+ (string-append secret-directory "/etc/ssh"))
+
+ (define guix-directory
+ (string-append secret-directory "/etc/guix"))
+
+ (unless (file-exists? ssh-directory)
+ ;; Generate SSH host keys under SSH-DIRECTORY.
+ (mkdir-p ssh-directory)
+ (invoke #$(file-append openssh "/bin/ssh-keygen")
+ "-A" "-f" secret-directory))
+
+ (unless (file-exists? guix-directory)
+ (invoke #$(initialize-hurd-vm-substitutes)
+ guix-directory)))))
+
+(define hurd-vm-service-type
+ (service-type
+ (name 'hurd-vm)
+ (extensions (list (service-extension shepherd-root-service-type
+ hurd-vm-shepherd-service)
+ (service-extension account-service-type
+ (const %hurd-vm-accounts))
+ (service-extension activation-service-type
+ hurd-vm-activation)))
+ (default-value (hurd-vm-configuration))
+ (description
+ "Provide a virtual machine (VM) running GNU/Hurd, also known as a
+@dfn{childhurd}.")))
HCoop / jackhill / guix / guix.git / blobdiff