aboutsummaryrefslogtreecommitdiff
path: root/gnu/services
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/services')
-rw-r--r--gnu/services/audio.scm7
-rw-r--r--gnu/services/base.scm58
-rw-r--r--gnu/services/configuration.scm81
-rw-r--r--gnu/services/cuirass.scm8
-rw-r--r--gnu/services/linux.scm11
-rw-r--r--gnu/services/mcron.scm2
-rw-r--r--gnu/services/telephony.scm49
-rw-r--r--gnu/services/virtualization.scm173
8 files changed, 314 insertions, 75 deletions
diff --git a/gnu/services/audio.scm b/gnu/services/audio.scm
index 260abdefed..ae991ced4d 100644
--- a/gnu/services/audio.scm
+++ b/gnu/services/audio.scm
@@ -138,9 +138,6 @@
str)
#\-) "_")))
-(define list-of-symbol?
- (list-of symbol?))
-
;; Helpers for deprecated field types, to be removed later.
(define %lazy-group (make-symbol "%lazy-group"))
@@ -428,7 +425,7 @@ to be appended to the audio output configuration.")
(sanitizer mpd-group-sanitizer))
(shepherd-requirement
- (list-of-symbol '())
+ (list-of-symbols '())
"This is a list of symbols naming Shepherd services that this service
will depend on."
empty-serializer)
@@ -763,7 +760,7 @@ user-group instead~%"))
empty-serializer)
(shepherd-requirement
- (list-of-symbol '())
+ (list-of-symbols '())
"This is a list of symbols naming Shepherd services that this service
will depend on."
empty-serializer)
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index b3f2d2e8b8..98d59fd36d 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -62,8 +62,9 @@
util-linux xfsprogs))
#:use-module (gnu packages bash)
#:use-module ((gnu packages base)
- #:select (coreutils glibc glibc-utf8-locales tar
- canonical-package))
+ #:select (coreutils glibc glibc/hurd
+ glibc-utf8-locales make-glibc-utf8-locales
+ tar canonical-package))
#:use-module ((gnu packages compression) #:select (gzip))
#:use-module (gnu packages fonts)
#:autoload (gnu packages guile-xyz) (guile-netlink)
@@ -87,6 +88,7 @@
#:use-module ((guix self) #:select (make-config.scm))
#:use-module (guix diagnostics)
#:use-module (guix i18n)
+ #:autoload (guix utils) (target-hurd?)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
@@ -1741,6 +1743,31 @@ archive' public keys, with GUIX."
(list (file-append guix "/share/guix/berlin.guix.gnu.org.pub")
(file-append guix "/share/guix/bordeaux.guix.gnu.org.pub")))
+(define (guix-machines-files-installation machines)
+ "Return a gexp to install MACHINES, a list of gexps, as
+/etc/guix/machines.scm, which is used for offloading."
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils))
+
+ (define machines-file
+ "/etc/guix/machines.scm")
+
+ ;; If MACHINES-FILE already exists, move it out of the way.
+ ;; Create a backup if it's a regular file: it's likely that the
+ ;; user manually updated it.
+ (if (file-exists? machines-file)
+ (if (and (symbolic-link? machines-file)
+ (store-file-name? (readlink machines-file)))
+ (delete-file machines-file)
+ (rename-file machines-file
+ (string-append machines-file ".bak")))
+ (mkdir-p (dirname machines-file)))
+
+ ;; Installed the declared machines file.
+ (symlink #+(scheme-file "machines.scm" machines)
+ machines-file))))
+
(define-record-type* <guix-configuration>
guix-configuration make-guix-configuration
guix-configuration?
@@ -1778,6 +1805,8 @@ archive' public keys, with GUIX."
(default #f))
(tmpdir guix-tmpdir ;string | #f
(default #f))
+ (build-machines guix-build-machines ;list of gexps | #f
+ (default #f))
(environment guix-configuration-environment ;list of strings
(default '())))
@@ -1831,6 +1860,12 @@ proxy of 'guix-daemon'...~%")
(define (guix-shepherd-service config)
"Return a <shepherd-service> for the Guix daemon service with CONFIG."
+ (define locales
+ (let-system (system target)
+ (if (target-hurd? (or target system))
+ (make-glibc-utf8-locales glibc/hurd)
+ glibc-utf8-locales)))
+
(match-record config <guix-configuration>
(guix build-group build-accounts authorize-key? authorized-keys
use-substitutes? substitute-urls max-silent-time timeout
@@ -1912,8 +1947,7 @@ proxy of 'guix-daemon'...~%")
;; 'nss-certs'. See
;; <https://bugs.gnu.org/32942>.
(string-append "GUIX_LOCPATH="
- #$glibc-utf8-locales
- "/lib/locale")
+ #$locales "/lib/locale")
"LC_ALL=en_US.utf8"
;; Make 'tar' and 'gzip' available so
;; that 'guix perform-download' can use
@@ -1958,8 +1992,15 @@ proxy of 'guix-daemon'...~%")
(system* #$(file-append guix "/bin/guix") "archive"
"--generate-key"))
+ ;; Optionally install /etc/guix/acl...
#$(if authorize-key?
(substitute-key-authorization authorized-keys guix)
+ #~#f)
+
+ ;; ... and /etc/guix/machines.scm.
+ #$(if (guix-build-machines config)
+ (guix-machines-files-installation
+ #~(list #$@(guix-build-machines config)))
#~#f))))
(define-record-type* <guix-extension>
@@ -1969,6 +2010,8 @@ proxy of 'guix-daemon'...~%")
(default '()))
(substitute-urls guix-extension-substitute-urls ;list of strings
(default '()))
+ (build-machines guix-extension-build-machines ;list of gexps
+ (default '()))
(chroot-directories guix-extension-chroot-directories ;list of file-like/strings
(default '())))
@@ -1978,6 +2021,8 @@ proxy of 'guix-daemon'...~%")
(guix-extension-authorized-keys b)))
(substitute-urls (append (guix-extension-substitute-urls a)
(guix-extension-substitute-urls b)))
+ (build-machines (append (guix-extension-build-machines a)
+ (guix-extension-build-machines b)))
(chroot-directories (append (guix-extension-chroot-directories a)
(guix-extension-chroot-directories b)))))
@@ -2001,6 +2046,11 @@ proxy of 'guix-daemon'...~%")
(guix-configuration-authorized-keys config)))
(substitute-urls (append (guix-extension-substitute-urls extension)
(guix-configuration-substitute-urls config)))
+ (build-machines
+ (and (or (guix-build-machines config)
+ (pair? (guix-extension-build-machines extension)))
+ (append (or (guix-build-machines config) '())
+ (guix-extension-build-machines extension))))
(chroot-directories
(append (guix-extension-chroot-directories extension)
(guix-configuration-chroot-directories config))))))
diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm
index 367b85c1be..d2b1687496 100644
--- a/gnu/services/configuration.scm
+++ b/gnu/services/configuration.scm
@@ -42,6 +42,7 @@
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
+ #:use-module (srfi srfi-171)
#:export (configuration-field
configuration-field-name
configuration-field-type
@@ -59,6 +60,10 @@
define-configuration/no-serialization
no-serialization
+ empty-serializer?
+ tfilter-maybe-value
+ base-transducer
+
serialize-configuration
define-maybe
define-maybe/no-serialization
@@ -75,7 +80,9 @@
interpose
list-of
+ list-of-packages?
list-of-strings?
+ list-of-symbols?
alist?
serialize-file-like
text-config?
@@ -125,13 +132,36 @@ does not have a default value" field kind)))
(default-value-thunk configuration-field-default-value-thunk)
(documentation configuration-field-documentation))
+(define (empty-serializer? field)
+ "Predicate that checks whether FIELD is exempt from serialization."
+ (eq? empty-serializer
+ (configuration-field-serializer field)))
+
+(define (tfilter-maybe-value config)
+ "Return a transducer for CONFIG that removes all maybe-type fields whose
+value is '%unset-marker."
+ (tfilter (lambda (field)
+ (let ((field-value ((configuration-field-getter field) config)))
+ (maybe-value-set? field-value)))))
+
+(define (base-transducer config)
+ "Return a transducer for CONFIG that calls the serializing procedures only
+for fields marked for serialization and whose values are not '%unset-marker."
+ (compose (tremove empty-serializer?)
+ ;; Only serialize fields whose value isn't '%unset-marker%.
+ (tfilter-maybe-value config)
+ (tmap (lambda (field)
+ ((configuration-field-serializer field)
+ (configuration-field-name field)
+ ((configuration-field-getter field) config))))))
+
(define (serialize-configuration config fields)
+ "Return a G-expression that contains the values corresponding to the
+FIELDS of CONFIG, a record that has been generated by `define-configuration'.
+The G-expression can then be serialized to disk by using something like
+`mixed-text-file'."
#~(string-append
- #$@(map (lambda (field)
- ((configuration-field-serializer field)
- (configuration-field-name field)
- ((configuration-field-getter field) config)))
- fields)))
+ #$@(list-transduce (base-transducer config) rcons fields)))
(define-syntax-rule (id ctx parts ...)
"Assemble PARTS into a raw (unhygienic) identifier."
@@ -190,32 +220,32 @@ does not have a default value" field kind)))
(define (normalize-extra-args s)
"Extract and normalize arguments following @var{doc}."
(let loop ((s s)
- (sanitizer* %unset-value)
- (serializer* %unset-value))
+ (sanitizer* #f)
+ (serializer* #f))
(syntax-case s (sanitizer serializer empty-serializer)
(((sanitizer proc) tail ...)
- (if (maybe-value-set? sanitizer*)
- (syntax-violation 'sanitizer "duplicate entry"
- #'proc)
+ (if sanitizer*
+ (syntax-violation 'sanitizer
+ "duplicate entry" #'proc)
(loop #'(tail ...) #'proc serializer*)))
(((serializer proc) tail ...)
- (if (maybe-value-set? serializer*)
- (syntax-violation 'serializer "duplicate or conflicting entry"
- #'proc)
+ (if serializer*
+ (syntax-violation 'serializer
+ "duplicate or conflicting entry" #'proc)
(loop #'(tail ...) sanitizer* #'proc)))
((empty-serializer tail ...)
- (if (maybe-value-set? serializer*)
+ (if serializer*
(syntax-violation 'empty-serializer
"duplicate or conflicting entry" #f)
(loop #'(tail ...) sanitizer* #'empty-serializer)))
(() ; stop condition
(values (list sanitizer* serializer*)))
((proc) ; TODO: deprecated, to be removed.
- (null? (filter-map maybe-value-set? (list sanitizer* serializer*)))
+ (not (or sanitizer* serializer*))
(begin
(warning #f (G_ "specifying serializers after documentation is \
deprecated, use (serializer ~a) instead~%") (syntax->datum #'proc))
- (values (list %unset-value #'proc)))))))
+ (values (list #f #'proc)))))))
(syntax-case syn ()
((_ stem (field field-type+def doc extra-args ...) ...)
@@ -239,11 +269,11 @@ deprecated, use (serializer ~a) instead~%") (syntax->datum #'proc))
default-value))
#'((field-type def) ...)))
((field-sanitizer ...)
- (map maybe-value #'(sanitizer* ...)))
+ #'(sanitizer* ...))
((field-serializer ...)
(map (lambda (type proc)
(and serialize?
- (or (maybe-value proc)
+ (or proc
(if serializer-prefix
(id #'stem serializer-prefix #'serialize- type)
(id #'stem #'serialize- type)))))
@@ -472,6 +502,11 @@ DELIMITER interposed LS. Support 'infix and 'suffix GRAMMAR values."
(cons delimiter acc))))
'() ls))
+
+;;;
+;;; Commonly used predicates
+;;;
+
(define (list-of pred?)
"Return a procedure that takes a list and check if all the elements of
the list result in @code{#t} when applying PRED? on them."
@@ -480,10 +515,20 @@ the list result in @code{#t} when applying PRED? on them."
(every pred? x)
#f)))
+(define list-of-packages?
+ (list-of package?))
(define list-of-strings?
(list-of string?))
+(define list-of-symbols?
+ (list-of symbol?))
+
+
+;;;
+;;; Special serializers
+;;;
+
(define alist?
(list-of pair?))
diff --git a/gnu/services/cuirass.scm b/gnu/services/cuirass.scm
index 43b0e0946e..71787a85e6 100644
--- a/gnu/services/cuirass.scm
+++ b/gnu/services/cuirass.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
-;;; Copyright © 2016-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016-2023 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
@@ -274,6 +274,9 @@
(cuirass-remote-server-configuration-cache
remote-server)))
(user (cuirass-configuration-user config))
+ ;; RUNSTATEDIR contains the "bridge" Unix-domain socket that 'cuirass
+ ;; web' connects to to communicate with 'cuirass register'.
+ (runstatedir "/var/run/cuirass")
(log "/var/log/cuirass")
(profile (string-append "/var/guix/profiles/per-user/" user))
(roots (string-append profile "/cuirass"))
@@ -285,6 +288,7 @@
(mkdir-p #$cache)
(mkdir-p #$log)
(mkdir-p #$roots)
+ (mkdir-p #$runstatedir)
(when #$remote-cache
(mkdir-p #$remote-cache))
@@ -295,6 +299,8 @@
(chown #$log uid gid)
(chown #$roots uid gid)
(chown #$profile uid gid)
+ (chown #$runstatedir uid gid)
+ (chmod #$runstatedir #o700)
(when #$remote-cache
(chown #$remote-cache uid gid)))))))
diff --git a/gnu/services/linux.scm b/gnu/services/linux.scm
index 1f01b39a21..9ee0d93030 100644
--- a/gnu/services/linux.scm
+++ b/gnu/services/linux.scm
@@ -41,6 +41,7 @@
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
+ #:use-module (srfi srfi-171)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:export (earlyoom-configuration
@@ -252,13 +253,9 @@ more information)."
(prefix fstrim-))
(define (serialize-fstrim-configuration config)
- (concatenate
- (filter list?
- (map (lambda (field)
- ((configuration-field-serializer field)
- (configuration-field-name field)
- ((configuration-field-getter field) config)))
- fstrim-configuration-fields))))
+ (list-transduce (compose (base-transducer config) tconcatenate)
+ rcons
+ fstrim-configuration-fields))
(define (fstrim-mcron-job config)
(match-record config <fstrim-configuration> (package schedule)
diff --git a/gnu/services/mcron.scm b/gnu/services/mcron.scm
index cea68beef8..e907d364da 100644
--- a/gnu/services/mcron.scm
+++ b/gnu/services/mcron.scm
@@ -165,7 +165,7 @@ files."
(ice-9 popen) ;for the 'schedule' action
(ice-9 rdelim)
(ice-9 match)
- ((shepherd support) #:select (%user-log-dir))
+ ((shepherd support) #:hide (mkdir-p)) ;for '%user-log-dir'
,@%default-modules))
(start #~(make-forkexec-constructor
(list #$(file-append mcron "/bin/mcron")
diff --git a/gnu/services/telephony.scm b/gnu/services/telephony.scm
index 23ccb8d403..c9b5d6cd99 100644
--- a/gnu/services/telephony.scm
+++ b/gnu/services/telephony.scm
@@ -37,6 +37,7 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-2)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-171)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:export (jami-account
@@ -116,15 +117,10 @@
(or (string? val)
(computed-file? val)))
-(define (string-list? val)
- (and (list? val)
- (and-map string? val)))
+(define account-fingerprint-list?
+ (list-of account-fingerprint?))
-(define (account-fingerprint-list? val)
- (and (list? val)
- (and-map account-fingerprint? val)))
-
-(define-maybe string-list)
+(define-maybe list-of-strings)
(define-maybe/no-serialization account-fingerprint-list)
@@ -134,7 +130,7 @@
;;; The following serializers are used to derive an account details alist from
;;; a <jami-account> record.
-(define (serialize-string-list _ val)
+(define (serialize-list-of-strings _ val)
(string-join val ";"))
(define (serialize-boolean _ val)
@@ -187,7 +183,7 @@ maintain communication between devices on such network even when the
connection to the the Internet has been lost. When left unspecified, the
value from the account archive prevails.")
(bootstrap-hostnames
- maybe-string-list
+ maybe-list-of-strings
"A list of hostnames or IPs pointing to OpenDHT nodes, that should be used
to initially join the OpenDHT network. When left unspecified, the value from
the account archive prevails.")
@@ -204,26 +200,23 @@ SET-ACCOUNT-DETAILS."
('rendezvous-point? "Account.rendezVous")
('peer-discovery? "Account.peerDiscovery")
('bootstrap-hostnames "Account.hostname")
- ('name-server-uri "RingNS.uri")
- (_ #f)))
+ ('name-server-uri "RingNS.uri")))
- (filter-map (lambda (field)
- (and-let* ((name (field-name->account-detail
+ (define jami-account-transducer
+ (compose (tremove empty-serializer?)
+ (tfilter-maybe-value jami-account-object)
+ (tmap (lambda (field)
+ (let* ((name (field-name->account-detail
(configuration-field-name field)))
- (value ((configuration-field-serializer field)
- name ((configuration-field-getter field)
- jami-account-object)))
- ;; The define-maybe default serializer produces an
- ;; empty string for unspecified values.
- (value* (if (string-null? value)
- #f
- value)))
- (cons name value*)))
- jami-account-fields))
-
-(define (jami-account-list? val)
- (and (list? val)
- (and-map jami-account? val)))
+ (value ((configuration-field-serializer field)
+ name ((configuration-field-getter field)
+ jami-account-object))))
+ (cons name value))))))
+
+ (list-transduce jami-account-transducer rcons jami-account-fields))
+
+(define jami-account-list?
+ (list-of jami-account?))
(define-maybe/no-serialization jami-account-list)
diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm
index e1a206e0eb..f0f0ab3bf1 100644
--- a/gnu/services/virtualization.scm
+++ b/gnu/services/virtualization.scm
@@ -27,7 +27,9 @@
#:use-module (gnu bootloader grub)
#:use-module (gnu image)
#:use-module (gnu packages admin)
+ #:use-module (gnu packages bash)
#:use-module (gnu packages gdb)
+ #:autoload (gnu packages gnupg) (guile-gcrypt)
#:use-module (gnu packages package-management)
#:use-module (gnu packages ssh)
#:use-module (gnu packages virtualization)
@@ -50,6 +52,8 @@
#:use-module (guix records)
#:use-module (guix store)
#:use-module (guix utils)
+ #:autoload (guix self) (make-config.scm)
+ #:autoload (guix platform) (platform-system)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
@@ -1061,6 +1065,40 @@ that will be listening to receive secret keys on port 1004, TCP."
;;; The Hurd in VM service: a Childhurd.
;;;
+(define (operating-system-with-offloading-account os)
+ (define accounts
+ (list (user-group
+ (name "offloading")
+ (system? #t))
+ (user-account
+ (name "offloading")
+ (group "offloading")
+ (system? #t)
+ (comment "Offloading privilege separation user")
+ (home-directory "/var/run/offloading")
+ (shell (file-append bash-minimal "/bin/sh")))))
+
+ (operating-system
+ (inherit os)
+ (services (cons (simple-service 'offloading-account
+ account-service-type
+ accounts)
+ (operating-system-user-services os)))))
+
+(define (operating-system-with-locked-root-account os)
+ "Return OS with a 'root' account whose password is uninitialized, thereby
+preventing password-based authentication as 'root'."
+ (define root
+ ;; %ROOT-ACCOUNT has an empty password; change that to an uninitialized
+ ;; password.
+ (user-account
+ (inherit %root-account)
+ (password #f)))
+
+ (operating-system
+ (inherit os)
+ (users (cons root (operating-system-users os)))))
+
(define %hurd-vm-operating-system
(operating-system
(inherit %hurd-default-operating-system)
@@ -1078,8 +1116,7 @@ that will be listening to receive secret keys on port 1004, TCP."
(openssh-configuration
(openssh openssh-sans-x)
(use-pam? #f)
- (port-number 2222)
- (permit-root-login #t)
+ (permit-root-login 'prohibit-password)
(allow-empty-passwords? #t)
(password-authentication? #t)))
@@ -1100,7 +1137,7 @@ that will be listening to receive secret keys on port 1004, TCP."
(default %hurd-vm-operating-system))
(qemu hurd-vm-configuration-qemu ;file-like
(default qemu-minimal))
- (image hurd-vm-configuration-image ;string
+ (image hurd-vm-configuration-image ;<image>
(thunked)
(default (hurd-vm-disk-image this-record)))
(disk-size hurd-vm-configuration-disk-size ;number or 'guess
@@ -1114,20 +1151,32 @@ that will be listening to receive secret keys on port 1004, TCP."
(net-options hurd-vm-configuration-net-options ;list of string
(thunked)
(default (hurd-vm-net-options this-record)))
+ (offloading? hurd-vm-configuration-offloading? ;Boolean
+ (default #t))
(secret-root hurd-vm-configuration-secret-root ;string
(default "/etc/childhurd")))
(define (hurd-vm-disk-image config)
"Return a disk-image for the Hurd according to CONFIG. The secret-service
is added to the OS specified in CONFIG."
- (let* ((os (secret-service-operating-system
- (hurd-vm-configuration-os config)))
+ (define transform
+ (compose secret-service-operating-system
+ ;; When offloading is enabled, (1) add the 'offloading' account,
+ ;; and (2) prevent users from logging in as 'root' without a
+ ;; password as this would allow any user on the host to populate
+ ;; the host's store indirectly (for example by logging in as root
+ ;; in the Hurd VM over VNC).
+ (if (hurd-vm-configuration-offloading? config)
+ (compose operating-system-with-locked-root-account
+ operating-system-with-offloading-account)
+ identity)))
+
+ (let* ((os (transform (hurd-vm-configuration-os config)))
(disk-size (hurd-vm-configuration-disk-size config))
(type (lookup-image-type-by-name 'hurd-qcow2))
(os->image (image-type-constructor type)))
- (system-image
- (image (inherit (os->image os))
- (size disk-size)))))
+ (image (inherit (os->image os))
+ (size disk-size))))
(define (hurd-vm-port config base)
"Return the forwarded vm port for this childhurd config."
@@ -1146,7 +1195,7 @@ is added to the OS specified in CONFIG."
"-:1004"
",hostfwd=tcp:127.0.0.1:"
(number->string (hurd-vm-port config %hurd-vm-ssh-port))
- "-:2222"
+ "-:22"
",hostfwd=tcp:127.0.0.1:"
(number->string (hurd-vm-port config %hurd-vm-vnc-port))
"-:5900")))
@@ -1169,7 +1218,7 @@ is added to the OS specified in CONFIG."
"-m" (number->string #$memory-size)
#$@net-options
#$@options
- "--hda" #+image
+ "--hda" #+(system-image image)
;; Cause the service to be respawned if the guest
;; reboots (it can reboot for instance if it did not
@@ -1272,6 +1321,50 @@ is added to the OS specified in CONFIG."
(program-file "initialize-hurd-vm-substitutes" run))
+(define (authorize-guest-substitutes-on-host)
+ "Return a program that authorizes the guest's archive signing key (passed as
+an argument) on the host."
+ (define not-config?
+ (match-lambda
+ ('(guix config) #f)
+ (('guix _ ...) #t)
+ (('gnu _ ...) #t)
+ (_ #f)))
+
+ (define run
+ (with-extensions (list guile-gcrypt)
+ (with-imported-modules `(((guix config) => ,(make-config.scm))
+ ,@(source-module-closure
+ '((guix pki)
+ (guix build utils))
+ #:select? not-config?))
+ #~(begin
+ (use-modules (ice-9 match)
+ (ice-9 textual-ports)
+ (gcrypt pk-crypto)
+ (guix pki)
+ (guix build utils))
+
+ (match (command-line)
+ ((_ guest-config-directory)
+ (let ((guest-key (string-append guest-config-directory
+ "/signing-key.pub")))
+ (if (file-exists? guest-key)
+ ;; Add guest key to the host's ACL.
+ (let* ((key (string->canonical-sexp
+ (call-with-input-file guest-key
+ get-string-all)))
+ (acl (public-keys->acl
+ (cons key (acl->public-keys (current-acl))))))
+ (with-atomic-file-replacement %acl-file
+ (lambda (_ port)
+ (write-acl acl port))))
+ (format (current-error-port)
+ "warning: guest key missing from '~a'~%"
+ guest-key)))))))))
+
+ (program-file "authorize-guest-substitutes-on-host" run))
+
(define (hurd-vm-activation config)
"Return a gexp to activate the Hurd VM according to CONFIG."
(with-imported-modules '((guix build utils))
@@ -1287,15 +1380,71 @@ is added to the OS specified in CONFIG."
(define guix-directory
(string-append secret-directory "/etc/guix"))
+ (define offloading-ssh-key
+ #$(hurd-vm-configuration-offloading-ssh-key config))
+
(unless (file-exists? ssh-directory)
;; Generate SSH host keys under SSH-DIRECTORY.
(mkdir-p ssh-directory)
(invoke #$(file-append openssh "/bin/ssh-keygen")
"-A" "-f" secret-directory))
+ (unless (or (not #$(hurd-vm-configuration-offloading? config))
+ (file-exists? offloading-ssh-key))
+ ;; Generate a user SSH key pair for the host to use when offloading
+ ;; to the guest.
+ (mkdir-p (dirname offloading-ssh-key))
+ (invoke #$(file-append openssh "/bin/ssh-keygen")
+ "-t" "ed25519" "-N" ""
+ "-f" offloading-ssh-key)
+
+ ;; Authorize it in the guest for user 'offloading'.
+ (let ((authorizations
+ (string-append ssh-directory
+ "/authorized_keys.d/offloading")))
+ (mkdir-p (dirname authorizations))
+ (copy-file (string-append offloading-ssh-key ".pub")
+ authorizations)
+ (chmod (dirname authorizations) #o555)))
+
(unless (file-exists? guix-directory)
(invoke #$(initialize-hurd-vm-substitutes)
- guix-directory)))))
+ guix-directory))
+
+ (when #$(hurd-vm-configuration-offloading? config)
+ ;; Authorize the archive signing key from GUIX-DIRECTORY in the host.
+ (invoke #$(authorize-guest-substitutes-on-host) guix-directory)))))
+
+(define (hurd-vm-configuration-offloading-ssh-key config)
+ "Return the name of the file containing the SSH key of user 'offloading'."
+ (string-append "/etc/guix/offload/ssh/childhurd"
+ (or (and=> (hurd-vm-configuration-id config)
+ number->string)
+ "")))
+
+(define (hurd-vm-guix-extension config)
+ "When offloading is enabled, add this childhurd to the list of offlading
+machines in /etc/guix/machines.scm."
+ (if (hurd-vm-configuration-offloading? config)
+ (let* ((image (hurd-vm-configuration-image config))
+ (platform (image-platform image))
+ (system (platform-system platform))
+ (vm-ssh-key (string-append
+ (hurd-vm-configuration-secret-root config)
+ "/etc/ssh/ssh_host_ed25519_key.pub"))
+ (host-ssh-key (hurd-vm-configuration-offloading-ssh-key config)))
+ (guix-extension
+ (build-machines
+ (list #~(build-machine
+ (name "localhost")
+ (port #$(hurd-vm-port config %hurd-vm-ssh-port))
+ (systems '(#$system))
+ (host-key (call-with-input-file #$vm-ssh-key
+ (@ (ice-9 textual-ports)
+ get-string-all)))
+ (user "offloading")
+ (private-key #$host-ssh-key))))))
+ (guix-extension)))
(define hurd-vm-service-type
(service-type
@@ -1304,6 +1453,8 @@ is added to the OS specified in CONFIG."
hurd-vm-shepherd-service)
(service-extension account-service-type
(const %hurd-vm-accounts))
+ (service-extension guix-service-type
+ hurd-vm-guix-extension)
(service-extension activation-service-type
hurd-vm-activation)))
(default-value (hurd-vm-configuration))
generated by cgit v1.2.3 (git 2.45.0) at 2024-11-23 21:20:03 +0000