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