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