projects/guix·blob bootstrap-team · refs

2031 lines · 82.2 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2017 Ryan Moe <[email protected]>
3;;; Copyright © 2018, 2020-2025 Ludovic Courtès <[email protected]>
4;;; Copyright © 2020, 2021, 2023, 2024 Janneke Nieuwenhuizen <[email protected]>
5;;; Copyright © 2021 Timotej Lazar <[email protected]>
6;;; Copyright © 2022, 2025 Oleg Pykhalov <[email protected]>
7;;; Copyright © 2022 Leo Nikkilä <[email protected]>
8;;; Copyright © 2023 Efraim Flashner <[email protected]>
9;;; Copyright © 2024 Raven Hallsby <[email protected]>
10;;; Copyright © 2025 Maxim Cournoyer <[email protected]>
11;;; Copyright © 2025 Nigko Yerden <[email protected]>
12;;;
13;;; This file is part of GNU Guix.
14;;;
15;;; GNU Guix is free software; you can redistribute it and/or modify it
16;;; under the terms of the GNU General Public License as published by
17;;; the Free Software Foundation; either version 3 of the License, or (at
18;;; your option) any later version.
19;;;
20;;; GNU Guix is distributed in the hope that it will be useful, but
21;;; WITHOUT ANY WARRANTY; without even the implied warranty of
22;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
23;;; GNU General Public License for more details.
24;;;
25;;; You should have received a copy of the GNU General Public License
26;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
27
28(define-module (gnu services virtualization)
29 #:use-module (gnu bootloader)
30 #:use-module (gnu bootloader grub)
31 #:use-module (gnu image)
32 #:use-module (gnu packages admin)
33 #:use-module (gnu packages bash)
34 #:use-module (gnu packages firmware)
35 #:use-module (gnu packages gdb)
36 #:autoload (gnu packages gnupg) (guile-gcrypt)
37 #:use-module (gnu packages package-management)
38 #:use-module (gnu packages ssh)
39 #:use-module (gnu packages base)
40 #:use-module (gnu packages gawk)
41 #:use-module (gnu packages linux)
42 #:use-module (gnu packages virtualization)
43 #:use-module (gnu services base)
44 #:use-module (gnu services configuration)
45 #:use-module (gnu services dbus)
46 #:use-module (gnu services shepherd)
47 #:use-module (gnu services ssh)
48 #:use-module (gnu services)
49 #:use-module (gnu system file-systems)
50 #:use-module (gnu system hurd)
51 #:use-module (gnu system image)
52 #:use-module (gnu system shadow)
53 #:autoload (gnu system vm) (linux-image-startup-command
54 virtualized-operating-system)
55 #:autoload (gnu system locale) (locale-definition)
56 #:use-module (gnu system)
57 #:use-module (guix derivations)
58 #:use-module (guix gexp)
59 #:use-module (guix modules)
60 #:use-module (guix monads)
61 #:use-module (guix packages)
62 #:use-module (guix records)
63 #:use-module (guix store)
64 #:use-module (guix ui)
65 #:use-module (guix utils)
66 #:autoload (guix self) (make-config.scm)
67 #:autoload (guix platform) (platform-system)
68
69 #:use-module ((srfi srfi-1) #:hide (partition))
70 #:use-module (srfi srfi-9)
71 #:use-module (srfi srfi-19)
72 #:use-module (srfi srfi-26)
73 #:use-module (rnrs bytevectors)
74 #:use-module (ice-9 match)
75
76 #:export (virtual-build-machine
77 virtual-build-machine-service-type
78
79 %virtual-build-machine-operating-system
80 %virtual-build-machine-default-vm
81
82 %hurd-vm-operating-system
83 hurd-vm-configuration
84 hurd-vm-configuration?
85 hurd-vm-configuration-os
86 hurd-vm-configuration-qemu
87 hurd-vm-configuration-type
88 hurd-vm-configuration-image
89 hurd-vm-configuration-disk-size
90 hurd-vm-configuration-memory-size
91 hurd-vm-configuration-options
92 hurd-vm-configuration-id
93 hurd-vm-configuration-net-options
94 hurd-vm-configuration-secrets
95
96 hurd-vm-disk-image
97 hurd-vm-port
98 hurd-vm-net-options
99 hurd-vm-service-type
100
101 libvirt-configuration
102 libvirt-configuration-access-drivers
103 libvirt-configuration-addr
104 libvirt-configuration-admin-keepalive-count
105 libvirt-configuration-admin-keepalive-interval
106 libvirt-configuration-audit-level
107 libvirt-configuration-auth-tcp
108 libvirt-configuration-auth-tls
109 libvirt-configuration-auth-unix-ro
110 libvirt-configuration-auth-unix-rw
111 libvirt-configuration-ca-file
112 libvirt-configuration-cert-file
113 libvirt-configuration-crl-file
114 libvirt-configuration-dmidecode
115 libvirt-configuration-firmwares
116 libvirt-configuration-host-uuid
117 libvirt-configuration-host-uuid-source
118 libvirt-configuration-keepalive-count
119 libvirt-configuration-keepalive-interval
120 libvirt-configuration-key-file
121 libvirt-configuration-libvirt
122 libvirt-configuration-listen-tcp?
123 libvirt-configuration-listen-tls?
124 libvirt-configuration-log-filters
125 libvirt-configuration-log-level
126 libvirt-configuration-log-outputs
127 libvirt-configuration-max-anonymous-clients
128 libvirt-configuration-max-client-requests
129 libvirt-configuration-max-clients
130 libvirt-configuration-max-queued-clients
131 libvirt-configuration-max-requests
132 libvirt-configuration-max-workers
133 libvirt-configuration-mdns-adv?
134 libvirt-configuration-min-workers
135 libvirt-configuration-ovs-timeout
136 libvirt-configuration-prio-workers
137 libvirt-configuration-qemu
138 libvirt-configuration-requirement
139 libvirt-configuration-sasl-allowed-usernames
140 libvirt-configuration-tcp-port
141 libvirt-configuration-tls-allowed-dn-list
142 libvirt-configuration-tls-no-verify-cert
143 libvirt-configuration-tls-port
144 libvirt-configuration-tls-priority
145 libvirt-configuration-unix-sock-dir
146 libvirt-configuration-unix-sock-group
147 libvirt-configuration-unix-sock-ro-perms
148 libvirt-configuration-unix-sock-rw-perms
149
150 libvirt-service-type
151 virtlog-configuration
152 virtlog-service-type
153
154 %qemu-platforms
155 lookup-qemu-platforms
156 qemu-platform?
157 qemu-platform-name
158
159 qemu-binfmt-configuration
160 qemu-binfmt-configuration?
161 qemu-binfmt-service-type
162
163 qemu-guest-agent-configuration
164 qemu-guest-agent-configuration?
165 qemu-guest-agent-service-type
166
167 xe-guest-utilities-configuration
168 xe-guest-utilities-service-type
169 xen-guest-agent-configuration
170 xen-guest-agent-service-type))
171
172(define (uglify-field-name field-name)
173 (let ((str (symbol->string field-name)))
174 (string-join
175 (string-split (string-delete #\? str) #\-)
176 "_")))
177
178(define (quote-val val)
179 (string-append "\"" val "\""))
180
181(define (serialize-field field-name val)
182 (format #t "~a = ~a\n" (uglify-field-name field-name) val))
183
184(define (serialize-string field-name val)
185 (serialize-field field-name (quote-val val)))
186
187(define (serialize-boolean field-name val)
188 (serialize-field field-name (if val 1 0)))
189
190(define (serialize-integer field-name val)
191 (serialize-field field-name val))
192
193(define (build-opt-list val)
194 (string-append
195 "["
196 (string-join (map quote-val val) ",")
197 "]"))
198
199(define optional-list? list?)
200(define optional-string? string?)
201
202(define (serialize-list field-name val)
203 (serialize-field field-name (build-opt-list val)))
204
205(define (serialize-optional-list field-name val)
206 (if (null? val)
207 (format #t "# ~a = []\n" (uglify-field-name field-name))
208 (serialize-list field-name val)))
209
210(define (serialize-optional-string field-name val)
211 (if (string-null? val)
212 (format #t "# ~a = \"\"\n" (uglify-field-name field-name))
213 (serialize-string field-name val)))
214
215(define list-of-file-likes?
216 (list-of file-like?))
217
218(define list-of-symbols?
219 (list-of symbol?))
220
221(define (serialize-list-of-symbols field-name val)
222 val)
223
224(define-configuration libvirt-configuration
225 (libvirt
226 (file-like libvirt)
227 "Libvirt package.")
228 (qemu
229 (file-like qemu)
230 "The QEMU package to use.")
231 (dmidecode
232 (file-like dmidecode)
233 "The Dmidecode package to use.")
234 (requirement
235 (list-of-symbols '(dbus-system))
236 "Shepherd services dependencies to the provisioned Shepherd service.")
237 (firmwares
238 (list-of-file-likes (list ovmf-x86-64))
239 "List of UEFI/BIOS firmware packages to make available. Each firmware
240package should contain a @file{share/qemu/firmware/@var{NAME}.json} QEMU
241firmware metadata file."
242 (serializer empty-serializer))
243 (listen-tls?
244 (boolean #t)
245 "Flag listening for secure TLS connections on the public TCP/IP port.
246must set @code{listen} for this to have any effect. It is necessary to setup
247a CA and issue server certificates before using this capability.")
248 (listen-tcp?
249 (boolean #f)
250 "Listen for unencrypted TCP connections on the public TCP/IP port.
251must set @code{listen} for this to have any effect. Using the TCP socket
252requires SASL authentication by default. Only SASL mechanisms which support
253data encryption are allowed. This is DIGEST_MD5 and GSSAPI (Kerberos5).")
254 (tls-port
255 (string "16514")
256 "Port for accepting secure TLS connections This can be a port number,
257or service name.")
258 (tcp-port
259 (string "16509")
260 "Port for accepting insecure TCP connections This can be a port number,
261or service name.")
262 (listen-addr
263 (string "0.0.0.0")
264 "IP address or hostname used for client connections.")
265 (mdns-adv?
266 (boolean #f)
267 "Flag toggling mDNS advertisement of the libvirt service.")
268 (mdns-name
269 (string (string-append "Virtualization Host " (gethostname)))
270 "Default mDNS advertisement name. This must be unique on the
271immediate broadcast network.")
272 (unix-sock-group
273 (string "libvirt")
274 "UNIX domain socket group ownership. This can be used to allow a trusted
275set of users access to management capabilities without becoming root.")
276 (unix-sock-ro-perms
277 (string "0777")
278 "UNIX socket permissions for the R/O socket. This is used for monitoring
279VM status only.")
280 (unix-sock-rw-perms
281 (string "0770")
282 "UNIX socket permissions for the R/W socket. Default allows only root. If
283PolicyKit is enabled on the socket, the default will change to allow
284everyone (e.g., @code{\"0777\"}).")
285 (unix-sock-admin-perms
286 (string "0777")
287 "UNIX socket permissions for the admin socket. Default allows only
288owner (root), do not change it unless you are sure to whom you are exposing
289the access to.")
290 (unix-sock-dir
291 (string "/var/run/libvirt")
292 "The directory in which sockets will be found/created.")
293 (auth-unix-ro
294 (string "polkit")
295 "Authentication scheme for UNIX read-only sockets. By default socket
296permissions allow anyone to connect.")
297 (auth-unix-rw
298 (string "polkit")
299 "Authentication scheme for UNIX read-write sockets. By default socket
300permissions only allow root. If PolicyKit support was compiled into libvirt,
301the default will be to use 'polkit' auth.")
302 (auth-tcp
303 (string "sasl")
304 "Authentication scheme for TCP sockets. If you don't enable SASL,
305then all TCP traffic is cleartext. Don't do this outside of a
306development/test scenario.")
307 (auth-tls
308 (string "none")
309 "Authentication scheme for TLS sockets. TLS sockets already have
310encryption provided by the TLS layer, and limited authentication is done by
311certificates. It is possible to make use of any SASL authentication mechanism
312as well, by using @code{\"sasl\"} for this option")
313 (access-drivers
314 (optional-list '())
315 "API access control scheme. By default an authenticated user is allowed
316access to all APIs. Access drivers can place restrictions on this.")
317 (key-file
318 (string "")
319 "Server key file path. If set to an empty string, then no private key is
320loaded.")
321 (cert-file
322 (string "")
323 "Server key file path. If set to an empty string, then no certificate is
324loaded.")
325 (ca-file
326 (string "")
327 "Server key file path. If set to an empty string, then no CA certificate
328is loaded.")
329 (crl-file
330 (string "")
331 "Certificate revocation list path. If set to an empty string, then no CRL
332is loaded.")
333 (tls-no-sanity-cert
334 (boolean #f)
335 "Disable verification of our own server certificates. When
336@command{libvirtd} starts it performs some sanity checks against its own
337certificates.")
338 (tls-no-verify-cert
339 (boolean #f)
340 "Disable verification of client certificates. Client certificate
341verification is the primary authentication mechanism. Any client which does
342not present a certificate signed by the CA will be rejected.")
343 (tls-allowed-dn-list
344 (optional-list '())
345 "Whitelist of allowed x509 Distinguished Name.")
346 (sasl-allowed-usernames
347 (optional-list '())
348 "Whitelist of allowed SASL usernames. The format for username depends on
349the SASL authentication mechanism.")
350 (tls-priority
351 (string "NORMAL")
352 "Override the compile time default TLS priority string. The default is
353usually \"NORMAL\" unless overridden at build time. Only set this if it is
354desired for libvirt to deviate from the global default settings.")
355 (max-clients
356 (integer 5000)
357 "Maximum number of concurrent client connections to allow over all sockets
358combined.")
359 (max-queued-clients
360 (integer 1000)
361 "Maximum length of queue of connections waiting to be accepted by the
362daemon. Note, that some protocols supporting re-transmission may obey this so
363that a later reattempt at connection succeeds.")
364 (max-anonymous-clients
365 (integer 20)
366 "Maximum length of queue of accepted but not yet authenticated clients.
367Set this to zero to turn this feature off.")
368 (min-workers
369 (integer 5)
370 "Number of workers to start up initially.")
371 (max-workers
372 (integer 20)
373 "Maximum number of worker threads. If the number of active clients exceeds
374@code{min-workers}, then more threads are spawned, up to @code{max_workers}
375limit. Typically you'd want @code{max_workers} to equal maximum number of
376clients allowed.")
377 (prio-workers
378 (integer 5)
379 "Number of priority workers. If all workers from above pool are stuck,
380some calls marked as high priority (notably domainDestroy) can be executed in
381this pool.")
382 (max-requests
383 (integer 20)
384 "Total global limit on concurrent RPC calls.")
385 (max-client-requests
386 (integer 5)
387 "Limit on concurrent requests from a single client connection. To avoid
388one client monopolizing the server this should be a small fraction of the
389global max_requests and max_workers parameter.")
390 (admin-min-workers
391 (integer 1)
392 "Same as @code{min-workers} but for the admin interface.")
393 (admin-max-workers
394 (integer 5)
395 "Same as @code{max-workers} but for the admin interface.")
396 (admin-max-clients
397 (integer 5)
398 "Same as @code{max-clients} but for the admin interface.")
399 (admin-max-queued-clients
400 (integer 5)
401 "Same as @code{max-queued-clients} but for the admin interface.")
402 (admin-max-client-requests
403 (integer 5)
404 "Same as @code{max-client-requests} but for the admin interface.")
405 (log-level
406 (integer 3)
407 "Semi-deprecated option for the logging level: using the @code{log-filters}
408option instead is recommend, as it provides finer control. The log level can
409be set to @code{4} for errors, @code{3} for warnings, @code{2} for information
410or @code{1} for debug. Note that since @code{log-filters} and
411@code{log-outputs} take precedence over this option, you will need to also
412adjust their logging levels to avoid filtering out messages.")
413 (log-filters
414 (string "3:remote 4:event")
415 "Logging filters. A filter allows selecting a different logging level for
416a given category of logs. The format for a filter is either
417@samp{@var{x}:@var{name}} or @samp{@var{x}:+@var{name}}, where name is a
418string which is matched against the category given in the
419@code{VIR_LOG_INIT()} at the top of each libvirt source file, e.g.,
420@samp{\"remote\"}, @samp{\"qemu\"}, or @samp{\"util.json\"}. @var{name} can
421be a substring of the full category name, in order to match multiple similar
422categories. The optional @samp{+} prefix tells libvirt to log stack traces
423for each message matching @var{name}. @var{x} is the log level value used to
424filter the associated message category. @var{x} can be set to @samp{4} for
425errors, @samp{3} for warnings, @samp{2} for information, or @samp{1} for
426debug. Multiple filters can be defined in a single filters statement, as
427space-separated values. Since @code{log-outputs} also include a level filter,
428you may need to also adjust its value to see all the filtered messages.")
429 (log-outputs
430 (string "3:syslog:libvirtd")
431 "Logging outputs. An output is one of the places to save logging
432information. The format for an output has the form
433@code{\"@var{x}:var{output}\"}, where @var{output} can be @samp{stderr},
434@samp{syslog:@var{name}}, where @var{name} is the syslog @code{ident} value to
435use, or @samp{file:@var{file_name}}, where @var{file_name} is the file name of
436the file to output to. @var{x} is the minimal level, which acts as a filter.
437@var{x} can be set to @var{x} can be set to @samp{4} for errors, @samp{3} for
438warnings, @samp{2} for information, or @samp{1} for debug. Multiple filters
439can be defined in a single filters statement, as space-separated values.")
440 (audit-level
441 (integer 1)
442 "Modify the behavior of the auditing subsystem. @samp{0} disables all
443auditing, samp{1} enables auditing only if enabled on thehost and @samp{2}
444enables auditing but exits if it is disabled on the host.")
445 (audit-logging
446 (boolean #f)
447 "Send audit messages via libvirt logging infrastructure.")
448 (host-uuid
449 (optional-string "")
450 "Host UUID. UUID must not have all digits be the same.")
451 (host-uuid-source
452 (string "smbios")
453 "Source to read host UUID. Use @code{\"smbios\"} to fetch the UUID via
454@code{dmidecode -s system-uuid}, or @code{\"machine-id\"} to fetch the UUID
455from @code{/etc/machine-id}. If @code{dmidecode} does not provide a valid
456UUID a temporary UUID will be generated.")
457 (keepalive-interval
458 (integer 5)
459 "A keepalive message is sent to a client after @code{keepalive_interval}
460seconds of inactivity to check if the client is still responding. If set to
461@code{-1}, libvirtd won't send keepalive requests; however clients can still
462send them and the daemon will send responses.")
463 (keepalive-count
464 (integer 5)
465 "Maximum number of keepalive messages that are allowed to be sent to the
466client without getting any response before the connection is considered
467broken. In other words, the connection is automatically closed approximately
468after @samp{keepalive_interval * (keepalive_count + 1)} seconds since the last
469message received from the client. When @code{keepalive-count} is set to
470@code{0}, connections will be automatically closed after
471@code{keepalive-interval} seconds of inactivity without sending any keepalive
472messages.")
473 (admin-keepalive-interval
474 (integer 5)
475 "Same as above but for admin interface.")
476 (admin-keepalive-count
477 (integer 5)
478 "Same as above but for admin interface.")
479 (ovs-timeout
480 (integer 5)
481 "Timeout for Open vSwitch calls. The @code{ovs-vsctl} utility is used for
482the configuration and its timeout option is set by default to 5 seconds to
483avoid potential infinite waits blocking libvirt."))
484
485(define* (libvirt-conf-file config)
486 "Return a libvirtd config file."
487 (plain-file "libvirtd.conf"
488 (with-output-to-string
489 (lambda ()
490 (serialize-configuration config libvirt-configuration-fields)))))
491
492(define %libvirt-accounts
493 (list (user-group (name "libvirt") (system? #t))))
494
495(define (%libvirt-activation config)
496 (let ((sock-dir (libvirt-configuration-unix-sock-dir config)))
497 #~(begin
498 (use-modules (guix build utils))
499 (mkdir-p #$sock-dir))))
500
501(define (libvirt-shepherd-service config)
502 (let* ((config-file (libvirt-conf-file config))
503 (libvirt (libvirt-configuration-libvirt config))
504 (listen-tcp? (libvirt-configuration-listen-tcp? config)))
505 (list (shepherd-service
506 (documentation "Run the libvirt daemon.")
507 (provision '(libvirtd))
508 (requirement (libvirt-configuration-requirement config))
509 (start #~(make-forkexec-constructor
510 (list (string-append #$libvirt "/sbin/libvirtd")
511 "-f" #$config-file
512 #$@(if listen-tcp? '("--listen") '()))
513 ;; For finding qemu, firmwares, the 'ip' command and
514 ;; kernel modules.
515 #:environment-variables
516 (list
517 (string-append
518 "PATH=/run/current-system/profile/bin:"
519 "/run/current-system/profile/sbin")
520 (string-append
521 "LINUX_MODULE_DIRECTORY="
522 "/run/booted-system/kernel/lib/modules"))))
523 (stop #~(make-kill-destructor))))))
524
525(define (/etc/qemu/firmware config)
526 (let ((firmwares (libvirt-configuration-firmwares config)))
527 `(("qemu/firmware"
528 ,(computed-file
529 "etc-qemu-firmware"
530 (with-imported-modules '((guix build union))
531 #~(begin
532 (use-modules (guix build union) (srfi srfi-26))
533 (union-build #$output
534 (map (cut string-append <> "/share/qemu/firmware")
535 (list #$@firmwares))))))))))
536
537(define libvirt-service-type
538 (service-type
539 (name 'libvirt)
540 (extensions
541 (list
542 (service-extension polkit-service-type
543 (compose list libvirt-configuration-libvirt))
544 (service-extension profile-service-type
545 (lambda (config)
546 (list (libvirt-configuration-dmidecode config)
547 (libvirt-configuration-libvirt config)
548 (libvirt-configuration-qemu config))))
549 ;; Libvirt only considers the $libvirt/share/qemu/firmware and
550 ;; /etc/qemu/firmware directories to locate the QEMU firmware metadata
551 ;; specifications.
552 (service-extension etc-service-type /etc/qemu/firmware)
553 (service-extension activation-service-type
554 %libvirt-activation)
555 (service-extension shepherd-root-service-type
556 libvirt-shepherd-service)
557 (service-extension account-service-type
558 (const %libvirt-accounts))))
559 (default-value (libvirt-configuration))
560 (description "Run @command{libvirtd}, a daemon of the libvirt
561virtualization management system. This daemon runs on host servers and
562performs required management tasks for virtualized guests.")))
563
564(define-record-type* <virtlog-configuration>
565 virtlog-configuration make-virtlog-configuration
566 virtlog-configuration?
567 (libvirt virtlog-configuration-libvirt
568 (default libvirt))
569 (log-level virtlog-configuration-log-level
570 (default 3))
571 (log-filters virtlog-configuration-log-filters
572 (default "3:remote 4:event"))
573 (log-outputs virtlog-configuration-log-outputs
574 (default "3:syslog:virtlogd"))
575 (max-clients virtlog-configuration-max-clients
576 (default 1024))
577 (max-size virtlog-configuration-max-size
578 (default 2097152)) ;; 2MB
579 (max-backups virtlog-configuration-max-backups
580 (default 3)))
581
582(define* (virtlogd-conf-file config)
583 "Return a virtlogd config file."
584 (plain-file "virtlogd.conf"
585 (string-append
586 "log_level = " (number->string (virtlog-configuration-log-level config)) "\n"
587 "log_filters = \"" (virtlog-configuration-log-filters config) "\"\n"
588 "log_outputs = \"" (virtlog-configuration-log-outputs config) "\"\n"
589 "max_clients = " (number->string (virtlog-configuration-max-clients config)) "\n"
590 "max_size = " (number->string (virtlog-configuration-max-size config)) "\n"
591 "max_backups = " (number->string (virtlog-configuration-max-backups config)) "\n")))
592
593(define (virtlogd-shepherd-service config)
594 (let* ((config-file (virtlogd-conf-file config))
595 (libvirt (virtlog-configuration-libvirt config)))
596 (list (shepherd-service
597 (documentation "Run the virtlog daemon.")
598 (provision '(virtlogd))
599 (requirement '(user-processes))
600 (start #~(make-forkexec-constructor
601 (list (string-append #$libvirt "/sbin/virtlogd")
602 "-f" #$config-file)))
603 (stop #~(make-kill-destructor))))))
604
605(define virtlog-service-type
606 (service-type (name 'virtlogd)
607 (extensions
608 (list
609 (service-extension shepherd-root-service-type
610 virtlogd-shepherd-service)))
611 (default-value (virtlog-configuration))
612 (description "Run @command{virtlogd}, a daemon libvirt that is
613used to manage logs from @acronym{VM, virtual machine} consoles.")))
614
615
616;;;
617;;; Transparent QEMU emulation via binfmt_misc.
618;;;
619
620;; Platforms that QEMU can emulate.
621(define-record-type* <qemu-platform>
622 qemu-platform make-qemu-platform
623 qemu-platform?
624 (name qemu-platform-name) ;string
625 (family qemu-platform-family) ;string
626 (magic qemu-platform-magic) ;bytevector
627 (mask qemu-platform-mask) ;bytevector
628
629 ;; Default flags:
630 ;;
631 ;; "F": fix binary. Open the qemu-user binary (statically linked) as soon
632 ;; as binfmt_misc interpretation is handled.
633 ;;
634 ;; "P": preserve argv[0]. QEMU 6.0 detects whether it's started with this
635 ;; flag and automatically does the right thing. Without this flag,
636 ;; argv[0] is replaced by the absolute file name of the executable, an
637 ;; observable difference that can cause discrepancies.
638 (flags qemu-platform-flags (default "FP"))) ;string
639
640(define-syntax bv
641 (lambda (s)
642 "Expand the given string into a bytevector."
643 (syntax-case s ()
644 ((_ str)
645 (string? (syntax->datum #'str))
646 (let ((bv (u8-list->bytevector
647 (map char->integer
648 (string->list (syntax->datum #'str))))))
649 bv)))))
650
651;;; The platform descriptions below are taken from
652;;; 'scripts/qemu-binfmt-conf.sh' in QEMU.
653
654(define %i386
655 (qemu-platform
656 (name "i386")
657 (family "i386")
658 (magic (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x03\x00"))
659 (mask (bv "\xff\xff\xff\xff\xff\xfe\xfe\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))))
660
661(define %i486
662 (qemu-platform
663 (name "i486")
664 (family "i386")
665 (magic (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x06\x00"))
666 (mask (bv "\xff\xff\xff\xff\xff\xfe\xfe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))))
667
668(define %x86_64
669 (qemu-platform
670 (name "x86_64")
671 (family "i386")
672 (magic (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x3e\x00"))
673 (mask (bv "\xff\xff\xff\xff\xff\xfe\xfe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))))
674
675(define %alpha
676 (qemu-platform
677 (name "alpha")
678 (family "alpha")
679 (magic (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x26\x90"))
680 (mask (bv "\xff\xff\xff\xff\xff\xfe\xfe\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))))
681
682(define %arm
683 (qemu-platform
684 (name "arm")
685 (family "arm")
686 (magic (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x28\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 %armeb
690 (qemu-platform
691 (name "armeb")
692 (family "armeb")
693 (magic (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x28"))
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 %sparc
697 (qemu-platform
698 (name "sparc")
699 (family "sparc")
700 (magic (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x02"))
701 (mask (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))))
702
703(define %sparc32plus
704 (qemu-platform
705 (name "sparc32plus")
706 (family "sparc")
707 (magic (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x12"))
708 (mask (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))))
709
710(define %sparc64
711 (qemu-platform
712 (name "sparc64")
713 (family "sparc")
714 (magic (bv "\x7fELF\x02\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x2b"))
715 (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))))
716
717(define %ppc
718 (qemu-platform
719 (name "ppc")
720 (family "ppc")
721 (magic (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x14"))
722 (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))))
723
724(define %ppc64
725 (qemu-platform
726 (name "ppc64")
727 (family "ppc")
728 (magic (bv "\x7fELF\x02\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x15"))
729 (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))))
730
731(define %ppc64le
732 (qemu-platform
733 (name "ppc64le")
734 (family "ppcle")
735 (magic (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x15\x00"))
736 (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\x00"))))
737
738(define %m68k
739 (qemu-platform
740 (name "m68k")
741 (family "m68k")
742 (magic (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x04"))
743 (mask (bv "\xff\xff\xff\xff\xff\xff\xfe\xfe\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))))
744
745;; XXX: We could use the other endianness on a MIPS host.
746(define %mips
747 (qemu-platform
748 (name "mips")
749 (family "mips")
750 (magic (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08"))
751 (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))))
752
753(define %mipsel
754 (qemu-platform
755 (name "mipsel")
756 (family "mips")
757 (magic (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08\x00"))
758 (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))))
759
760(define %mipsn32
761 (qemu-platform
762 (name "mipsn32")
763 (family "mips")
764 (magic (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08"))
765 (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))))
766
767(define %mipsn32el
768 (qemu-platform
769 (name "mipsn32el")
770 (family "mips")
771 (magic (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08\x00"))
772 (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))))
773
774(define %mips64
775 (qemu-platform
776 (name "mips64")
777 (family "mips")
778 (magic (bv "\x7fELF\x02\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08"))
779 (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))))
780
781(define %mips64el
782 (qemu-platform
783 (name "mips64el")
784 (family "mips")
785 (magic (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08\x00"))
786 (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))))
787
788(define %sh4
789 (qemu-platform
790 (name "sh4")
791 (family "sh4")
792 (magic (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x2a\x00"))
793 (mask (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))))
794
795(define %sh4eb
796 (qemu-platform
797 (name "sh4eb")
798 (family "sh4")
799 (magic (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x2a"))
800 (mask (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))))
801
802(define %s390x
803 (qemu-platform
804 (name "s390x")
805 (family "s390x")
806 (magic (bv "\x7fELF\x02\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x16"))
807 (mask (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))))
808
809(define %aarch64
810 (qemu-platform
811 (name "aarch64")
812 (family "arm")
813 (magic (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\xb7\x00"))
814 (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))))
815
816(define %aarch64be
817 (qemu-platform
818 (name "aarch64be")
819 (family "armeb")
820 (magic (bv "\x7fELF\x02\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\xb7"))
821 (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))))
822
823(define %hppa
824 (qemu-platform
825 (name "hppa")
826 (family "hppa")
827 (magic (bv "\x7f\x45\x4c\x46\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x0f"))
828 (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))))
829
830(define %riscv32
831 (qemu-platform
832 (name "riscv32")
833 (family "riscv")
834 (magic (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\xf3\x00"))
835 (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))))
836
837(define %riscv64
838 (qemu-platform
839 (name "riscv64")
840 (family "riscv")
841 (magic (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\xf3\x00"))
842 (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))))
843
844(define %xtensa
845 (qemu-platform
846 (name "xtensa")
847 (family "xtensa")
848 (magic (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x5e\x00"))
849 (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))))
850
851(define %xtensaeb
852 (qemu-platform
853 (name "xtensaeb")
854 (family "xtensaeb")
855 (magic (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x5e"))
856 (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))))
857
858(define %microblaze
859 (qemu-platform
860 (name "microblaze")
861 (family "microblaze")
862 (magic (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\xba\xab"))
863 (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))))
864
865(define %microblazeel
866 (qemu-platform
867 (name "microblazeel")
868 (family "microblazeel")
869 (magic (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\xab\xba"))
870 (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))))
871
872(define %or1k
873 (qemu-platform
874 (name "or1k")
875 (family "or1k")
876 (magic (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x5c"))
877 (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))))
878
879(define %hexagon
880 (qemu-platform
881 (name "hexagon")
882 (family "hexagon")
883 (magic (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\xa4\x00"))
884 (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))))
885
886(define %loongarch64
887 (qemu-platform
888 (name "loongarch64")
889 (family "loongarch")
890 (magic (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x02\x01"))
891 (mask (bv "\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))))
892
893;; binfmt_misc: register: failed to install interpreter file /gnu/store/...
894;; i486 and aarch64be aren't supported by the qemu-binfmt service.
895(define %qemu-platforms
896 (list %i386 %x86_64 %alpha %arm %sparc32plus %sparc64 %ppc %ppc64
897 %ppc64le %m68k %mips %mipsel %mipsn32 %mipsn32el %mips64 %mips64el %sh4
898 %sh4eb %s390x %aarch64 %hppa %riscv32 %riscv64 %xtensa
899 %xtensaeb %microblaze %microblazeel %or1k %hexagon %loongarch64))
900
901(define (lookup-qemu-platforms . names)
902 "Return the list of QEMU platforms that match NAMES--a list of names such as
903\"arm\", \"hppa\", etc."
904 (filter (lambda (platform)
905 (member (qemu-platform-name platform) names))
906 %qemu-platforms))
907
908(define-record-type* <qemu-binfmt-configuration>
909 qemu-binfmt-configuration make-qemu-binfmt-configuration
910 qemu-binfmt-configuration?
911 (qemu qemu-binfmt-configuration-qemu
912 (default qemu))
913 (platforms qemu-binfmt-configuration-platforms
914 (default '()))) ;safest default
915
916(define (qemu-platform->binfmt qemu platform)
917 "Return a gexp that evaluates to a binfmt string for PLATFORM, using the
918given QEMU package."
919 (define (bytevector->binfmt-string bv)
920 ;; Return a binfmt-friendly string representing BV. Hex-encode every
921 ;; character, in particular because the doc notes "that you must escape
922 ;; any NUL bytes; parsing halts at the first one".
923 (string-concatenate
924 (map (lambda (n)
925 (string-append "\\x"
926 (string-pad (number->string n 16) 2 #\0)))
927 (bytevector->u8-list bv))))
928
929 (match platform
930 (($ <qemu-platform> name family magic mask flags)
931 ;; See 'Documentation/binfmt_misc.txt' in the kernel.
932 #~(string-append ":qemu-" #$name ":M::"
933 #$(bytevector->binfmt-string magic)
934 ":" #$(bytevector->binfmt-string mask)
935 ":" #$qemu:static "/bin/qemu-" #$name
936 ":" #$flags))))
937
938(define %binfmt-mount-point
939 (file-system-mount-point %binary-format-file-system))
940
941(define %binfmt-register-file
942 (string-append %binfmt-mount-point "/register"))
943
944(define qemu-binfmt-shepherd-services
945 (match-lambda
946 (($ <qemu-binfmt-configuration> qemu platforms)
947 (list (shepherd-service
948 (provision '(qemu-binfmt))
949 (documentation "Install binfmt_misc handlers for QEMU.")
950 (requirement '(file-system-/proc/sys/fs/binfmt_misc
951 file-system-/gnu/store))
952 (start #~(lambda ()
953 ;; Register the handlers for all of PLATFORMS.
954 (for-each (lambda (str)
955 (call-with-output-file
956 #$%binfmt-register-file
957 (lambda (port)
958 (display str port))))
959 (list
960 #$@(map (cut qemu-platform->binfmt qemu
961 <>)
962 platforms)))
963 #t))
964 (stop #~(lambda (_)
965 ;; Unregister the handlers.
966 (for-each (lambda (name)
967 (let ((file (string-append
968 #$%binfmt-mount-point
969 "/qemu-" name)))
970 (call-with-output-file file
971 (lambda (port)
972 (display "-1" port)))))
973 '#$(map qemu-platform-name platforms))
974 #f)))))))
975
976(define qemu-binfmt-service-type
977 ;; TODO: Make a separate binfmt_misc service out of this?
978 (service-type (name 'qemu-binfmt)
979 (extensions
980 (list (service-extension file-system-service-type
981 (const
982 (list %binary-format-file-system)))
983 (service-extension shepherd-root-service-type
984 qemu-binfmt-shepherd-services)))
985 (default-value (qemu-binfmt-configuration))
986 (description
987 "This service supports transparent emulation of binaries
988compiled for other architectures using QEMU and the @code{binfmt_misc}
989functionality of the kernel Linux.")))
990
991
992;;;
993;;; QEMU guest agent service.
994;;;
995
996(define-configuration qemu-guest-agent-configuration
997 (qemu
998 (file-like qemu-minimal)
999 "QEMU package.")
1000 (device
1001 (string "")
1002 "Path to device or socket used to communicate with the host. If not
1003specified, the QEMU default path is used."))
1004
1005(define (qemu-guest-agent-shepherd-service config)
1006 (let ((qemu (qemu-guest-agent-configuration-qemu config))
1007 (device (qemu-guest-agent-configuration-device config)))
1008 (list
1009 (shepherd-service
1010 (provision '(qemu-guest-agent))
1011
1012 ;; The service needs to depend on udev, which brings up devices like
1013 ;; those under /dev/virtio-ports.
1014 (requirement '(user-processes udev))
1015
1016 (documentation "Run the QEMU guest agent.")
1017 (start #~(make-forkexec-constructor
1018 `(,(string-append #$qemu "/bin/qemu-ga")
1019 "--statedir" "/var/run"
1020 ,@(if (string-null? #$device)
1021 '()
1022 (list "--path" #$device)))
1023 #:log-file "/var/log/qemu-ga.log"))
1024 (stop #~(make-kill-destructor))))))
1025
1026(define qemu-guest-agent-service-type
1027 (service-type
1028 (name 'qemu-guest-agent)
1029 (extensions
1030 (list (service-extension shepherd-root-service-type
1031 qemu-guest-agent-shepherd-service)))
1032 (default-value (qemu-guest-agent-configuration))
1033 (description "Run the QEMU guest agent.")))
1034
1035
1036;;;
1037;;; Guest agent for VMs running under Xen
1038;;;
1039(define-configuration/no-serialization xe-guest-utilities-configuration
1040 (package
1041 (package xe-guest-utilities)
1042 "Xen guest management utilities package.")
1043 (pid-file
1044 (string "/var/run/xe-daemon.pid")
1045 "Path to the file holding the PID of xe-deamon.")
1046 (log-file
1047 (string "/var/log/xe-guest-utilties.log")
1048 "Path to xe-guest-utilities log file."))
1049
1050(define (generate-xe-guest-utilities-documentation)
1051 "Generate documentation for xe-guest-utilities-configuration fields"
1052 (generate-documentation
1053 `((xe-guest-utilities-configuration ,xe-guest-utilities-configuration-fields))
1054 'xe-guest-utilities-configuration))
1055
1056(define (xe-guest-utilities-shepherd-service config)
1057 (let ((xe-guest-utils (xe-guest-utilities-configuration-package config))
1058 (pid-file (xe-guest-utilities-configuration-pid-file config))
1059 (log-file (xe-guest-utilities-configuration-log-file config)))
1060 (list
1061 (shepherd-service
1062 (provision '(xen-guest-agent))
1063 (requirement '(networking user-processes udev))
1064 (documentation "Run the Xen guest management agent.")
1065 (start
1066 #~(lambda _
1067 (let ((pid (make-forkexec-constructor
1068 (list
1069 #$(file-append xe-guest-utils
1070 "/sbin/xe-daemon")
1071 "-p" #$pid-file)
1072 #:log-file #$log-file
1073 #:pid-file #$pid-file
1074 #:environment-variables
1075 (list (string-append
1076 "PATH="
1077 #$(file-append xe-guest-utils "/bin") ":"
1078 ;; logger
1079 #$(file-append inetutils "/bin"))))))
1080 ;; Run xe-linux-distribution script before starting the actual
1081 ;; daemon. The script collects some basic system information that
1082 ;; is shared back to the Xen host.
1083 (system* #$(file-append xe-guest-utils "/sbin/xe-linux-distribution")
1084 "/var/cache/xe-linux-distribution")
1085 ;; Finally, start and return the PID made by
1086 ;; make-forkexec-constructor.
1087 pid)))
1088 (stop #~(make-kill-destructor))))))
1089
1090(define (xe-guest-utilities-udev-rules-service config)
1091 (let ((guest-utils (xe-guest-utilities-configuration-package config)))
1092 (list
1093 (file->udev-rule
1094 "z10_xen-vcpu-hotplug.rules"
1095 (file-append guest-utils "/lib/udev/rules.d/z10_xen-vcpu-hotplug.rules")))))
1096
1097(define xe-guest-utilities-service-type
1098 (service-type
1099 (name 'xe-guest-utilities)
1100 (extensions
1101 (list (service-extension shepherd-root-service-type
1102 xe-guest-utilities-shepherd-service)
1103 (service-extension udev-service-type
1104 xe-guest-utilities-udev-rules-service)))
1105 (default-value (xe-guest-utilities-configuration))
1106 (description "Run the Xen guest management utilities.")))
1107
1108(define-configuration/no-serialization xen-guest-agent-configuration
1109 (package
1110 (package xen-guest-agent)
1111 "Xen guest agent package."))
1112
1113(define (generate-xen-guest-agent-documentation)
1114 "Generate documentation for xen-guest-agent-configuration fields"
1115 (generate-documentation
1116 `((xen-guest-agent-configuration ,xen-guest-agent-configuration-fields))
1117 'xen-guest-agent-configuration))
1118
1119(define (xen-guest-agent-shepherd-service config)
1120 (list
1121 (shepherd-service
1122 (provision '(xen-guest-agent))
1123 (requirement '(networking user-processes udev))
1124 (documentation "Run the Xen guest management agent.")
1125 (start #~(make-forkexec-constructor
1126 (list #$(file-append xen-guest-agent "/bin/xen-guest-agent"))))
1127 (stop #~(make-kill-destructor)))))
1128
1129(define xen-guest-agent-service-type
1130 (service-type
1131 (name 'xen-guest-agent)
1132 (extensions
1133 (list (service-extension shepherd-root-service-type
1134 xen-guest-agent-shepherd-service)))
1135 (default-value (xen-guest-agent-configuration))
1136 (description "Run the Xen guest management utilities.")))
1137
1138
1139;;;
1140;;; Secrets for guest VMs.
1141;;;
1142
1143(define (secret-service-shepherd-services address)
1144 "Return a Shepherd service that fetches sensitive material at local PORT,
1145over TCP. Reboot upon failure."
1146 ;; This is a Shepherd service, rather than an activation snippet, to make
1147 ;; sure it is started once 'networking' is up so it can accept incoming
1148 ;; connections.
1149 (list
1150 (shepherd-service
1151 (documentation "Fetch secrets from the host at startup time.")
1152 (provision '(secret-service-client))
1153 (requirement '(loopback networking))
1154 (modules '((gnu build secret-service)
1155 (guix build utils)
1156 ((shepherd system) #:select (reboot))))
1157 (start (with-imported-modules '((gnu build secret-service)
1158 (guix build utils))
1159 #~(lambda ()
1160 ;; Since shepherd's output port goes to /dev/log, write this
1161 ;; message to stderr so it's visible on the Mach console.
1162 (format (current-error-port)
1163 "receiving secrets from the host...~%")
1164 (force-output (current-error-port))
1165
1166 (let ((sent (secret-service-receive-secrets #$address)))
1167 (unless sent
1168 (sleep 3)
1169 (reboot))))))
1170 (stop #~(const #f)))))
1171
1172(define secret-service-type
1173 (service-type
1174 (name 'secret-service)
1175 (extensions (list (service-extension shepherd-root-service-type
1176 secret-service-shepherd-services)
1177
1178 ;; Make every Shepherd service depend on
1179 ;; 'secret-service-client'.
1180 (service-extension user-processes-service-type
1181 (const '(secret-service-client)))))
1182 (description
1183 "This service fetches secret key and other sensitive material over TCP at
1184boot time. This service is meant to be used by virtual machines (VMs) that
1185can only be accessed by their host.")))
1186
1187(define* (secret-service-operating-system os
1188 #:optional
1189 (address
1190 #~(make-socket-address
1191 AF_INET INADDR_ANY 1004)))
1192 "Return an operating system based on OS that includes the secret-service,
1193that will be listening to receive secret keys on ADDRESS."
1194 (operating-system
1195 (inherit os)
1196 (services
1197 ;; Turn off SSH and Guix key generation that normally happens during
1198 ;; activation: that requires entropy and thus takes time during boot, and
1199 ;; those keys are going to be overwritten by secrets received from the
1200 ;; host anyway.
1201 (cons (service secret-service-type address)
1202 (modify-services (operating-system-user-services os)
1203 (openssh-service-type
1204 config => (openssh-configuration
1205 (inherit config)
1206 (generate-host-keys? #f)))
1207 (guix-service-type
1208 config => (guix-configuration
1209 (inherit config)
1210 (generate-substitute-key? #f))))))))
1211
1212
1213;;;
1214;;; Offloading-as-a-service.
1215;;;
1216
1217(define-record-type* <virtual-build-machine>
1218 virtual-build-machine make-virtual-build-machine
1219 virtual-build-machine?
1220 this-virtual-build-machine
1221 (name virtual-build-machine-name
1222 (default 'build-vm))
1223 (image virtual-build-machine-image
1224 (thunked)
1225 (default
1226 (virtual-build-machine-default-image
1227 this-virtual-build-machine)))
1228 (qemu virtual-build-machine-qemu
1229 (default qemu-minimal))
1230 (cpu virtual-build-machine-cpu
1231 (thunked)
1232 (default
1233 (qemu-cpu-model-for-date
1234 (virtual-build-machine-systems this-virtual-build-machine)
1235 (virtual-build-machine-date this-virtual-build-machine))))
1236 (cpu-count virtual-build-machine-cpu-count
1237 (default 4))
1238 (memory-size virtual-build-machine-memory-size ;integer (MiB)
1239 (default 2048))
1240 (date virtual-build-machine-date
1241 ;; Default to a date "in the past" assuming a common use case
1242 ;; is to rebuild old packages.
1243 (default (make-date 0 0 00 00 01 01 2020 0)))
1244 (port-forwardings virtual-build-machine-port-forwardings
1245 (default
1246 `((,%build-vm-ssh-port . 22)
1247 (,%build-vm-secrets-port . 1004))))
1248 (systems virtual-build-machine-systems
1249 (default (list (%current-system))))
1250 (auto-start? virtual-build-machine-auto-start?
1251 (default #f)))
1252
1253(define %build-vm-ssh-port
1254 ;; Default host port where the guest's SSH port is forwarded.
1255 11022)
1256
1257(define %build-vm-secrets-port
1258 ;; Host port to communicate secrets to the build VM.
1259 ;; FIXME: Anyone on the host can talk to it; use virtio ports or AF_VSOCK
1260 ;; instead.
1261 11044)
1262
1263(define %x86-64-intel-cpu-models
1264 ;; List of release date/CPU model pairs representing Intel's x86_64 models.
1265 ;; The list is taken from
1266 ;; <https://en.wikipedia.org/wiki/List_of_Intel_CPU_microarchitectures>.
1267 ;; CPU model strings are those found in 'qemu-system-x86_64 -cpu help'.
1268 (letrec-syntax ((cpu-models (syntax-rules ()
1269 ((_ (date model) rest ...)
1270 (alist-cons (date->time-utc
1271 (string->date date "~Y-~m-~d"))
1272 model
1273 (cpu-models rest ...)))
1274 ((_)
1275 '()))))
1276 (reverse
1277 (cpu-models ("2006-01-01" "core2duo")
1278 ("2010-01-01" "Westmere")
1279 ("2008-01-01" "Nehalem")
1280 ("2011-01-01" "SandyBridge")
1281 ("2012-01-01" "IvyBridge")
1282 ("2013-01-01" "Haswell")
1283 ("2014-01-01" "Broadwell")
1284 ("2015-01-01" "Skylake-Client")))))
1285
1286(define (qemu-cpu-model-for-date systems date)
1287 "Return the QEMU name of a CPU model for SYSTEMS that was current at DATE."
1288 (if (any (cut string-prefix? "x86_64-" <>) systems)
1289 (let ((time (date->time-utc date)))
1290 (any (match-lambda
1291 ((release-date . model)
1292 (and (time<? release-date time)
1293 model)))
1294 %x86-64-intel-cpu-models))
1295 ;; TODO: Add models for other architectures.
1296 "host"))
1297
1298(define (virtual-build-machine-ssh-port config)
1299 "Return the host port where CONFIG has its VM's SSH port forwarded."
1300 (any (match-lambda
1301 ((host-port . 22) host-port)
1302 (_ #f))
1303 (virtual-build-machine-port-forwardings config)))
1304
1305(define (virtual-build-machine-secrets-port config)
1306 "Return the host port where CONFIG has its VM's secrets port forwarded."
1307 (any (match-lambda
1308 ((host-port . 1004) host-port)
1309 (_ #f))
1310 (virtual-build-machine-port-forwardings config)))
1311
1312(define %system-log-message-destination
1313 ;; Shepherd system log message destination procedure. Log most messages to
1314 ;; the console, which goes to the serial output, allowing the host to log
1315 ;; it.
1316 #~(lambda (message)
1317 (cond ((= (system-log-priority debug)
1318 (system-log-message-priority message))
1319 '("/var/log/debug"))
1320 ((member (system-log-message-facility message)
1321 (list (system-log-facility authorization)
1322 (system-log-facility authorization/private)))
1323 '("/var/log/secure"))
1324 (else
1325 '("/dev/console")))))
1326
1327(define gc-service-type ;TODO: Factorize.
1328 (shepherd-service-type
1329 'garbage-collection
1330 (lambda _
1331 (shepherd-service
1332 (provision '(gc))
1333 (requirement '(user-processes guix-daemon))
1334 (start #~(make-timer-constructor
1335 (calendar-event #:minutes '(12))
1336 (command
1337 '("/run/current-system/profile/bin/guix" "gc" "-F2G"))
1338 #:wait-for-termination? #t))
1339 (stop #~(make-timer-constructor))
1340 (actions (list shepherd-trigger-action))))
1341 #t
1342 (description "Periodically collect garbage.")))
1343
1344(define %virtual-build-machine-operating-system
1345 (operating-system
1346 (host-name "build-machine")
1347
1348 (locale "en_US.utf8")
1349 (locale-definitions
1350 ;; Save space by providing only one locale.
1351 (list (locale-definition (name "en_US.utf8")
1352 (source "en_US")
1353 (charset "UTF-8"))))
1354
1355 (bootloader (bootloader-configuration ;unused
1356 (bootloader grub-minimal-bootloader)
1357 (targets '("/dev/null"))))
1358 (file-systems (cons (file-system ;unused
1359 (mount-point "/")
1360 (device "none")
1361 (type "tmpfs"))
1362 %base-file-systems))
1363 (users (cons (user-account
1364 (name "offload")
1365 (group "users")
1366 (supplementary-groups '("kvm"))
1367 (comment "Account used for offloading"))
1368 %base-user-accounts))
1369 (services (cons* (service static-networking-service-type
1370 (list %qemu-static-networking))
1371 (service openssh-service-type
1372 (openssh-configuration
1373 (openssh openssh-sans-x)))
1374
1375 ;; Run GC once per hour.
1376 (service gc-service-type)
1377
1378 (modify-services %base-services
1379 ;; By default, the secret service introduces a
1380 ;; pre-initialized /etc/guix/acl file in the VM. Thus,
1381 ;; clear 'authorize-key?' so that it's not overridden
1382 ;; at activation time.
1383 ;; Since it's used for offloading, disable substitutes
1384 ;; (this avoids network issues).
1385 (guix-service-type config =>
1386 (guix-configuration
1387 (inherit config)
1388 (authorize-key? #f)
1389 (use-substitutes? #f)))
1390 (shepherd-system-log-service-type
1391 config =>
1392 (system-log-configuration
1393 (message-destination %system-log-message-destination)))
1394 (delete mingetty-service-type)
1395 (delete console-font-service-type))))))
1396
1397(define %default-virtual-build-machine-image-size
1398 ;; Size of the default disk image of virtual build machines. It should be
1399 ;; large enough to let users build a few things.
1400 (* 20 (expt 2 30)))
1401
1402(define (virtual-build-machine-default-image config)
1403 (let* ((type (lookup-image-type-by-name 'mbr-raw))
1404 (base (os->image %virtual-build-machine-operating-system
1405 #:type type)))
1406 (image (inherit base)
1407 (name (symbol-append 'build-vm-
1408 (virtual-build-machine-name config)))
1409 (format 'compressed-qcow2)
1410 (partition-table-type 'mbr)
1411 (volatile-root? #f)
1412 (shared-store? #f)
1413 (size %default-virtual-build-machine-image-size)
1414 (partitions (match (image-partitions base)
1415 ((root)
1416 ;; Increase the size of the root partition to match
1417 ;; that of the disk image.
1418 (let ((root-size (- size (* 50 (expt 2 20)))))
1419 (list (partition
1420 (inherit root)
1421 (size root-size))))))))))
1422
1423(define (virtual-build-machine-account-name config)
1424 (string-append "build-vm-"
1425 (symbol->string
1426 (virtual-build-machine-name config))))
1427
1428(define (virtual-build-machine-accounts config)
1429 (let ((name (virtual-build-machine-account-name config)))
1430 (list (user-group (name name) (system? #t))
1431 (user-account
1432 (name name)
1433 (group name)
1434 (supplementary-groups '("kvm"))
1435 (comment "Privilege separation user for the virtual build machine")
1436 (home-directory "/var/empty")
1437 (shell (file-append shadow "/sbin/nologin"))
1438 (system? #t)))))
1439
1440(define (build-vm-shepherd-services config)
1441 (define transform
1442 (compose secret-service-operating-system
1443 operating-system-with-locked-root-account
1444 operating-system-with-offloading-account
1445 (lambda (os)
1446 (virtualized-operating-system os #:full-boot? #t))))
1447
1448 (define transformed-image
1449 (let ((base (virtual-build-machine-image config)))
1450 (image
1451 (inherit base)
1452 (operating-system
1453 (transform (image-operating-system base))))))
1454
1455 (define command
1456 (linux-image-startup-command transformed-image
1457 #:qemu
1458 (virtual-build-machine-qemu config)
1459 #:cpu
1460 (virtual-build-machine-cpu config)
1461 #:cpu-count
1462 (virtual-build-machine-cpu-count config)
1463 #:memory-size
1464 (virtual-build-machine-memory-size config)
1465 #:port-forwardings
1466 (virtual-build-machine-port-forwardings
1467 config)
1468 #:date
1469 (virtual-build-machine-date config)))
1470
1471 (define user
1472 (virtual-build-machine-account-name config))
1473
1474 (list (shepherd-service
1475 (documentation "Run the build virtual machine service.")
1476 (provision (list (virtual-build-machine-name config)))
1477 (requirement '(user-processes))
1478 (modules `((gnu build secret-service)
1479 (guix build utils)
1480 ,@%default-modules))
1481 (start
1482 (with-imported-modules (source-module-closure
1483 '((gnu build secret-service)
1484 (guix build utils)))
1485 #~(lambda arguments
1486 (let* ((pid (fork+exec-command (append #$command arguments)
1487 #:user #$user
1488 #:group "kvm"
1489 #:environment-variables
1490 ;; QEMU tries to write to /var/tmp
1491 ;; by default.
1492 '("TMPDIR=/tmp")))
1493 (port #$(virtual-build-machine-secrets-port config))
1494 (root #$(virtual-build-machine-secret-root config))
1495 (address (make-socket-address AF_INET INADDR_LOOPBACK
1496 port)))
1497 (catch #t
1498 (lambda _
1499 (if (secret-service-send-secrets address root)
1500 pid
1501 (begin
1502 (kill (- pid) SIGTERM)
1503 #f)))
1504 (lambda (key . args)
1505 (kill (- pid) SIGTERM)
1506 (apply throw key args)))))))
1507 (stop #~(make-kill-destructor))
1508 (actions
1509 (list (shepherd-action
1510 (name 'configuration)
1511 (documentation
1512 "Display the configuration of this virtual build machine.")
1513 (procedure
1514 #~(lambda (_)
1515 (format #t "CPU: ~a~%"
1516 #$(virtual-build-machine-cpu config))
1517 (format #t "number of CPU cores: ~a~%"
1518 #$(virtual-build-machine-cpu-count config))
1519 (format #t "memory size: ~a MiB~%"
1520 #$(virtual-build-machine-memory-size config))
1521 (format #t "initial date: ~a~%"
1522 #$(date->string
1523 (virtual-build-machine-date config))))))))
1524 (auto-start? (virtual-build-machine-auto-start? config)))))
1525
1526(define (authorize-guest-substitutes-on-host)
1527 "Return a program that authorizes the guest's archive signing key (passed as
1528an argument) on the host."
1529 (define not-config?
1530 (match-lambda
1531 ('(guix config) #f)
1532 (('guix _ ...) #t)
1533 (('gnu _ ...) #t)
1534 (_ #f)))
1535
1536 (define run
1537 (with-extensions (list guile-gcrypt)
1538 (with-imported-modules `(((guix config) => ,(make-config.scm))
1539 ,@(source-module-closure
1540 '((guix pki)
1541 (guix build utils))
1542 #:select? not-config?))
1543 #~(begin
1544 (use-modules (ice-9 match)
1545 (ice-9 textual-ports)
1546 (gcrypt pk-crypto)
1547 (guix pki)
1548 (guix build utils))
1549
1550 (match (command-line)
1551 ((_ guest-config-directory)
1552 (let ((guest-key (string-append guest-config-directory
1553 "/signing-key.pub")))
1554 (if (file-exists? guest-key)
1555 ;; Add guest key to the host's ACL.
1556 (let* ((key (string->canonical-sexp
1557 (call-with-input-file guest-key
1558 get-string-all)))
1559 (acl (public-keys->acl
1560 (cons key (acl->public-keys (current-acl))))))
1561 (with-atomic-file-replacement %acl-file
1562 (lambda (_ port)
1563 (write-acl acl port))))
1564 (format (current-error-port)
1565 "warning: guest key missing from '~a'~%"
1566 guest-key)))))))))
1567
1568 (program-file "authorize-guest-substitutes-on-host" run))
1569
1570(define (initialize-build-vm-substitutes)
1571 "Initialize the Hurd VM's key pair and ACL and store it on the host."
1572 (define run
1573 (with-imported-modules '((guix build utils))
1574 #~(begin
1575 (use-modules (guix build utils)
1576 (ice-9 match))
1577
1578 (define host-key
1579 "/etc/guix/signing-key.pub")
1580
1581 (define host-acl
1582 "/etc/guix/acl")
1583
1584 (match (command-line)
1585 ((_ guest-config-directory)
1586 (setenv "GUIX_CONFIGURATION_DIRECTORY"
1587 guest-config-directory)
1588 (invoke #+(file-append guix "/bin/guix") "archive"
1589 "--generate-key")
1590
1591 (when (file-exists? host-acl)
1592 ;; Copy the host ACL.
1593 (copy-file host-acl
1594 (string-append guest-config-directory
1595 "/acl")))
1596
1597 (when (file-exists? host-key)
1598 ;; Add the host key to the childhurd's ACL.
1599 (let ((key (open-fdes host-key O_RDONLY)))
1600 (close-fdes 0)
1601 (dup2 key 0)
1602 (execl #+(file-append guix "/bin/guix")
1603 "guix" "archive" "--authorize"))))))))
1604
1605 (program-file "initialize-build-vm-substitutes" run))
1606
1607(define* (build-vm-activation secret-directory
1608 #:key
1609 offloading-ssh-key
1610 (offloading? #t))
1611 (with-imported-modules '((guix build utils))
1612 #~(begin
1613 (use-modules (guix build utils))
1614
1615 (define secret-directory
1616 #$secret-directory)
1617
1618 (define ssh-directory
1619 (string-append secret-directory "/etc/ssh"))
1620
1621 (define guix-directory
1622 (string-append secret-directory "/etc/guix"))
1623
1624 (define offloading-ssh-key
1625 #$offloading-ssh-key)
1626
1627 (unless (file-exists? ssh-directory)
1628 ;; Generate SSH host keys under SSH-DIRECTORY.
1629 (mkdir-p ssh-directory)
1630 (invoke #$(file-append openssh "/bin/ssh-keygen")
1631 "-A" "-f" secret-directory))
1632
1633 (unless (or (not #$offloading?)
1634 (file-exists? offloading-ssh-key))
1635 ;; Generate a user SSH key pair for the host to use when offloading
1636 ;; to the guest.
1637 (mkdir-p (dirname offloading-ssh-key))
1638 (invoke #$(file-append openssh "/bin/ssh-keygen")
1639 "-t" "ed25519" "-N" ""
1640 "-f" offloading-ssh-key)
1641
1642 ;; Authorize it in the guest for user 'offloading'.
1643 (let ((authorizations
1644 (string-append ssh-directory
1645 "/authorized_keys.d/offloading")))
1646 (mkdir-p (dirname authorizations))
1647 (copy-file (string-append offloading-ssh-key ".pub")
1648 authorizations)
1649 (chmod (dirname authorizations) #o555)))
1650
1651 (unless (file-exists? guix-directory)
1652 (invoke #$(initialize-build-vm-substitutes)
1653 guix-directory))
1654
1655 (when #$offloading?
1656 ;; Authorize the archive signing key from GUIX-DIRECTORY in the host.
1657 (invoke #$(authorize-guest-substitutes-on-host) guix-directory)))))
1658
1659(define (virtual-build-machine-offloading-ssh-key config)
1660 "Return the name of the file containing the SSH key of user 'offloading'."
1661 (string-append "/etc/guix/offload/ssh/virtual-build-machine/"
1662 (symbol->string
1663 (virtual-build-machine-name config))))
1664
1665(define (virtual-build-machine-activation config)
1666 "Return a gexp to activate the build VM according to CONFIG."
1667 (build-vm-activation (virtual-build-machine-secret-root config)
1668 #:offloading? #t
1669 #:offloading-ssh-key
1670 (virtual-build-machine-offloading-ssh-key config)))
1671
1672(define (virtual-build-machine-secret-root config)
1673 (string-append "/etc/guix/virtual-build-machines/"
1674 (symbol->string
1675 (virtual-build-machine-name config))))
1676
1677(define (check-vm-availability config)
1678 "Return a Scheme file that evaluates to true if the service corresponding to
1679CONFIG, a <virtual-build-machine>, is up and running."
1680 (define service-name
1681 (virtual-build-machine-name config))
1682
1683 (scheme-file "check-build-vm-availability.scm"
1684 #~(begin
1685 (use-modules (gnu services herd)
1686 (srfi srfi-34))
1687
1688 (guard (c ((service-not-found-error? c) #f))
1689 (->bool (live-service-running
1690 (current-service '#$service-name)))))))
1691
1692(define (build-vm-guix-extension config)
1693 (define vm-ssh-key
1694 (string-append
1695 (virtual-build-machine-secret-root config)
1696 "/etc/ssh/ssh_host_ed25519_key.pub"))
1697
1698 (define host-ssh-key
1699 (virtual-build-machine-offloading-ssh-key config))
1700
1701 (guix-extension
1702 (build-machines
1703 (list #~(if (primitive-load #$(check-vm-availability config))
1704 (list (build-machine
1705 (name "localhost")
1706 (port #$(virtual-build-machine-ssh-port config))
1707 (systems
1708 '#$(virtual-build-machine-systems config))
1709 (user "offloading")
1710 (host-key (call-with-input-file #$vm-ssh-key
1711 (@ (ice-9 textual-ports)
1712 get-string-all)))
1713 (private-key #$host-ssh-key)))
1714 '())))))
1715
1716(define virtual-build-machine-service-type
1717 (service-type
1718 (name 'build-vm)
1719 (extensions (list (service-extension shepherd-root-service-type
1720 build-vm-shepherd-services)
1721 (service-extension guix-service-type
1722 build-vm-guix-extension)
1723 (service-extension account-service-type
1724 virtual-build-machine-accounts)
1725 (service-extension activation-service-type
1726 virtual-build-machine-activation)))
1727 (description
1728 "Create a @dfn{virtual build machine}: a virtual machine (VM) that builds
1729can be offloaded to. By default, the virtual machine starts with a clock
1730running at some point in the past.")
1731 (default-value (virtual-build-machine))))
1732
1733
1734;;;
1735;;; The Hurd in VM service: a Childhurd.
1736;;;
1737
1738(define (operating-system-with-offloading-account os)
1739 (define accounts
1740 (list (user-group
1741 (name "offloading")
1742 (system? #t))
1743 (user-account
1744 (name "offloading")
1745 (group "offloading")
1746 (system? #t)
1747 (comment "Offloading privilege separation user")
1748 (home-directory "/var/run/offloading")
1749 (shell (file-append bash-minimal "/bin/sh")))))
1750
1751 (operating-system
1752 (inherit os)
1753 (services (cons (simple-service 'offloading-account
1754 account-service-type
1755 accounts)
1756 (operating-system-user-services os)))))
1757
1758(define (operating-system-with-locked-root-account os)
1759 "Return OS with a 'root' account whose password is uninitialized, thereby
1760preventing password-based authentication as 'root'."
1761 (define root
1762 ;; %ROOT-ACCOUNT has an empty password; change that to an uninitialized
1763 ;; password.
1764 (user-account
1765 (inherit %root-account)
1766 (password #f)))
1767
1768 (operating-system
1769 (inherit os)
1770 (users (cons root (operating-system-users os)))))
1771
1772(define %hurd-vm-operating-system
1773 (operating-system
1774 (inherit %hurd-default-operating-system)
1775 (host-name "childhurd")
1776 (timezone "Europe/Amsterdam")
1777 (bootloader (bootloader-configuration
1778 (bootloader grub-minimal-bootloader)
1779 (targets '("/dev/vda"))
1780 (timeout 0)))
1781 (packages (cons* gdb-minimal
1782 (operating-system-packages
1783 %hurd-default-operating-system)))
1784 (services (cons*
1785 (service openssh-service-type
1786 (openssh-configuration
1787 (openssh openssh-sans-x)
1788 (use-pam? #f)
1789 (permit-root-login 'prohibit-password)
1790 (allow-empty-passwords? #t)
1791 (password-authentication? #t)))
1792
1793 ;; By default, the secret service introduces a pre-initialized
1794 ;; /etc/guix/acl file in the childhurd. Thus, clear
1795 ;; 'authorize-key?' so that it's not overridden at activation
1796 ;; time.
1797 (modify-services %base-services+qemu-networking/hurd
1798 (guix-service-type config =>
1799 (guix-configuration
1800 (inherit config)
1801 (authorize-key? #f))))))))
1802
1803(define (sanitize-hurd-vm-configuration-type value)
1804 (unless (memq value '(hurd-qcow2 hurd64-qcow2))
1805 (leave (G_ "hurd-vm: '~a' is not a valid type~%") value))
1806 value)
1807
1808(define-record-type* <hurd-vm-configuration>
1809 hurd-vm-configuration make-hurd-vm-configuration
1810 hurd-vm-configuration?
1811 (os hurd-vm-configuration-os ;<operating-system>
1812 (default %hurd-vm-operating-system))
1813 (qemu hurd-vm-configuration-qemu ;file-like
1814 (default qemu-minimal))
1815 (type hurd-vm-configuration-type ;symbol
1816 (default 'hurd-qcow2)
1817 (sanitize sanitize-hurd-vm-configuration-type))
1818 (image hurd-vm-configuration-image ;<image>
1819 (thunked)
1820 (default (hurd-vm-disk-image this-record)))
1821 (disk-size hurd-vm-configuration-disk-size ;number or 'guess
1822 (default 'guess))
1823 (memory-size hurd-vm-configuration-memory-size ;number
1824 (default 2048))
1825 (options hurd-vm-configuration-options ;list of string
1826 (default `("--snapshot")))
1827 (id hurd-vm-configuration-id ;#f or integer [1..]
1828 (default #f))
1829 (net-options hurd-vm-configuration-net-options ;list of string
1830 (thunked)
1831 (default (hurd-vm-net-options this-record)))
1832 (offloading? hurd-vm-configuration-offloading? ;Boolean
1833 (default #t))
1834 (secret-root hurd-vm-configuration-secret-root ;string
1835 (default "/etc/childhurd")))
1836
1837(define (hurd-vm-disk-image config)
1838 "Return a disk-image for the Hurd according to CONFIG. The secret-service
1839is added to the OS specified in CONFIG."
1840 (define transform
1841 (compose secret-service-operating-system
1842 ;; When offloading is enabled, (1) add the 'offloading' account,
1843 ;; and (2) prevent users from logging in as 'root' without a
1844 ;; password as this would allow any user on the host to populate
1845 ;; the host's store indirectly (for example by logging in as root
1846 ;; in the Hurd VM over VNC).
1847 (if (hurd-vm-configuration-offloading? config)
1848 (compose operating-system-with-locked-root-account
1849 operating-system-with-offloading-account)
1850 identity)))
1851
1852 (let* ((os (transform (hurd-vm-configuration-os config)))
1853 (disk-size (hurd-vm-configuration-disk-size config))
1854 (type (lookup-image-type-by-name
1855 (hurd-vm-configuration-type config)))
1856 (os->image (image-type-constructor type)))
1857 (image (inherit (os->image os))
1858 (size disk-size))))
1859
1860(define (hurd-vm-port config base)
1861 "Return the forwarded vm port for this childhurd config."
1862 (let ((id (or (hurd-vm-configuration-id config) 0)))
1863 (+ base (* 1000 id))))
1864(define %hurd-vm-secrets-port 11004)
1865(define %hurd-vm-ssh-port 10022)
1866(define %hurd-vm-vnc-port 15900)
1867
1868(define (hurd-vm-net-options config)
1869 `("--device" "rtl8139,netdev=net0"
1870 "--netdev"
1871 ,(string-append "user,id=net0"
1872 ",hostfwd=tcp:127.0.0.1:"
1873 (number->string (hurd-vm-port config %hurd-vm-secrets-port))
1874 "-:1004"
1875 ",hostfwd=tcp:127.0.0.1:"
1876 (number->string (hurd-vm-port config %hurd-vm-ssh-port))
1877 "-:22"
1878 ",hostfwd=tcp:127.0.0.1:"
1879 (number->string (hurd-vm-port config %hurd-vm-vnc-port))
1880 "-:5900")))
1881
1882(define (hurd-vm-shepherd-service config)
1883 "Return a <shepherd-service> for a Hurd in a Virtual Machine with CONFIG."
1884
1885 (let ((image (hurd-vm-configuration-image config))
1886 (qemu (hurd-vm-configuration-qemu config))
1887 (memory-size (hurd-vm-configuration-memory-size config))
1888 (type (hurd-vm-configuration-type config))
1889 (options (hurd-vm-configuration-options config))
1890 (id (hurd-vm-configuration-id config))
1891 (net-options (hurd-vm-configuration-net-options config))
1892 (provisions '(hurd-vm childhurd)))
1893
1894 (define vm-command
1895 ;; XXX: Use the x86_64 emulator instead of the i386 one to work around
1896 ;; "Bad ram pointer" issues: <https://issues.guix.gnu.org/66053>.
1897
1898 ;; The default qemu machine has problems with high memory on x86_64-gnu
1899 ;; https://lists.gnu.org/archive/html/bug-hurd/2025-11/msg00025.html
1900 #~(append (list #$(file-append qemu "/bin/qemu-system-x86_64")
1901 "-m" (number->string #$memory-size)
1902 #$@(if (eq? type 'hurd64-qcow2)
1903 '("-M" "q35")
1904 '())
1905 #$@net-options
1906 #$@options
1907 "--hda" #+(if (image? image)
1908 (system-image image)
1909 image)
1910
1911 ;; Cause the service to be respawned if the guest
1912 ;; reboots (it can reboot for instance if it did not
1913 ;; receive valid secrets, or if it crashed.)
1914 "--no-reboot")
1915 (if (file-exists? "/dev/kvm")
1916 '("--enable-kvm")
1917 '())))
1918
1919 (list
1920 (shepherd-service
1921 (documentation "Run the Hurd in a Virtual Machine: a Childhurd.")
1922 (provision (if id
1923 (map
1924 (cute symbol-append <>
1925 (string->symbol (number->string id)))
1926 provisions)
1927 provisions))
1928 (requirement '(loopback networking user-processes))
1929 (start
1930 (with-imported-modules
1931 (source-module-closure '((gnu build secret-service)
1932 (guix build utils)))
1933 #~(lambda ()
1934 (let* ((pid (fork+exec-command #$vm-command
1935 #:user "childhurd"
1936 ;; XXX TODO: use "childhurd" after
1937 ;; updating Shepherd
1938 #:group "kvm"
1939 #:environment-variables
1940 ;; QEMU tries to write to /var/tmp
1941 ;; by default.
1942 '("TMPDIR=/tmp")))
1943 (port #$(hurd-vm-port config %hurd-vm-secrets-port))
1944 (root #$(hurd-vm-configuration-secret-root config))
1945 (address (make-socket-address AF_INET INADDR_LOOPBACK
1946 port)))
1947 (catch #t
1948 (lambda _
1949 ;; XXX: 'secret-service-send-secrets' won't complete until
1950 ;; the guest has booted and its secret service server is
1951 ;; running, which could take 20+ seconds during which PID 1
1952 ;; is stuck waiting.
1953 (if (secret-service-send-secrets address root)
1954 pid
1955 (begin
1956 (kill (- pid) SIGTERM)
1957 #f)))
1958 (lambda (key . args)
1959 (kill (- pid) SIGTERM)
1960 (apply throw key args)))))))
1961 (modules `((gnu build secret-service)
1962 (guix build utils)
1963 ,@%default-modules))
1964 (stop #~(make-kill-destructor))))))
1965
1966(define %hurd-vm-accounts
1967 (list (user-group (name "childhurd") (system? #t))
1968 (user-account
1969 (name "childhurd")
1970 (group "childhurd")
1971 (supplementary-groups '("kvm"))
1972 (comment "Privilege separation user for the childhurd")
1973 (home-directory "/var/empty")
1974 (shell (file-append shadow "/sbin/nologin"))
1975 (system? #t))))
1976
1977(define (hurd-vm-activation config)
1978 "Return a gexp to activate the Hurd VM according to CONFIG."
1979 (build-vm-activation (hurd-vm-configuration-secret-root config)
1980 #:offloading?
1981 (hurd-vm-configuration-offloading? config)
1982 #:offloading-ssh-key
1983 (hurd-vm-configuration-offloading-ssh-key config)))
1984
1985(define (hurd-vm-configuration-offloading-ssh-key config)
1986 "Return the name of the file containing the SSH key of user 'offloading'."
1987 (string-append "/etc/guix/offload/ssh/childhurd"
1988 (or (and=> (hurd-vm-configuration-id config)
1989 number->string)
1990 "")))
1991
1992(define (hurd-vm-guix-extension config)
1993 "When offloading is enabled, add this childhurd to the list of offlading
1994machines in /etc/guix/machines.scm."
1995 (if (hurd-vm-configuration-offloading? config)
1996 (let* ((image (hurd-vm-configuration-image config))
1997 (platform (image-platform image))
1998 (system (platform-system platform))
1999 (vm-ssh-key (string-append
2000 (hurd-vm-configuration-secret-root config)
2001 "/etc/ssh/ssh_host_ed25519_key.pub"))
2002 (host-ssh-key (hurd-vm-configuration-offloading-ssh-key config)))
2003 (guix-extension
2004 (build-machines
2005 (list #~(build-machine
2006 (name "localhost")
2007 (port #$(hurd-vm-port config %hurd-vm-ssh-port))
2008 (systems '(#$system))
2009 (host-key (call-with-input-file #$vm-ssh-key
2010 (@ (ice-9 textual-ports)
2011 get-string-all)))
2012 (user "offloading")
2013 (overload-threshold 1.8) ;current load reporting is off by 1
2014 (private-key #$host-ssh-key))))))
2015 (guix-extension)))
2016
2017(define hurd-vm-service-type
2018 (service-type
2019 (name 'hurd-vm)
2020 (extensions (list (service-extension shepherd-root-service-type
2021 hurd-vm-shepherd-service)
2022 (service-extension account-service-type
2023 (const %hurd-vm-accounts))
2024 (service-extension guix-service-type
2025 hurd-vm-guix-extension)
2026 (service-extension activation-service-type
2027 hurd-vm-activation)))
2028 (default-value (hurd-vm-configuration))
2029 (description
2030 "Provide a virtual machine (VM) running GNU/Hurd, also known as a
2031@dfn{childhurd}.")))