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