;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Ryan Moe ;;; Copyright © 2018, 2020-2022 Ludovic Courtès ;;; Copyright © 2020,2021 Jan (janneke) Nieuwenhuizen ;;; Copyright © 2021 Timotej Lazar ;;; Copyright © 2022 Oleg Pykhalov ;;; ;;; This file is part of GNU Guix. ;;; ;;; GNU Guix is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or (at ;;; your option) any later version. ;;; ;;; GNU Guix is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see . (define-module (gnu services virtualization) #: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 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 (%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 %qemu-platforms lookup-qemu-platforms qemu-platform? qemu-platform-name qemu-binfmt-configuration qemu-binfmt-configuration? qemu-binfmt-service-type qemu-guest-agent-configuration qemu-guest-agent-configuration? qemu-guest-agent-service-type)) (define (uglify-field-name field-name) (let ((str (symbol->string field-name))) (string-join (string-split (string-delete #\? str) #\-) "_"))) (define (quote-val val) (string-append "\"" val "\"")) (define (serialize-field field-name val) (format #t "~a = ~a\n" (uglify-field-name field-name) val)) (define (serialize-string field-name val) (serialize-field field-name (quote-val val))) (define (serialize-boolean field-name val) (serialize-field field-name (if val 1 0))) (define (serialize-integer field-name val) (serialize-field field-name val)) (define (build-opt-list val) (string-append "[" (string-join (map quote-val val) ",") "]")) (define optional-list? list?) (define optional-string? string?) (define (serialize-list field-name val) (serialize-field field-name (build-opt-list val))) (define (serialize-optional-list field-name val) (if (null? val) (format #t "# ~a = []\n" (uglify-field-name field-name)) (serialize-list field-name val))) (define (serialize-optional-string field-name val) (if (string-null? val) (format #t "# ~a = \"\"\n" (uglify-field-name field-name)) (serialize-string field-name val))) (define-configuration libvirt-configuration (libvirt (file-like libvirt) "Libvirt package.") (qemu (file-like qemu) "Qemu package.") (listen-tls? (boolean #t) "Flag listening for secure TLS connections on the public TCP/IP port. must set @code{listen} for this to have any effect. It is necessary to setup a CA and issue server certificates before using this capability.") (listen-tcp? (boolean #f) "Listen for unencrypted TCP connections on the public TCP/IP port. must set @code{listen} for this to have any effect. Using the TCP socket requires SASL authentication by default. Only SASL mechanisms which support data encryption are allowed. This is DIGEST_MD5 and GSSAPI (Kerberos5)") (tls-port (string "16514") "Port for accepting secure TLS connections This can be a port number, or service name") (tcp-port (string "16509") "Port for accepting insecure TCP connections This can be a port number, or service name") (listen-addr (string "0.0.0.0") "IP address or hostname used for client connections.") (mdns-adv? (boolean #f) "Flag toggling mDNS advertisement of the libvirt service. Alternatively can disable for all services on a host by stopping the Avahi daemon.") (mdns-name (string (string-append "Virtualization Host " (gethostname))) "Default mDNS advertisement name. This must be unique on the immediate broadcast network.") (unix-sock-group (string "libvirt") "UNIX domain socket group ownership. This can be used to allow a 'trusted' set of users access to management capabilities without becoming root.") (unix-sock-ro-perms (string "0777") "UNIX socket permissions for the R/O socket. This is used for monitoring VM status only.") (unix-sock-rw-perms (string "0770") "UNIX socket permissions for the R/W socket. Default allows only root. If PolicyKit is enabled on the socket, the default will change to allow everyone (eg, 0777)") (unix-sock-admin-perms (str