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,2021 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 make-qemu-platform
 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   (flags    qemu-platform-flags (default "F")))   ;string
 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
 582    (name "i386")
 583    (family "i386")
 584    (magic (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x03\x00"))
 585    (mask (bv "\xff\xff\xff\xff\xff\xfe\xfe\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))))
 586
 587 (define %i486
 588   (qemu-platform
 589    (name "i486")
 590    (family "i386")
 591    (magic (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x06\x00"))
 592    (mask (bv "\xff\xff\xff\xff\xff\xfe\xfe\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))))
 593
 594 (define %alpha
 595   (qemu-platform
 596    (name "alpha")
 597    (family "alpha")
 598    (magic (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x26\x90"))
 599    (mask (bv "\xff\xff\xff\xff\xff\xfe\xfe\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))))
 600
 601 (define %arm
 602   (qemu-platform
 603    (name "arm")
 604    (family "arm")
 605    (magic (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x28\x00"))
 606    (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))))
 607
 608 (define %armeb
 609   (qemu-platform
 610    (name "armeb")
 611    (family "arm")
 612    (magic (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x28"))
 613    (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))))
 614
 615 (define %sparc
 616   (qemu-platform
 617    (name "sparc")
 618    (family "sparc")
 619    (magic (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x02"))
 620    (mask (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))))
 621
 622 (define %sparc32plus
 623   (qemu-platform
 624    (name "sparc32plus")
 625    (family "sparc")
 626    (magic (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x12"))
 627    (mask (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))))
 628
 629 (define %ppc
 630   (qemu-platform
 631    (name "ppc")
 632    (family "ppc")
 633    (magic (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x14"))
 634    (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))))
 635
 636 (define %ppc64
 637   (qemu-platform
 638    (name "ppc64")
 639    (family "ppc")
 640    (magic (bv "\x7fELF\x02\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x15"))
 641    (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))))
 642
 643 (define %ppc64le
 644   (qemu-platform
 645    (name "ppc64le")
 646    (family "ppcle")
 647    (magic (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x15\x00"))
 648    (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\x00"))))
 649
 650 (define %m68k
 651   (qemu-platform
 652    (name "m68k")
 653    (family "m68k")
 654    (magic (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x04"))
 655    (mask (bv "\xff\xff\xff\xff\xff\xff\xfe\xfe\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))))
 656
 657 ;; XXX: We could use the other endianness on a MIPS host.
 658 (define %mips
 659   (qemu-platform
 660    (name "mips")
 661    (family "mips")
 662    (magic (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08"))
 663    (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))))
 664
 665 (define %mipsel
 666   (qemu-platform
 667    (name "mipsel")
 668    (family "mips")
 669    (magic (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08\x00"))
 670    (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))))
 671
 672 (define %mipsn32
 673   (qemu-platform
 674    (name "mipsn32")
 675    (family "mips")
 676    (magic (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08"))
 677    (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))))
 678
 679 (define %mipsn32el
 680   (qemu-platform
 681    (name "mipsn32el")
 682    (family "mips")
 683    (magic (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08\x00"))
 684    (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))))
 685
 686 (define %mips64
 687   (qemu-platform
 688    (name "mips64")
 689    (family "mips")
 690    (magic (bv "\x7fELF\x02\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08"))
 691    (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))))
 692
 693 (define %mips64el
 694   (qemu-platform
 695    (name "mips64el")
 696    (family "mips")
 697    (magic (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08\x00"))
 698    (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))))
 699
 700 (define %riscv32
 701   (qemu-platform
 702    (name "riscv32")
 703    (family "riscv")
 704    (magic (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\xf3\x00"))
 705    (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))))
 706
 707 (define %riscv64
 708   (qemu-platform
 709    (name "riscv64")
 710    (family "riscv")
 711    (magic (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\xf3\x00"))
 712    (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))))
 713
 714 (define %sh4
 715   (qemu-platform
 716    (name "sh4")
 717    (family "sh4")
 718    (magic (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x2a\x00"))
 719    (mask (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))))
 720
 721 (define %sh4eb
 722   (qemu-platform
 723    (name "sh4eb")
 724    (family "sh4")
 725    (magic (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x2a"))
 726    (mask (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))))
 727
 728 (define %s390x
 729   (qemu-platform
 730    (name "s390x")
 731    (family "s390x")
 732    (magic (bv "\x7fELF\x02\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x16"))
 733    (mask (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))))
 734
 735 (define %aarch64
 736   (qemu-platform
 737    (name "aarch64")
 738    (family "arm")
 739    (magic (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\xb7\x00"))
 740    (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))))
 741
 742 (define %hppa
 743   (qemu-platform
 744    (name "hppa")
 745    (family "hppa")
 746    (magic (bv "\x7f\x45\x4c\x46\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x0f"))
 747    (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))))
 748
 749 (define %qemu-platforms
 750   (list %i386 %i486 %alpha %arm %sparc32plus %ppc %ppc64 %ppc64le %m68k
 751         %mips %mipsel %mipsn32 %mipsn32el %mips64 %mips64el
 752         %riscv32 %riscv64 %sh4 %sh4eb %s390x %aarch64 %hppa))
 753
 754 (define (lookup-qemu-platforms . names)
 755   "Return the list of QEMU platforms that match NAMES--a list of names such as
 756 \"arm\", \"hppa\", etc."
 757   (filter (lambda (platform)
 758             (member (qemu-platform-name platform) names))
 759           %qemu-platforms))
 760
 761 (define-record-type* <qemu-binfmt-configuration>
 762   qemu-binfmt-configuration make-qemu-binfmt-configuration
 763   qemu-binfmt-configuration?
 764   (qemu        qemu-binfmt-configuration-qemu
 765                (default qemu))
 766   (platforms   qemu-binfmt-configuration-platforms
 767                (default '())))          ;safest default
 768
 769 (define (qemu-platform->binfmt qemu platform)
 770   "Return a gexp that evaluates to a binfmt string for PLATFORM, using the
 771 given QEMU package."
 772   (define (bytevector->binfmt-string bv)
 773     ;; Return a binfmt-friendly string representing BV.  Hex-encode every
 774     ;; character, in particular because the doc notes "that you must escape
 775     ;; any NUL bytes; parsing halts at the first one".
 776     (string-concatenate
 777      (map (lambda (n)
 778             (string-append "\\x"
 779                            (string-pad (number->string n 16) 2 #\0)))
 780           (bytevector->u8-list bv))))
 781
 782   (match platform
 783     (($ <qemu-platform> name family magic mask flags)
 784      ;; See 'Documentation/binfmt_misc.txt' in the kernel.
 785      #~(string-append ":qemu-" #$name ":M::"
 786                       #$(bytevector->binfmt-string magic)
 787                       ":" #$(bytevector->binfmt-string mask)
 788                       ":" #$qemu:static "/bin/qemu-" #$name
 789                       ":" #$flags))))
 790
 791 (define %binfmt-mount-point
 792   (file-system-mount-point %binary-format-file-system))
 793
 794 (define %binfmt-register-file
 795   (string-append %binfmt-mount-point "/register"))
 796
 797 (define qemu-binfmt-shepherd-services
 798   (match-lambda
 799     (($ <qemu-binfmt-configuration> qemu platforms)
 800      (list (shepherd-service
 801             (provision '(qemu-binfmt))
 802             (documentation "Install binfmt_misc handlers for QEMU.")
 803             (requirement '(file-system-/proc/sys/fs/binfmt_misc))
 804             (start #~(lambda ()
 805                        ;; Register the handlers for all of PLATFORMS.
 806                        (for-each (lambda (str)
 807                                    (call-with-output-file
 808                                        #$%binfmt-register-file
 809                                      (lambda (port)
 810                                        (display str port))))
 811                                  (list
 812                                   #$@(map (cut qemu-platform->binfmt qemu
 813                                                <>)
 814                                           platforms)))
 815                        #t))
 816             (stop #~(lambda (_)
 817                       ;; Unregister the handlers.
 818                       (for-each (lambda (name)
 819                                   (let ((file (string-append
 820                                                #$%binfmt-mount-point
 821                                                "/qemu-" name)))
 822                                     (call-with-output-file file
 823                                       (lambda (port)
 824                                         (display "-1" port)))))
 825                                 '#$(map qemu-platform-name platforms))
 826                       #f)))))))
 827
 828 (define qemu-binfmt-service-type
 829   ;; TODO: Make a separate binfmt_misc service out of this?
 830   (service-type (name 'qemu-binfmt)
 831                 (extensions
 832                  (list (service-extension file-system-service-type
 833                                           (const
 834                                            (list %binary-format-file-system)))
 835                        (service-extension shepherd-root-service-type
 836                                           qemu-binfmt-shepherd-services)))
 837                 (default-value (qemu-binfmt-configuration))
 838                 (description
 839                  "This service supports transparent emulation of binaries
 840 compiled for other architectures using QEMU and the @code{binfmt_misc}
 841 functionality of the kernel Linux.")))
 842
 843 \f
 844 ;;;
 845 ;;; Secrets for guest VMs.
 846 ;;;
 847
 848 (define (secret-service-activation port)
 849   "Return an activation snippet that fetches sensitive material at local PORT,
 850 over TCP.  Reboot upon failure."
 851   (with-imported-modules '((gnu build secret-service)
 852                            (guix build utils))
 853     #~(begin
 854         (use-modules (gnu build secret-service))
 855         (let ((sent (secret-service-receive-secrets #$port)))
 856           (unless sent
 857             (sleep 3)
 858             (reboot))))))
 859
 860 (define secret-service-type
 861   (service-type
 862    (name 'secret-service)
 863    (extensions (list (service-extension activation-service-type
 864                                         secret-service-activation)))
 865    (description
 866     "This service fetches secret key and other sensitive material over TCP at
 867 boot time.  This service is meant to be used by virtual machines (VMs) that
 868 can only be accessed by their host.")))
 869
 870 (define (secret-service-operating-system os)
 871   "Return an operating system based on OS that includes the secret-service,
 872 that will be listening to receive secret keys on port 1004, TCP."
 873   (operating-system
 874     (inherit os)
 875     ;; Arrange so that the secret service activation snippet shows up before
 876     ;; the OpenSSH and Guix activation snippets.  That way, we receive OpenSSH
 877     ;; and Guix keys before the activation snippets try to generate fresh keys
 878     ;; for nothing.
 879     (services (append (operating-system-user-services os)
 880                       (list (service secret-service-type 1004))))))
 881
 882 \f
 883 ;;;
 884 ;;; The Hurd in VM service: a Childhurd.
 885 ;;;
 886
 887 (define %hurd-vm-operating-system
 888   (operating-system
 889     (inherit %hurd-default-operating-system)
 890     (host-name "childhurd")
 891     (timezone "Europe/Amsterdam")
 892     (bootloader (bootloader-configuration
 893                  (bootloader grub-minimal-bootloader)
 894                  (target "/dev/vda")
 895                  (timeout 0)))
 896     (packages (cons* gdb-minimal
 897                      (operating-system-packages
 898                       %hurd-default-operating-system)))
 899     (services (cons*
 900                (service openssh-service-type
 901                         (openssh-configuration
 902                          (openssh openssh-sans-x)
 903                          (use-pam? #f)
 904                          (port-number 2222)
 905                          (permit-root-login #t)
 906                          (allow-empty-passwords? #t)
 907                          (password-authentication? #t)))
 908
 909                ;; By default, the secret service introduces a pre-initialized
 910                ;; /etc/guix/acl file in the childhurd.  Thus, clear
 911                ;; 'authorize-key?' so that it's not overridden at activation
 912                ;; time.
 913                (modify-services %base-services/hurd
 914                  (guix-service-type config =>
 915                                     (guix-configuration
 916                                      (inherit config)
 917                                      (authorize-key? #f))))))))
 918
 919 (define-record-type* <hurd-vm-configuration>
 920   hurd-vm-configuration make-hurd-vm-configuration
 921   hurd-vm-configuration?
 922   (os          hurd-vm-configuration-os                 ;<operating-system>
 923                (default %hurd-vm-operating-system))
 924   (qemu        hurd-vm-configuration-qemu               ;<package>
 925                (default qemu-minimal))
 926   (image       hurd-vm-configuration-image              ;string
 927                (thunked)
 928                (default (hurd-vm-disk-image this-record)))
 929   (disk-size   hurd-vm-configuration-disk-size          ;number or 'guess
 930                (default 'guess))
 931   (memory-size hurd-vm-configuration-memory-size        ;number
 932                (default 512))
 933   (options     hurd-vm-configuration-options            ;list of string
 934                (default `("--snapshot")))
 935   (id          hurd-vm-configuration-id                 ;#f or integer [1..]
 936                (default #f))
 937   (net-options hurd-vm-configuration-net-options        ;list of string
 938                (thunked)
 939                (default (hurd-vm-net-options this-record)))
 940   (secret-root hurd-vm-configuration-secret-root        ;string
 941                (default "/etc/childhurd")))
 942
 943 (define (hurd-vm-disk-image config)
 944   "Return a disk-image for the Hurd according to CONFIG.  The secret-service
 945 is added to the OS specified in CONFIG."
 946   (let* ((os        (secret-service-operating-system
 947                      (hurd-vm-configuration-os config)))
 948          (disk-size (hurd-vm-configuration-disk-size config))
 949          (type      (lookup-image-type-by-name 'hurd-qcow2))
 950          (os->image (image-type-constructor type)))
 951     (system-image
 952      (image (inherit (os->image os))
 953             (size disk-size)))))
 954
 955 (define (hurd-vm-port config base)
 956   "Return the forwarded vm port for this childhurd config."
 957   (let ((id (or (hurd-vm-configuration-id config) 0)))
 958     (+ base (* 1000 id))))
 959 (define %hurd-vm-secrets-port 11004)
 960 (define %hurd-vm-ssh-port 10022)
 961 (define %hurd-vm-vnc-port 15900)
 962
 963 (define (hurd-vm-net-options config)
 964   `("--device" "rtl8139,netdev=net0"
 965     "--netdev"
 966     ,(string-append "user,id=net0"
 967                     ",hostfwd=tcp:127.0.0.1:"
 968                     (number->string (hurd-vm-port config %hurd-vm-secrets-port))
 969                     "-:1004"
 970                     ",hostfwd=tcp:127.0.0.1:"
 971                     (number->string (hurd-vm-port config %hurd-vm-ssh-port))
 972                     "-:2222"
 973                     ",hostfwd=tcp:127.0.0.1:"
 974                     (number->string (hurd-vm-port config %hurd-vm-vnc-port))
 975                     "-:5900")))
 976
 977 (define (hurd-vm-shepherd-service config)
 978   "Return a <shepherd-service> for a Hurd in a Virtual Machine with CONFIG."
 979
 980   (let ((image       (hurd-vm-configuration-image config))
 981         (qemu        (hurd-vm-configuration-qemu config))
 982         (memory-size (hurd-vm-configuration-memory-size config))
 983         (options     (hurd-vm-configuration-options config))
 984         (id          (hurd-vm-configuration-id config))
 985         (net-options (hurd-vm-configuration-net-options config))
 986         (provisions  '(hurd-vm childhurd)))
 987
 988     (define vm-command
 989       #~(append (list #$(file-append qemu "/bin/qemu-system-i386")
 990                       "-m" (number->string #$memory-size)
 991                       #$@net-options
 992                       #$@options
 993                       "--hda" #+image
 994
 995                       ;; Cause the service to be respawned if the guest
 996                       ;; reboots (it can reboot for instance if it did not
 997                       ;; receive valid secrets, or if it crashed.)
 998                       "--no-reboot")
 999                 (if (file-exists? "/dev/kvm")
1000                     '("--enable-kvm")
1001                     '())))
1002
1003     (list
1004      (shepherd-service
1005       (documentation "Run the Hurd in a Virtual Machine: a Childhurd.")
1006       (provision (if id
1007                      (map
1008                       (cute symbol-append <>
1009                             (string->symbol (number->string id)))
1010                       provisions)
1011                      provisions))
1012       (requirement '(loopback networking user-processes))
1013       (start
1014        (with-imported-modules
1015            (source-module-closure '((gnu build secret-service)
1016                                     (guix build utils)))
1017          #~(lambda ()
1018              (let ((pid  (fork+exec-command #$vm-command
1019                                             #:user "childhurd"
1020                                             ;; XXX TODO: use "childhurd" after
1021                                             ;; updating Shepherd
1022                                             #:group "kvm"
1023                                             #:environment-variables
1024                                             ;; QEMU tries to write to /var/tmp
1025                                             ;; by default.
1026                                             '("TMPDIR=/tmp")))
1027                    (port #$(hurd-vm-port config %hurd-vm-secrets-port))
1028                    (root #$(hurd-vm-configuration-secret-root config)))
1029                (catch #t
1030                  (lambda _
1031                    ;; XXX: 'secret-service-send-secrets' won't complete until
1032                    ;; the guest has booted and its secret service server is
1033                    ;; running, which could take 20+ seconds during which PID 1
1034                    ;; is stuck waiting.
1035                    (if (secret-service-send-secrets port root)
1036                        pid
1037                        (begin
1038                          (kill (- pid) SIGTERM)
1039                          #f)))
1040                  (lambda (key . args)
1041                    (kill (- pid) SIGTERM)
1042                    (apply throw key args)))))))
1043       (modules `((gnu build secret-service)
1044                  (guix build utils)
1045                  ,@%default-modules))
1046       (stop  #~(make-kill-destructor))))))
1047
1048 (define %hurd-vm-accounts
1049   (list (user-group (name "childhurd") (system? #t))
1050         (user-account
1051          (name "childhurd")
1052          (group "childhurd")
1053          (supplementary-groups '("kvm"))
1054          (comment "Privilege separation user for the childhurd")
1055          (home-directory "/var/empty")
1056          (shell (file-append shadow "/sbin/nologin"))
1057          (system? #t))))
1058
1059 (define (initialize-hurd-vm-substitutes)
1060   "Initialize the Hurd VM's key pair and ACL and store it on the host."
1061   (define run
1062     (with-imported-modules '((guix build utils))
1063       #~(begin
1064           (use-modules (guix build utils)
1065                        (ice-9 match))
1066
1067           (define host-key
1068             "/etc/guix/signing-key.pub")
1069
1070           (define host-acl
1071             "/etc/guix/acl")
1072
1073           (match (command-line)
1074             ((_ guest-config-directory)
1075              (setenv "GUIX_CONFIGURATION_DIRECTORY"
1076                      guest-config-directory)
1077              (invoke #+(file-append guix "/bin/guix") "archive"
1078                      "--generate-key")
1079
1080              (when (file-exists? host-acl)
1081                ;; Copy the host ACL.
1082                (copy-file host-acl
1083                           (string-append guest-config-directory
1084                                          "/acl")))
1085
1086              (when (file-exists? host-key)
1087                ;; Add the host key to the childhurd's ACL.
1088                (let ((key (open-fdes host-key O_RDONLY)))
1089                  (close-fdes 0)
1090                  (dup2 key 0)
1091                  (execl #+(file-append guix "/bin/guix")
1092                         "guix" "archive" "--authorize"))))))))
1093
1094   (program-file "initialize-hurd-vm-substitutes" run))
1095
1096 (define (hurd-vm-activation config)
1097   "Return a gexp to activate the Hurd VM according to CONFIG."
1098   (with-imported-modules '((guix build utils))
1099     #~(begin
1100         (use-modules (guix build utils))
1101
1102         (define secret-directory
1103           #$(hurd-vm-configuration-secret-root config))
1104
1105         (define ssh-directory
1106           (string-append secret-directory "/etc/ssh"))
1107
1108         (define guix-directory
1109           (string-append secret-directory "/etc/guix"))
1110
1111         (unless (file-exists? ssh-directory)
1112           ;; Generate SSH host keys under SSH-DIRECTORY.
1113           (mkdir-p ssh-directory)
1114           (invoke #$(file-append openssh "/bin/ssh-keygen")
1115                   "-A" "-f" secret-directory))
1116
1117         (unless (file-exists? guix-directory)
1118           (invoke #$(initialize-hurd-vm-substitutes)
1119                   guix-directory)))))
1120
1121 (define hurd-vm-service-type
1122   (service-type
1123    (name 'hurd-vm)
1124    (extensions (list (service-extension shepherd-root-service-type
1125                                         hurd-vm-shepherd-service)
1126                      (service-extension account-service-type
1127                                         (const %hurd-vm-accounts))
1128                      (service-extension activation-service-type
1129                                         hurd-vm-activation)))
1130    (default-value (hurd-vm-configuration))
1131    (description
1132     "Provide a virtual machine (VM) running GNU/Hurd, also known as a
1133 @dfn{childhurd}.")))