services: Add libvirt services

* gnu/services/virtualization.scm: New file.
* doc/guix.texi (Virtualization Services): Document it.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add it.

Signed-off-by: Christopher Baines <mail@cbaines.net>

2 files changed, 493 insertions, 0 deletions

diff --git a/gnu/local.mk b/gnu/local.mk
index 1c6158cbfc..1bec2227ec 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -440,6 +440,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/services/dns.scm				\
   %D%/services/kerberos.scm			\
   %D%/services/lirc.scm				\
+  %D%/services/virtualization.scm		\
   %D%/services/mail.scm				\
   %D%/services/mcron.scm			\
   %D%/services/messaging.scm			\
diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm
new file mode 100644
index 0000000000..845cdb07ba
--- /dev/null
+++ b/gnu/services/virtualization.scm
@@ -0,0 +1,492 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Ryan Moe <ryan.moe@gmail.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 services)
+  #:use-module (gnu services configuration)
+  #:use-module (gnu services base)
+  #:use-module (gnu services dbus)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu system shadow)
+  #:use-module (gnu packages admin)
+  #:use-module (gnu packages virtualization)
+  #:use-module (guix records)
+  #:use-module (guix gexp)
+  #:use-module (guix packages)
+  #:use-module (ice-9 match)
+
+  #:export (libvirt-configuration
+            libvirt-service-type
+            virtlog-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
+   (package libvirt)
+   "Libvirt 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 "root")
+   "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 accepted but not yet authenticated
+clients. Set this to zero to turn this feature off")
+  (min-workers
+   (integer 5)
+   "Number of workers to start up initially.")
+  (max-workers
+   (integer 20)
+   "Maximum number of worker threads.
+
+If the number of active clients exceeds @code{min-workers},
+then more threads are spawned, up to max_workers limit.
+Typically you'd want max_workers to equal maximum number
+of clients allowed.")
+  (prio-workers
+   (integer 5)
+   "Number of priority workers. If all workers from above
+pool are stuck, some calls marked as high priority
+(notably domainDestroy) can be executed in this pool.")
+  (max-requests
+    (integer 20)
+    "Total global limit on concurrent RPC calls.")
+  (max-client-requests
+    (integer 5)
+    "Limit on concurrent requests from a single client
+connection. To avoid one client monopolizing the server
+this should be a small fraction of the global max_requests
+and max_workers parameter.")
+  (admin-min-workers
+    (integer 1)
+    "Same as @code{min-workers} but for the admin interface.")
+  (admin-max-workers
+     (integer 5)
+    "Same as @code{max-workers} but for the admin interface.")
+  (admin-max-clients
+    (integer 5)
+    "Same as @code{max-clients} but for the admin interface.")
+  (admin-max-queued-clients
+    (integer 5)
+    "Same as @code{max-queued-clients} but for the admin interface.")
+  (admin-max-client-requests
+    (integer 5)
+    "Same as @code{max-client-requests} but for the admin interface.")
+  (log-level
+    (integer 3)
+    "Logging level. 4 errors, 3 warnings, 2 information, 1 debug.")
+  (log-filters
+    (string "3:remote 4:event")
+    "Logging filters.
+
+A filter allows to select a different logging level for a given category
+of logs
+The format for a filter is one of:
+@itemize
+@item x:name
+
+@item x:+name
+@end itemize
+
+where @code{name} is a string which is matched against the category
+given in the @code{VIR_LOG_INIT()} at the top of each libvirt source
+file, e.g., \"remote\", \"qemu\", or \"util.json\" (the name in the
+filter can be a substring of the full category name, in order
+to match multiple similar categories), the optional \"+\" prefix
+tells libvirt to log stack trace for each message matching
+name, and @code{x} is the minimal level where matching messages should
+be logged:
+
+@itemize
+@item 1: DEBUG
+@item 2: INFO
+@item 3: WARNING
+@item 4: ERROR
+@end itemize
+
+Multiple filters can be defined in a single filters statement, they just
+need to be separated by spaces.")
+  (log-outputs
+    (string "3:stderr")
+    "Logging outputs.
+
+An output is one of the places to save logging information
+The format for an output can be:
+
+@table @code
+@item x:stderr
+output goes to stderr
+
+@item x:syslog:name
+use syslog for the output and use the given name as the ident
+
+@item x:file:file_path
+output to a file, with the given filepath
+
+@item x:journald
+output to journald logging system
+@end table
+
+In all case the x prefix is the minimal level, acting as a filter
+
+@itemize
+@item 1: DEBUG
+@item 2: INFO
+@item 3: WARNING
+@item 4: ERROR
+@end itemize
+
+Multiple outputs can be defined, they just need to be separated by spaces.")
+  (audit-level
+    (integer 1)
+    "Allows usage of the auditing subsystem to be altered
+
+@itemize
+@item 0: disable all auditing
+@item 1: enable auditing, only if enabled on host
+@item 2: enable auditing, and exit if disabled on host.
+@end itemize
+")
+  (audit-logging
+    (boolean #f)
+    "Send audit messages via libvirt logging infrastructure.")
+  (host-uuid
+    (optional-string "")
+    "Host UUID. UUID must not have all digits be the same.")
+  (host-uuid-source
+    (string "smbios")
+    "Source to read host UUID.
+
+@itemize
+
+@item @code{smbios}: fetch the UUID from @code{dmidecode -s system-uuid}
+
+@item @code{machine-id}: fetch the UUID from @code{/etc/machine-id}
+
+@end itemize
+
+If @code{dmidecode} does not provide a valid UUID a temporary UUID
+will be generated.")
+  (keepalive-interval
+    (integer 5)
+    "A keepalive message is sent to a client after
+@code{keepalive_interval} seconds of inactivity to check if
+the client is still responding. If set to -1, libvirtd will
+never send keepalive requests; however clients can still send
+them and the daemon will send responses.")
+  (keepalive-count
+    (integer 5)
+    "Maximum number of keepalive messages that are allowed to be sent
+to the client without getting any response before the connection is
+considered broken.
+
+In other words, the connection is automatically
+closed approximately after
+@code{keepalive_interval * (keepalive_count + 1)} seconds since the last
+message received from the client. When @code{keepalive-count} is
+set to 0, connections will be automatically closed after
+@code{keepalive-interval} seconds of inactivity without sending any
+keepalive messages.")
+  (admin-keepalive-interval
+    (integer 5)
+    "Same as above but for admin interface.")
+  (admin-keepalive-count
+    (integer 5)
+    "Same as above but for admin interface.")
+  (ovs-timeout
+    (integer 5)
+    "Timeout for Open vSwitch calls.
+
+The @code{ovs-vsctl} utility is used for the configuration and
+its timeout option is set by default to 5 seconds to avoid
+potential infinite waits blocking libvirt."))
+
+(define* (libvirt-conf-file config)
+  "Return a libvirtd config file."
+  (plain-file "libvirtd.conf"
+              (with-output-to-string
+                (lambda ()
+                  (serialize-configuration config libvirt-configuration-fields)))))
+
+(define %libvirt-accounts
+  (list (user-group (name "libvirt") (system? #t))))
+
+(define (%libvirt-activation config)
+  (let ((sock-dir (libvirt-configuration-unix-sock-dir config)))
+    #~(begin
+        (use-modules (guix build utils))
+        (mkdir-p #$sock-dir))))
+
+
+(define (libvirt-shepherd-service config)
+  (let* ((config-file (libvirt-conf-file config))
+         (libvirt (libvirt-configuration-libvirt config)))
+    (list (shepherd-service
+           (documentation "Run the libvirt daemon.")
+           (provision '(libvirtd))
+           (start #~(make-forkexec-constructor
+                     (list (string-append #$libvirt "/sbin/libvirtd")
+                           "-f" #$config-file)))
+           (stop #~(make-kill-destructor))))))
+
+(define libvirt-service-type
+  (service-type (name 'libvirt)
+		(extensions
+                 (list
+                  (service-extension polkit-service-type
+                                     (compose list libvirt-configuration-libvirt))
+                  (service-extension profile-service-type
+                                     (compose list
+                                              libvirt-configuration-libvirt))
+                  (service-extension activation-service-type
+                                     %libvirt-activation)
+                  (service-extension shepherd-root-service-type
+                                     libvirt-shepherd-service)
+                  (service-extension account-service-type
+                                     (const %libvirt-accounts))))
+                (default-value (libvirt-configuration))))
+
+
+(define-record-type* <virtlog-configuration>
+  virtlog-configuration make-virtlog-configuration
+  virtlog-configuration?
+  (libvirt      virtlog-configuration-libvirt
+                (default libvirt))
+  (log-level    virtlog-configuration-log-level
+                (default 3))
+  (log-filters  virtlog-configuration-log-filters
+                (default "3:remote 4:event"))
+  (log-outputs  virtlog-configuration-log-outputs
+                (default "3:syslog:virtlogd"))
+  (max-clients  virtlog-configuration-max-clients
+                (default 1024))
+  (max-size     virtlog-configuration-max-size
+                (default 2097152)) ;; 2MB
+  (max-backups  virtlog-configuration-max-backups
+                (default 3)))
+
+(define* (virtlogd-conf-file config)
+  "Return a virtlogd config file."
+  (plain-file "virtlogd.conf"
+              (string-append
+               "log_level = " (number->string (virtlog-configuration-log-level config)) "\n"
+               "log_filters = \"" (virtlog-configuration-log-filters config) "\"\n"
+               "log_outputs = \"" (virtlog-configuration-log-outputs config) "\"\n"
+               "max_clients = " (number->string (virtlog-configuration-max-clients config)) "\n"
+               "max_size = " (number->string (virtlog-configuration-max-size config)) "\n"
+               "max_backups = " (number->string (virtlog-configuration-max-backups config)) "\n")))
+
+(define (virtlogd-shepherd-service config)
+  (let* ((config-file (virtlogd-conf-file config))
+         (libvirt (virtlog-configuration-libvirt config)))
+    (list (shepherd-service
+           (documentation "Run the virtlog daemon.")
+           (provision '(virtlogd))
+           (start #~(make-forkexec-constructor
+                     (list (string-append #$libvirt "/sbin/virtlogd")
+                           "-f" #$config-file)))
+           (stop #~(make-kill-destructor))))))
+
+(define virtlog-service-type
+  (service-type (name 'virtlogd)
+		(extensions
+                 (list
+                  (service-extension shepherd-root-service-type
+                                     virtlogd-shepherd-service)))
+                (default-value (virtlog-configuration))))
+
+(define (generate-libvirt-documentation)
+  (generate-documentation
+   `((libvirt-configuration ,libvirt-configuration-fields))
+   'libvirt-configuration))