gnu/services/virtualization.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2017 Ryan Moe <ryan.moe@gmail.com>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (gnu services virtualization)
  20   #:use-module (gnu services)
  21   #:use-module (gnu services configuration)
  22   #:use-module (gnu services base)
  23   #:use-module (gnu services dbus)
  24   #:use-module (gnu services shepherd)
  25   #:use-module (gnu system shadow)
  26   #:use-module (gnu packages admin)
  27   #:use-module (gnu packages virtualization)
  28   #:use-module (guix records)
  29   #:use-module (guix gexp)
  30   #:use-module (guix packages)
  31   #:use-module (ice-9 match)
  32
  33   #:export (libvirt-configuration
  34             libvirt-service-type
  35             virtlog-service-type))
  36
  37 (define (uglify-field-name field-name)
  38   (let ((str (symbol->string field-name)))
  39     (string-join
  40      (string-split (string-delete #\? str) #\-)
  41      "_")))
  42
  43 (define (quote-val val)
  44   (string-append "\"" val "\""))
  45
  46 (define (serialize-field field-name val)
  47   (format #t "~a = ~a\n" (uglify-field-name field-name) val))
  48
  49 (define (serialize-string field-name val)
  50   (serialize-field field-name (quote-val val)))
  51
  52 (define (serialize-boolean field-name val)
  53   (serialize-field field-name (if val 1 0)))
  54
  55 (define (serialize-integer field-name val)
  56   (serialize-field field-name val))
  57
  58 (define (build-opt-list val)
  59   (string-append
  60    "["
  61    (string-join (map quote-val val) ",")
  62    "]"))
  63
  64 (define optional-list? list?)
  65 (define optional-string? string?)
  66
  67 (define (serialize-list field-name val)
  68   (serialize-field field-name (build-opt-list val)))
  69
  70 (define (serialize-optional-list field-name val)
  71   (if (null? val)
  72       (format #t "# ~a = []\n" (uglify-field-name field-name))
  73       (serialize-list field-name val)))
  74
  75 (define (serialize-optional-string field-name val)
  76   (if (string-null? val)
  77       (format #t "# ~a = \"\"\n" (uglify-field-name field-name))
  78       (serialize-string field-name val)))
  79
  80 (define-configuration libvirt-configuration
  81   (libvirt
  82    (package libvirt)
  83    "Libvirt package.")
  84   (listen-tls?
  85    (boolean #t)
  86    "Flag listening for secure TLS connections on the public TCP/IP port.
  87 must set @code{listen} for this to have any effect.
  88
  89 It is necessary to setup a CA and issue server certificates before
  90 using this capability.")
  91   (listen-tcp?
  92    (boolean #f)
  93    "Listen for unencrypted TCP connections on the public TCP/IP port.
  94 must set @code{listen} for this to have any effect.
  95
  96 Using the TCP socket requires SASL authentication by default. Only
  97 SASL mechanisms which support data encryption are allowed. This is
  98 DIGEST_MD5 and GSSAPI (Kerberos5)")
  99   (tls-port
 100    (string "16514")
 101    "Port for accepting secure TLS connections This can be a port number,
 102 or service name")
 103   (tcp-port
 104    (string "16509")
 105    "Port for accepting insecure TCP connections This can be a port number,
 106 or service name")
 107   (listen-addr
 108    (string "0.0.0.0")
 109    "IP address or hostname used for client connections.")
 110   (mdns-adv?
 111    (boolean #f)
 112    "Flag toggling mDNS advertisement of the libvirt service.
 113
 114 Alternatively can disable for all services on a host by
 115 stopping the Avahi daemon.")
 116   (mdns-name
 117    (string (string-append "Virtualization Host " (gethostname)))
 118    "Default mDNS advertisement name. This must be unique on the
 119 immediate broadcast network.")
 120   (unix-sock-group
 121    (string "root")
 122    "UNIX domain socket group ownership. This can be used to
 123 allow a 'trusted' set of users access to management capabilities
 124 without becoming root.")
 125   (unix-sock-ro-perms
 126    (string "0777")
 127    "UNIX socket permissions for the R/O socket. This is used
 128 for monitoring VM status only.")
 129   (unix-sock-rw-perms
 130    (string "0770")
 131    "UNIX socket permissions for the R/W socket. Default allows
 132 only root. If PolicyKit is enabled on the socket, the default
 133 will change to allow everyone (eg, 0777)")
 134   (unix-sock-admin-perms
 135    (string "0777")
 136    "UNIX socket permissions for the admin socket. Default allows
 137 only owner (root), do not change it unless you are sure to whom
 138 you are exposing the access to.")
 139   (unix-sock-dir
 140    (string "/var/run/libvirt")
 141    "The directory in which sockets will be found/created.")
 142   (auth-unix-ro
 143    (string "polkit")
 144    "Authentication scheme for UNIX read-only sockets. By default
 145 socket permissions allow anyone to connect")
 146   (auth-unix-rw
 147    (string "polkit")
 148    "Authentication scheme for UNIX read-write sockets. By default
 149 socket permissions only allow root. If PolicyKit support was compiled
 150 into libvirt, the default will be to use 'polkit' auth.")
 151   (auth-tcp
 152    (string "sasl")
 153    "Authentication scheme for TCP sockets. If you don't enable SASL,
 154 then all TCP traffic is cleartext. Don't do this outside of a dev/test
 155 scenario.")
 156   (auth-tls
 157    (string "none")
 158    "Authentication scheme for TLS sockets. TLS sockets already have
 159 encryption provided by the TLS layer, and limited authentication is
 160 done by certificates.
 161
 162 It is possible to make use of any SASL authentication mechanism as
 163 well, by using 'sasl' for this option")
 164   (access-drivers
 165    (optional-list '())
 166    "API access control scheme.
 167
 168 By default an authenticated user is allowed access to all APIs. Access
 169 drivers can place restrictions on this.")
 170   (key-file
 171    (string "")
 172    "Server key file path. If set to an empty string, then no private key
 173 is loaded.")
 174   (cert-file
 175    (string "")
 176    "Server key file path. If set to an empty string, then no certificate
 177 is loaded.")
 178   (ca-file
 179    (string "")
 180    "Server key file path. If set to an empty string, then no CA certificate
 181 is loaded.")
 182   (crl-file
 183    (string "")
 184    "Certificate revocation list path. If set to an empty string, then no
 185 CRL is loaded.")
 186   (tls-no-sanity-cert
 187    (boolean #f)
 188    "Disable verification of our own server certificates.
 189
 190 When libvirtd starts it performs some sanity checks against its own
 191 certificates.")
 192   (tls-no-verify-cert
 193    (boolean #f)
 194    "Disable verification of client certificates.
 195
 196 Client certificate verification is the primary authentication mechanism.
 197 Any client which does not present a certificate signed by the CA
 198 will be rejected.")
 199   (tls-allowed-dn-list
 200    (optional-list '())
 201    "Whitelist of allowed x509 Distinguished Name.")
 202   (sasl-allowed-usernames
 203    (optional-list '())
 204    "Whitelist of allowed SASL usernames. The format for username
 205 depends on the SASL authentication mechanism.")
 206   (tls-priority
 207    (string "NORMAL")
 208    "Override the compile time default TLS priority string. The
 209 default is usually \"NORMAL\" unless overridden at build time.
 210 Only set this is it is desired for libvirt to deviate from
 211 the global default settings.")
 212   (max-clients
 213    (integer 5000)
 214    "Maximum number of concurrent client connections to allow
 215 over all sockets combined.")
 216   (max-queued-clients
 217    (integer 1000)
 218    "Maximum length of queue of connections waiting to be
 219 accepted by the daemon. Note, that some protocols supporting
 220 retransmission may obey this so that a later reattempt at
 221 connection succeeds.")
 222   (max-anonymous-clients
 223    (integer 20)
 224    "Maximum length of queue of accepted but not yet authenticated
 225 clients. Set this to zero to turn this feature off")
 226   (min-workers
 227    (integer 5)
 228    "Number of workers to start up initially.")
 229   (max-workers
 230    (integer 20)
 231    "Maximum number of worker threads.
 232
 233 If the number of active clients exceeds @code{min-workers},
 234 then more threads are spawned, up to max_workers limit.
 235 Typically you'd want max_workers to equal maximum number
 236 of clients allowed.")
 237   (prio-workers
 238    (integer 5)
 239    "Number of priority workers. If all workers from above
 240 pool are stuck, some calls marked as high priority
 241 (notably domainDestroy) can be executed in this pool.")
 242   (max-requests
 243     (integer 20)
 244     "Total global limit on concurrent RPC calls.")
 245   (max-client-requests
 246     (integer 5)
 247     "Limit on concurrent requests from a single client
 248 connection. To avoid one client monopolizing the server
 249 this should be a small fraction of the global max_requests
 250 and max_workers parameter.")
 251   (admin-min-workers
 252     (integer 1)
 253     "Same as @code{min-workers} but for the admin interface.")
 254   (admin-max-workers
 255      (integer 5)
 256     "Same as @code{max-workers} but for the admin interface.")
 257   (admin-max-clients
 258     (integer 5)
 259     "Same as @code{max-clients} but for the admin interface.")
 260   (admin-max-queued-clients
 261     (integer 5)
 262     "Same as @code{max-queued-clients} but for the admin interface.")
 263   (admin-max-client-requests
 264     (integer 5)
 265     "Same as @code{max-client-requests} but for the admin interface.")
 266   (log-level
 267     (integer 3)
 268     "Logging level. 4 errors, 3 warnings, 2 information, 1 debug.")
 269   (log-filters
 270     (string "3:remote 4:event")
 271     "Logging filters.
 272
 273 A filter allows to select a different logging level for a given category
 274 of logs
 275 The format for a filter is one of:
 276 @itemize
 277 @item x:name
 278
 279 @item x:+name
 280 @end itemize
 281
 282 where @code{name} is a string which is matched against the category
 283 given in the @code{VIR_LOG_INIT()} at the top of each libvirt source
 284 file, e.g., \"remote\", \"qemu\", or \"util.json\" (the name in the
 285 filter can be a substring of the full category name, in order
 286 to match multiple similar categories), the optional \"+\" prefix
 287 tells libvirt to log stack trace for each message matching
 288 name, and @code{x} is the minimal level where matching messages should
 289 be logged:
 290
 291 @itemize
 292 @item 1: DEBUG
 293 @item 2: INFO
 294 @item 3: WARNING
 295 @item 4: ERROR
 296 @end itemize
 297
 298 Multiple filters can be defined in a single filters statement, they just
 299 need to be separated by spaces.")
 300   (log-outputs
 301     (string "3:stderr")
 302     "Logging outputs.
 303
 304 An output is one of the places to save logging information
 305 The format for an output can be:
 306
 307 @table @code
 308 @item x:stderr
 309 output goes to stderr
 310
 311 @item x:syslog:name
 312 use syslog for the output and use the given name as the ident
 313
 314 @item x:file:file_path
 315 output to a file, with the given filepath
 316
 317 @item x:journald
 318 output to journald logging system
 319 @end table
 320
 321 In all case the x prefix is the minimal level, acting as a filter
 322
 323 @itemize
 324 @item 1: DEBUG
 325 @item 2: INFO
 326 @item 3: WARNING
 327 @item 4: ERROR
 328 @end itemize
 329
 330 Multiple outputs can be defined, they just need to be separated by spaces.")
 331   (audit-level
 332     (integer 1)
 333     "Allows usage of the auditing subsystem to be altered
 334
 335 @itemize
 336 @item 0: disable all auditing
 337 @item 1: enable auditing, only if enabled on host
 338 @item 2: enable auditing, and exit if disabled on host.
 339 @end itemize
 340 ")
 341   (audit-logging
 342     (boolean #f)
 343     "Send audit messages via libvirt logging infrastructure.")
 344   (host-uuid
 345     (optional-string "")
 346     "Host UUID. UUID must not have all digits be the same.")
 347   (host-uuid-source
 348     (string "smbios")
 349     "Source to read host UUID.
 350
 351 @itemize
 352
 353 @item @code{smbios}: fetch the UUID from @code{dmidecode -s system-uuid}
 354
 355 @item @code{machine-id}: fetch the UUID from @code{/etc/machine-id}
 356
 357 @end itemize
 358
 359 If @code{dmidecode} does not provide a valid UUID a temporary UUID
 360 will be generated.")
 361   (keepalive-interval
 362     (integer 5)
 363     "A keepalive message is sent to a client after
 364 @code{keepalive_interval} seconds of inactivity to check if
 365 the client is still responding. If set to -1, libvirtd will
 366 never send keepalive requests; however clients can still send
 367 them and the daemon will send responses.")
 368   (keepalive-count
 369     (integer 5)
 370     "Maximum number of keepalive messages that are allowed to be sent
 371 to the client without getting any response before the connection is
 372 considered broken.
 373
 374 In other words, the connection is automatically
 375 closed approximately after
 376 @code{keepalive_interval * (keepalive_count + 1)} seconds since the last
 377 message received from the client. When @code{keepalive-count} is
 378 set to 0, connections will be automatically closed after
 379 @code{keepalive-interval} seconds of inactivity without sending any
 380 keepalive messages.")
 381   (admin-keepalive-interval
 382     (integer 5)
 383     "Same as above but for admin interface.")
 384   (admin-keepalive-count
 385     (integer 5)
 386     "Same as above but for admin interface.")
 387   (ovs-timeout
 388     (integer 5)
 389     "Timeout for Open vSwitch calls.
 390
 391 The @code{ovs-vsctl} utility is used for the configuration and
 392 its timeout option is set by default to 5 seconds to avoid
 393 potential infinite waits blocking libvirt."))
 394
 395 (define* (libvirt-conf-file config)
 396   "Return a libvirtd config file."
 397   (plain-file "libvirtd.conf"
 398               (with-output-to-string
 399                 (lambda ()
 400                   (serialize-configuration config libvirt-configuration-fields)))))
 401
 402 (define %libvirt-accounts
 403   (list (user-group (name "libvirt") (system? #t))))
 404
 405 (define (%libvirt-activation config)
 406   (let ((sock-dir (libvirt-configuration-unix-sock-dir config)))
 407     #~(begin
 408         (use-modules (guix build utils))
 409         (mkdir-p #$sock-dir))))
 410
 411
 412 (define (libvirt-shepherd-service config)
 413   (let* ((config-file (libvirt-conf-file config))
 414          (libvirt (libvirt-configuration-libvirt config)))
 415     (list (shepherd-service
 416            (documentation "Run the libvirt daemon.")
 417            (provision '(libvirtd))
 418            (start #~(make-forkexec-constructor
 419                      (list (string-append #$libvirt "/sbin/libvirtd")
 420                            "-f" #$config-file)))
 421            (stop #~(make-kill-destructor))))))
 422
 423 (define libvirt-service-type
 424   (service-type (name 'libvirt)
 425                 (extensions
 426                  (list
 427                   (service-extension polkit-service-type
 428                                      (compose list libvirt-configuration-libvirt))
 429                   (service-extension profile-service-type
 430                                      (compose list
 431                                               libvirt-configuration-libvirt))
 432                   (service-extension activation-service-type
 433                                      %libvirt-activation)
 434                   (service-extension shepherd-root-service-type
 435                                      libvirt-shepherd-service)
 436                   (service-extension account-service-type
 437                                      (const %libvirt-accounts))))
 438                 (default-value (libvirt-configuration))))
 439
 440
 441 (define-record-type* <virtlog-configuration>
 442   virtlog-configuration make-virtlog-configuration
 443   virtlog-configuration?
 444   (libvirt      virtlog-configuration-libvirt
 445                 (default libvirt))
 446   (log-level    virtlog-configuration-log-level
 447                 (default 3))
 448   (log-filters  virtlog-configuration-log-filters
 449                 (default "3:remote 4:event"))
 450   (log-outputs  virtlog-configuration-log-outputs
 451                 (default "3:syslog:virtlogd"))
 452   (max-clients  virtlog-configuration-max-clients
 453                 (default 1024))
 454   (max-size     virtlog-configuration-max-size
 455                 (default 2097152)) ;; 2MB
 456   (max-backups  virtlog-configuration-max-backups
 457                 (default 3)))
 458
 459 (define* (virtlogd-conf-file config)
 460   "Return a virtlogd config file."
 461   (plain-file "virtlogd.conf"
 462               (string-append
 463                "log_level = " (number->string (virtlog-configuration-log-level config)) "\n"
 464                "log_filters = \"" (virtlog-configuration-log-filters config) "\"\n"
 465                "log_outputs = \"" (virtlog-configuration-log-outputs config) "\"\n"
 466                "max_clients = " (number->string (virtlog-configuration-max-clients config)) "\n"
 467                "max_size = " (number->string (virtlog-configuration-max-size config)) "\n"
 468                "max_backups = " (number->string (virtlog-configuration-max-backups config)) "\n")))
 469
 470 (define (virtlogd-shepherd-service config)
 471   (let* ((config-file (virtlogd-conf-file config))
 472          (libvirt (virtlog-configuration-libvirt config)))
 473     (list (shepherd-service
 474            (documentation "Run the virtlog daemon.")
 475            (provision '(virtlogd))
 476            (start #~(make-forkexec-constructor
 477                      (list (string-append #$libvirt "/sbin/virtlogd")
 478                            "-f" #$config-file)))
 479            (stop #~(make-kill-destructor))))))
 480
 481 (define virtlog-service-type
 482   (service-type (name 'virtlogd)
 483                 (extensions
 484                  (list
 485                   (service-extension shepherd-root-service-type
 486                                      virtlogd-shepherd-service)))
 487                 (default-value (virtlog-configuration))))
 488
 489 (define (generate-libvirt-documentation)
 490   (generate-documentation
 491    `((libvirt-configuration ,libvirt-configuration-fields))
 492    'libvirt-configuration))