;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Ryan Moe <ryan.moe@gmail.com>
-;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; 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 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 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-configuration
virtlog-service-type
(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
(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")
(define %qemu-platforms
(list %i386 %i486 %alpha %arm %sparc32plus %ppc %ppc64 %ppc64le %m68k
%mips %mipsel %mipsn32 %mipsn32el %mips64 %mips64el
- %sh4 %sh4eb %s390x %aarch64 %hppa))
+ %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
"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