gnu/services/virtualization.scm

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