gnu/services/virtualization.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2017 Ryan Moe <ryan.moe@gmail.com>
   3 ;;; Copyright © 2018, 2020 Ludovic Courtès <ludo@gnu.org>
   4 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (gnu services virtualization)
  22   #:use-module (gnu bootloader)
  23   #:use-module (gnu bootloader grub)
  24   #:use-module (gnu image)
  25   #:use-module (gnu packages admin)
  26   #:use-module (gnu packages gdb)
  27   #:use-module (gnu packages package-management)
  28   #:use-module (gnu packages ssh)
  29   #:use-module (gnu packages virtualization)
  30   #:use-module (gnu services base)
  31   #:use-module (gnu services configuration)
  32   #:use-module (gnu services dbus)
  33   #:use-module (gnu services shepherd)
  34   #:use-module (gnu services ssh)
  35   #:use-module (gnu services)
  36   #:use-module (gnu system file-systems)
  37   #:use-module (gnu system hurd)
  38   #:use-module (gnu system image)
  39   #:use-module (gnu system shadow)
  40   #:use-module (gnu system)
  41   #:use-module (guix derivations)
  42   #:use-module (guix gexp)
  43   #:use-module (guix modules)
  44   #:use-module (guix monads)
  45   #:use-module (guix packages)
  46   #:use-module (guix records)
  47   #:use-module (guix store)
  48   #:use-module (guix utils)
  49
  50   #:use-module (srfi srfi-9)
  51   #:use-module (srfi srfi-26)
  52   #:use-module (rnrs bytevectors)
  53   #:use-module (ice-9 match)
  54
  55   #:export (%hurd-vm-operating-system
  56             hurd-vm-configuration
  57             hurd-vm-configuration?
  58             hurd-vm-configuration-os
  59             hurd-vm-configuration-qemu
  60             hurd-vm-configuration-image
  61             hurd-vm-configuration-disk-size
  62             hurd-vm-configuration-memory-size
  63             hurd-vm-configuration-options
  64             hurd-vm-configuration-id
  65             hurd-vm-configuration-net-options
  66             hurd-vm-configuration-secrets
  67
  68             hurd-vm-disk-image
  69             hurd-vm-port
  70             hurd-vm-net-options
  71             hurd-vm-service-type
  72
  73             libvirt-configuration
  74             libvirt-service-type
  75             virtlog-configuration
  76             virtlog-service-type
  77
  78             %qemu-platforms
  79             lookup-qemu-platforms
  80             qemu-platform?
  81             qemu-platform-name
  82
  83             qemu-binfmt-configuration
  84             qemu-binfmt-configuration?
  85             qemu-binfmt-service-type))
  86
  87 (define (uglify-field-name field-name)
  88   (let ((str (symbol->string field-name)))
  89     (string-join
  90      (string-split (string-delete #\? str) #\-)
  91      "_")))
  92
  93 (define (quote-val val)
  94   (string-append "\"" val "\""))
  95
  96 (define (serialize-field field-name val)
  97   (format #t "~a = ~a\n" (uglify-field-name field-name) val))
  98
  99 (define (serialize-string field-name val)
 100   (serialize-field field-name (quote-val val)))
 101
 102 (define (serialize-boolean field-name val)
 103   (serialize-field field-name (if val 1 0)))
 104
 105 (define (serialize-integer field-name val)
 106   (serialize-field field-name val))
 107
 108 (define (build-opt-list val)
 109   (string-append
 110    "["
 111    (string-join (map quote-val val) ",")
 112    "]"))
 113
 114 (define optional-list? list?)
 115 (define optional-string? string?)
 116
 117 (define (serialize-list field-name val)
 118   (serialize-field field-name (build-opt-list val)))
 119
 120 (define (serialize-optional-list field-name val)
 121   (if (null? val)
 122       (format #t "# ~a = []\n" (uglify-field-name field-name))
 123       (serialize-list field-name val)))
 124
 125 (define (serialize-optional-string field-name val)
 126   (if (string-null? val)
 127       (format #t "# ~a = \"\"\n" (uglify-field-name field-name))
 128       (serialize-string field-name val)))
 129
 130 (define-configuration libvirt-configuration
 131   (libvirt
 132    (package libvirt)
 133    "Libvirt package.")
 134   (listen-tls?
 135    (boolean #t)
 136    "Flag listening for secure TLS connections on the public TCP/IP port.
 137 must set @code{listen} for this to have any effect.
 138
 139 It is necessary to setup a CA and issue server certificates before
 140 using this capability.")
 141   (listen-tcp?
 142    (boolean #f)
 143    "Listen for unencrypted TCP connections on the public TCP/IP port.
 144 must set @code{listen} for this to have any effect.
 145
 146 Using the TCP socket requires SASL authentication by default. Only
 147 SASL mechanisms which support data encryption are allowed. This is
 148 DIGEST_MD5 and GSSAPI (Kerberos5)")
 149   (tls-port
 150    (string "16514")
 151    "Port for accepting secure TLS connections This can be a port number,
 152 or service name")
 153   (tcp-port
 154    (string "16509")
 155    "Port for accepting insecure TCP connections This can be a port number,
 156 or service name")
 157   (listen-addr
 158    (string "0.0.0.0")
 159    "IP address or hostname used for client connections.")
 160   (mdns-adv?
 161    (boolean #f)
 162    "Flag toggling mDNS advertisement of the libvirt service.
 163
 164 Alternatively can disable for all services on a host by
 165 stopping the Avahi daemon.")
 166   (mdns-name
 167    (string (string-append "Virtualization Host " (gethostname)))
 168    "Default mDNS advertisement name. This must be unique on the
 169 immediate broadcast network.")
 170   (unix-sock-group
 171    (string "root")
 172    "UNIX domain socket group ownership. This can be used to
 173 allow a 'trusted' set of users access to management capabilities
 174 without becoming root.")
 175   (unix-sock-ro-perms
 176    (string "0777")
 177    "UNIX socket permissions for the R/O socket. This is used
 178 for monitoring VM status only.")
 179   (unix-sock-rw-perms
 180    (string "0770")
 181    "UNIX socket permissions for the R/W socket. Default allows
 182 only root. If PolicyKit is enabled on the socket, the default
 183 will change to allow everyone (eg, 0777)")
 184   (unix-sock-admin-perms
 185    (string "0777")
 186    "UNIX socket permissions for the admin socket. Default allows
 187 only owner (root), do not change it unless you are sure to whom
 188 you are exposing the access to.")
 189   (unix-sock-dir
 190    (string "/var/run/libvirt")
 191    "The directory in which sockets will be found/created.")
 192   (auth-unix-ro
 193    (string "polkit")
 194    "Authentication scheme for UNIX read-only sockets. By default
 195 socket permissions allow anyone to connect")
 196   (auth-unix-rw
 197    (string "polkit")
 198    "Authentication scheme for UNIX read-write sockets. By default
 199 socket permissions only allow root. If PolicyKit support was compiled
 200 into libvirt, the default will be to use 'polkit' auth.")
 201   (auth-tcp
 202    (string "sasl")
 203    "Authentication scheme for TCP sockets. If you don't enable SASL,
 204 then all TCP traffic is cleartext. Don't do this outside of a dev/test
 205 scenario.")
 206   (auth-tls
 207    (string "none")
 208    "Authentication scheme for TLS sockets. TLS sockets already have
 209 encryption provided by the TLS layer, and limited authentication is
 210 done by certificates.
 211
 212 It is possible to make use of any SASL authentication mechanism as
 213 well, by using 'sasl' for this option")
 214   (access-drivers
 215    (optional-list '())
 216    "API access control scheme.
 217
 218 By default an authenticated user is allowed access to all APIs. Access
 219 drivers can place restrictions on this.")
 220   (key-file
 221    (string "")
 222    "Server key file path. If set to an empty string, then no private key
 223 is loaded.")
 224   (cert-file
 225    (string "")
 226    "Server key file path. If set to an empty string, then no certificate
 227 is loaded.")
 228   (ca-file
 229    (string "")
 230    "Server key file path. If set to an empty string, then no CA certificate
 231 is loaded.")
 232   (crl-file
 233    (string "")
 234    "Certificate revocation list path. If set to an empty string, then no
 235 CRL is loaded.")
 236   (tls-no-sanity-cert
 237    (boolean #f)
 238    "Disable verification of our own server certificates.
 239
 240 When libvirtd starts it performs some sanity checks against its own
 241 certificates.")
 242   (tls-no-verify-cert
 243    (boolean #f)
 244    "Disable verification of client certificates.
 245
 246 Client certificate verification is the primary authentication mechanism.
 247 Any client which does not present a certificate signed by the CA
 248 will be rejected.")
 249   (tls-allowed-dn-list
 250    (optional-list '())
 251    "Whitelist of allowed x509 Distinguished Name.")
 252   (sasl-allowed-usernames
 253    (optional-list '())
 254    "Whitelist of allowed SASL usernames. The format for username
 255 depends on the SASL authentication mechanism.")
 256   (tls-priority
 257    (string "NORMAL")
 258    "Override the compile time default TLS priority string. The
 259 default is usually \"NORMAL\" unless overridden at build time.
 260 Only set this is it is desired for libvirt to deviate from
 261 the global default settings.")
 262   (max-clients
 263    (integer 5000)
 264    "Maximum number of concurrent client connections to allow
 265 over all sockets combined.")
 266   (max-queued-clients
 267    (integer 1000)
 268    "Maximum length of queue of connections waiting to be
 269 accepted by the daemon. Note, that some protocols supporting
 270 retransmission may obey this so that a later reattempt at
 271 connection succeeds.")
 272   (max-anonymous-clients
 273    (integer 20)
 274    "Maximum length of queue of accepted but not yet authenticated
 275 clients. Set this to zero to turn this feature off")
 276   (min-workers
 277    (integer 5)
 278    "Number of workers to start up initially.")
 279   (max-workers
 280    (integer 20)
 281    "Maximum number of worker threads.
 282
 283 If the number of active clients exceeds @code{min-workers},
 284 then more threads are spawned, up to max_workers limit.
 285 Typically you'd want max_workers to equal maximum number
 286 of clients allowed.")
 287   (prio-workers
 288    (integer 5)
 289    "Number of priority workers. If all workers from above
 290 pool are stuck, some calls marked as high priority
 291 (notably domainDestroy) can be executed in this pool.")
 292   (max-requests
 293     (integer 20)
 294     "Total global limit on concurrent RPC calls.")
 295   (max-client-requests
 296     (integer 5)
 297     "Limit on concurrent requests from a single client
 298 connection. To avoid one client monopolizing the server
 299 this should be a small fraction of the global max_requests
 300 and max_workers parameter.")
 301   (admin-min-workers
 302     (integer 1)
 303     "Same as @code{min-workers} but for the admin interface.")
 304   (admin-max-workers
 305      (integer 5)
 306     "Same as @code{max-workers} but for the admin interface.")
 307   (admin-max-clients
 308     (integer 5)
 309     "Same as @code{max-clients} but for the admin interface.")
 310   (admin-max-queued-clients
 311     (integer 5)
 312     "Same as @code{max-queued-clients} but for the admin interface.")
 313   (admin-max-client-requests
 314     (integer 5)
 315     "Same as @code{max-client-requests} but for the admin interface.")
 316   (log-level
 317     (integer 3)
 318     "Logging level. 4 errors, 3 warnings, 2 information, 1 debug.")
 319   (log-filters
 320     (string "3:remote 4:event")
 321     "Logging filters.
 322
 323 A filter allows selecting a different logging level for a given category
 324 of logs
 325 The format for a filter is one of:
 326 @itemize
 327 @item x:name
 328
 329 @item x:+name
 330 @end itemize
 331
 332 where @code{name} is a string which is matched against the category
 333 given in the @code{VIR_LOG_INIT()} at the top of each libvirt source
 334 file, e.g., \"remote\", \"qemu\", or \"util.json\" (the name in the
 335 filter can be a substring of the full category name, in order
 336 to match multiple similar categories), the optional \"+\" prefix
 337 tells libvirt to log stack trace for each message matching
 338 name, and @code{x} is the minimal level where matching messages should
 339 be logged:
 340
 341 @itemize
 342 @item 1: DEBUG
 343 @item 2: INFO
 344 @item 3: WARNING
 345 @item 4: ERROR
 346 @end itemize
 347
 348 Multiple filters can be defined in a single filters statement, they just
 349 need to be separated by spaces.")
 350   (log-outputs
 351     (string "3:syslog:libvirtd")
 352     "Logging outputs.
 353
 354 An output is one of the places to save logging information
 355 The format for an output can be:
 356
 357 @table @code
 358 @item x:stderr
 359 output goes to stderr
 360
 361 @item x:syslog:name
 362 use syslog for the output and use the given name as the ident
 363
 364 @item x:file:file_path
 365 output to a file, with the given filepath
 366
 367 @item x:journald
 368 output to journald logging system
 369 @end table
 370
 371 In all case the x prefix is the minimal level, acting as a filter
 372
 373 @itemize
 374 @item 1: DEBUG
 375 @item 2: INFO
 376 @item 3: WARNING
 377 @item 4: ERROR
 378 @end itemize
 379
 380 Multiple outputs can be defined, they just need to be separated by spaces.")
 381   (audit-level
 382     (integer 1)
 383     "Allows usage of the auditing subsystem to be altered
 384
 385 @itemize
 386 @item 0: disable all auditing
 387 @item 1: enable auditing, only if enabled on host
 388 @item 2: enable auditing, and exit if disabled on host.
 389 @end itemize
 390 ")
 391   (audit-logging
 392     (boolean #f)
 393     "Send audit messages via libvirt logging infrastructure.")
 394   (host-uuid
 395     (optional-string "")
 396     "Host UUID. UUID must not have all digits be the same.")
 397   (host-uuid-source
 398     (string "smbios")
 399     "Source to read host UUID.
 400
 401 @itemize
 402
 403 @item @code{smbios}: fetch the UUID from @code{dmidecode -s system-uuid}
 404
 405 @item @code{machine-id}: fetch the UUID from @code{/etc/machine-id}
 406
 407 @end itemize
 408
 409 If @code{dmidecode} does not provide a valid UUID a temporary UUID
 410 will be generated.")
 411   (keepalive-interval
 412     (integer 5)
 413     "A keepalive message is sent to a client after
 414 @code{keepalive_interval} seconds of inactivity to check if
 415 the client is still responding. If set to -1, libvirtd will
 416 never send keepalive requests; however clients can still send
 417 them and the daemon will send responses.")
 418   (keepalive-count
 419     (integer 5)
 420     "Maximum number of keepalive messages that are allowed to be sent
 421 to the client without getting any response before the connection is
 422 considered broken.
 423
 424 In other words, the connection is automatically
 425 closed approximately after
 426 @code{keepalive_interval * (keepalive_count + 1)} seconds since the last
 427 message received from the client. When @code{keepalive-count} is
 428 set to 0, connections will be automatically closed after
 429 @code{keepalive-interval} seconds of inactivity without sending any
 430 keepalive messages.")
 431   (admin-keepalive-interval
 432     (integer 5)
 433     "Same as above but for admin interface.")
 434   (admin-keepalive-count
 435     (integer 5)
 436     "Same as above but for admin interface.")
 437   (ovs-timeout
 438     (integer 5)
 439     "Timeout for Open vSwitch calls.
 440
 441 The @code{ovs-vsctl} utility is used for the configuration and
 442 its timeout option is set by default to 5 seconds to avoid
 443 potential infinite waits blocking libvirt."))
 444
 445 (define* (libvirt-conf-file config)
 446   "Return a libvirtd config file."
 447   (plain-file "libvirtd.conf"
 448               (with-output-to-string
 449                 (lambda ()
 450                   (serialize-configuration config libvirt-configuration-fields)))))
 451
 452 (define %libvirt-accounts
 453   (list (user-group (name "libvirt") (system? #t))))
 454
 455 (define (%libvirt-activation config)
 456   (let ((sock-dir (libvirt-configuration-unix-sock-dir config)))
 457     #~(begin
 458         (use-modules (guix build utils))
 459         (mkdir-p #$sock-dir))))
 460
 461
 462 (define (libvirt-shepherd-service config)
 463   (let* ((config-file (libvirt-conf-file config))
 464          (libvirt (libvirt-configuration-libvirt config)))
 465     (list (shepherd-service
 466            (documentation "Run the libvirt daemon.")
 467            (provision '(libvirtd))
 468            (start #~(make-forkexec-constructor
 469                      (list (string-append #$libvirt "/sbin/libvirtd")
 470                            "-f" #$config-file)
 471                      ;; For finding qemu and ip binaries.
 472                      #:environment-variables
 473                      (list (string-append
 474                             "PATH=/run/current-system/profile/bin:"
 475                             "/run/current-system/profile/sbin"))))
 476            (stop #~(make-kill-destructor))))))
 477
 478 (define libvirt-service-type
 479   (service-type (name 'libvirt)
 480                 (extensions
 481                  (list
 482                   (service-extension polkit-service-type
 483                                      (compose list libvirt-configuration-libvirt))
 484                   (service-extension profile-service-type
 485                                      (lambda (config)
 486                                        (list
 487                                         (libvirt-configuration-libvirt config)
 488                                         qemu)))
 489                   (service-extension activation-service-type
 490                                      %libvirt-activation)
 491                   (service-extension shepherd-root-service-type
 492                                      libvirt-shepherd-service)
 493                   (service-extension account-service-type
 494                                      (const %libvirt-accounts))))
 495                 (default-value (libvirt-configuration))))
 496
 497
 498 (define-record-type* <virtlog-configuration>
 499   virtlog-configuration make-virtlog-configuration
 500   virtlog-configuration?
 501   (libvirt      virtlog-configuration-libvirt
 502                 (default libvirt))
 503   (log-level    virtlog-configuration-log-level
 504                 (default 3))
 505   (log-filters  virtlog-configuration-log-filters
 506                 (default "3:remote 4:event"))
 507   (log-outputs  virtlog-configuration-log-outputs
 508                 (default "3:syslog:virtlogd"))
 509   (max-clients  virtlog-configuration-max-clients
 510                 (default 1024))
 511   (max-size     virtlog-configuration-max-size
 512                 (default 2097152)) ;; 2MB
 513   (max-backups  virtlog-configuration-max-backups
 514                 (default 3)))
 515
 516 (define* (virtlogd-conf-file config)
 517   "Return a virtlogd config file."
 518   (plain-file "virtlogd.conf"
 519               (string-append
 520                "log_level = " (number->string (virtlog-configuration-log-level config)) "\n"
 521                "log_filters = \"" (virtlog-configuration-log-filters config) "\"\n"
 522                "log_outputs = \"" (virtlog-configuration-log-outputs config) "\"\n"
 523                "max_clients = " (number->string (virtlog-configuration-max-clients config)) "\n"
 524                "max_size = " (number->string (virtlog-configuration-max-size config)) "\n"
 525                "max_backups = " (number->string (virtlog-configuration-max-backups config)) "\n")))
 526
 527 (define (virtlogd-shepherd-service config)
 528   (let* ((config-file (virtlogd-conf-file config))
 529          (libvirt (virtlog-configuration-libvirt config)))
 530     (list (shepherd-service
 531            (documentation "Run the virtlog daemon.")
 532            (provision '(virtlogd))
 533            (start #~(make-forkexec-constructor
 534                      (list (string-append #$libvirt "/sbin/virtlogd")
 535                            "-f" #$config-file)))
 536            (stop #~(make-kill-destructor))))))
 537
 538 (define virtlog-service-type
 539   (service-type (name 'virtlogd)
 540                 (extensions
 541                  (list
 542                   (service-extension shepherd-root-service-type
 543                                      virtlogd-shepherd-service)))
 544                 (default-value (virtlog-configuration))))
 545
 546 (define (generate-libvirt-documentation)
 547   (generate-documentation
 548    `((libvirt-configuration ,libvirt-configuration-fields))
 549    'libvirt-configuration))
 550
 551 \f
 552 ;;;
 553 ;;; Transparent QEMU emulation via binfmt_misc.
 554 ;;;
 555
 556 ;; Platforms that QEMU can emulate.
 557 (define-record-type <qemu-platform>
 558   (qemu-platform name family magic mask)
 559   qemu-platform?
 560   (name     qemu-platform-name)                   ;string
 561   (family   qemu-platform-family)                 ;string
 562   (magic    qemu-platform-magic)                  ;bytevector
 563   (mask     qemu-platform-mask))                  ;bytevector
 564
 565 (define-syntax bv
 566   (lambda (s)
 567     "Expand the given string into a bytevector."
 568     (syntax-case s ()
 569       ((_ str)
 570        (string? (syntax->datum #'str))
 571        (let ((bv (u8-list->bytevector
 572                   (map char->integer
 573                        (string->list (syntax->datum #'str))))))
 574          bv)))))
 575
 576 ;;; The platform descriptions below are taken from
 577 ;;; 'scripts/qemu-binfmt-conf.sh' in QEMU.
 578
 579 (define %i386
 580   (qemu-platform "i386" "i386"
 581                  (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x03\x00")
 582                  (bv "\xff\xff\xff\xff\xff\xfe\xfe\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))
 583
 584 (define %i486
 585   (qemu-platform "i486" "i386"
 586                  (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x06\x00")
 587                  (bv "\xff\xff\xff\xff\xff\xfe\xfe\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))
 588
 589 (define %alpha
 590   (qemu-platform "alpha" "alpha"
 591                  (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x26\x90")
 592                  (bv "\xff\xff\xff\xff\xff\xfe\xfe\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))
 593
 594 (define %arm
 595   (qemu-platform "arm" "arm"
 596                  (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x28\x00")
 597                  (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))
 598
 599 (define %armeb
 600   (qemu-platform "armeb" "arm"
 601                  (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x28")
 602                  (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))
 603
 604 (define %sparc
 605   (qemu-platform "sparc" "sparc"
 606                  (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x02")
 607                  (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))
 608
 609 (define %sparc32plus
 610   (qemu-platform "sparc32plus" "sparc"
 611                  (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x12")
 612                  (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))
 613
 614 (define %ppc
 615   (qemu-platform "ppc" "ppc"
 616                  (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x14")
 617                  (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))
 618
 619 (define %ppc64
 620   (qemu-platform "ppc64" "ppc"
 621                  (bv "\x7fELF\x02\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x15")
 622                  (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))
 623
 624 (define %ppc64le
 625   (qemu-platform "ppc64le" "ppcle"
 626                  (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x15\x00")
 627                  (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\x00")))
 628
 629 (define %m68k
 630   (qemu-platform "m68k" "m68k"
 631                  (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x04")
 632                  (bv "\xff\xff\xff\xff\xff\xff\xfe\xfe\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))
 633
 634 ;; XXX: We could use the other endianness on a MIPS host.
 635 (define %mips
 636   (qemu-platform "mips" "mips"
 637                  (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08")
 638                  (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))
 639
 640 (define %mipsel
 641   (qemu-platform "mipsel" "mips"
 642                  (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08\x00")
 643                  (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))
 644
 645 (define %mipsn32
 646   (qemu-platform "mipsn32" "mips"
 647                  (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08")
 648                  (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))
 649
 650 (define %mipsn32el
 651   (qemu-platform "mipsn32el" "mips"
 652                  (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08\x00")
 653                  (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))
 654
 655 (define %mips64
 656   (qemu-platform "mips64" "mips"
 657                  (bv "\x7fELF\x02\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08")
 658                  (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))
 659
 660 (define %mips64el
 661   (qemu-platform "mips64el" "mips"
 662                  (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08\x00")
 663                  (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))
 664
 665 (define %riscv32
 666   (qemu-platform "riscv32" "riscv"
 667                  (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\xf3\x00")
 668                  (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))
 669
 670 (define %riscv64
 671   (qemu-platform "riscv64" "riscv"
 672                  (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\xf3\x00")
 673                  (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))
 674
 675 (define %sh4
 676   (qemu-platform "sh4" "sh4"
 677                  (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x2a\x00")
 678                  (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))
 679
 680 (define %sh4eb
 681   (qemu-platform "sh4eb" "sh4"
 682                  (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x2a")
 683                  (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))
 684
 685 (define %s390x
 686   (qemu-platform "s390x" "s390x"
 687                  (bv "\x7fELF\x02\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x16")
 688                  (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))
 689
 690 (define %aarch64
 691   (qemu-platform "aarch64" "arm"
 692                  (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\xb7\x00")
 693                  (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))
 694
 695 (define %hppa
 696   (qemu-platform "hppa" "hppa"
 697                  (bv "\x7f\x45\x4c\x46\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x0f")
 698                  (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))
 699
 700 (define %qemu-platforms
 701   (list %i386 %i486 %alpha %arm %sparc32plus %ppc %ppc64 %ppc64le %m68k
 702         %mips %mipsel %mipsn32 %mipsn32el %mips64 %mips64el
 703         %riscv32 %riscv64 %sh4 %sh4eb %s390x %aarch64 %hppa))
 704
 705 (define (lookup-qemu-platforms . names)
 706   "Return the list of QEMU platforms that match NAMES--a list of names such as
 707 \"arm\", \"hppa\", etc."
 708   (filter (lambda (platform)
 709             (member (qemu-platform-name platform) names))
 710           %qemu-platforms))
 711
 712 (define-record-type* <qemu-binfmt-configuration>
 713   qemu-binfmt-configuration make-qemu-binfmt-configuration
 714   qemu-binfmt-configuration?
 715   (qemu        qemu-binfmt-configuration-qemu
 716                (default qemu))
 717   (platforms   qemu-binfmt-configuration-platforms
 718                (default '()))                     ;safest default
 719   (guix-support? qemu-binfmt-configuration-guix-support?
 720                  (default #f)))
 721
 722 (define (qemu-platform->binfmt qemu platform)
 723   "Return a gexp that evaluates to a binfmt string for PLATFORM, using the
 724 given QEMU package."
 725   (define (bytevector->binfmt-string bv)
 726     ;; Return a binfmt-friendly string representing BV.  Hex-encode every
 727     ;; character, in particular because the doc notes "that you must escape
 728     ;; any NUL bytes; parsing halts at the first one".
 729     (string-concatenate
 730      (map (lambda (n)
 731             (string-append "\\x"
 732                            (string-pad (number->string n 16) 2 #\0)))
 733           (bytevector->u8-list bv))))
 734
 735   (match platform
 736     (($ <qemu-platform> name family magic mask)
 737      ;; See 'Documentation/binfmt_misc.txt' in the kernel.
 738      #~(string-append ":qemu-" #$name ":M::"
 739                       #$(bytevector->binfmt-string magic)
 740                       ":" #$(bytevector->binfmt-string mask)
 741                       ":" #$(file-append qemu "/bin/qemu-" name)
 742                       ":"                         ;FLAGS go here
 743                       ))))
 744
 745 (define %binfmt-mount-point
 746   (file-system-mount-point %binary-format-file-system))
 747
 748 (define %binfmt-register-file
 749   (string-append %binfmt-mount-point "/register"))
 750
 751 (define qemu-binfmt-shepherd-services
 752   (match-lambda
 753     (($ <qemu-binfmt-configuration> qemu platforms)
 754      (list (shepherd-service
 755             (provision '(qemu-binfmt))
 756             (documentation "Install binfmt_misc handlers for QEMU.")
 757             (requirement '(file-system-/proc/sys/fs/binfmt_misc))
 758             (start #~(lambda ()
 759                        ;; Register the handlers for all of PLATFORMS.
 760                        (for-each (lambda (str)
 761                                    (call-with-output-file
 762                                        #$%binfmt-register-file
 763                                      (lambda (port)
 764                                        (display str port))))
 765                                  (list
 766                                   #$@(map (cut qemu-platform->binfmt qemu
 767                                                <>)
 768                                           platforms)))
 769                        #t))
 770             (stop #~(lambda (_)
 771                       ;; Unregister the handlers.
 772                       (for-each (lambda (name)
 773                                   (let ((file (string-append
 774                                                #$%binfmt-mount-point
 775                                                "/qemu-" name)))
 776                                     (call-with-output-file file
 777                                       (lambda (port)
 778                                         (display "-1" port)))))
 779                                 '#$(map qemu-platform-name platforms))
 780                       #f)))))))
 781
 782 (define qemu-binfmt-guix-chroot
 783   (match-lambda
 784     ;; Add QEMU and its dependencies to the guix-daemon chroot so that our
 785     ;; binfmt_misc handlers work in the chroot (otherwise 'execve' would fail
 786     ;; with ENOENT.)
 787     ;;
 788     ;; The 'F' flag of binfmt_misc is meant to address this problem by loading
 789     ;; the interpreter upfront rather than lazily, but apparently that is
 790     ;; insufficient (perhaps it loads the 'qemu-ARCH' binary upfront but looks
 791     ;; up its dependencies lazily?).
 792     (($ <qemu-binfmt-configuration> qemu platforms guix?)
 793      (if guix? (list qemu) '()))))
 794
 795 (define qemu-binfmt-service-type
 796   ;; TODO: Make a separate binfmt_misc service out of this?
 797   (service-type (name 'qemu-binfmt)
 798                 (extensions
 799                  (list (service-extension file-system-service-type
 800                                           (const
 801                                            (list %binary-format-file-system)))
 802                        (service-extension shepherd-root-service-type
 803                                           qemu-binfmt-shepherd-services)
 804                        (service-extension guix-service-type
 805                                           qemu-binfmt-guix-chroot)))
 806                 (default-value (qemu-binfmt-configuration))
 807                 (description
 808                  "This service supports transparent emulation of binaries
 809 compiled for other architectures using QEMU and the @code{binfmt_misc}
 810 functionality of the kernel Linux.")))
 811
 812 \f
 813 ;;;
 814 ;;; Secrets for guest VMs.
 815 ;;;
 816
 817 (define (secret-service-activation port)
 818   "Return an activation snippet that fetches sensitive material at local PORT,
 819 over TCP.  Reboot upon failure."
 820   (with-imported-modules '((gnu build secret-service)
 821                            (guix build utils))
 822     #~(begin
 823         (use-modules (gnu build secret-service))
 824         (let ((sent (secret-service-receive-secrets #$port)))
 825           (unless sent
 826             (sleep 3)
 827             (reboot))))))
 828
 829 (define secret-service-type
 830   (service-type
 831    (name 'secret-service)
 832    (extensions (list (service-extension activation-service-type
 833                                         secret-service-activation)))
 834    (description
 835     "This service fetches secret key and other sensitive material over TCP at
 836 boot time.  This service is meant to be used by virtual machines (VMs) that
 837 can only be accessed by their host.")))
 838
 839 (define (secret-service-operating-system os)
 840   "Return an operating system based on OS that includes the secret-service,
 841 that will be listening to receive secret keys on port 1004, TCP."
 842   (operating-system
 843     (inherit os)
 844     ;; Arrange so that the secret service activation snippet shows up before
 845     ;; the OpenSSH and Guix activation snippets.  That way, we receive OpenSSH
 846     ;; and Guix keys before the activation snippets try to generate fresh keys
 847     ;; for nothing.
 848     (services (append (operating-system-user-services os)
 849                       (list (service secret-service-type 1004))))))
 850
 851 \f
 852 ;;;
 853 ;;; The Hurd in VM service: a Childhurd.
 854 ;;;
 855
 856 (define %hurd-vm-operating-system
 857   (operating-system
 858     (inherit %hurd-default-operating-system)
 859     (host-name "childhurd")
 860     (timezone "Europe/Amsterdam")
 861     (bootloader (bootloader-configuration
 862                  (bootloader grub-minimal-bootloader)
 863                  (target "/dev/vda")
 864                  (timeout 0)))
 865     (packages (cons* gdb-minimal
 866                      (operating-system-packages
 867                       %hurd-default-operating-system)))
 868     (services (cons*
 869                (service openssh-service-type
 870                         (openssh-configuration
 871                          (openssh openssh-sans-x)
 872                          (use-pam? #f)
 873                          (port-number 2222)
 874                          (permit-root-login #t)
 875                          (allow-empty-passwords? #t)
 876                          (password-authentication? #t)))
 877
 878                ;; By default, the secret service introduces a pre-initialized
 879                ;; /etc/guix/acl file in the childhurd.  Thus, clear
 880                ;; 'authorize-key?' so that it's not overridden at activation
 881                ;; time.
 882                (modify-services %base-services/hurd
 883                  (guix-service-type config =>
 884                                     (guix-configuration
 885                                      (inherit config)
 886                                      (authorize-key? #f))))))))
 887
 888 (define-record-type* <hurd-vm-configuration>
 889   hurd-vm-configuration make-hurd-vm-configuration
 890   hurd-vm-configuration?
 891   (os          hurd-vm-configuration-os                 ;<operating-system>
 892                (default %hurd-vm-operating-system))
 893   (qemu        hurd-vm-configuration-qemu               ;<package>
 894                (default qemu-minimal))
 895   (image       hurd-vm-configuration-image              ;string
 896                (thunked)
 897                (default (hurd-vm-disk-image this-record)))
 898   (disk-size   hurd-vm-configuration-disk-size          ;number or 'guess
 899                (default 'guess))
 900   (memory-size hurd-vm-configuration-memory-size        ;number
 901                (default 512))
 902   (options     hurd-vm-configuration-options            ;list of string
 903                (default `("--snapshot")))
 904   (id          hurd-vm-configuration-id                 ;#f or integer [1..]
 905                (default #f))
 906   (net-options hurd-vm-configuration-net-options        ;list of string
 907                (thunked)
 908                (default (hurd-vm-net-options this-record)))
 909   (secret-root hurd-vm-configuration-secret-root        ;string
 910                (default "/etc/childhurd")))
 911
 912 (define (hurd-vm-disk-image config)
 913   "Return a disk-image for the Hurd according to CONFIG.  The secret-service
 914 is added to the OS specified in CONFIG."
 915   (let* ((os        (secret-service-operating-system
 916                      (hurd-vm-configuration-os config)))
 917          (disk-size (hurd-vm-configuration-disk-size config))
 918          (type      (lookup-image-type-by-name 'hurd-qcow2))
 919          (os->image (image-type-constructor type)))
 920     (system-image (os->image os))))
 921
 922 (define (hurd-vm-port config base)
 923   "Return the forwarded vm port for this childhurd config."
 924   (let ((id (or (hurd-vm-configuration-id config) 0)))
 925     (+ base (* 1000 id))))
 926 (define %hurd-vm-secrets-port 11004)
 927 (define %hurd-vm-ssh-port 10022)
 928 (define %hurd-vm-vnc-port 15900)
 929
 930 (define (hurd-vm-net-options config)
 931   `("--device" "rtl8139,netdev=net0"
 932     "--netdev"
 933     ,(string-append "user,id=net0"
 934                     ",hostfwd=tcp:127.0.0.1:"
 935                     (number->string (hurd-vm-port config %hurd-vm-secrets-port))
 936                     "-:1004"
 937                     ",hostfwd=tcp:127.0.0.1:"
 938                     (number->string (hurd-vm-port config %hurd-vm-ssh-port))
 939                     "-:2222"
 940                     ",hostfwd=tcp:127.0.0.1:"
 941                     (number->string (hurd-vm-port config %hurd-vm-vnc-port))
 942                     "-:5900")))
 943
 944 (define (hurd-vm-shepherd-service config)
 945   "Return a <shepherd-service> for a Hurd in a Virtual Machine with CONFIG."
 946
 947   (let ((image       (hurd-vm-configuration-image config))
 948         (qemu        (hurd-vm-configuration-qemu config))
 949         (memory-size (hurd-vm-configuration-memory-size config))
 950         (options     (hurd-vm-configuration-options config))
 951         (id          (hurd-vm-configuration-id config))
 952         (net-options (hurd-vm-configuration-net-options config))
 953         (provisions  '(hurd-vm childhurd)))
 954
 955     (define vm-command
 956       #~(append (list #$(file-append qemu "/bin/qemu-system-i386")
 957                       "-m" (number->string #$memory-size)
 958                       #$@net-options
 959                       #$@options
 960                       "--hda" #+image
 961
 962                       ;; Cause the service to be respawned if the guest
 963                       ;; reboots (it can reboot for instance if it did not
 964                       ;; receive valid secrets, or if it crashed.)
 965                       "--no-reboot")
 966                 (if (file-exists? "/dev/kvm")
 967                     '("--enable-kvm")
 968                     '())))
 969
 970     (list
 971      (shepherd-service
 972       (documentation "Run the Hurd in a Virtual Machine: a Childhurd.")
 973       (provision (if id
 974                      (map
 975                       (cute symbol-append <>
 976                             (string->symbol (number->string id)))
 977                       provisions)
 978                      provisions))
 979       (requirement '(loopback networking user-processes))
 980       (start
 981        (with-imported-modules
 982            (source-module-closure '((gnu build secret-service)
 983                                     (guix build utils)))
 984          #~(lambda ()
 985              (let ((pid  (fork+exec-command #$vm-command
 986                                             #:user "childhurd"
 987                                             ;; XXX TODO: use "childhurd" after
 988                                             ;; updating Shepherd
 989                                             #:group "kvm"
 990                                             #:environment-variables
 991                                             ;; QEMU tries to write to /var/tmp
 992                                             ;; by default.
 993                                             '("TMPDIR=/tmp")))
 994                    (port #$(hurd-vm-port config %hurd-vm-secrets-port))
 995                    (root #$(hurd-vm-configuration-secret-root config)))
 996                (catch #t
 997                  (lambda _
 998                    ;; XXX: 'secret-service-send-secrets' won't complete until
 999                    ;; the guest has booted and its secret service server is
1000                    ;; running, which could take 20+ seconds during which PID 1
1001                    ;; is stuck waiting.
1002                    (if (secret-service-send-secrets port root)
1003                        pid
1004                        (begin
1005                          (kill (- pid) SIGTERM)
1006                          #f)))
1007                  (lambda (key . args)
1008                    (kill (- pid) SIGTERM)
1009                    (apply throw key args)))))))
1010       (modules `((gnu build secret-service)
1011                  (guix build utils)
1012                  ,@%default-modules))
1013       (stop  #~(make-kill-destructor))))))
1014
1015 (define %hurd-vm-accounts
1016   (list (user-group (name "childhurd") (system? #t))
1017         (user-account
1018          (name "childhurd")
1019          (group "childhurd")
1020          (supplementary-groups '("kvm"))
1021          (comment "Privilege separation user for the childhurd")
1022          (home-directory "/var/empty")
1023          (shell (file-append shadow "/sbin/nologin"))
1024          (system? #t))))
1025
1026 (define (initialize-hurd-vm-substitutes)
1027   "Initialize the Hurd VM's key pair and ACL and store it on the host."
1028   (define run
1029     (with-imported-modules '((guix build utils))
1030       #~(begin
1031           (use-modules (guix build utils)
1032                        (ice-9 match))
1033
1034           (define host-key
1035             "/etc/guix/signing-key.pub")
1036
1037           (define host-acl
1038             "/etc/guix/acl")
1039
1040           (match (command-line)
1041             ((_ guest-config-directory)
1042              (setenv "GUIX_CONFIGURATION_DIRECTORY"
1043                      guest-config-directory)
1044              (invoke #+(file-append guix "/bin/guix") "archive"
1045                      "--generate-key")
1046
1047              (when (file-exists? host-acl)
1048                ;; Copy the host ACL.
1049                (copy-file host-acl
1050                           (string-append guest-config-directory
1051                                          "/acl")))
1052
1053              (when (file-exists? host-key)
1054                ;; Add the host key to the childhurd's ACL.
1055                (let ((key (open-fdes host-key O_RDONLY)))
1056                  (close-fdes 0)
1057                  (dup2 key 0)
1058                  (execl #+(file-append guix "/bin/guix")
1059                         "guix" "archive" "--authorize"))))))))
1060
1061   (program-file "initialize-hurd-vm-substitutes" run))
1062
1063 (define (hurd-vm-activation config)
1064   "Return a gexp to activate the Hurd VM according to CONFIG."
1065   (with-imported-modules '((guix build utils))
1066     #~(begin
1067         (use-modules (guix build utils))
1068
1069         (define secret-directory
1070           #$(hurd-vm-configuration-secret-root config))
1071
1072         (define ssh-directory
1073           (string-append secret-directory "/etc/ssh"))
1074
1075         (define guix-directory
1076           (string-append secret-directory "/etc/guix"))
1077
1078         (unless (file-exists? ssh-directory)
1079           ;; Generate SSH host keys under SSH-DIRECTORY.
1080           (mkdir-p ssh-directory)
1081           (invoke #$(file-append openssh "/bin/ssh-keygen")
1082                   "-A" "-f" secret-directory))
1083
1084         (unless (file-exists? guix-directory)
1085           (invoke #$(initialize-hurd-vm-substitutes)
1086                   guix-directory)))))
1087
1088 (define hurd-vm-service-type
1089   (service-type
1090    (name 'hurd-vm)
1091    (extensions (list (service-extension shepherd-root-service-type
1092                                         hurd-vm-shepherd-service)
1093                      (service-extension account-service-type
1094                                         (const %hurd-vm-accounts))
1095                      (service-extension activation-service-type
1096                                         hurd-vm-activation)))
1097    (default-value (hurd-vm-configuration))
1098    (description
1099     "Provide a virtual machine (VM) running GNU/Hurd, also known as a
1100 @dfn{childhurd}.")))