# GNU Guix --- Functional package management for GNU # Copyright © 2018, 2019, 2020 Ludovic Courtès # Copyright © 2020 Eric Bavier # # 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 . # # Test the 'guix pack --relocatable' using the external store, if any. # guix pack --version # 'guix pack --relocatable' requires a C compiler and libc.a, which our # bootstrap binaries don't provide. To make the test relatively inexpensive, # run it on the user's global store if possible, on the grounds that binaries # may already be there or can be built or downloaded inexpensively. storedir="`guile -c '(use-modules (guix config))(display %storedir)'`" localstatedir="`guile -c '(use-modules (guix config))(display %localstatedir)'`" NIX_STORE_DIR="$storedir" GUIX_DAEMON_SOCKET="$localstatedir/guix/daemon-socket/socket" export NIX_STORE_DIR GUIX_DAEMON_SOCKET if ! guile -c '(use-modules (guix)) (exit (false-if-exception (open-connection)))' then exit 77 fi # Attempt to run the given command in a namespace where the store is # invisible. This makes sure the presence of the store does not hide # problems. run_without_store () { if unshare -r true # Are user namespaces supported? then # Run that relocatable executable in a user namespace where we "erase" # the store by mounting an empt
;;; 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 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>
;;;
;;; 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 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))

(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 V