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