projects/guix·blob master · refs

2114 lines · 86.6 KiB

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