;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 David Craven ;;; Copyright © 2019 Ludovic Courtès ;;; Copyright © 2019 Jesse Gildersleve ;;; Copyright © 2020 Jakub Kądziołka ;;; ;;; 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 se
aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Ryan Moe <ryan.moe@gmail.com>
;;; Copyright © 2018, 2020-2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020, 2021, 2023, 2024 Janneke Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2021 Timotej Lazar <timotej.lazar@araneo.si>
;;; Copyright © 2022 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2022 Leo Nikkilä <hello@lnikki.la>
;;; Copyright © 2023 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2024 Raven Hallsby <karl@hallsby.com>
;;;
;;; 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 <http://www.gnu.org/licenses/>.

(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 bash)
  #:use-module (gnu packages gdb)
  #:autoload   (gnu packages gnupg) (guile-gcrypt)
  #:use-module (gnu packages package-management)
  #:use-module (gnu packages ssh)
  #:use-module (gnu packages base)
  #:use-module (gnu packages gawk)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages virtualization)
  #:use-module (gnu services base)
  #:use-module (gnu services configuration)
  #:use-module (gnu services dbus)
  #:use-module (gnu services mcron)
  #: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)
  #:autoload   (gnu system vm) (linux-image-startup-command
                                virtualized-operating-system)
  #:autoload   (gnu system locale) (locale-definition)
  #: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)
  #:autoload   (guix self) (make-config.scm)
  #:autoload   (guix platform) (platform-system)

  #:use-module ((srfi srfi-1) #:hide (partition))
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 match)

  #:export (virtual-build-machine
            virtual-build-machine-service-type

            %virtual-build-machine-operating-system
            %virtual-build-machine-default-vm

            %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

            xe-guest-utilities-configuration
            xe-guest-utilities-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
   (string "0777")
   "UNIX socket permissions for the admin socket. Default allows
only owner (root), do not change it unless you are sure to whom
you are exposing the access to.")
  (unix-sock-dir
   (string "/var/run/libvirt")
   "The directory in which sockets will be found/created.")
  (auth-unix-ro
   (string "polkit")
   "Authentication scheme for UNIX read-only sockets. By default
socket permissions allow anyone to connect")
  (auth-unix-rw
   (string "polkit")
   "Authentication scheme for UNIX read-write sockets. By default
socket permissions only allow root. If PolicyKit support was compiled
into libvirt, the default will be to use 'polkit' auth.")
  (auth-tcp
   (string "sasl")
   "Authentication scheme for TCP sockets. If you don't enable SASL,
then all TCP traffic is cleartext. Don't do this outside of a dev/test
scenario.")
  (auth-tls
   (string "none")
   "Authentication scheme for TLS sockets. TLS sockets already have
encryption provided by the TLS layer, and limited authentication is
done by certificates.

It is possible to make use of any SASL authentication mechanism as
well, by using 'sasl' for this option")
  (access-drivers
   (optional-list '())
   "API access control scheme.

By default an authenticated user is allowed access to all APIs. Access
drivers can place restrictions on this.")
  (key-file
   (string "")
   "Server key file path. If set to an empty string, then no private key
is loaded.")
  (cert-file
   (string "")
   "Server key file path. If set to an empty string, then no certificate
is loaded.")
  (ca-file
   (string "")
   "Server key file path. If set to an empty string, then no CA certificate
is loaded.")
  (crl-file
   (string "")
   "Certificate revocation list path. If set to an empty string, then no
CRL is loaded.")
  (tls-no-sanity-cert
   (boolean #f)
   "Disable verification of our own server certificates.

When libvirtd starts it performs some sanity checks against its own
certificates.")
  (tls-no-verify-cert
   (boolean #f)
   "Disable verification of client certificates.

Client certificate verification is the primary authentication mechanism.
Any client which does not present a certificate signed by the CA
will be rejected.")
  (tls-allowed-dn-list
   (optional-list '())
   "Whitelist of allowed x509 Distinguished Name.")
  (sasl-allowed-usernames
   (optional-list '())
   "Whitelist of allowed SASL usernames. The format for username
depends on the SASL authentication mechanism.")
  (tls-priority
   (string "NORMAL")
   "Override the compile time default TLS priority string. The
default is usually \"NORMAL\" unless overridden at build time.
Only set this is it is desired for libvirt to deviate from
the global default settings.")
  (max-clients
   (integer 5000)
   "Maximum number of concurrent client connections to allow
over all sockets combined.")
  (max-queued-clients
   (integer 1000)
   "Maximum length of queue of connections waiting to be
accepted by the daemon. Note, that some protocols supporting
retransmission may obey this so that a later reattempt at
connection succeeds.")
  (max-anonymous-clients
   (integer 20)
   "Maximum length of queue of accep