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