diff options
Diffstat (limited to 'gnu/services')
32 files changed, 2709 insertions, 1511 deletions
diff --git a/gnu/services/admin.scm b/gnu/services/admin.scm index 252bedb0bd..1c10cfb1f6 100644 --- a/gnu/services/admin.scm +++ b/gnu/services/admin.scm @@ -1,7 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org> -;;; Copyright © 2016-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re> +;;; Copyright © 2023 Giacomo Leidi <goodoldpaul@autistici.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -58,6 +59,7 @@ unattended-upgrade-configuration unattended-upgrade-configuration? unattended-upgrade-configuration-operating-system-file + unattended-upgrade-configuration-operating-system-expression unattended-upgrade-configuration-channels unattended-upgrade-configuration-schedule unattended-upgrade-configuration-services-to-restart @@ -263,6 +265,8 @@ Old log files are removed or compressed according to the configuration.") unattended-upgrade-configuration? (operating-system-file unattended-upgrade-operating-system-file (default "/run/current-system/configuration.scm")) + (operating-system-expression unattended-upgrade-operating-system-expression + (default #f)) (schedule unattended-upgrade-configuration-schedule (default "30 01 * * 0")) (channels unattended-upgrade-configuration-channels @@ -296,6 +300,14 @@ Old log files are removed or compressed according to the configuration.") (define config-file (unattended-upgrade-operating-system-file config)) + (define expression + (unattended-upgrade-operating-system-expression config)) + + (define arguments + (if expression + #~(list "-e" (object->string '#$expression)) + #~(list #$config-file))) + (define code (with-imported-modules (source-module-closure '((guix build utils) (gnu services herd))) @@ -333,9 +345,9 @@ Old log files are removed or compressed according to the configuration.") (format #t "~a starting upgrade...~%" (timestamp)) (guard (c ((invoke-error? c) (report-invoke-error c))) - (invoke #$(file-append guix "/bin/guix") - "time-machine" "-C" #$channels - "--" "system" "reconfigure" #$config-file) + (apply invoke #$(file-append guix "/bin/guix") + "time-machine" "-C" #$channels + "--" "system" "reconfigure" #$arguments) ;; 'guix system delete-generations' fails when there's no ;; matching generation. Thus, catch 'invoke-error?'. diff --git a/gnu/services/avahi.scm b/gnu/services/avahi.scm index 3b8d0512c7..1c4220e490 100644 --- a/gnu/services/avahi.scm +++ b/gnu/services/avahi.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014-2020, 2022 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -137,7 +137,8 @@ #$@(if debug? #~("--debug") #~()) "-f" #$config) #:pid-file "/run/avahi-daemon/pid")) - (stop #~(make-kill-destructor)))))) + (stop #~(make-kill-destructor)) + (actions (list (shepherd-configuration-action config))))))) (define avahi-service-type (let ((avahi-package (compose list avahi-configuration-avahi))) diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 616bc42e69..9e799445d2 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -19,6 +19,7 @@ ;;; Copyright © 2021 muradm <mail@muradm.net> ;;; Copyright © 2022 Guillaume Le Vaillant <glv@posteo.net> ;;; Copyright © 2022 Justin Veilleux <terramorpha@cock.li> +;;; Copyright © 2022 ( <paren@disroot.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -55,17 +56,25 @@ #:select (file-system-packages)) #:use-module (gnu packages admin) #:use-module ((gnu packages linux) - #:select (alsa-utils crda eudev e2fsprogs fuse gpm kbd lvm2 rng-tools)) + #:select (alsa-utils btrfs-progs crda eudev + e2fsprogs f2fs-tools fuse gpm kbd lvm2 rng-tools + util-linux xfsprogs)) #:use-module (gnu packages bash) #:use-module ((gnu packages base) - #:select (coreutils glibc glibc-utf8-locales tar)) + #:select (coreutils glibc glibc-utf8-locales tar + canonical-package)) #:use-module ((gnu packages compression) #:select (gzip)) #:autoload (gnu packages guile-xyz) (guile-netlink) #:autoload (gnu packages hurd) (hurd) #:use-module (gnu packages package-management) #:use-module ((gnu packages gnupg) #:select (guile-gcrypt)) - #:use-module (gnu packages linux) + #:use-module ((gnu packages disk) + #:select (dosfstools)) + #:use-module ((gnu packages file-systems) + #:select (bcachefs-tools exfat-utils jfsutils zfs)) + #:use-module (gnu packages fonts) #:use-module (gnu packages terminals) + #:use-module ((gnu packages wm) #:select (sway)) #:use-module ((gnu build file-systems) #:select (mount-flags->bit-mask swap-space->flags-bit-mask)) @@ -86,6 +95,7 @@ #:export (fstab-service-type root-file-system-service file-system-service-type + file-system-utilities swap-service host-name-service %default-console-font @@ -188,6 +198,7 @@ guix-configuration-generate-substitute-key? guix-configuration-extra-options guix-configuration-log-file + guix-configuration-environment guix-extension guix-extension? @@ -231,6 +242,8 @@ greetd-configuration greetd-terminal-configuration greetd-agreety-session + greetd-wlgreet-session + greetd-wlgreet-sway-session %base-services)) @@ -488,6 +501,31 @@ upon boot." (memq 'bind-mount (file-system-flags file-system)))) file-systems)) +(define (file-system-type->utilities type) + "Return the package providing the utilities for file system TYPE, #f +otherwise." + (assoc-ref + `(("bcachefs" . ,bcachefs-tools) + ("btrfs" . ,btrfs-progs) + ("exfat" . ,exfat-utils) + ("ext2" . ,e2fsprogs) + ("ext3" . ,e2fsprogs) + ("ext4" . ,e2fsprogs) + ("fat" . ,dosfstools) + ("f2fs" . ,f2fs-tools) + ("jfs" . ,jfsutils) + ("vfat" . ,dosfstools) + ("xfs" . ,xfsprogs) + ("zfs" . ,zfs)) + type)) + +(define (file-system-utilities file-systems) + "Return a list of packages containing file system utilities for +FILE-SYSTEMS." + (filter-map (lambda (file-system) + (file-system-type->utilities (file-system-type file-system))) + file-systems)) + (define file-system-service-type (service-type (name 'file-systems) (extensions @@ -495,6 +533,8 @@ upon boot." file-system-shepherd-services) (service-extension fstab-service-type file-system-fstab-entries) + (service-extension profile-service-type + file-system-utilities) ;; Have 'user-processes' depend on 'file-systems'. (service-extension user-processes-service-type @@ -940,148 +980,148 @@ to use as the tty. This is primarily useful for headless systems." ((device-name _ ...) device-name)))))))) -(define agetty-shepherd-service - (match-lambda - (($ <agetty-configuration> agetty tty term baud-rate auto-login - login-program login-pause? eight-bits? no-reset? remote? flow-control? - host no-issue? init-string no-clear? local-line extract-baud? - skip-login? no-newline? login-options chroot hangup? keep-baud? timeout - detect-case? wait-cr? no-hints? no-hostname? long-hostname? - erase-characters kill-characters chdir delay nice extra-options - shepherd-requirement) - (list - (shepherd-service - (documentation "Run agetty on a tty.") - (provision (list (symbol-append 'term- (string->symbol (or tty "console"))))) - - ;; Since the login prompt shows the host name, wait for the 'host-name' - ;; service to be done. Also wait for udev essentially so that the tty - ;; text is not lost in the middle of kernel messages (see also - ;; mingetty-shepherd-service). - (requirement (cons* 'user-processes 'host-name 'udev - shepherd-requirement)) - - (modules '((ice-9 match) (gnu build linux-boot))) - (start - (with-imported-modules (source-module-closure - '((gnu build linux-boot))) - #~(lambda args - (let ((defaulted-tty #$(or tty (default-serial-port)))) - (apply - (if defaulted-tty - (make-forkexec-constructor - (list #$(file-append util-linux "/sbin/agetty") - #$@extra-options - #$@(if eight-bits? - #~("--8bits") - #~()) - #$@(if no-reset? - #~("--noreset") - #~()) - #$@(if remote? - #~("--remote") - #~()) - #$@(if flow-control? - #~("--flow-control") - #~()) - #$@(if host - #~("--host" #$host) - #~()) - #$@(if no-issue? - #~("--noissue") - #~()) - #$@(if init-string - #~("--init-string" #$init-string) - #~()) - #$@(if no-clear? - #~("--noclear") - #~()) +(define (agetty-shepherd-service config) + (match-record config <agetty-configuration> + (agetty tty term baud-rate auto-login + login-program login-pause? eight-bits? no-reset? remote? flow-control? + host no-issue? init-string no-clear? local-line extract-baud? + skip-login? no-newline? login-options chroot hangup? keep-baud? timeout + detect-case? wait-cr? no-hints? no-hostname? long-hostname? + erase-characters kill-characters chdir delay nice extra-options + shepherd-requirement) + (list + (shepherd-service + (documentation "Run agetty on a tty.") + (provision (list (symbol-append 'term- (string->symbol (or tty "console"))))) + + ;; Since the login prompt shows the host name, wait for the 'host-name' + ;; service to be done. Also wait for udev essentially so that the tty + ;; text is not lost in the middle of kernel messages (see also + ;; mingetty-shepherd-service). + (requirement (cons* 'user-processes 'host-name 'udev + shepherd-requirement)) + + (modules '((ice-9 match) (gnu build linux-boot))) + (start + (with-imported-modules (source-module-closure + '((gnu build linux-boot))) + #~(lambda args + (let ((defaulted-tty #$(or tty (default-serial-port)))) + (apply + (if defaulted-tty + (make-forkexec-constructor + (list #$(file-append util-linux "/sbin/agetty") + #$@extra-options + #$@(if eight-bits? + #~("--8bits") + #~()) + #$@(if no-reset? + #~("--noreset") + #~()) + #$@(if remote? + #~("--remote") + #~()) + #$@(if flow-control? + #~("--flow-control") + #~()) + #$@(if host + #~("--host" #$host) + #~()) + #$@(if no-issue? + #~("--noissue") + #~()) + #$@(if init-string + #~("--init-string" #$init-string) + #~()) + #$@(if no-clear? + #~("--noclear") + #~()) ;;; FIXME This doesn't work as expected. According to agetty(8), if this option ;;; is not passed, then the default is 'auto'. However, in my tests, when that ;;; option is selected, agetty never presents the login prompt, and the ;;; term-ttyS0 service respawns every few seconds. - #$@(if local-line - #~(#$(match local-line - ('auto "--local-line=auto") - ('always "--local-line=always") - ('never "-local-line=never"))) - #~()) - #$@(if tty - #~() - #~("--keep-baud")) - #$@(if extract-baud? - #~("--extract-baud") - #~()) - #$@(if skip-login? - #~("--skip-login") - #~()) - #$@(if no-newline? - #~("--nonewline") - #~()) - #$@(if login-options - #~("--login-options" #$login-options) - #~()) - #$@(if chroot - #~("--chroot" #$chroot) - #~()) - #$@(if hangup? - #~("--hangup") - #~()) - #$@(if keep-baud? - #~("--keep-baud") - #~()) - #$@(if timeout - #~("--timeout" #$(number->string timeout)) - #~()) - #$@(if detect-case? - #~("--detect-case") - #~()) - #$@(if wait-cr? - #~("--wait-cr") - #~()) - #$@(if no-hints? - #~("--nohints?") - #~()) - #$@(if no-hostname? - #~("--nohostname") - #~()) - #$@(if long-hostname? - #~("--long-hostname") - #~()) - #$@(if erase-characters - #~("--erase-chars" #$erase-characters) - #~()) - #$@(if kill-characters - #~("--kill-chars" #$kill-characters) - #~()) - #$@(if chdir - #~("--chdir" #$chdir) - #~()) - #$@(if delay - #~("--delay" #$(number->string delay)) - #~()) - #$@(if nice - #~("--nice" #$(number->string nice)) - #~()) - #$@(if auto-login - (list "--autologin" auto-login) - '()) - #$@(if login-program - #~("--login-program" #$login-program) - #~()) - #$@(if login-pause? - #~("--login-pause") - #~()) - defaulted-tty - #$@(if baud-rate - #~(#$baud-rate) - #~()) - #$@(if term - #~(#$term) - #~()))) - (const #f)) ; never start. - args))))) - (stop #~(make-kill-destructor))))))) + #$@(if local-line + #~(#$(match local-line + ('auto "--local-line=auto") + ('always "--local-line=always") + ('never "-local-line=never"))) + #~()) + #$@(if tty + #~() + #~("--keep-baud")) + #$@(if extract-baud? + #~("--extract-baud") + #~()) + #$@(if skip-login? + #~("--skip-login") + #~()) + #$@(if no-newline? + #~("--nonewline") + #~()) + #$@(if login-options + #~("--login-options" #$login-options) + #~()) + #$@(if chroot + #~("--chroot" #$chroot) + #~()) + #$@(if hangup? + #~("--hangup") + #~()) + #$@(if keep-baud? + #~("--keep-baud") + #~()) + #$@(if timeout + #~("--timeout" #$(number->string timeout)) + #~()) + #$@(if detect-case? + #~("--detect-case") + #~()) + #$@(if wait-cr? + #~("--wait-cr") + #~()) + #$@(if no-hints? + #~("--nohints?") + #~()) + #$@(if no-hostname? + #~("--nohostname") + #~()) + #$@(if long-hostname? + #~("--long-hostname") + #~()) + #$@(if erase-characters + #~("--erase-chars" #$erase-characters) + #~()) + #$@(if kill-characters + #~("--kill-chars" #$kill-characters) + #~()) + #$@(if chdir + #~("--chdir" #$chdir) + #~()) + #$@(if delay + #~("--delay" #$(number->string delay)) + #~()) + #$@(if nice + #~("--nice" #$(number->string nice)) + #~()) + #$@(if auto-login + (list "--autologin" auto-login) + '()) + #$@(if login-program + #~("--login-program" #$login-program) + #~()) + #$@(if login-pause? + #~("--login-pause") + #~()) + defaulted-tty + #$@(if baud-rate + #~(#$baud-rate) + #~()) + #$@(if term + #~(#$term) + #~()))) + (const #f)) ; never start. + args))))) + (stop #~(make-kill-destructor)))))) (define agetty-service-type (service-type (name 'agetty) @@ -1111,42 +1151,42 @@ the tty to run, among other things." (clear-on-logout? mingetty-clear-on-logout? ;Boolean (default #t))) -(define mingetty-shepherd-service - (match-lambda - (($ <mingetty-configuration> mingetty tty auto-login login-program - login-pause? clear-on-logout?) - (list - (shepherd-service - (documentation "Run mingetty on an tty.") - (provision (list (symbol-append 'term- (string->symbol tty)))) - - ;; Since the login prompt shows the host name, wait for the 'host-name' - ;; service to be done. Also wait for udev essentially so that the tty - ;; text is not lost in the middle of kernel messages (XXX). - (requirement '(user-processes host-name udev virtual-terminal)) - - (start #~(make-forkexec-constructor - (list #$(file-append mingetty "/sbin/mingetty") - - ;; Avoiding 'vhangup' allows us to avoid 'setfont' - ;; errors down the path where various ioctls get - ;; EIO--see 'hung_up_tty_ioctl' in driver/tty/tty_io.c - ;; in Linux. - "--nohangup" #$tty - - #$@(if clear-on-logout? - #~() - #~("--noclear")) - #$@(if auto-login - #~("--autologin" #$auto-login) - #~()) - #$@(if login-program - #~("--loginprog" #$login-program) - #~()) - #$@(if login-pause? - #~("--loginpause") - #~())))) - (stop #~(make-kill-destructor))))))) +(define (mingetty-shepherd-service config) + (match-record config <mingetty-configuration> + (mingetty tty auto-login login-program + login-pause? clear-on-logout?) + (list + (shepherd-service + (documentation "Run mingetty on an tty.") + (provision (list (symbol-append 'term- (string->symbol tty)))) + + ;; Since the login prompt shows the host name, wait for the 'host-name' + ;; service to be done. Also wait for udev essentially so that the tty + ;; text is not lost in the middle of kernel messages (XXX). + (requirement '(user-processes host-name udev virtual-terminal)) + + (start #~(make-forkexec-constructor + (list #$(file-append mingetty "/sbin/mingetty") + + ;; Avoiding 'vhangup' allows us to avoid 'setfont' + ;; errors down the path where various ioctls get + ;; EIO--see 'hung_up_tty_ioctl' in driver/tty/tty_io.c + ;; in Linux. + "--nohangup" #$tty + + #$@(if clear-on-logout? + #~() + #~("--noclear")) + #$@(if auto-login + #~("--autologin" #$auto-login) + #~()) + #$@(if login-program + #~("--loginprog" #$login-program) + #~()) + #$@(if login-pause? + #~("--loginpause") + #~())))) + (stop #~(make-kill-destructor)))))) (define mingetty-service-type (service-type (name 'mingetty) @@ -1174,7 +1214,13 @@ the tty to run, among other things." (name-services nscd-configuration-name-services ;list of file-like (default '())) (glibc nscd-configuration-glibc ;file-like - (default glibc))) + (default (let-system (system target) + ;; Unless we're cross-compiling, arrange to use nscd + ;; from 'glibc-final' instead of pulling in a second + ;; glibc copy. + (if target + glibc + (canonical-package glibc)))))) (define-record-type* <nscd-cache> nscd-cache make-nscd-cache nscd-cache? @@ -1223,46 +1269,47 @@ the tty to run, among other things." (define (nscd.conf-file config) "Return the @file{nscd.conf} configuration file for @var{config}, an @code{<nscd-configuration>} object." - (define cache->config - (match-lambda - (($ <nscd-cache> (= symbol->string database) - positive-ttl negative-ttl size check-files? - persistent? shared? max-size propagate?) - (string-append "\nenable-cache\t" database "\tyes\n" - - "positive-time-to-live\t" database "\t" - (number->string positive-ttl) "\n" - "negative-time-to-live\t" database "\t" - (number->string negative-ttl) "\n" - "suggested-size\t" database "\t" - (number->string size) "\n" - "check-files\t" database "\t" - (if check-files? "yes\n" "no\n") - "persistent\t" database "\t" - (if persistent? "yes\n" "no\n") - "shared\t" database "\t" - (if shared? "yes\n" "no\n") - "max-db-size\t" database "\t" - (number->string max-size) "\n" - "auto-propagate\t" database "\t" - (if propagate? "yes\n" "no\n"))))) - - (match config - (($ <nscd-configuration> log-file debug-level caches) - (plain-file "nscd.conf" - (string-append "\ + (define (cache->config cache) + (match-record cache <nscd-cache> + (database positive-time-to-live negative-time-to-live + suggested-size check-files? + persistent? shared? max-database-size auto-propagate?) + (let ((database (symbol->string database))) + (string-append "\nenable-cache\t" database "\tyes\n" + + "positive-time-to-live\t" database "\t" + (number->string positive-time-to-live) "\n" + "negative-time-to-live\t" database "\t" + (number->string negative-time-to-live) "\n" + "suggested-size\t" database "\t" + (number->string suggested-size) "\n" + "check-files\t" database "\t" + (if check-files? "yes\n" "no\n") + "persistent\t" database "\t" + (if persistent? "yes\n" "no\n") + "shared\t" database "\t" + (if shared? "yes\n" "no\n") + "max-db-size\t" database "\t" + (number->string max-database-size) "\n" + "auto-propagate\t" database "\t" + (if auto-propagate? "yes\n" "no\n"))))) + + (match-record config <nscd-configuration> + (log-file debug-level caches) + (plain-file "nscd.conf" + (string-append "\ # Configuration of libc's name service cache daemon (nscd).\n\n" - (if log-file - (string-append "logfile\t" log-file) - "") - "\n" - (if debug-level - (string-append "debug-level\t" - (number->string debug-level)) - "") - "\n" - (string-concatenate - (map cache->config caches))))))) + (if log-file + (string-append "logfile\t" log-file) + "") + "\n" + (if debug-level + (string-append "debug-level\t" + (number->string debug-level)) + "") + "\n" + (string-concatenate + (map cache->config caches)))))) (define (nscd-action-procedure nscd config option) ;; XXX: This is duplicated from mcron; factorize. @@ -1290,10 +1337,11 @@ the tty to run, among other things." (loop))))))) (define (nscd-actions nscd config) - "Return Shepherd actions for NSCD." + "Return Shepherd actions for NSCD using CONFIG its config file." ;; Make this functionality available as actions because that's a simple way ;; to run the right 'nscd' binary with the right config file. - (list (shepherd-action + (list (shepherd-configuration-action config) + (shepherd-action (name 'statistics) (documentation "Display statistics about nscd usage.") (procedure (nscd-action-procedure nscd config "--statistics"))) @@ -1607,7 +1655,9 @@ archive' public keys, with GUIX." (http-proxy guix-http-proxy ;string | #f (default #f)) (tmpdir guix-tmpdir ;string | #f - (default #f))) + (default #f)) + (environment guix-configuration-environment ;list of strings + (default '()))) (define %default-guix-configuration (guix-configuration)) @@ -1663,7 +1713,7 @@ proxy of 'guix-daemon'...~%") (guix build-group build-accounts authorize-key? authorized-keys use-substitutes? substitute-urls max-silent-time timeout log-compression discover? extra-options log-file - http-proxy tmpdir chroot-directories) + http-proxy tmpdir chroot-directories environment) (list (shepherd-service (documentation "Run the Guix daemon.") (provision '(guix-daemon)) @@ -1752,24 +1802,23 @@ proxy of 'guix-daemon'...~%") (if proxy (list (string-append "http_proxy=" proxy) (string-append "https_proxy=" proxy)) - '())) + '()) + '#$environment) #:log-file #$log-file)))) (stop #~(make-kill-destructor)))))) (define (guix-accounts config) "Return the user accounts and user groups for CONFIG." - (match config - (($ <guix-configuration> _ build-group build-accounts) - (cons (user-group - (name build-group) - (system? #t) - - ;; Use a fixed GID so that we can create the store with the right - ;; owner. - (id 30000)) - (guix-build-accounts build-accounts - #:group build-group))))) + (cons (user-group + (name (guix-configuration-build-group config)) + (system? #t) + + ;; Use a fixed GID so that we can create the store with the right + ;; owner. + (id 30000)) + (guix-build-accounts (guix-configuration-build-accounts config) + #:group (guix-configuration-build-group config)))) (define (guix-activation config) "Return the activation gexp for CONFIG." @@ -1979,7 +2028,9 @@ raise a deprecation warning if the 'compression-level' field was used." (define %guix-publish-log-rotations (list (log-rotation - (files (list "/var/log/guix-publish.log"))))) + (files (list "/var/log/guix-publish.log")) + (options `("rotate 4" ;don't keep too many of them + ,@%default-log-rotation-options))))) (define (guix-publish-activation config) (let ((cache (guix-publish-configuration-cache config))) @@ -2092,95 +2143,94 @@ item of @var{packages}." (udev-rule "90-kvm.rules" "KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n")) -(define udev-shepherd-service +(define (udev-shepherd-service config) ;; Return a <shepherd-service> for UDEV with RULES. - (match-lambda - (($ <udev-configuration> udev) - (list - (shepherd-service - (provision '(udev)) - - ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can - ;; be added: see - ;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>. - (requirement '(root-file-system)) - - (documentation "Populate the /dev directory, dynamically.") - (start - (with-imported-modules (source-module-closure - '((gnu build linux-boot))) - #~(lambda () - (define udevd - ;; 'udevd' from eudev. - #$(file-append udev "/sbin/udevd")) - - (define (wait-for-udevd) - ;; Wait until someone's listening on udevd's control - ;; socket. - (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0))) - (let try () - (catch 'system-error - (lambda () - (connect sock PF_UNIX "/run/udev/control") - (close-port sock)) - (lambda args - (format #t "waiting for udevd...~%") - (usleep 500000) - (try)))))) - - ;; Allow udev to find the modules. - (setenv "LINUX_MODULE_DIRECTORY" - "/run/booted-system/kernel/lib/modules") - - (let* ((kernel-release - (utsname:release (uname))) - (linux-module-directory - (getenv "LINUX_MODULE_DIRECTORY")) - (directory - (string-append linux-module-directory "/" - kernel-release)) - (old-umask (umask #o022))) - ;; If we're in a container, DIRECTORY might not exist, - ;; for instance because the host runs a different - ;; kernel. In that case, skip it; we'll just miss a few - ;; nodes like /dev/fuse. - (when (file-exists? directory) - (make-static-device-nodes directory)) - (umask old-umask)) - - (let ((pid (fork+exec-command - (list udevd) - #:environment-variables - (cons* - ;; The first one is for udev, the second one for - ;; eudev. - "UDEV_CONFIG_FILE=/etc/udev/udev.conf" - "EUDEV_RULES_DIRECTORY=/etc/udev/rules.d" - (string-append "LINUX_MODULE_DIRECTORY=" - (getenv "LINUX_MODULE_DIRECTORY")) - (default-environment-variables))))) - ;; Wait until udevd is up and running. This appears to - ;; be needed so that the events triggered below are - ;; actually handled. - (wait-for-udevd) - - ;; Trigger device node creation. - (system* #$(file-append udev "/bin/udevadm") - "trigger" "--action=add") - - ;; Wait for things to settle down. - (system* #$(file-append udev "/bin/udevadm") - "settle") - pid)))) - (stop #~(make-kill-destructor)) - - ;; When halting the system, 'udev' is actually killed by - ;; 'user-processes', i.e., before its own 'stop' method was called. - ;; Thus, make sure it is not respawned. - (respawn? #f) - ;; We need additional modules. - (modules `((gnu build linux-boot) ;'make-static-device-nodes' - ,@%default-modules))))))) + (let ((udev (udev-configuration-udev config))) + (list + (shepherd-service + (provision '(udev)) + + ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can + ;; be added: see + ;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>. + (requirement '(root-file-system)) + + (documentation "Populate the /dev directory, dynamically.") + (start + (with-imported-modules (source-module-closure + '((gnu build linux-boot))) + #~(lambda () + (define udevd + ;; 'udevd' from eudev. + #$(file-append udev "/sbin/udevd")) + + (define (wait-for-udevd) + ;; Wait until someone's listening on udevd's control + ;; socket. + (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0))) + (let try () + (catch 'system-error + (lambda () + (connect sock PF_UNIX "/run/udev/control") + (close-port sock)) + (lambda args + (format #t "waiting for udevd...~%") + (usleep 500000) + (try)))))) + + ;; Allow udev to find the modules. + (setenv "LINUX_MODULE_DIRECTORY" + "/run/booted-system/kernel/lib/modules") + + (let* ((kernel-release + (utsname:release (uname))) + (linux-module-directory + (getenv "LINUX_MODULE_DIRECTORY")) + (directory + (string-append linux-module-directory "/" + kernel-release)) + (old-umask (umask #o022))) + ;; If we're in a container, DIRECTORY might not exist, + ;; for instance because the host runs a different + ;; kernel. In that case, skip it; we'll just miss a few + ;; nodes like /dev/fuse. + (when (file-exists? directory) + (make-static-device-nodes directory)) + (umask old-umask)) + + (let ((pid (fork+exec-command + (list udevd) + #:environment-variables + (cons* + ;; The first one is for udev, the second one for + ;; eudev. + "UDEV_CONFIG_FILE=/etc/udev/udev.conf" + "EUDEV_RULES_DIRECTORY=/etc/udev/rules.d" + (string-append "LINUX_MODULE_DIRECTORY=" + (getenv "LINUX_MODULE_DIRECTORY")) + (default-environment-variables))))) + ;; Wait until udevd is up and running. This appears to + ;; be needed so that the events triggered below are + ;; actually handled. + (wait-for-udevd) + + ;; Trigger device node creation. + (system* #$(file-append udev "/bin/udevadm") + "trigger" "--action=add") + + ;; Wait for things to settle down. + (system* #$(file-append udev "/bin/udevadm") + "settle") + pid)))) + (stop #~(make-kill-destructor)) + + ;; When halting the system, 'udev' is actually killed by + ;; 'user-processes', i.e., before its own 'stop' method was called. + ;; Thus, make sure it is not respawned. + (respawn? #f) + ;; We need additional modules. + (modules `((gnu build linux-boot) ;'make-static-device-nodes' + ,@%default-modules)))))) (define udev.conf (computed-file "udev.conf" @@ -2188,14 +2238,15 @@ item of @var{packages}." (lambda (port) (format port "udev_rules=\"/etc/udev/rules.d\"~%"))))) -(define udev-etc - (match-lambda - (($ <udev-configuration> udev rules) - `(("udev" - ,(file-union - "udev" `(("udev.conf" ,udev.conf) - ("rules.d" ,(udev-rules-union (cons* udev kvm-udev-rule - rules)))))))))) +(define (udev-etc config) + (match-record config <udev-configuration> + (udev rules) + `(("udev" + ,(file-union "udev" + `(("udev.conf" ,udev.conf) + ("rules.d" + ,(udev-rules-union (cons* udev kvm-udev-rule + rules))))))))) (define udev-service-type (service-type (name 'udev) @@ -2205,11 +2256,11 @@ item of @var{packages}." (service-extension etc-service-type udev-etc))) (compose concatenate) ;concatenate the list of rules (extend (lambda (config rules) - (match config - (($ <udev-configuration> udev initial-rules) - (udev-configuration - (udev udev) - (rules (append initial-rules rules))))))) + (let ((initial-rules + (udev-configuration-rules config))) + (udev-configuration + (inherit config) + (rules (append initial-rules rules)))))) (default-value (udev-configuration)) (description "Run @command{udev}, which populates the @file{/dev} @@ -2347,23 +2398,23 @@ instance." (options gpm-configuration-options ;list of strings (default %default-gpm-options))) -(define gpm-shepherd-service - (match-lambda - (($ <gpm-configuration> gpm options) - (list (shepherd-service - (requirement '(udev)) - (provision '(gpm)) - ;; 'gpm' runs in the background and sets a PID file. - ;; Note that it requires running as "root". - (start #~(make-forkexec-constructor - (list #$(file-append gpm "/sbin/gpm") - #$@options) - #:pid-file "/var/run/gpm.pid" - #:pid-file-timeout 3)) - (stop #~(lambda (_) - ;; Return #f if successfully stopped. - (not (zero? (system* #$(file-append gpm "/sbin/gpm") - "-k")))))))))) +(define (gpm-shepherd-service config) + (match-record config <gpm-configuration> + (gpm options) + (list (shepherd-service + (requirement '(udev)) + (provision '(gpm)) + ;; 'gpm' runs in the background and sets a PID file. + ;; Note that it requires running as "root". + (start #~(make-forkexec-constructor + (list #$(file-append gpm "/sbin/gpm") + #$@options) + #:pid-file "/var/run/gpm.pid" + #:pid-file-timeout 3)) + (stop #~(lambda (_) + ;; Return #f if successfully stopped. + (not (zero? (system* #$(file-append gpm "/sbin/gpm") + "-k"))))))))) (define gpm-service-type (service-type (name 'gpm) @@ -2443,7 +2494,15 @@ notably to select, copy, and paste text. The default options use the (documentation "kmscon virtual terminal") (requirement '(user-processes udev dbus-system)) (provision (list (symbol-append 'term- (string->symbol virtual-terminal)))) - (start #~(make-forkexec-constructor #$kmscon-command)) + (start #~(make-forkexec-constructor + #$kmscon-command + + ;; The installer needs to be able to display glyphs from + ;; various scripts, so give it access to unifont. + ;; TODO: Make this configurable. + #:environment-variables + (list (string-append "XDG_DATA_DIRS=" + #$font-gnu-unifont "/share")))) (stop #~(make-kill-destructor))))) (description "Start the @command{kmscon} virtual terminal emulator for the Linux @dfn{kernel mode setting} (KMS)."))) @@ -2616,32 +2675,64 @@ to CONFIG." "/servers/socket/2") #f)))) -(define network-set-up/linux - (match-lambda - (($ <static-networking> addresses links routes) - (scheme-file "set-up-network" - (with-extensions (list guile-netlink) - #~(begin - (use-modules (ip addr) (ip link) (ip route)) - - #$@(map (lambda (address) - #~(begin - (addr-add #$(network-address-device address) - #$(network-address-value address) - #:ipv6? - #$(network-address-ipv6? address)) - ;; FIXME: loopback? - (link-set #$(network-address-device address) - #:multicast-on #t - #:up #t))) - addresses) - #$@(map (match-lambda - (($ <network-link> name type arguments) - #~(link-add #$name #$type - #:type-args '#$arguments))) - links) - #$@(map (lambda (route) - #~(route-add #$(network-route-destination route) +(define (network-set-up/linux config) + (match-record config <static-networking> + (addresses links routes) + (scheme-file "set-up-network" + (with-extensions (list guile-netlink) + #~(begin + (use-modules (ip addr) (ip link) (ip route)) + + #$@(map (lambda (address) + #~(begin + (addr-add #$(network-address-device address) + #$(network-address-value address) + #:ipv6? + #$(network-address-ipv6? address)) + ;; FIXME: loopback? + (link-set #$(network-address-device address) + #:multicast-on #t + #:up #t))) + addresses) + #$@(map (match-lambda + (($ <network-link> name type arguments) + #~(link-add #$name #$type + #:type-args '#$arguments))) + links) + #$@(map (lambda (route) + #~(route-add #$(network-route-destination route) + #:device + #$(network-route-device route) + #:ipv6? + #$(network-route-ipv6? route) + #:via + #$(network-route-gateway route) + #:src + #$(network-route-source route))) + routes) + #t))))) + +(define (network-tear-down/linux config) + (match-record config <static-networking> + (addresses links routes) + (scheme-file "tear-down-network" + (with-extensions (list guile-netlink) + #~(begin + (use-modules (ip addr) (ip link) (ip route) + (netlink error) + (srfi srfi-34)) + + (define-syntax-rule (false-if-netlink-error exp) + (guard (c ((netlink-error? c) #f)) + exp)) + + ;; Wrap calls in 'false-if-netlink-error' so this + ;; script goes as far as possible undoing the effects + ;; of "set-up-network". + + #$@(map (lambda (route) + #~(false-if-netlink-error + (route-del #$(network-route-destination route) #:device #$(network-route-device route) #:ipv6? @@ -2649,80 +2740,47 @@ to CONFIG." #:via #$(network-route-gateway route) #:src - #$(network-route-source route))) - routes) - #t)))))) - -(define network-tear-down/linux - (match-lambda - (($ <static-networking> addresses links routes) - (scheme-file "tear-down-network" - (with-extensions (list guile-netlink) - #~(begin - (use-modules (ip addr) (ip link) (ip route) - (netlink error) - (srfi srfi-34)) - - (define-syntax-rule (false-if-netlink-error exp) - (guard (c ((netlink-error? c) #f)) - exp)) - - ;; Wrap calls in 'false-if-netlink-error' so this - ;; script goes as far as possible undoing the effects - ;; of "set-up-network". - - #$@(map (lambda (route) - #~(false-if-netlink-error - (route-del #$(network-route-destination route) - #:device - #$(network-route-device route) - #:ipv6? - #$(network-route-ipv6? route) - #:via - #$(network-route-gateway route) - #:src - #$(network-route-source route)))) - routes) - #$@(map (match-lambda - (($ <network-link> name type arguments) - #~(false-if-netlink-error - (link-del #$name)))) - links) - #$@(map (lambda (address) + #$(network-route-source route)))) + routes) + #$@(map (match-lambda + (($ <network-link> name type arguments) #~(false-if-netlink-error - (addr-del #$(network-address-device - address) - #$(network-address-value address) - #:ipv6? - #$(network-address-ipv6? address)))) - addresses) - #f)))))) + (link-del #$name)))) + links) + #$@(map (lambda (address) + #~(false-if-netlink-error + (addr-del #$(network-address-device + address) + #$(network-address-value address) + #:ipv6? + #$(network-address-ipv6? address)))) + addresses) + #f))))) (define (static-networking-shepherd-service config) - (match config - (($ <static-networking> addresses links routes - provision requirement name-servers) - (let ((loopback? (and provision (memq 'loopback provision)))) - (shepherd-service + (match-record config <static-networking> + (addresses links routes provision requirement name-servers) + (let ((loopback? (and provision (memq 'loopback provision)))) + (shepherd-service - (documentation - "Bring up the networking interface using a static IP address.") - (requirement requirement) - (provision provision) + (documentation + "Bring up the networking interface using a static IP address.") + (requirement requirement) + (provision provision) - (start #~(lambda _ - ;; Return #t if successfully started. - (load #$(let-system (system target) - (if (string-contains (or target system) "-linux") - (network-set-up/linux config) - (network-set-up/hurd config)))))) - (stop #~(lambda _ - ;; Return #f is successfully stopped. + (start #~(lambda _ + ;; Return #t if successfully started. (load #$(let-system (system target) (if (string-contains (or target system) "-linux") - (network-tear-down/linux config) - (network-tear-down/hurd config)))))) - (respawn? #f)))))) + (network-set-up/linux config) + (network-set-up/hurd config)))))) + (stop #~(lambda _ + ;; Return #f is successfully stopped. + (load #$(let-system (system target) + (if (string-contains (or target system) "-linux") + (network-tear-down/linux config) + (network-tear-down/hurd config)))))) + (respawn? #f))))) (define (static-networking-shepherd-services networks) (map static-networking-shepherd-service networks)) @@ -2835,51 +2893,152 @@ to handle." (extra-env greetd-agreety-extra-env (default '())) (xdg-env? greetd-agreety-xdg-env? (default #t))) -(define greetd-agreety-tty-session-command - (match-lambda - (($ <greetd-agreety-session> _ command args extra-env) - (program-file - "agreety-tty-session-command" - #~(begin - (use-modules (ice-9 match)) - (for-each (match-lambda ((var . val) (setenv var val))) - (quote (#$@extra-env))) - (apply execl #$command #$command (list #$@args))))))) - -(define greetd-agreety-tty-xdg-session-command - (match-lambda - (($ <greetd-agreety-session> _ command args extra-env) - (program-file - "agreety-tty-xdg-session-command" - #~(begin - (use-modules (ice-9 match)) - (let* - ((username (getenv "USER")) - (useruid (passwd:uid (getpwuid username))) - (useruid (number->string useruid))) - (setenv "XDG_SESSION_TYPE" "tty") - (setenv "XDG_RUNTIME_DIR" (string-append "/run/user/" useruid))) - (for-each (match-lambda ((var . val) (setenv var val))) - (quote (#$@extra-env))) - (apply execl #$command #$command (list #$@args))))))) - -(define (make-greetd-agreety-session-command config command) - (let ((agreety (file-append (greetd-agreety config) "/bin/agreety"))) +(define (greetd-agreety-tty-session-command config) + (match-record config <greetd-agreety-session> + (command command-args extra-env) + (program-file + "agreety-tty-session-command" + #~(begin + (use-modules (ice-9 match)) + (for-each (match-lambda ((var . val) (setenv var val))) + (quote (#$@extra-env))) + (apply execl #$command #$command (list #$@command-args)))))) + +(define (greetd-agreety-tty-xdg-session-command config) + (match-record config <greetd-agreety-session> + (command command-args extra-env) (program-file - "agreety-command" - #~(execl #$agreety #$agreety "-c" #$command)))) - -(define (make-greetd-default-session-command config-or-command) - (cond ((greetd-agreety-session? config-or-command) - (cond ((greetd-agreety-xdg-env? config-or-command) - (make-greetd-agreety-session-command - config-or-command - (greetd-agreety-tty-xdg-session-command config-or-command))) - (#t - (make-greetd-agreety-session-command - config-or-command - (greetd-agreety-tty-session-command config-or-command))))) - (#t config-or-command))) + "agreety-tty-xdg-session-command" + #~(begin + (use-modules (ice-9 match)) + (let* + ((username (getenv "USER")) + (useruid (passwd:uid (getpwuid username))) + (useruid (number->string useruid))) + (setenv "XDG_SESSION_TYPE" "tty") + (setenv "XDG_RUNTIME_DIR" (string-append "/run/user/" useruid))) + (for-each (match-lambda ((var . val) (setenv var val))) + (quote (#$@extra-env))) + (apply execl #$command #$command (list #$@command-args)))))) + +(define-gexp-compiler (greetd-agreety-session-compiler + (session <greetd-agreety-session>) + system target) + (let ((agreety (file-append (greetd-agreety session) + "/bin/agreety")) + (command ((if (greetd-agreety-xdg-env? session) + greetd-agreety-tty-xdg-session-command + greetd-agreety-tty-session-command) + session))) + (lower-object + (program-file "agreety-command" + #~(execl #$agreety #$agreety "-c" #$command))))) + +(define-record-type* <greetd-wlgreet-session> + greetd-wlgreet-session make-greetd-wlgreet-session + greetd-wlgreet-session? + (wlgreet greetd-wlgreet (default wlgreet)) + (command greetd-wlgreet-command + (default (file-append sway "/bin/sway"))) + (command-args greetd-wlgreet-command-args (default '())) + (output-mode greetd-wlgreet-output-mode (default "all")) + (scale greetd-wlgreet-scale (default 1)) + (background greetd-wlgreet-background (default '(0 0 0 0.9))) + (headline greetd-wlgreet-headline (default '(1 1 1 1))) + (prompt greetd-wlgreet-prompt (default '(1 1 1 1))) + (prompt-error greetd-wlgreet-prompt-error (default '(1 1 1 1))) + (border greetd-wlgreet-border (default '(1 1 1 1))) + (extra-env greetd-wlgreet-extra-env (default '()))) + +(define (greetd-wlgreet-wayland-session-command session) + (program-file "wlgreet-session-command" + #~(let* ((username (getenv "USER")) + (useruid (number->string + (passwd:uid (getpwuid username)))) + (command #$(greetd-wlgreet-command session))) + (use-modules (ice-9 match)) + (setenv "XDG_SESSION_TYPE" "wayland") + (setenv "XDG_RUNTIME_DIR" (string-append "/run/user/" useruid)) + (for-each (lambda (env) (setenv (car env) (cdr env))) + '(#$@(greetd-wlgreet-extra-env session))) + (apply execl command command + (list #$@(greetd-wlgreet-command-args session)))))) + +(define (make-wlgreet-config-color section-name color) + (match color + ((red green blue opacity) + (string-append + "[" section-name "]\n" + "red = " (number->string red) "\n" + "green = " (number->string green) "\n" + "blue = " (number->string blue) "\n" + "opacity = " (number->string opacity) "\n")))) + +(define (make-wlgreet-configuration-file session) + (let ((command (greetd-wlgreet-wayland-session-command session)) + (output-mode (greetd-wlgreet-output-mode session)) + (scale (greetd-wlgreet-scale session)) + (background (greetd-wlgreet-background session)) + (headline (greetd-wlgreet-headline session)) + (prompt (greetd-wlgreet-prompt session)) + (prompt-error (greetd-wlgreet-prompt-error session)) + (border (greetd-wlgreet-border session))) + (mixed-text-file "wlgreet.toml" + "command = \"" command "\"\n" + "outputMode = \"" output-mode "\"\n" + "scale = " (number->string scale) "\n" + (apply string-append + (map (match-lambda + ((section-name . color) + (make-wlgreet-config-color section-name color))) + `(("background" . ,background) + ("headline" . ,headline) + ("prompt" . ,prompt) + ("prompt-error" . ,prompt-error) + ("border" . ,border))))))) + +(define-record-type* <greetd-wlgreet-sway-session> + greetd-wlgreet-sway-session make-greetd-wlgreet-sway-session + greetd-wlgreet-sway-session? + (wlgreet-session greetd-wlgreet-sway-session-wlgreet-session ;<greetd-wlgreet-session> + (default (greetd-wlgreet-session))) + (sway greetd-wlgreet-sway-session-sway (default sway)) ;<package> + (sway-configuration greetd-wlgreet-sway-session-sway-configuration ;file-like + (default (plain-file "wlgreet-sway-config" "")))) + +(define (make-wlgreet-sway-configuration-file session) + (let* ((wlgreet-session (greetd-wlgreet-sway-session-wlgreet-session session)) + (wlgreet-config (make-wlgreet-configuration-file wlgreet-session)) + (wlgreet (file-append (greetd-wlgreet wlgreet-session) "/bin/wlgreet")) + (sway-config (greetd-wlgreet-sway-session-sway-configuration session)) + (swaymsg (file-append (greetd-wlgreet-sway-session-sway session) + "/bin/swaymsg"))) + (mixed-text-file "wlgreet-sway.conf" + "include " sway-config "\n" + "xwayland disable\n" + "exec \"" wlgreet " --config " wlgreet-config "; " + swaymsg " exit\"\n"))) + +(define-gexp-compiler (greetd-wlgreet-sway-session-compiler + (session <greetd-wlgreet-sway-session>) + system target) + (let ((sway (file-append (greetd-wlgreet-sway-session-sway session) + "/bin/sway")) + (config (make-wlgreet-sway-configuration-file session))) + (lower-object + (program-file "wlgreet-sway-session-command" + #~(let* ((log-file (open-output-file + (string-append "/tmp/sway-greeter." + (number->string (getpid)) + ".log"))) + (username (getenv "USER")) + (useruid (number->string (passwd:uid (getpwuid username))))) + ;; redirect stdout/err to log-file + (dup2 (fileno log-file) 1) + (dup2 1 2) + (sleep 1) ;give seatd/logind some time to start up + (setenv "XDG_RUNTIME_DIR" (string-append "/run/user/" useruid)) + (execl #$sway #$sway "-d" "-c" #$config)))))) (define-record-type* <greetd-terminal-configuration> greetd-terminal-configuration make-greetd-terminal-configuration @@ -2891,10 +3050,10 @@ to handle." (default (default-log-file-name this-record))) (terminal-vt greetd-terminal-vt (default "7")) (terminal-switch greetd-terminal-switch (default #f)) + (source-profile? greetd-source-profile? (default #t)) (default-session-user greetd-default-session-user (default "greeter")) (default-session-command greetd-default-session-command - (default (greetd-agreety-session)) - (sanitize make-greetd-default-session-command))) + (default (greetd-agreety-session)))) (define (default-config-file-name config) (string-join (list "config-" (greetd-terminal-vt config) ".toml") "")) @@ -2905,12 +3064,14 @@ to handle." (define (make-greetd-terminal-configuration-file config) (let* ((config-file-name (greetd-config-file-name config)) + (source-profile? (greetd-source-profile? config)) (terminal-vt (greetd-terminal-vt config)) (terminal-switch (greetd-terminal-switch config)) (default-session-user (greetd-default-session-user config)) (default-session-command (greetd-default-session-command config))) (mixed-text-file config-file-name + "source_profile = " (if source-profile? "true" "false") "\n" "[terminal]\n" "vt = " terminal-vt "\n" "switch = " (if terminal-switch "true" "false") "\n" diff --git a/gnu/services/certbot.scm b/gnu/services/certbot.scm index 1c819bef48..8e6784df2b 100644 --- a/gnu/services/certbot.scm +++ b/gnu/services/certbot.scm @@ -148,12 +148,13 @@ (define (certbot-renewal-jobs config) (list ;; Attempt to renew the certificates twice per day, at a random minute - ;; within the hour. See https://certbot.eff.org/all-instructions/. + ;; within the hour. See https://eff-certbot.readthedocs.io/. #~(job '(next-minute-from (next-hour '(0 12)) (list (random 60))) #$(certbot-command config)))) (define (certbot-activation config) (let* ((certbot-directory "/var/lib/certbot") + (certbot-cert-directory "/etc/letsencrypt/live") (script (in-vicinity certbot-directory "renew-certificates")) (message (format #f (G_ "~a may need to be run~%") script))) (match config @@ -164,6 +165,7 @@ (use-modules (guix build utils)) (mkdir-p #$webroot) (mkdir-p #$certbot-directory) + (mkdir-p #$certbot-cert-directory) (copy-file #$(certbot-command config) #$script) (display #$message))))))) diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm index 636c49ccba..6b0291dc00 100644 --- a/gnu/services/configuration.scm +++ b/gnu/services/configuration.scm @@ -242,17 +242,17 @@ does not have a default value" field kind))) stem #,(id #'stem #'make- #'stem) #,(id #'stem #'stem #'?) - (%location #,(id #'stem #'stem #'-location) - (default (and=> (current-source-location) - source-properties->location)) - (innate)) #,@(map (lambda (name getter def) #`(#,name #,getter (default #,def) (sanitize #,(id #'stem #'validate- #'stem #'- name)))) #'(field ...) #'(field-getter ...) - #'(field-default ...))) + #'(field-default ...)) + (%location #,(id #'stem #'stem #'-source-location) + (default (and=> (current-source-location) + source-properties->location)) + (innate))) (define #,(id #'stem #'stem #'-fields) (list (configuration-field @@ -436,7 +436,11 @@ the list result in @code{#t} when applying PRED? on them." (define list-of-strings? (list-of string?)) -(define alist? list?) +(define alist? + (match-lambda + (() #t) + ((head . tail) (and (pair? head) (alist? tail))) + (_ #f))) (define serialize-file-like empty-serializer) @@ -469,9 +473,6 @@ applied on the fields and values of FIELDS using the COMBINE is a procedure that takes one or more arguments and combines all the alist entries into one value, @code{string-append} or -@code{append} are usually good candidates for this. - -See the @code{serialize-alist} procedure in `@code{(gnu home services -version-control}' for an example usage.)}" +@code{append} are usually good candidates for this." (apply combine (map (generic-serialize-alist-entry serialize-field) fields))) diff --git a/gnu/services/cuirass.scm b/gnu/services/cuirass.scm index 52de5ca7c0..43b0e0946e 100644 --- a/gnu/services/cuirass.scm +++ b/gnu/services/cuirass.scm @@ -125,7 +125,7 @@ (let ((cuirass (cuirass-configuration-cuirass config)) (cache-directory (cuirass-configuration-cache-directory config)) (web-log-file (cuirass-configuration-web-log-file config)) - (log-file (cuirass-configuration-log-file config)) + (main-log-file (cuirass-configuration-log-file config)) (user (cuirass-configuration-user config)) (group (cuirass-configuration-group config)) (interval (cuirass-configuration-interval config)) @@ -169,7 +169,7 @@ #:user #$user #:group #$group - #:log-file #$log-file)) + #:log-file #$main-log-file)) (stop #~(make-kill-destructor))) ,(shepherd-service (documentation "Run Cuirass web interface.") @@ -302,8 +302,13 @@ (define (cuirass-log-rotations config) "Return the list of log rotations that corresponds to CONFIG." (list (log-rotation - (files (list (cuirass-configuration-log-file config) - (cuirass-configuration-web-log-file config))) + (files (append (list (cuirass-configuration-log-file config) + (cuirass-configuration-web-log-file config)) + (let ((server + (cuirass-configuration-remote-server config))) + (if server + (list (cuirass-remote-server-log-file server)) + '())))) (frequency 'weekly) (options `("rotate 40" ;worth keeping ,@%default-log-rotation-options))))) @@ -394,12 +399,21 @@ CONFIG." #:log-file #$log-file)) (stop #~(make-kill-destructor)))))) +(define (cuirass-remote-worker-log-rotations config) + "Return the list of log rotations that corresponds to CONFIG." + (list (log-rotation + (files (list (cuirass-remote-worker-log-file config))) + (frequency 'weekly) + (options `("rotate 4" ;don't keep too many of them + ,@%default-log-rotation-options))))) + (define cuirass-remote-worker-service-type (service-type (name 'cuirass-remote-worker) (extensions - (list - (service-extension shepherd-root-service-type - cuirass-remote-worker-shepherd-service))) + (list (service-extension shepherd-root-service-type + cuirass-remote-worker-shepherd-service) + (service-extension rottlog-service-type + cuirass-remote-worker-log-rotations))) (description "Run the Cuirass remote build worker service."))) diff --git a/gnu/services/databases.scm b/gnu/services/databases.scm index fb3cd3c478..b7bd1e587e 100644 --- a/gnu/services/databases.scm +++ b/gnu/services/databases.scm @@ -6,8 +6,9 @@ ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.net> -;;; Copyright © 2020 Marius Bakke <marius@gnu.org> +;;; Copyright © 2020, 2022 Marius Bakke <marius@gnu.org> ;;; Copyright © 2021 David Larsson <david.larsson@selfhosted.xyz> +;;; Copyright © 2021 Aljosha Papsch <ep@stern-data.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,6 +30,7 @@ #:use-module (gnu services shepherd) #:use-module (gnu system shadow) #:use-module (gnu packages admin) + #:use-module (gnu packages base) #:use-module (gnu packages databases) #:use-module (guix build-system trivial) #:use-module (guix build union) @@ -532,6 +534,7 @@ applications."))) (bind-address mysql-configuration-bind-address (default "127.0.0.1")) (port mysql-configuration-port (default 3306)) (socket mysql-configuration-socket (default "/run/mysqld/mysqld.sock")) + (datadir mysql-configuration-datadir (default "/var/lib/mysql")) (extra-content mysql-configuration-extra-content (default "")) (extra-environment mysql-configuration-extra-environment (default #~'())) (auto-upgrade? mysql-configuration-auto-upgrade? (default #t))) @@ -549,112 +552,114 @@ applications."))) (define mysql-configuration-file (match-lambda - (($ <mysql-configuration> mysql bind-address port socket extra-content) + (($ <mysql-configuration> mysql bind-address port socket datadir extra-content) (mixed-text-file "my.cnf" "[mysqld] -datadir=/var/lib/mysql +datadir=" datadir " socket=" socket " bind-address=" bind-address " port=" (number->string port) " " extra-content " ")))) -(define (%mysql-activation config) - "Return an activation gexp for the MySQL or MariaDB database server." - (let ((mysql (mysql-configuration-mysql config)) - (my.cnf (mysql-configuration-file config))) - #~(begin - (use-modules (ice-9 popen) - (guix build utils)) - (let* ((mysqld (string-append #$mysql "/bin/mysqld")) - (user (getpwnam "mysql")) - (uid (passwd:uid user)) - (gid (passwd:gid user)) - (datadir "/var/lib/mysql") - (rundir "/run/mysqld")) - (mkdir-p datadir) - (chown datadir uid gid) - (mkdir-p rundir) - (chown rundir uid gid) - ;; Initialize the database when it doesn't exist. - (when (not (file-exists? (string-append datadir "/mysql"))) - (if (string-prefix? "mysql-" (strip-store-file-name #$mysql)) - ;; For MySQL. - (system* mysqld - (string-append "--defaults-file=" #$my.cnf) - "--initialize" - "--user=mysql") - ;; For MariaDB. - ;; XXX: The 'mysql_install_db' script doesn't work directly - ;; due to missing 'mkdir' in PATH. - (let ((p (open-pipe* OPEN_WRITE mysqld - (string-append - "--defaults-file=" #$my.cnf) - "--bootstrap" - "--user=mysql"))) - ;; Create the system database, as does by 'mysql_install_db'. - (display "create database mysql;\n" p) - (display "use mysql;\n" p) - (for-each - (lambda (sql) - (call-with-input-file - (string-append #$mysql:lib "/share/mysql/" sql) - (lambda (in) (dump-port in p)))) - '("mysql_system_tables.sql" - "mysql_performance_tables.sql" - "mysql_system_tables_data.sql" - "fill_help_tables.sql")) - ;; Remove the anonymous user and disable root access from - ;; remote machines, as does by 'mysql_secure_installation'. - (display " -DELETE FROM user WHERE User=''; -DELETE FROM user WHERE User='root' AND - Host NOT IN ('localhost', '127.0.0.1', '::1'); -FLUSH PRIVILEGES; -" p) - (close-pipe p)))))))) +(define (mysqld-wrapper config) + "Start mysqld, and initialize the system tables if necessary." + (program-file + "mysqld-wrapper" + (with-imported-modules (source-module-closure + '((guix build utils))) + (let ((mysql (mysql-configuration-mysql config)) + (datadir (mysql-configuration-datadir config)) + (my.cnf (mysql-configuration-file config))) + #~(begin + (use-modules (guix build utils)) + (let* ((mysqld (string-append #$mysql "/bin/mysqld")) + (user (getpwnam "mysql")) + (uid (passwd:uid user)) + (gid (passwd:gid user)) + (rundir "/run/mysqld")) + (mkdir-p #$datadir) + (chown #$datadir uid gid) + (mkdir-p rundir) + (chown rundir uid gid) + (unless (file-exists? (string-append #$datadir "/mysql")) + (let ((init (system* #$(mysql-install config)))) + (unless (= 0 (status:exit-val init)) + (throw 'system-error "MySQL initialization failed.")))) + ;; Drop privileges and start the server. + (setgid gid) (setuid uid) + (execl mysqld mysqld + (string-append "--defaults-file=" #$my.cnf)))))))) (define (mysql-shepherd-service config) (list (shepherd-service (provision '(mysql)) + (requirement '(user-processes)) (documentation "Run the MySQL server.") - (start (let ((mysql (mysql-configuration-mysql config)) + (start (let ((mysql (mysql-configuration-mysql config)) (extra-env (mysql-configuration-extra-environment config)) (my.cnf (mysql-configuration-file config))) #~(make-forkexec-constructor - (list (string-append #$mysql "/bin/mysqld") - (string-append "--defaults-file=" #$my.cnf)) - #:user "mysql" #:group "mysql" - #:log-file "/var/log/mysqld.log" - #:environment-variables #$extra-env))) + (list #$(mysqld-wrapper config)) + #:log-file "/var/log/mysqld.log" + #:environment-variables #$extra-env))) (stop #~(make-kill-destructor))))) -(define (mysql-upgrade-wrapper mysql socket-file) +(define (mysql-install config) + "Install MySQL system database and secure the installation." + (let ((mysql (mysql-configuration-mysql config)) + (my.cnf (mysql-configuration-file config))) + (program-file + "mysql-install" + (with-imported-modules (source-module-closure + '((guix build utils))) + #~(begin + (use-modules (guix build utils)) + ;; Make sed, mkdir, uname, etc available for mariadb-install-db. + (set-path-environment-variable "PATH" '("bin") + (list #$sed #$coreutils)) + (if (string=? "mariadb" #$(package-name mysql)) + ;; For MariaDB. + (system* #$(file-append mysql "/bin/mariadb-install-db") + (string-append "--defaults-file=" #$my.cnf) + "--skip-test-db" + "--user=mysql") + ;; For MySQL. + (system* #$(file-append mysql "/bin/mysqld") + (string-append "--defaults-file=" #$my.cnf) + "--initialize" + "--user=mysql"))))))) + +(define (mysql-upgrade-wrapper config) ;; The MySQL socket and PID file may appear before the server is ready to ;; accept connections. Ensure the socket is responsive before attempting ;; to run the upgrade script. - (program-file - "mysql-upgrade-wrapper" - #~(begin - (let ((mysql-upgrade #$(file-append mysql "/bin/mysql_upgrade")) - (timeout 10)) - (begin - (let loop ((i 0)) - (catch 'system-error - (lambda () - (let ((sock (socket PF_UNIX SOCK_STREAM 0))) - (connect sock AF_UNIX #$socket-file) - (close-port sock) - ;; The socket is ready! - (execl mysql-upgrade mysql-upgrade - (string-append "--socket=" #$socket-file)))) - (lambda args - (if (< i timeout) - (begin - (sleep 1) - (loop (+ 1 i))) - ;; No luck, give up. - (throw 'timeout-error - "MySQL server did not appear in time!")))))))))) + (let ((mysql (mysql-configuration-mysql config)) + (socket-file (mysql-configuration-socket config)) + (config-file (mysql-configuration-file config))) + (program-file + "mysql-upgrade-wrapper" + #~(begin + (let ((mysql-upgrade #$(file-append mysql "/bin/mysql_upgrade")) + (timeout 20)) + (begin + (let loop ((i 0)) + (catch 'system-error + (lambda () + (let ((sock (socket PF_UNIX SOCK_STREAM 0))) + (connect sock AF_UNIX #$socket-file) + (close-port sock) + ;; The socket is ready! + (execl mysql-upgrade mysql-upgrade + (string-append "--defaults-file=" #$config-file) + "--user=mysql"))) + (lambda args + (if (< i timeout) + (begin + (sleep 1) + (loop (+ 1 i))) + ;; No luck, give up. + (throw 'timeout-error + "MySQL server did not appear in time!"))))))))))) (define (mysql-upgrade-shepherd-service config) (list (shepherd-service @@ -662,17 +667,17 @@ FLUSH PRIVILEGES; (requirement '(mysql)) (one-shot? #t) (documentation "Upgrade MySQL database schemas.") - (start (let ((mysql (mysql-configuration-mysql config)) - (socket (mysql-configuration-socket config))) - #~(make-forkexec-constructor - (list #$(mysql-upgrade-wrapper mysql socket)) - #:user "mysql" #:group "mysql")))))) + (start #~(make-forkexec-constructor + (list #$(mysql-upgrade-wrapper config)) + #:user "mysql" #:group "mysql" + #:log-file "/var/log/mysql_upgrade.log"))))) (define (mysql-shepherd-services config) - (if (mysql-configuration-auto-upgrade? config) - (append (mysql-shepherd-service config) - (mysql-upgrade-shepherd-service config)) - (mysql-shepherd-service config))) + (let ((mysql-services (mysql-shepherd-service config))) + (if (mysql-configuration-auto-upgrade? config) + (append mysql-services + (mysql-upgrade-shepherd-service config)) + mysql-services))) (define mysql-service-type (service-type @@ -680,8 +685,6 @@ FLUSH PRIVILEGES; (extensions (list (service-extension account-service-type (const %mysql-accounts)) - (service-extension activation-service-type - %mysql-activation) (service-extension shepherd-root-service-type mysql-shepherd-services))) (default-value (mysql-configuration)) diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm index e4c719fe71..4b56b8f3eb 100644 --- a/gnu/services/dbus.scm +++ b/gnu/services/dbus.scm @@ -40,6 +40,8 @@ dbus-service wrapped-dbus-service + polkit-configuration + polkit-configuration? polkit-service-type polkit-service)) diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm index 1b087635d1..fe1f0fd20a 100644 --- a/gnu/services/desktop.scm +++ b/gnu/services/desktop.scm @@ -5,7 +5,7 @@ ;;; Copyright © 2016 Sou Bunnbu <iyzsong@gmail.com> ;;; Copyright © 2017, 2020, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2017 Nikita <nikita@n0.is> -;;; Copyright © 2018, 2020 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2018, 2020, 2022 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2017, 2019 Christopher Baines <mail@cbaines.net> ;;; Copyright © 2019 Tim Gesthuizen <tim.gesthuizen@yahoo.de> @@ -273,7 +273,8 @@ #:environment-variables (list (string-append "UPOWER_CONF_FILE_NAME=" #$config)))) - (stop #~(make-kill-destructor)))))) + (stop #~(make-kill-destructor)) + (actions (list (shepherd-configuration-action config))))))) (define upower-service-type (let ((upower-package (compose list upower-configuration-upower))) @@ -759,7 +760,7 @@ site} for more information." (bluetooth-configuration-enable-adv-mon-interleave-scan config)) 1 0)) - + "\n[GATT]" "\nCache = " (symbol->string (bluetooth-configuration-cache config)) "\nKeySize = " (number->string (bluetooth-configuration-key-size config)) @@ -837,9 +838,7 @@ Bluetooth devices and provides a number of D-Bus interfaces."))) "Return a service that runs the @command{bluetoothd} daemon, which manages all the Bluetooth devices and provides a number of D-Bus interfaces. When AUTO-ENABLE? is true, the bluetooth controller is powered automatically at -boot. - -Users need to be in the @code{lp} group to access the D-Bus service. +boot, which can be useful when using a bluetooth keyboard or mouse. " (service bluetooth-service-type (bluetooth-configuration @@ -1168,6 +1167,9 @@ seats.)" (define (elogind-shepherd-service config) "Return a Shepherd service to start elogind according to @var{config}." + (define config-file + (elogind-configuration-file config)) + (list (shepherd-service (requirement '(dbus-system)) (provision '(elogind)) @@ -1176,9 +1178,9 @@ seats.)" "/libexec/elogind/elogind")) #:environment-variables (list (string-append "ELOGIND_CONF_FILE=" - #$(elogind-configuration-file - config))))) - (stop #~(make-kill-destructor))))) + #$config-file)))) + (stop #~(make-kill-destructor)) + (actions (list (shepherd-configuration-action config-file)))))) (define elogind-service-type (service-type (name 'elogind) @@ -1539,6 +1541,11 @@ rules." (package-direct-input-selector "efl") enlightenment-package)) + (service-extension udev-service-type + (compose list + (package-direct-input-selector + "ddcutil") + enlightenment-package)) (service-extension setuid-program-service-type enlightenment-setuid-programs) (service-extension profile-service-type diff --git a/gnu/services/dict.scm b/gnu/services/dict.scm index f042219cbd..35253a0077 100644 --- a/gnu/services/dict.scm +++ b/gnu/services/dict.scm @@ -182,7 +182,8 @@ database { (stop #~(if (and (defined? 'make-inetd-destructor) #$(= 1 (length interfaces))) ;XXX (make-inetd-destructor) - (make-kill-destructor))))))) + (make-kill-destructor))) + (actions (list (shepherd-configuration-action dicod.conf))))))) (define dicod-service-type (service-type diff --git a/gnu/services/games.scm b/gnu/services/games.scm index 6c2af44b49..e63c1c1299 100644 --- a/gnu/services/games.scm +++ b/gnu/services/games.scm @@ -19,6 +19,7 @@ (define-module (gnu services games) #:use-module (gnu services) + #:use-module (gnu services configuration) #:use-module (gnu services shepherd) #:use-module (gnu packages admin) #:use-module (gnu packages games) @@ -28,13 +29,46 @@ #:autoload (guix least-authority) (least-authority-wrapper) #:use-module (guix gexp) #:use-module (guix modules) + #:use-module (guix packages) #:use-module (guix records) #:use-module (ice-9 match) - #:export (wesnothd-configuration + #:export (joycond-configuration + joycond-configuration? + joycond-service-type + + wesnothd-configuration wesnothd-configuration? wesnothd-service-type)) ;;; +;;; Joycond +;;; + +(define-configuration/no-serialization joycond-configuration + (package (package joycond) "The joycond package to use")) + +(define (joycond-shepherd-service config) + (let ((joycond (joycond-configuration-package config))) + (list (shepherd-service + (documentation "Run joycond.") + (provision '(joycond)) + (requirement '(bluetooth)) + (start #~(make-forkexec-constructor + (list #$(file-append joycond "/bin/joycond")))) + (stop #~(make-kill-destructor)))))) + +(define joycond-service-type + (service-type + (name 'joycond) + (description + "Run @command{joycond} for pairing Nintendo joycons via Bluetooth.") + (extensions + (list (service-extension shepherd-root-service-type + joycond-shepherd-service))) + (default-value (joycond-configuration)))) + + +;;; ;;; The Battle for Wesnoth server ;;; diff --git a/gnu/services/ganeti.scm b/gnu/services/ganeti.scm index 85adbd7362..f4fec3833e 100644 --- a/gnu/services/ganeti.scm +++ b/gnu/services/ganeti.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2020 Marius Bakke <marius@gnu.org> +;;; Copyright © 2020, 2022 Marius Bakke <marius@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -683,7 +683,8 @@ information to OS install scripts or instances."))) #~(#$schedule)) ((? list?) #~('#$schedule))) - #$(ganeti-watcher-command config)))))) + #$(ganeti-watcher-command config) + "ganeti-watcher"))))) (define ganeti-watcher-service-type (service-type (name 'ganeti-watcher) @@ -725,7 +726,8 @@ is declared offline by known master candidates."))) #~('#$master-schedule))) (lambda () (system* #$(file-append ganeti "/sbin/ganeti-cleaner") - "master"))) + "master")) + "ganeti master cleaner") #~(job #$@(match node-schedule ((? string?) #~(#$node-schedule)) @@ -733,7 +735,8 @@ is declared offline by known master candidates."))) #~('#$node-schedule))) (lambda () (system* #$(file-append ganeti "/sbin/ganeti-cleaner") - "node"))))))) + "node")) + "ganeti node cleaner"))))) (define ganeti-cleaner-service-type (service-type (name 'ganeti-cleaner) @@ -777,6 +780,8 @@ than 21 days from @file{/var/lib/ganeti/queue/archive}."))) (default (ganeti-cleaner-configuration))) (file-storage-paths ganeti-configuration-file-storage-paths ;list of strings | gexp (default '())) + (hooks ganeti-configuration-hooks ;<file-like> | #f + (default #f)) (os ganeti-configuration-os ;list of <ganeti-os> (default '()))) @@ -819,8 +824,9 @@ than 21 days from @file{/var/lib/ganeti/queue/archive}."))) (define-record-type* <ganeti-os> ganeti-os make-ganeti-os ganeti-os? (name ganeti-os-name) ;string - (extension ganeti-os-extension) ;string - (variants ganeti-os-variants ;list of <ganeti-os-variant> + (extension ganeti-os-extension ;#f | string + (default #f)) + (variants ganeti-os-variants ;<file-like> | list of <ganeti-os-variant> (default '()))) (define-record-type* <ganeti-os-variant> @@ -909,7 +915,7 @@ trap - EXIT (partition-alignment debootstrap-configuration-partition-alignment ;#f | integer (default 2048))) -(define (hooks->directory hooks) +(define (debootstrap-hooks->directory hooks) (match hooks ((? file-like?) hooks) @@ -917,7 +923,7 @@ trap - EXIT (let ((names (map car hooks)) (files (map cdr hooks))) (with-imported-modules '((guix build utils)) - (computed-file "hooks-union" + (computed-file "debootstrap-hooks" #~(begin (use-modules (guix build utils) (ice-9 match)) @@ -941,7 +947,7 @@ trap - EXIT (($ <debootstrap-configuration> hooks proxy mirror arch suite extra-pkgs components generate-cache? clean-cache partition-style partition-alignment) - (let ((customize-dir (hooks->directory hooks))) + (let ((customize-dir (debootstrap-hooks->directory hooks))) (gexp->derivation "debootstrap-variant" #~(call-with-output-file (ungexp output "out") @@ -992,37 +998,48 @@ trap - EXIT (define (ganeti-os->directory os) "Return the derivation to build the configuration directory to be installed in /etc/ganeti/instance-$os for OS." - (let* ((name (ganeti-os-name os)) - (extension (ganeti-os-extension os)) - (variants (ganeti-os-variants os)) - (names (map ganeti-os-variant-name variants)) - (configs (map ganeti-os-variant-configuration variants))) - (with-imported-modules '((guix build utils)) - (define builder - #~(begin - (use-modules (guix build utils) - (ice-9 format) - (ice-9 match) - (srfi srfi-1)) - (mkdir-p #$output) - (unless (null? '#$names) - (let ((variants-dir (string-append #$output "/variants"))) - (mkdir-p variants-dir) - (call-with-output-file (string-append variants-dir "/variants.list") - (lambda (port) - (format port "~a~%" - (string-join '#$names "\n")))) - (for-each (match-lambda - ((name file) - (symlink file - (string-append variants-dir "/" name - #$extension)))) - - '#$(zip names configs)))))) - - (computed-file (string-append name "-os") builder)))) - -(define (ganeti-directory file-storage-file os) + (let ((name (ganeti-os-name os)) + (extension (ganeti-os-extension os)) + (variants (ganeti-os-variants os))) + (define builder + (with-imported-modules '((guix build utils)) + (if (file-like? variants) + #~(begin + (use-modules (guix build utils)) + (mkdir-p #$output) + (symlink #$variants + (string-append #$output "/variants"))) + #~(begin + (use-modules (guix build utils) + (ice-9 format) + (ice-9 match) + (srfi srfi-1)) + (mkdir-p #$output) + (let ((variants-dir (string-append #$output "/variants")) + (names '#$(map ganeti-os-variant-name variants)) + (configs '#$(map ganeti-os-variant-configuration variants))) + (mkdir-p variants-dir) + (unless (null? names) + (call-with-output-file (string-append variants-dir + "/variants.list") + (lambda (port) + (format port "~a~%" + (string-join names "\n")))) + (for-each (match-lambda + ((name file) + (let ((file-name + (if #$extension + (string-append name #$extension) + name))) + (symlink file + (string-append variants-dir "/" + file-name))))) + (zip names configs)))))))) + + (computed-file (string-append name "-os") builder + #:local-build? #t))) + +(define (ganeti-directory file-storage-file hooks os) (let ((dirs (map ganeti-os->directory os)) (names (map ganeti-os-name os))) (define builder @@ -1032,6 +1049,9 @@ in /etc/ganeti/instance-$os for OS." (when #$file-storage-file (symlink #$file-storage-file (string-append #$output "/file-storage-paths"))) + (when #$hooks + (symlink #$hooks + (string-append #$output "/hooks"))) (for-each (match-lambda ((name dest) (symlink dest @@ -1051,6 +1071,7 @@ in /etc/ganeti/instance-$os for OS." (list `("ganeti" ,(ganeti-directory (file-storage-file (ganeti-configuration-file-storage-paths config)) + (ganeti-configuration-hooks config) (ganeti-configuration-os config))))) (define (debootstrap-os variants) diff --git a/gnu/services/getmail.scm b/gnu/services/getmail.scm index 0a1c34cfd3..19faea782f 100644 --- a/gnu/services/getmail.scm +++ b/gnu/services/getmail.scm @@ -215,18 +215,6 @@ lines.") (parameter-alist '()) "Extra options to include.")) -(define (serialize-getmail-configuration-file field-name val) - (match val - (($ <getmail-configuration-file> location - retriever destination options) - #~(string-append - "[retriever]\n" - #$(serialize-getmail-retriever-configuration #f retriever) - "\n[destination]\n" - #$(serialize-getmail-destination-configuration #f destination) - "\n[options]\n" - #$(serialize-getmail-options-configuration #f options))))) - (define-configuration getmail-configuration-file (retriever (getmail-retriever-configuration (getmail-retriever-configuration)) @@ -238,6 +226,17 @@ lines.") (getmail-options-configuration (getmail-options-configuration)) "Configure getmail.")) +(define (serialize-getmail-configuration-file field-name val) + (match-record val <getmail-configuration-file> + (retriever destination options) + #~(string-append + "[retriever]\n" + #$(serialize-getmail-retriever-configuration #f retriever) + "\n[destination]\n" + #$(serialize-getmail-destination-configuration #f destination) + "\n[options]\n" + #$(serialize-getmail-options-configuration #f options)))) + (define (serialize-symbol field-name val) "") (define (serialize-getmail-configuration field-name val) "") @@ -339,29 +338,28 @@ notifications. This depends on the server supporting the IDLE extension.") (define (getmail-shepherd-services configs) "Return a list of <shepherd-service> for CONFIGS." - (map (match-lambda - (($ <getmail-configuration> location name package - user group directory rcfile idle - environment-variables) - (shepherd-service - (documentation "Run getmail.") - (provision (list (symbol-append 'getmail- name))) - (requirement '(networking)) - (start #~(make-forkexec-constructor - `(#$(file-append package "/bin/getmail") - ,(string-append "--getmaildir=" #$directory) - #$@(map (lambda (idle) - (string-append "--idle=" idle)) - idle) - ,(string-append "--rcfile=" #$rcfile)) - #:user #$user - #:group #$group - #:environment-variables - (list #$@environment-variables) - #:log-file - #$(string-append "/var/log/getmail-" - (symbol->string name)))) - (stop #~(make-kill-destructor))))) + (map (lambda (config) + (match-record config <getmail-configuration> + (name package user group directory rcfile idle environment-variables) + (shepherd-service + (documentation "Run getmail.") + (provision (list (symbol-append 'getmail- name))) + (requirement '(networking)) + (start #~(make-forkexec-constructor + `(#$(file-append package "/bin/getmail") + ,(string-append "--getmaildir=" #$directory) + #$@(map (lambda (idle) + (string-append "--idle=" idle)) + idle) + ,(string-append "--rcfile=" #$rcfile)) + #:user #$user + #:group #$group + #:environment-variables + (list #$@environment-variables) + #:log-file + #$(string-append "/var/log/getmail-" + (symbol->string name)))) + (stop #~(make-kill-destructor))))) configs)) (define getmail-service-type diff --git a/gnu/services/guix.scm b/gnu/services/guix.scm index dac1e5841a..65bf0b5a7f 100644 --- a/gnu/services/guix.scm +++ b/gnu/services/guix.scm @@ -59,6 +59,7 @@ guix-build-coordinator-agent-configuration-authentication guix-build-coordinator-agent-configuration-systems guix-build-coordinator-agent-configuration-max-parallel-builds + guix-build-coordinator-agent-configuration-max-allocated-builds guix-build-coordinator-agent-configuration-max-1min-load-average guix-build-coordinator-agent-configuration-derivation-substitute-urls guix-build-coordinator-agent-configuration-non-derivation-substitute-urls @@ -177,6 +178,9 @@ (max-parallel-builds guix-build-coordinator-agent-configuration-max-parallel-builds (default 1)) + (max-allocated-builds + guix-build-coordinator-agent-configuration-max-allocated-builds + (default #f)) (max-1min-load-average guix-build-coordinator-agent-configuration-max-1min-load-average (default #f)) @@ -329,31 +333,38 @@ (documentation "Guix Build Coordinator") (provision '(guix-build-coordinator)) (requirement '(networking)) - (start #~(make-forkexec-constructor - (list #$(make-guix-build-coordinator-start-script - database-uri-string - allocation-strategy - "/var/run/guix-build-coordinator/pid" - package - #:agent-communication-uri-string - agent-communication-uri-string - #:client-communication-uri-string - client-communication-uri-string - #:hooks hooks - #:parallel-hooks parallel-hooks - #:guile guile)) - #:user #$user - #:group #$group - #:pid-file "/var/run/guix-build-coordinator/pid" - ;; Allow time for migrations to run - #:pid-file-timeout 60 - #:environment-variables - `(,(string-append - "GUIX_LOCPATH=" #$glibc-utf8-locales "/lib/locale") - "LC_ALL=en_US.utf8" - "PATH=/run/current-system/profile/bin") ; for hooks - #:log-file "/var/log/guix-build-coordinator/coordinator.log")) - (stop #~(make-kill-destructor)))))) + (start #~(lambda args + (parameterize ((%current-logfile-date-format "")) + (apply + (make-forkexec-constructor + (list #$(make-guix-build-coordinator-start-script + database-uri-string + allocation-strategy + "/var/run/guix-build-coordinator/pid" + package + #:agent-communication-uri-string + agent-communication-uri-string + #:client-communication-uri-string + client-communication-uri-string + #:hooks hooks + #:parallel-hooks parallel-hooks + #:guile guile)) + #:user #$user + #:group #$group + #:pid-file "/var/run/guix-build-coordinator/pid" + ;; Allow time for migrations to run + #:pid-file-timeout 60 + #:environment-variables + `(,(string-append + "GUIX_LOCPATH=" #$glibc-utf8-locales "/lib/locale") + "LC_ALL=en_US.utf8" + "PATH=/run/current-system/profile/bin") ; for hooks + #:log-file "/var/log/guix-build-coordinator/coordinator.log") + args)))) + (stop #~(make-kill-destructor)) + (modules + `((shepherd comm) + ,@%default-modules)))))) (define (guix-build-coordinator-activation config) #~(begin @@ -406,6 +417,7 @@ (define (guix-build-coordinator-agent-shepherd-services config) (match-record config <guix-build-coordinator-agent-configuration> (package user coordinator authentication max-parallel-builds + max-allocated-builds max-1min-load-average derivation-substitute-urls non-derivation-substitute-urls systems) @@ -414,57 +426,67 @@ (documentation "Guix Build Coordinator Agent") (provision '(guix-build-coordinator-agent)) (requirement '(networking)) - (start #~(make-forkexec-constructor - (list #$(file-append package "/bin/guix-build-coordinator-agent") - #$(string-append "--coordinator=" coordinator) - #$@(match authentication - (($ <guix-build-coordinator-agent-password-auth> - uuid password) - #~(#$(string-append "--uuid=" uuid) - #$(string-append "--password=" password))) - (($ <guix-build-coordinator-agent-password-file-auth> - uuid password-file) - #~(#$(string-append "--uuid=" uuid) - #$(string-append "--password-file=" - password-file))) - (($ <guix-build-coordinator-agent-dynamic-auth> - agent-name token) - #~(#$(string-append "--name=" agent-name) - #$(string-append "--dynamic-auth-token=" token))) - (($ - <guix-build-coordinator-agent-dynamic-auth-with-file> - agent-name token-file) - #~(#$(string-append "--name=" agent-name) - #$(string-append "--dynamic-auth-token-file=" - token-file)))) - #$(simple-format #f "--max-parallel-builds=~A" - max-parallel-builds) - #$@(if max-1min-load-average - #~(#$(simple-format #f "--max-1min-load-average=~A" - max-1min-load-average)) - #~()) - #$@(if derivation-substitute-urls - #~(#$(string-append - "--derivation-substitute-urls=" + (start + #~(lambda _ + (parameterize ((%current-logfile-date-format "")) + (fork+exec-command + (list #$(file-append package "/bin/guix-build-coordinator-agent") + #$(string-append "--coordinator=" coordinator) + #$@(match authentication + (($ <guix-build-coordinator-agent-password-auth> + uuid password) + #~(#$(string-append "--uuid=" uuid) + #$(string-append "--password=" password))) + (($ <guix-build-coordinator-agent-password-file-auth> + uuid password-file) + #~(#$(string-append "--uuid=" uuid) + #$(string-append "--password-file=" + password-file))) + (($ <guix-build-coordinator-agent-dynamic-auth> + agent-name token) + #~(#$(string-append "--name=" agent-name) + #$(string-append "--dynamic-auth-token=" token))) + (($ + <guix-build-coordinator-agent-dynamic-auth-with-file> + agent-name token-file) + #~(#$(string-append "--name=" agent-name) + #$(string-append "--dynamic-auth-token-file=" + token-file)))) + #$(simple-format #f "--max-parallel-builds=~A" + max-parallel-builds) + #$@(if max-allocated-builds + #~(#$(simple-format #f "--max-allocated-builds=~A" + max-allocated-builds)) + #~()) + #$@(if max-1min-load-average + #~(#$(simple-format #f "--max-1min-load-average=~A" + max-1min-load-average)) + #~()) + #$@(if derivation-substitute-urls + #~(#$(string-append + "--derivation-substitute-urls=" (string-join derivation-substitute-urls " "))) - #~()) - #$@(if non-derivation-substitute-urls - #~(#$(string-append - "--non-derivation-substitute-urls=" - (string-join non-derivation-substitute-urls " "))) - #~()) - #$@(map (lambda (system) - (string-append "--system=" system)) - (or systems '()))) - #:user #$user - #:environment-variables - `(,(string-append - "GUIX_LOCPATH=" #$glibc-utf8-locales "/lib/locale") - ;; XDG_CACHE_HOME is used by Guix when caching narinfo files - "XDG_CACHE_HOME=/var/cache/guix-build-coordinator-agent" - "LC_ALL=en_US.utf8") - #:log-file "/var/log/guix-build-coordinator/agent.log")) - (stop #~(make-kill-destructor)))))) + #~()) + #$@(if non-derivation-substitute-urls + #~(#$(string-append + "--non-derivation-substitute-urls=" + (string-join non-derivation-substitute-urls " "))) + #~()) + #$@(map (lambda (system) + (string-append "--system=" system)) + (or systems '()))) + #:user #$user + #:environment-variables + `(,(string-append + "GUIX_LOCPATH=" #$glibc-utf8-locales "/lib/locale") + ;; XDG_CACHE_HOME is used by Guix when caching narinfo files + "XDG_CACHE_HOME=/var/cache/guix-build-coordinator-agent" + "LC_ALL=en_US.utf8") + #:log-file "/var/log/guix-build-coordinator/agent.log")))) + (stop #~(make-kill-destructor)) + (modules + `((shepherd comm) + ,@%default-modules)))))) (define (guix-build-coordinator-agent-activation config) #~(begin @@ -517,39 +539,44 @@ (provision '(guix-build-coordinator-queue-builds)) (requirement '(networking)) (start - #~(make-forkexec-constructor - (list - #$(file-append - package - "/bin/guix-build-coordinator-queue-builds-from-guix-data-service") - #$(string-append "--coordinator=" coordinator) - #$@(map (lambda (system) - (string-append "--system=" system)) - (or systems '())) - #$@(map (match-lambda - ((system . target) - (string-append "--system-and-target=" system "=" target))) - (or systems-and-targets '())) - #$@(if guix-data-service - #~(#$(string-append "--guix-data-service=" guix-data-service)) - #~()) - #$@(if guix-data-service-build-server-id - #~(#$(simple-format - #f - "--guix-data-service-build-server-id=~A" - guix-data-service-build-server-id)) - #~()) - #$@(if processed-commits-file - #~(#$(string-append "--processed-commits-file=" - processed-commits-file)) - #~())) - #:user #$user - #:environment-variables - `(,(string-append - "GUIX_LOCPATH=" #$glibc-utf8-locales "/lib/locale") - "LC_ALL=en_US.utf8") - #:log-file "/var/log/guix-build-coordinator/queue-builds.log")) - (stop #~(make-kill-destructor)))))) + #~(lambda _ + (parameterize ((%current-logfile-date-format "")) + (fork+exec-command + (list + #$(file-append + package + "/bin/guix-build-coordinator-queue-builds-from-guix-data-service") + #$(string-append "--coordinator=" coordinator) + #$@(map (lambda (system) + (string-append "--system=" system)) + (or systems '())) + #$@(map (match-lambda + ((system . target) + (string-append "--system-and-target=" system "=" target))) + (or systems-and-targets '())) + #$@(if guix-data-service + #~(#$(string-append "--guix-data-service=" guix-data-service)) + #~()) + #$@(if guix-data-service-build-server-id + #~(#$(simple-format + #f + "--guix-data-service-build-server-id=~A" + guix-data-service-build-server-id)) + #~()) + #$@(if processed-commits-file + #~(#$(string-append "--processed-commits-file=" + processed-commits-file)) + #~())) + #:user #$user + #:environment-variables + `(,(string-append + "GUIX_LOCPATH=" #$glibc-utf8-locales "/lib/locale") + "LC_ALL=en_US.utf8") + #:log-file "/var/log/guix-build-coordinator/queue-builds.log")))) + (stop #~(make-kill-destructor)) + (modules + `((shepherd comm) + ,@%default-modules)))))) (define (guix-build-coordinator-queue-builds-activation config) #~(begin diff --git a/gnu/services/ldap.scm b/gnu/services/ldap.scm new file mode 100644 index 0000000000..49a33fac08 --- /dev/null +++ b/gnu/services/ldap.scm @@ -0,0 +1,317 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018, 2019, 2022 Ricardo Wurmus <rekado@elephly.net> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of thye GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gnu services ldap) + #:use-module (gnu packages admin) + #:use-module (gnu packages openldap) + #:use-module (gnu services) + #:use-module (gnu services configuration) + #:use-module (gnu services shepherd) + #:use-module (gnu system shadow) + #:use-module (guix gexp) + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) + #:use-module (ice-9 string-fun) + #:export (directory-server-service-type + directory-server-shepherd-service + + directory-server-instance-configuration + slapd-configuration + backend-configuration)) + +(define (uglify-field-name name) + (let ((str (string-map (match-lambda + (#\- #\_) + (chr chr)) + (symbol->string name)))) + (if (string-suffix? "?" str) + (substring str 0 (1- (string-length str))) + str))) +(define (serialize-field field-name val) + (format #t "~a = ~a\n" (uglify-field-name field-name) val)) +(define serialize-string serialize-field) +(define-maybe string) +(define (serialize-boolean field-name val) + (serialize-field field-name (if val "True" "False"))) +(define (serialize-number field-name val) + (serialize-field field-name (number->string val))) + + +(define-configuration slapd-configuration + (instance-name + (string "localhost") + "Sets the name of the instance. You can refer to this value in other +parameters of this INF file using the \"{instance_name}\" variable. Note that +this name cannot be changed after the installation!") + (user + (string "dirsrv") + "Sets the user name the ns-slapd process will use after the service +started.") + (group + (string "dirsrv") + "Sets the group name the ns-slapd process will use after the service +started.") + (port + (number 389) + "Sets the TCP port the instance uses for LDAP connections.") + (secure-port + (number 636) + "Sets the TCP port the instance uses for TLS-secured LDAP +connections (LDAPS).") + (root-dn + (string "cn=Directory Manager") + "Sets the Distinquished Name (DN) of the administrator account for this +instance.") + (root-password + (string "{invalid}YOU-SHOULD-CHANGE-THIS") + "Sets the password of the account specified in the \"root-dn\" parameter. +You can either set this parameter to a plain text password dscreate hashes +during the installation or to a \"{algorithm}hash\" string generated by the +pwdhash utility. Note that setting a plain text password can be a security +risk if unprivileged users can read this INF file!") + (self-sign-cert + (boolean #t) + "Sets whether the setup creates a self-signed certificate and enables TLS +encryption during the installation. This is not suitable for production, but +it enables administrators to use TLS right after the installation. You can +replace the self-signed certificate with a certificate issued by a certificate +authority.") + (self-sign-cert-valid-months + (number 24) + "Set the number of months the issued self-signed certificate will be valid.") + (backup-dir + (string "/var/lib/dirsrv/slapd-{instance_name}/bak") + "Set the backup directory of the instance.") + (cert-dir + (string "/etc/dirsrv/slapd-{instance_name}") + "Sets the directory of the instance's Network Security Services (NSS) +database.") + (config-dir + (string "/etc/dirsrv/slapd-{instance_name}") + "Sets the configuration directory of the instance.") + (db-dir + (string "/var/lib/dirsrv/slapd-{instance_name}/db") + "Sets the database directory of the instance.") + (initconfig-dir + (string "/etc/dirsrv/registry") + "Sets the directory of the operating system's rc configuration directory.") + (ldif-dir + (string "/var/lib/dirsrv/slapd-{instance_name}/ldif") + "Sets the LDIF export and import directory of the instance.") + (lock-dir + (string "/var/lock/dirsrv/slapd-{instance_name}") + "Sets the lock directory of the instance.") + (log-dir + (string "/var/log/dirsrv/slapd-{instance_name}") + "Sets the log directory of the instance.") + (run-dir + (string "/run/dirsrv") + "Sets PID directory of the instance.") + (schema-dir + (string "/etc/dirsrv/slapd-{instance_name}/schema") + "Sets schema directory of the instance.") + (tmp-dir + (string "/tmp") + "Sets the temporary directory of the instance.")) + +(define (serialize-slapd-configuration field-name val) + #t) + + +(define-configuration backend-userroot-configuration + (create-suffix-entry? + (boolean #false) + "Set this parameter to #true to create a generic root node entry for the +suffix in the database.") + (require-index? + (boolean #false) + "Set this parameter to #true to refuse unindexed searches in this +database.") + (sample-entries + (string "no") + "Set this parameter to \"yes\" to add latest version of sample entries to +this database. Or, use \"001003006\" to use the 1.3.6 version sample entries. +Use this option, for example, to create a database for testing purposes.") + (suffix + maybe-string + "Sets the root suffix stored in this database. If you do not set the +suffix attribute the install process will not create the backend/suffix. You +can also create multiple backends/suffixes by duplicating this section.")) + +(define (serialize-backend-userroot-configuration field-name val) + #t) + + +(define-configuration directory-server-instance-configuration + (package + (file-like 389-ds-base) + "The 389-ds-base package.") + ;; General settings + (config-version + (number 2) + "Sets the format version of the configuration file. To use the INF file +with dscreate, this parameter must be 2.") + (full-machine-name + (string "localhost") + "Sets the fully qualified hostname (FQDN) of this system.") + (selinux + (boolean #false) + "Enables SELinux detection and integration during the installation of this +instance. If set to #T, dscreate auto-detects whether SELinux is enabled.") + (strict-host-checking + (boolean #t) + "Sets whether the server verifies the forward and reverse record set in the +\"full-machine-name\" parameter. When installing this instance with GSSAPI +authentication behind a load balancer, set this parameter to #F.") + (systemd + (boolean #false) + "Enables systemd platform features. If set to #T, dscreate auto-detects +whether systemd is installed.") + (slapd + (slapd-configuration (slapd-configuration)) + "Configuration of slapd.") + (backend-userroot + (backend-userroot-configuration (backend-userroot-configuration)) + "Configuration of the userroot backend.")) + +(define (serialize-directory-server-instance-configuration x) + (format #t "[general]\n") + (serialize-configuration + x + (filter (lambda (field) + (not (member (configuration-field-name field) + '(package slapd backend-userroot)))) + directory-server-instance-configuration-fields)) + ;; Do not start instance while running dscreate. Do this later with + ;; shepherd. + (format #t "start = False\n") + (format #t "\n[slapd]\n") + (serialize-configuration + (directory-server-instance-configuration-slapd x) + slapd-configuration-fields) + (format #t "\n[backend-userroot]\n") + (serialize-configuration + (directory-server-instance-configuration-backend-userroot x) + backend-userroot-configuration-fields)) + +(define (directory-server-instance-config-file config) + "Return an LDAP directory server instance configuration file." + (let* ((slapd (directory-server-instance-configuration-slapd config)) + (instance-name (slapd-configuration-instance-name slapd))) + (plain-file + (string-append "dirsrv-" instance-name ".inf") + (with-output-to-string + (lambda () + (serialize-directory-server-instance-configuration config)))))) + +(define (directory-server-shepherd-service config) + "Return a shepherd service for an LDAP directory server with CONFIG." + (let* ((389-ds-base (directory-server-instance-configuration-package config)) + (slapd (directory-server-instance-configuration-slapd config)) + (instance-name + (slapd-configuration-instance-name slapd))) + (list (shepherd-service + (documentation "Run an 389 directory server instance.") + (provision (list (symbol-append 'directory-server- + (string->symbol instance-name)))) + (requirement '()) + (start #~(make-forkexec-constructor + (list #$(file-append 389-ds-base "/sbin/dsctl") + #$instance-name "start") + #:pid-file + (string-append + #$(slapd-configuration-run-dir slapd) + "/slapd-" #$instance-name ".pid"))) + (stop #~(make-kill-destructor)))))) + +(define (directory-server-accounts config) + (let* ((slapd (directory-server-instance-configuration-slapd config)) + (user (slapd-configuration-user slapd)) + (group (slapd-configuration-group slapd))) + (list (user-group + (name group) + (system? #true)) + (user-account + (name user) + (group group) + (system? #true) + (comment "System user for the 389 directory server") + (home-directory "/var/empty") + (shell (file-append shadow "/sbin/nologin")))))) + +(define (directory-server-activation config) + (let* ((389-ds-base (directory-server-instance-configuration-package config)) + (config-file (directory-server-instance-config-file config)) + (slapd (directory-server-instance-configuration-slapd config)) + (instance-name (slapd-configuration-instance-name slapd)) + (user (slapd-configuration-user slapd)) + (group (slapd-configuration-group slapd)) + (instantiate (lambda (proc) + (string-replace-substring + (proc slapd) "{instance_name}" instance-name))) + (config-dir (instantiate slapd-configuration-config-dir)) + (all-dirs (delete-duplicates + (map (compose dirname instantiate) + (list slapd-configuration-backup-dir + slapd-configuration-cert-dir + slapd-configuration-db-dir + slapd-configuration-ldif-dir + slapd-configuration-lock-dir + slapd-configuration-log-dir + slapd-configuration-run-dir + slapd-configuration-schema-dir))))) + ;; 389-ds-base doesn't let us update an instance configuration, so bail + ;; out when the configuration directory already exists. + #~(begin + (use-modules (ice-9 match) + (guix build utils)) + (if (file-exists? #$config-dir) + (format #t + "directory-server: Instance configuration for `~a' already exists. Skipping.\n" + #$instance-name) + (let ((owner (getpwnam #$user))) + (for-each (lambda (dir) + (mkdir-p dir) + (chown dir (passwd:uid owner) (passwd:gid owner))) + (sort '#$all-dirs string<=)) + (system* #$(file-append 389-ds-base "/sbin/dscreate") + "from-file" #$config-file)))))) + +(define directory-server-service-type + (service-type (name 'directory-server) + (extensions + (list (service-extension shepherd-root-service-type + directory-server-shepherd-service) + (service-extension activation-service-type + directory-server-activation) + (service-extension account-service-type + directory-server-accounts))) + (default-value (directory-server-instance-configuration)) + (description + "Run a directory server instance."))) + +(define (generate-directory-server-documentation) + (generate-documentation + `((directory-server-instance-configuration + ,directory-server-instance-configuration-fields + (slapd slapd-configuration) + (backend-userroot backend-userroot-configuration)) + (slapd-configuration ,slapd-configuration-fields) + (backend-userroot-configuration + ,backend-userroot-configuration-fields)) + 'directory-server-instance-configuration)) diff --git a/gnu/services/lightdm.scm b/gnu/services/lightdm.scm index 07f2e808dd..7e3864fec2 100644 --- a/gnu/services/lightdm.scm +++ b/gnu/services/lightdm.scm @@ -40,7 +40,6 @@ #:use-module (guix records) #:use-module (ice-9 format) #:use-module (ice-9 match) - #:use-module (oop goops) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (lightdm-seat-configuration @@ -177,17 +176,18 @@ Provider Interface (AT-SPI).") "Extra configuration values to append to the LightDM GTK Greeter configuration file.")) -(define (strip-class-name-brackets name) - "Remove the '<<' and '>>' brackets from NAME, a symbol." - (let ((name* (symbol->string name))) - (if (and (string-prefix? "<<" name*) - (string-suffix? ">>" name*)) - (string->symbol (string-drop (string-drop-right name* 2) 2)) - (error "unexpected class name" name*)))) +(define (strip-record-type-name-brackets name) + "Remove the '<' and '>' brackets from NAME, a symbol." + (let ((name (symbol->string name))) + (if (and (string-prefix? "<" name) + (string-suffix? ">" name)) + (string->symbol (string-drop (string-drop-right name 1) 1)) + (error "unexpected record type name" name)))) (define (config->name config) "Return the constructor name (a symbol) from CONFIG." - (strip-class-name-brackets (class-name (class-of config)))) + (strip-record-type-name-brackets + (record-type-name (struct-vtable config)))) (define (greeter-configuration->greeter-fields config) "Return the fields of CONFIG, a greeter configuration." @@ -323,7 +323,7 @@ a symbol." (define (list-of-greeter-configurations? greeter-configs) (and ((list-of greeter-configuration?) greeter-configs) ;; Greeter configurations must also not be provided more than once. - (let* ((types (map (cut (compose class-name class-of) <>) + (let* ((types (map (compose record-type-name struct-vtable) greeter-configs)) (dupes (filter (lambda (type) (< 1 (count (cut eq? type <>) types))) @@ -374,7 +374,7 @@ security: \" -SecurityTypes None\" )) @end lisp -Or to set a PasswordFile for the classic (unsecure) VncAuth mecanism: +Or to set a PasswordFile for the classic (unsecure) VncAuth mechanism: @lisp (vnc-server-command (file-append tigervnc-server \"/bin/Xvnc\" diff --git a/gnu/services/mail.scm b/gnu/services/mail.scm index 43f144a42d..6f588679b1 100644 --- a/gnu/services/mail.scm +++ b/gnu/services/mail.scm @@ -35,6 +35,7 @@ #:use-module (gnu packages admin) #:use-module (gnu packages dav) #:use-module (gnu packages tls) + #:use-module (guix modules) #:use-module (guix records) #:use-module (guix packages) #:use-module (guix gexp) @@ -1512,64 +1513,61 @@ greyed out, instead of only later giving \"not selectable\" popup error. (lambda () (serialize-configuration config dovecot-configuration-fields))))))) - #~(begin - (use-modules (guix build utils)) - (define (mkdir-p/perms directory owner perms) - (mkdir-p directory) - (chown "/var/run/dovecot" (passwd:uid owner) (passwd:gid owner)) - (chmod directory perms)) - (define (build-subject parameters) - (string-concatenate - (map (lambda (pair) - (let ((k (car pair)) (v (cdr pair))) - (define (escape-char str chr) - (string-join (string-split str chr) (string #\\ chr))) - (string-append "/" k "=" - (escape-char (escape-char v #\=) #\/)))) - (filter (lambda (pair) (cdr pair)) parameters)))) - (define* (create-self-signed-certificate-if-absent - #:key private-key public-key (owner (getpwnam "root")) - (common-name (gethostname)) - (organization-name "Guix") - (organization-unit-name "Default Self-Signed Certificate") - (subject-parameters `(("CN" . ,common-name) - ("O" . ,organization-name) - ("OU" . ,organization-unit-name))) - (subject (build-subject subject-parameters))) - ;; Note that by default, OpenSSL outputs keys in PEM format. This - ;; is what we want. - (unless (file-exists? private-key) - (cond - ((zero? (system* (string-append #$openssl "/bin/openssl") - "genrsa" "-out" private-key "2048")) - (chown private-key (passwd:uid owner) (passwd:gid owner)) - (chmod private-key #o400)) - (else - (format (current-error-port) - "Failed to create private key at ~a.\n" private-key)))) - (unless (file-exists? public-key) - (cond - ((zero? (system* (string-append #$openssl "/bin/openssl") - "req" "-new" "-x509" "-key" private-key - "-out" public-key "-days" "3650" - "-batch" "-subj" subject)) - (chown public-key (passwd:uid owner) (passwd:gid owner)) - (chmod public-key #o444)) - (else - (format (current-error-port) - "Failed to create public key at ~a.\n" public-key))))) - (let ((user (getpwnam "dovecot"))) - (mkdir-p/perms "/var/run/dovecot" user #o755) - (mkdir-p/perms "/var/lib/dovecot" user #o755) - (mkdir-p/perms "/etc/dovecot" user #o755) - (copy-file #$(plain-file "dovecot.conf" config-str) - "/etc/dovecot/dovecot.conf") - (mkdir-p/perms "/etc/dovecot/private" user #o700) - (create-self-signed-certificate-if-absent - #:private-key "/etc/dovecot/private/default.pem" - #:public-key "/etc/dovecot/default.pem" - #:owner (getpwnam "root") - #:common-name (format #f "Dovecot service on ~a" (gethostname))))))) + (with-imported-modules (source-module-closure '((gnu build activation))) + #~(begin + (use-modules (guix build utils) (gnu build activation)) + (define (build-subject parameters) + (string-concatenate + (map (lambda (pair) + (let ((k (car pair)) (v (cdr pair))) + (define (escape-char str chr) + (string-join (string-split str chr) (string #\\ chr))) + (string-append "/" k "=" + (escape-char (escape-char v #\=) #\/)))) + (filter (lambda (pair) (cdr pair)) parameters)))) + (define* (create-self-signed-certificate-if-absent + #:key private-key public-key (owner (getpwnam "root")) + (common-name (gethostname)) + (organization-name "Guix") + (organization-unit-name "Default Self-Signed Certificate") + (subject-parameters `(("CN" . ,common-name) + ("O" . ,organization-name) + ("OU" . ,organization-unit-name))) + (subject (build-subject subject-parameters))) + ;; Note that by default, OpenSSL outputs keys in PEM format. This + ;; is what we want. + (unless (file-exists? private-key) + (cond + ((zero? (system* (string-append #$openssl "/bin/openssl") + "genrsa" "-out" private-key "2048")) + (chown private-key (passwd:uid owner) (passwd:gid owner)) + (chmod private-key #o400)) + (else + (format (current-error-port) + "Failed to create private key at ~a.\n" private-key)))) + (unless (file-exists? public-key) + (cond + ((zero? (system* (string-append #$openssl "/bin/openssl") + "req" "-new" "-x509" "-key" private-key + "-out" public-key "-days" "3650" + "-batch" "-subj" subject)) + (chown public-key (passwd:uid owner) (passwd:gid owner)) + (chmod public-key #o444)) + (else + (format (current-error-port) + "Failed to create public key at ~a.\n" public-key))))) + (let ((user (getpwnam "dovecot"))) + (mkdir-p/perms "/var/run/dovecot" user #o755) + (mkdir-p/perms "/var/lib/dovecot" user #o755) + (mkdir-p/perms "/etc/dovecot" user #o755) + (copy-file #$(plain-file "dovecot.conf" config-str) + "/etc/dovecot/dovecot.conf") + (mkdir-p/perms "/etc/dovecot/private" user #o700) + (create-self-signed-certificate-if-absent + #:private-key "/etc/dovecot/private/default.pem" + #:public-key "/etc/dovecot/default.pem" + #:owner (getpwnam "root") + #:common-name (format #f "Dovecot service on ~a" (gethostname)))))))) (define (dovecot-shepherd-service config) "Return a list of <shepherd-service> for CONFIG." @@ -1653,6 +1651,8 @@ by @code{dovecot-configuration}. @var{config} may also be created by opensmtpd-configuration? (package opensmtpd-configuration-package (default opensmtpd)) + (shepherd-requirement opensmtpd-configuration-shepherd-requirement + (default '())) ; list of symbols (config-file opensmtpd-configuration-config-file (default %default-opensmtpd-config-file)) (setgid-commands? opensmtpd-setgid-commands? (default #t))) @@ -1668,18 +1668,18 @@ action outbound relay match from local for any action outbound ")) -(define opensmtpd-shepherd-service - (match-lambda - (($ <opensmtpd-configuration> package config-file) - (list (shepherd-service - (provision '(smtpd)) - (requirement '(loopback)) - (documentation "Run the OpenSMTPD daemon.") - (start (let ((smtpd (file-append package "/sbin/smtpd"))) - #~(make-forkexec-constructor - (list #$smtpd "-f" #$config-file) - #:pid-file "/var/run/smtpd.pid"))) - (stop #~(make-kill-destructor))))))) +(define (opensmtpd-shepherd-service config) + (match-record config <opensmtpd-configuration> + (package config-file shepherd-requirement) + (list (shepherd-service + (provision '(smtpd)) + (requirement `(loopback ,@shepherd-requirement)) + (documentation "Run the OpenSMTPD daemon.") + (start (let ((smtpd (file-append package "/sbin/smtpd"))) + #~(make-forkexec-constructor + (list #$smtpd "-f" #$config-file) + #:pid-file "/var/run/smtpd.pid"))) + (stop #~(make-kill-destructor)))))) (define %opensmtpd-accounts (list (user-group @@ -1700,58 +1700,56 @@ match from local for any action outbound (home-directory "/var/empty") (shell (file-append shadow "/sbin/nologin"))))) -(define opensmtpd-activation - (match-lambda - (($ <opensmtpd-configuration> package config-file) - (let ((smtpd (file-append package "/sbin/smtpd"))) - #~(begin - (use-modules (guix build utils)) - ;; Create mbox and spool directories. - (mkdir-p "/var/mail") - (mkdir-p "/var/spool/smtpd") - (chmod "/var/spool/smtpd" #o711) - (mkdir-p "/var/spool/mail") - (chmod "/var/spool/mail" #o711)))))) +(define (opensmtpd-activation config) + (match-record config <opensmtpd-configuration> (package config-file) + (let ((smtpd (file-append package "/sbin/smtpd"))) + #~(begin + (use-modules (guix build utils)) + ;; Create mbox and spool directories. + (mkdir-p "/var/mail") + (mkdir-p "/var/spool/smtpd") + (chmod "/var/spool/smtpd" #o711) + (mkdir-p "/var/spool/mail") + (chmod "/var/spool/mail" #o711))))) (define %opensmtpd-pam-services (list (unix-pam-service "smtpd"))) -(define opensmtpd-set-gids - (match-lambda - (($ <opensmtpd-configuration> package config-file set-gids?) - (if set-gids? - (list - (setuid-program - (program (file-append package "/sbin/smtpctl")) - (setuid? #false) - (setgid? #true) - (group "smtpq")) - (setuid-program - (program (file-append package "/sbin/sendmail")) - (setuid? #false) - (setgid? #true) - (group "smtpq")) - (setuid-program - (program (file-append package "/sbin/send-mail")) - (setuid? #false) - (setgid? #true) - (group "smtpq")) - (setuid-program - (program (file-append package "/sbin/makemap")) - (setuid? #false) - (setgid? #true) - (group "smtpq")) - (setuid-program - (program (file-append package "/sbin/mailq")) - (setuid? #false) - (setgid? #true) - (group "smtpq")) - (setuid-program - (program (file-append package "/sbin/newaliases")) - (setuid? #false) - (setgid? #true) - (group "smtpq"))) - '())))) +(define (opensmtpd-set-gids config) + (match-record config <opensmtpd-configuration> (package config-file setgid-commands?) + (if setgid-commands? + (list + (setuid-program + (program (file-append package "/sbin/smtpctl")) + (setuid? #false) + (setgid? #true) + (group "smtpq")) + (setuid-program + (program (file-append package "/sbin/sendmail")) + (setuid? #false) + (setgid? #true) + (group "smtpq")) + (setuid-program + (program (file-append package "/sbin/send-mail")) + (setuid? #false) + (setgid? #true) + (group "smtpq")) + (setuid-program + (program (file-append package "/sbin/makemap")) + (setuid? #false) + (setgid? #true) + (group "smtpq")) + (setuid-program + (program (file-append package "/sbin/mailq")) + (setuid? #false) + (setgid? #true) + (group "smtpq")) + (setuid-program + (program (file-append package "/sbin/newaliases")) + (setuid? #false) + (setgid? #true) + (group "smtpq"))) + '()))) (define opensmtpd-service-type (service-type diff --git a/gnu/services/mcron.scm b/gnu/services/mcron.scm index 23760ebda4..52332d6123 100644 --- a/gnu/services/mcron.scm +++ b/gnu/services/mcron.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,6 +19,7 @@ (define-module (gnu services mcron) #:use-module (gnu services) + #:use-module (gnu services configuration) #:use-module (gnu services shepherd) #:use-module (gnu packages guile-xyz) #:use-module (guix deprecation) @@ -30,6 +32,8 @@ mcron-configuration? mcron-configuration-mcron mcron-configuration-jobs + mcron-configuration-log? + mcron-configuration-log-format mcron-service-type)) @@ -48,13 +52,23 @@ ;;; ;;; Code: -(define-record-type* <mcron-configuration> mcron-configuration - make-mcron-configuration - mcron-configuration? - (mcron mcron-configuration-mcron ;file-like - (default mcron)) - (jobs mcron-configuration-jobs ;list of <mcron-job> - (default '()))) +(define list-of-gexps? + (list-of gexp?)) + +(define-configuration/no-serialization mcron-configuration + (mcron (file-like mcron) "The mcron package to use.") + (jobs + (list-of-gexps '()) + "This is a list of gexps (@pxref{G-Expressions}), where each gexp +corresponds to an mcron job specification (@pxref{Syntax, mcron job +specifications,, mcron, GNU@tie{}mcron}).") + (log? (boolean #t) "Log messages to standard output.") + (log-format + (string "~1@*~a ~a: ~a~%") + "@code{(ice-9 format)} format string for log messages. The default value +produces messages like \"@samp{@var{pid} @var{name}: +@var{message}\"} (@pxref{Invoking mcron, Invoking,, mcron, GNU@tie{}mcron}). +Each message is also prefixed by a timestamp by GNU Shepherd.")) (define (job-files mcron jobs) "Return a list of file-like object for JOBS, a list of gexps." @@ -124,21 +138,25 @@ files." (define mcron-shepherd-services (match-lambda - (($ <mcron-configuration> mcron ()) ;nothing to do! + (($ <mcron-configuration> mcron ()) ;nothing to do! '()) - (($ <mcron-configuration> mcron jobs) + (($ <mcron-configuration> mcron jobs log? log-format) (let ((files (job-files mcron jobs))) (list (shepherd-service (provision '(mcron)) (requirement '(user-processes)) (modules `((srfi srfi-1) (srfi srfi-26) - (ice-9 popen) ;for the 'schedule' action + (ice-9 popen) ;for the 'schedule' action (ice-9 rdelim) (ice-9 match) ,@%default-modules)) (start #~(make-forkexec-constructor - (list (string-append #$mcron "/bin/mcron") #$@files) + (list (string-append #$mcron "/bin/mcron") + #$@(if log? + #~("--log" "--log-format" #$log-format) + #~()) + #$@files) ;; Disable auto-compilation of the job files and set a ;; sane value for 'PATH'. @@ -172,4 +190,11 @@ files." jobs))))) (default-value (mcron-configuration)))) ;empty job list + +;;; +;;; Generate documentation. +;;; +(define (generate-doc) + (configuration->documentation 'mcron-configuration)) + ;;; mcron.scm ends here diff --git a/gnu/services/monitoring.scm b/gnu/services/monitoring.scm index 9c8704092c..44e2e8886c 100644 --- a/gnu/services/monitoring.scm +++ b/gnu/services/monitoring.scm @@ -224,15 +224,12 @@ Prometheus.") (define (serialize-string field-name val) - (if (and (string? val) (string=? val "")) + (if (or (eq? 'user field-name) + (eq? 'group field-name) + (and (string? val) (string=? val ""))) "" (serialize-field field-name val))) -(define group? string?) - -(define serialize-group - (const "")) - (define include-files? list?) (define (serialize-include-files field-name val) @@ -256,8 +253,8 @@ Prometheus.") (user (string "zabbix") "User who will run the Zabbix server.") - (group ;for zabbix-server-account procedure - (group "zabbix") + (group + (string "zabbix") "Group who will run the Zabbix server.") (db-host (string "127.0.0.1") @@ -407,7 +404,10 @@ configuration file.")) /etc/ssl/certs" "SSL_CERT_FILE=/run/current-system/profile\ /etc/ssl/certs/ca-certificates.crt"))) - (stop #~(make-kill-destructor)))))) + (stop #~(make-kill-destructor + ;; The server needs to finish database work on shutdown + ;; which can take a while for big or busy databases. + #:grace-period 60)))))) (define zabbix-server-service-type (service-type @@ -438,7 +438,7 @@ results in a Web interface."))) (string "zabbix") "User who will run the Zabbix agent.") (group - (group "zabbix") + (string "zabbix") "Group who will run the Zabbix agent.") (hostname (string "") @@ -516,6 +516,18 @@ configuration file.")) (format port #$(serialize-configuration config zabbix-agent-configuration-fields))))))) +(define (zabbix-agent-arguments config) + #~(let* ((config-file #$(zabbix-agent-config-file config)) + (agent #$(zabbix-agent-configuration-zabbix-agent config)) + (agent2? (file-exists? (string-append agent "/sbin/zabbix_agent2")))) + (if agent2? + (list (string-append agent "/sbin/zabbix_agent2") + "-config" config-file + "-foreground") + (list (string-append agent "/sbin/zabbix_agentd") + "--config" config-file + "--foreground")))) + (define (zabbix-agent-shepherd-service config) "Return a <shepherd-service> for Zabbix agent with CONFIG." (list (shepherd-service @@ -523,10 +535,7 @@ configuration file.")) (requirement '(user-processes)) (documentation "Run Zabbix agent daemon.") (start #~(make-forkexec-constructor - (list #$(file-append (zabbix-agent-configuration-zabbix-agent config) - "/sbin/zabbix_agentd") - "--config" #$(zabbix-agent-config-file config) - "--foreground") + #$(zabbix-agent-arguments config) #:user #$(zabbix-agent-configuration-user config) #:group #$(zabbix-agent-configuration-group config) #:pid-file #$(zabbix-agent-configuration-pid-file config) @@ -576,7 +585,7 @@ fastcgi_param PHP_VALUE \"post_max_size = 16M (define (zabbix-front-end-nginx-extension config) (match config - (($ <zabbix-front-end-configuration> _ server nginx) + (($ <zabbix-front-end-configuration> server nginx) (if (null? nginx) (list (nginx-server-configuration @@ -622,8 +631,8 @@ create it manually.") (define (zabbix-front-end-config config) (match-record config <zabbix-front-end-configuration> - (%location db-host db-port db-name db-user db-password db-secret-file - zabbix-host zabbix-port) + (db-host db-port db-name db-user db-password db-secret-file + zabbix-host zabbix-port %location) (mixed-text-file "zabbix.conf.php" "\ <?php diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm index 9d85728371..89ce16f6af 100644 --- a/gnu/services/networking.scm +++ b/gnu/services/networking.scm @@ -18,6 +18,8 @@ ;;; Copyright © 2021 Christine Lemmer-Webber <cwebber@dustycloud.org> ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> ;;; Copyright © 2021 Guillaume Le Vaillant <glv@posteo.net> +;;; Copyright © 2022, 2023 Andrew Tropin <andrew@trop.in> +;;; Copyright © 2023 Declan Tsien <declantsien@riseup.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -66,6 +68,9 @@ #:use-module (guix modules) #:use-module (guix packages) #:use-module (guix deprecation) + #:use-module (guix diagnostics) + #:autoload (guix ui) (display-hint) + #:use-module (guix i18n) #:use-module (rnrs enums) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) @@ -77,6 +82,10 @@ static-networking-service-type) #:export (%facebook-host-aliases dhcp-client-service-type + dhcp-client-configuration + dhcp-client-configuration? + dhcp-client-configuration-package + dhcp-client-configuration-interfaces dhcpd-service-type dhcpd-configuration @@ -259,52 +268,80 @@ fe80::1%lo0 connect.facebook.net fe80::1%lo0 www.connect.facebook.net fe80::1%lo0 apps.facebook.com\n") + +(define-record-type* <dhcp-client-configuration> + dhcp-client-configuration make-dhcp-client-configuration + dhcp-client-configuration? + (package dhcp-client-configuration-package ;file-like + (default isc-dhcp)) + (interfaces dhcp-client-configuration-interfaces + (default 'all))) ;'all | list of strings + +(define dhcp-client-shepherd-service + (match-lambda + ((? dhcp-client-configuration? config) + (let ((package (dhcp-client-configuration-package config)) + (interfaces (dhcp-client-configuration-interfaces config)) + (pid-file "/var/run/dhclient.pid")) + (list (shepherd-service + (documentation "Set up networking via DHCP.") + (requirement '(user-processes udev)) + + ;; XXX: Running with '-nw' ("no wait") avoids blocking for a minute when + ;; networking is unavailable, but also means that the interface is not up + ;; yet when 'start' completes. To wait for the interface to be ready, one + ;; should instead monitor udev events. + (provision '(networking)) + + (start #~(lambda _ + (define dhclient + (string-append #$package "/sbin/dhclient")) + + ;; When invoked without any arguments, 'dhclient' discovers all + ;; non-loopback interfaces *that are up*. However, the relevant + ;; interfaces are typically down at this point. Thus we perform + ;; our own interface discovery here. + (define valid? + (lambda (interface) + (and (arp-network-interface? interface) + (not (loopback-network-interface? interface)) + ;; XXX: Make sure the interfaces are up so that + ;; 'dhclient' can actually send/receive over them. + ;; Ignore those that cannot be activated. + (false-if-exception + (set-network-interface-up interface))))) + (define ifaces + (filter valid? + #$(match interfaces + ('all + #~(all-network-interface-names)) + (_ + #~'#$interfaces)))) + + (false-if-exception (delete-file #$pid-file)) + (let ((pid (fork+exec-command + (cons* dhclient "-nw" + "-pf" #$pid-file ifaces)))) + (and (zero? (cdr (waitpid pid))) + (read-pid-file #$pid-file))))) + (stop #~(make-kill-destructor)))))) + (package + (warning (G_ "'dhcp-client' service now expects a \ +'dhcp-client-configuration' record~%")) + (display-hint (G_ "The value associated with instances of +@code{dhcp-client-service-type} must now be a @code{dhcp-client-configuration} +record instead of a package. Please adjust your configuration accordingly.")) + (dhcp-client-shepherd-service + (dhcp-client-configuration + (package package)))))) + (define dhcp-client-service-type - (shepherd-service-type - 'dhcp-client - (lambda (dhcp) - (define dhclient - (file-append dhcp "/sbin/dhclient")) - - (define pid-file - "/var/run/dhclient.pid") - - (shepherd-service - (documentation "Set up networking via DHCP.") - (requirement '(user-processes udev)) - - ;; XXX: Running with '-nw' ("no wait") avoids blocking for a minute when - ;; networking is unavailable, but also means that the interface is not up - ;; yet when 'start' completes. To wait for the interface to be ready, one - ;; should instead monitor udev events. - (provision '(networking)) - - (start #~(lambda _ - ;; When invoked without any arguments, 'dhclient' discovers all - ;; non-loopback interfaces *that are up*. However, the relevant - ;; interfaces are typically down at this point. Thus we perform - ;; our own interface discovery here. - (define valid? - (lambda (interface) - (and (arp-network-interface? interface) - (not (loopback-network-interface? interface)) - ;; XXX: Make sure the interfaces are up so that - ;; 'dhclient' can actually send/receive over them. - ;; Ignore those that cannot be activated. - (false-if-exception - (set-network-interface-up interface))))) - (define ifaces - (filter valid? (all-network-interface-names))) - - (false-if-exception (delete-file #$pid-file)) - (let ((pid (fork+exec-command - (cons* #$dhclient "-nw" - "-pf" #$pid-file ifaces)))) - (and (zero? (cdr (waitpid pid))) - (read-pid-file #$pid-file))))) - (stop #~(make-kill-destructor)))) - isc-dhcp - (description "Run @command{dhcp}, a Dynamic Host Configuration + (service-type (name 'dhcp-client) + (extensions + (list (service-extension shepherd-root-service-type + dhcp-client-shepherd-service))) + (default-value (dhcp-client-configuration)) + (description "Run @command{dhcp}, a Dynamic Host Configuration Protocol (DHCP) client, on all the non-loopback network interfaces."))) (define-record-type* <dhcpd-configuration> @@ -326,46 +363,46 @@ Protocol (DHCP) client, on all the non-loopback network interfaces."))) (interfaces dhcpd-configuration-interfaces (default '()))) -(define dhcpd-shepherd-service - (match-lambda - (($ <dhcpd-configuration> package config-file version run-directory - lease-file pid-file interfaces) - (unless config-file - (error "Must supply a config-file")) - (list (shepherd-service - ;; Allow users to easily run multiple versions simultaneously. - (provision (list (string->symbol - (string-append "dhcpv" version "-daemon")))) - (documentation (string-append "Run the DHCPv" version " daemon")) - (requirement '(networking)) - (start #~(make-forkexec-constructor - '(#$(file-append package "/sbin/dhcpd") - #$(string-append "-" version) - "-lf" #$lease-file - "-pf" #$pid-file - "-cf" #$config-file - #$@interfaces) - #:pid-file #$pid-file)) - (stop #~(make-kill-destructor))))))) +(define (dhcpd-shepherd-service config) + (match-record config <dhcpd-configuration> + (package config-file version run-directory + lease-file pid-file interfaces) + (unless config-file + (error "Must supply a config-file")) + (list (shepherd-service + ;; Allow users to easily run multiple versions simultaneously. + (provision (list (string->symbol + (string-append "dhcpv" version "-daemon")))) + (documentation (string-append "Run the DHCPv" version " daemon")) + (requirement '(networking)) + (start #~(make-forkexec-constructor + '(#$(file-append package "/sbin/dhcpd") + #$(string-append "-" version) + "-lf" #$lease-file + "-pf" #$pid-file + "-cf" #$config-file + #$@interfaces) + #:pid-file #$pid-file)) + (stop #~(make-kill-destructor)))))) -(define dhcpd-activation - (match-lambda - (($ <dhcpd-configuration> package config-file version run-directory - lease-file pid-file interfaces) - (with-imported-modules '((guix build utils)) - #~(begin - (unless (file-exists? #$run-directory) - (mkdir #$run-directory)) - ;; According to the DHCP manual (man dhcpd.leases), the lease - ;; database must be present for dhcpd to start successfully. - (unless (file-exists? #$lease-file) - (with-output-to-file #$lease-file - (lambda _ (display "")))) - ;; Validate the config. - (invoke/quiet - #$(file-append package "/sbin/dhcpd") - #$(string-append "-" version) - "-t" "-cf" #$config-file)))))) +(define (dhcpd-activation config) + (match-record config <dhcpd-configuration> + (package config-file version run-directory + lease-file pid-file interfaces) + (with-imported-modules '((guix build utils)) + #~(begin + (unless (file-exists? #$run-directory) + (mkdir #$run-directory)) + ;; According to the DHCP manual (man dhcpd.leases), the lease + ;; database must be present for dhcpd to start successfully. + (unless (file-exists? #$lease-file) + (with-output-to-file #$lease-file + (lambda _ (display "")))) + ;; Validate the config. + (invoke/quiet + #$(file-append package "/sbin/dhcpd") + #$(string-append "-" version) + "-t" "-cf" #$config-file))))) (define dhcpd-service-type (service-type @@ -416,16 +453,16 @@ daemon is responsible for allocating IP addresses to its client."))) (fold loop res x) (cons (format #f "~a" x) res))))) - (match ntp-server - (($ <ntp-server> type address options) - ;; XXX: It'd be neater if fields were validated at the syntax level (for - ;; static ones at least). Perhaps the Guix record type could support a - ;; predicate property on a field? - (unless (enum-set-member? type ntp-server-types) - (error "Invalid NTP server type" type)) - (string-join (cons* (symbol->string type) - address - (flatten options)))))) + (match-record ntp-server <ntp-server> + (type address options) + ;; XXX: It'd be neater if fields were validated at the syntax level (for + ;; static ones at least). Perhaps the Guix record type could support a + ;; predicate property on a field? + (unless (enum-set-member? type ntp-server-types) + (error "Invalid NTP server type" type)) + (string-join (cons* (symbol->string type) + address + (flatten options))))) (define %ntp-servers ;; Default set of NTP servers. These URLs are managed by the NTP Pool project. @@ -464,17 +501,16 @@ deprecated. Please use <ntp-server> records instead.\n") ((($ <ntp-server>) ($ <ntp-server>) ...) ntp-servers)))) -(define ntp-shepherd-service - (lambda (config) - (match config - (($ <ntp-configuration> ntp servers allow-large-adjustment?) - (let ((servers (ntp-configuration-servers config))) - ;; TODO: Add authentication support. - (define config - (string-append "driftfile /var/run/ntpd/ntp.drift\n" - (string-join (map ntp-server->string servers) - "\n") - " +(define (ntp-shepherd-service config) + (match-record config <ntp-configuration> + (ntp servers allow-large-adjustment?) + (let ((servers (ntp-configuration-servers config))) + ;; TODO: Add authentication support. + (define config + (string-append "driftfile /var/run/ntpd/ntp.drift\n" + (string-join (map ntp-server->string servers) + "\n") + " # Disable status queries as a workaround for CVE-2013-5211: # <http://support.ntp.org/bin/view/Main/SecurityNotice#DRDoS_Amplification_Attack_using>. restrict default kod nomodify notrap nopeer noquery limited @@ -488,21 +524,21 @@ restrict -6 ::1 # option by default, as documented in the 'ntp.conf' manual. restrict source notrap nomodify noquery\n")) - (define ntpd.conf - (plain-file "ntpd.conf" config)) - - (list (shepherd-service - (provision '(ntpd)) - (documentation "Run the Network Time Protocol (NTP) daemon.") - (requirement '(user-processes networking)) - (start #~(make-forkexec-constructor - (list (string-append #$ntp "/bin/ntpd") "-n" - "-c" #$ntpd.conf "-u" "ntpd" - #$@(if allow-large-adjustment? - '("-g") - '())) - #:log-file "/var/log/ntpd.log")) - (stop #~(make-kill-destructor))))))))) + (define ntpd.conf + (plain-file "ntpd.conf" config)) + + (list (shepherd-service + (provision '(ntpd)) + (documentation "Run the Network Time Protocol (NTP) daemon.") + (requirement '(user-processes networking)) + (start #~(make-forkexec-constructor + (list (string-append #$ntp "/bin/ntpd") "-n" + "-c" #$ntpd.conf "-u" "ntpd" + #$@(if allow-large-adjustment? + '("-g") + '())) + #:log-file "/var/log/ntpd.log")) + (stop #~(make-kill-destructor))))))) (define %ntp-accounts (list (user-account @@ -619,7 +655,8 @@ will keep the system clock synchronized with that of the given servers.") ;; while running, leading shepherd to disable it. To ;; prevent spamming stderr, redirect output to logfile. #:log-file "/var/log/ntpd.log")) - (stop #~(make-kill-destructor)))))) + (stop #~(make-kill-destructor)) + (actions (list (shepherd-configuration-action ntpd.conf))))))) (define (openntpd-service-activation config) "Return the activation gexp for CONFIG." @@ -708,19 +745,19 @@ daemon will keep the system clock synchronized with that of the given servers.") " ") "\n"))) entries))) -(define inetd-shepherd-service - (match-lambda - (($ <inetd-configuration> program ()) '()) ; empty list of entries -> do nothing - (($ <inetd-configuration> program entries) - (list - (shepherd-service - (documentation "Run inetd.") - (provision '(inetd)) - (requirement '(user-processes networking syslogd)) - (start #~(make-forkexec-constructor - (list #$program #$(inetd-config-file entries)) - #:pid-file "/var/run/inetd.pid")) - (stop #~(make-kill-destructor))))))) +(define (inetd-shepherd-service config) + (let ((entries (inetd-configuration-entries config))) + (if (null? entries) + '() ;do nothing + (let ((program (inetd-configuration-program config))) + (list (shepherd-service + (documentation "Run inetd.") + (provision '(inetd)) + (requirement '(user-processes networking syslogd)) + (start #~(make-forkexec-constructor + (list #$program #$(inetd-config-file entries)) + #:pid-file "/var/run/inetd.pid")) + (stop #~(make-kill-destructor)))))))) (define-public inetd-service-type (service-type @@ -904,102 +941,94 @@ applications in communication. It is used by Jami, for example."))) (define (tor-configuration->torrc config) "Return a 'torrc' file for CONFIG." - (match config - (($ <tor-configuration> tor config-file services - socks-socket-type control-socket?) - (computed-file - "torrc" - (with-imported-modules '((guix build utils)) - #~(begin - (use-modules (guix build utils) - (ice-9 match)) - - (call-with-output-file #$output - (lambda (port) - (display "\ + (match-record config <tor-configuration> + (tor config-file hidden-services socks-socket-type control-socket?) + (computed-file + "torrc" + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (ice-9 match)) + + (call-with-output-file #$output + (lambda (port) + (display "\ ### These lines were generated from your system configuration: DataDirectory /var/lib/tor Log notice syslog\n" port) - (when (eq? 'unix '#$socks-socket-type) - (display "\ + (when (eq? 'unix '#$socks-socket-type) + (display "\ SocksPort unix:/var/run/tor/socks-sock UnixSocksGroupWritable 1\n" port)) - (when #$control-socket? - (display "\ + (when #$control-socket? + (display "\ ControlSocket unix:/var/run/tor/control-sock GroupWritable RelaxDirModeCheck ControlSocketsGroupWritable 1\n" - port)) + port)) - (for-each (match-lambda - ((service (ports hosts) ...) - (format port "\ + (for-each (match-lambda + ((service (ports hosts) ...) + (format port "\ HiddenServiceDir /var/lib/tor/hidden-services/~a~%" - service) - (for-each (lambda (tcp-port host) - (format port "\ + service) + (for-each (lambda (tcp-port host) + (format port "\ HiddenServicePort ~a ~a~%" - tcp-port host)) - ports hosts))) - '#$(map (match-lambda - (($ <hidden-service> name mapping) - (cons name mapping))) - services)) - - (display "\ + tcp-port host)) + ports hosts))) + '#$(map (match-lambda + (($ <hidden-service> name mapping) + (cons name mapping))) + hidden-services)) + + (display "\ ### End of automatically generated lines.\n\n" port) - ;; Append the user's config file. - (call-with-input-file #$config-file - (lambda (input) - (dump-port input port))) - #t)))))))) + ;; Append the user's config file. + (call-with-input-file #$config-file + (lambda (input) + (dump-port input port))) + #t))))))) (define (tor-shepherd-service config) "Return a <shepherd-service> running Tor." - (match config - (($ <tor-configuration> tor) - (let* ((torrc (tor-configuration->torrc config)) - (tor (least-authority-wrapper - (file-append tor "/bin/tor") - #:name "tor" - #:mappings (list (file-system-mapping - (source "/var/lib/tor") - (target source) - (writable? #t)) - (file-system-mapping - (source "/dev/log") ;for syslog - (target source)) - (file-system-mapping - (source "/var/run/tor") - (target source) - (writable? #t)) - (file-system-mapping - (source torrc) - (target source))) - #:namespaces (delq 'net %namespaces)))) - (with-imported-modules (source-module-closure - '((gnu build shepherd) - (gnu system file-systems))) - (list (shepherd-service - (provision '(tor)) - - ;; Tor needs at least one network interface to be up, hence the - ;; dependency on 'loopback'. - (requirement '(user-processes loopback syslogd)) - - (modules '((gnu build shepherd) - (gnu system file-systems))) - - ;; XXX: #:pid-file won't work because the wrapped 'tor' - ;; program would print its PID within the user namespace - ;; instead of its actual PID outside. There's no inetd or - ;; systemd socket activation support either (there's - ;; 'sd_notify' though), so we're stuck with that. - (start #~(make-forkexec-constructor - (list #$tor "-f" #$torrc) - #:user "tor" #:group "tor")) - (stop #~(make-kill-destructor)) - (documentation "Run the Tor anonymous network overlay.")))))))) + (let* ((torrc (tor-configuration->torrc config)) + (tor (least-authority-wrapper + (file-append (tor-configuration-tor config) "/bin/tor") + #:name "tor" + #:mappings (list (file-system-mapping + (source "/var/lib/tor") + (target source) + (writable? #t)) + (file-system-mapping + (source "/dev/log") ;for syslog + (target source)) + (file-system-mapping + (source "/var/run/tor") + (target source) + (writable? #t)) + (file-system-mapping + (source torrc) + (target source))) + #:namespaces (delq 'net %namespaces)))) + (list (shepherd-service + (provision '(tor)) + + ;; Tor needs at least one network interface to be up, hence the + ;; dependency on 'loopback'. + (requirement '(user-processes loopback syslogd)) + + ;; XXX: #:pid-file won't work because the wrapped 'tor' + ;; program would print its PID within the user namespace + ;; instead of its actual PID outside. There's no inetd or + ;; systemd socket activation support either (there's + ;; 'sd_notify' though), so we're stuck with that. + (start #~(make-forkexec-constructor + (list #$tor "-f" #$torrc) + #:user "tor" #:group "tor")) + (stop #~(make-kill-destructor)) + (actions (list (shepherd-configuration-action torrc))) + (documentation "Run the Tor anonymous network overlay."))))) (define (tor-activation config) "Set up directories for Tor and its hidden services, if any." @@ -1114,19 +1143,20 @@ project's documentation} for more information." (dns network-manager-configuration-dns (default "default")) (vpn-plugins network-manager-configuration-vpn-plugins ;list of file-like - (default '()))) + (default '())) + (iwd? network-manager-configuration-iwd? (default #f))) -(define network-manager-activation +(define (network-manager-activation config) ;; Activation gexp for NetworkManager - (match-lambda - (($ <network-manager-configuration> network-manager dns vpn-plugins) - #~(begin - (use-modules (guix build utils)) - (mkdir-p "/etc/NetworkManager/system-connections") - #$@(if (equal? dns "dnsmasq") - ;; create directory to store dnsmasq lease file - '((mkdir-p "/var/lib/misc")) - '()))))) + (match-record config <network-manager-configuration> + (network-manager dns vpn-plugins) + #~(begin + (use-modules (guix build utils)) + (mkdir-p "/etc/NetworkManager/system-connections") + #$@(if (equal? dns "dnsmasq") + ;; create directory to store dnsmasq lease file + '((mkdir-p "/var/lib/misc")) + '())))) (define (vpn-plugin-directory plugins) "Return a directory containing PLUGINS, the NM VPN plugins." @@ -1159,44 +1189,47 @@ project's documentation} for more information." (cons (user-group (name "network-manager") (system? #t)) accounts)))) -(define network-manager-environment - (match-lambda - (($ <network-manager-configuration> network-manager dns vpn-plugins) - ;; Define this variable in the global environment such that - ;; "nmcli connection import type openvpn file foo.ovpn" works. - `(("NM_VPN_PLUGIN_DIR" - . ,(file-append (vpn-plugin-directory vpn-plugins) - "/lib/NetworkManager/VPN")))))) - -(define network-manager-shepherd-service - (match-lambda - (($ <network-manager-configuration> network-manager dns vpn-plugins) - (let ((conf (plain-file "NetworkManager.conf" - (string-append "[main]\ndns=" dns "\n"))) - (vpn (vpn-plugin-directory vpn-plugins))) - (list (shepherd-service - (documentation "Run the NetworkManager.") - (provision '(networking)) - (requirement '(user-processes dbus-system wpa-supplicant loopback)) - (start #~(make-forkexec-constructor - (list (string-append #$network-manager - "/sbin/NetworkManager") - (string-append "--config=" #$conf) - "--no-daemon") - #:environment-variables - (list (string-append "NM_VPN_PLUGIN_DIR=" #$vpn - "/lib/NetworkManager/VPN") - ;; Override non-existent default users - "NM_OPENVPN_USER=" - "NM_OPENVPN_GROUP="))) - (stop #~(make-kill-destructor)))))))) +(define (network-manager-environment config) + (match-record config <network-manager-configuration> + (network-manager dns vpn-plugins) + ;; Define this variable in the global environment such that + ;; "nmcli connection import type openvpn file foo.ovpn" works. + `(("NM_VPN_PLUGIN_DIR" + . ,(file-append (vpn-plugin-directory vpn-plugins) + "/lib/NetworkManager/VPN"))))) + +(define (network-manager-shepherd-service config) + (match-record config <network-manager-configuration> + (network-manager dns vpn-plugins iwd?) + (let ((conf (plain-file "NetworkManager.conf" + (string-append + "[main]\ndns=" dns "\n" + (if iwd? "[device]\nwifi.backend=iwd\n" "")))) + (vpn (vpn-plugin-directory vpn-plugins))) + (list (shepherd-service + (documentation "Run the NetworkManager.") + (provision '(networking)) + (requirement (append '(user-processes dbus-system loopback) + (if iwd? '(iwd) '(wpa-supplicant)))) + (start #~(make-forkexec-constructor + (list (string-append #$network-manager + "/sbin/NetworkManager") + (string-append "--config=" #$conf) + "--no-daemon") + #:environment-variables + (list (string-append "NM_VPN_PLUGIN_DIR=" #$vpn + "/lib/NetworkManager/VPN") + ;; Override non-existent default users + "NM_OPENVPN_USER=" + "NM_OPENVPN_GROUP="))) + (stop #~(make-kill-destructor))))))) (define network-manager-service-type - (let - ((config->packages - (match-lambda - (($ <network-manager-configuration> network-manager _ vpn-plugins) - `(,network-manager ,@vpn-plugins))))) + (let ((config->packages + (lambda (config) + (match-record config <network-manager-configuration> + (network-manager vpn-plugins) + `(,network-manager ,@vpn-plugins))))) (service-type (name 'network-manager) @@ -1233,6 +1266,8 @@ wireless networking.")))) (connman connman-configuration-connman (default connman)) (disable-vpn? connman-configuration-disable-vpn? + (default #f)) + (iwd? connman-configuration-iwd? (default #f))) (define (connman-activation config) @@ -1249,18 +1284,21 @@ wireless networking.")))) (and (connman-configuration? config) (let ((connman (connman-configuration-connman config)) - (disable-vpn? (connman-configuration-disable-vpn? config))) + (disable-vpn? (connman-configuration-disable-vpn? config)) + (iwd? (connman-configuration-iwd? config))) (list (shepherd-service (documentation "Run Connman") (provision '(networking)) (requirement - '(user-processes dbus-system loopback wpa-supplicant)) + (append '(user-processes dbus-system loopback) + (if iwd? '(iwd) '()))) (start #~(make-forkexec-constructor (list (string-append #$connman "/sbin/connmand") "--nodaemon" "--nodnsproxy" - #$@(if disable-vpn? '("--noplugin=vpn") '())) + #$@(if disable-vpn? '("--noplugin=vpn") '()) + #$@(if iwd? '("--wifi=iwd_agent") '())) ;; As connman(8) notes, when passing '-n', connman ;; "directs log output to the controlling terminal in @@ -1303,9 +1341,8 @@ a network connection manager.")))) (define modem-manager-service-type (let ((config->package - (match-lambda - (($ <modem-manager-configuration> modem-manager) - (list modem-manager))))) + (lambda (config) + (list (modem-manager-configuration-modem-manager config))))) (service-type (name 'modem-manager) (extensions (list (service-extension dbus-root-service-type @@ -1376,24 +1413,25 @@ device is detected." usb-modeswitch package specified in CONFIG. The rules file will invoke usb_modeswitch.sh from the usb-modeswitch package, modified to pass the right config file." - (match config - (($ <usb-modeswitch-configuration> usb-modeswitch data config-file) - (computed-file - "usb_modeswitch.rules" - (with-imported-modules '((guix build utils)) - #~(begin - (use-modules (guix build utils)) - (let ((in (string-append #$data "/udev/40-usb_modeswitch.rules")) - (out (string-append #$output "/lib/udev/rules.d")) - (script #$(usb-modeswitch-sh usb-modeswitch config-file))) - (mkdir-p out) - (chdir out) - (install-file in out) - (substitute* "40-usb_modeswitch.rules" - (("PROGRAM=\"usb_modeswitch") - (string-append "PROGRAM=\"" script "/usb_modeswitch")) - (("RUN\\+=\"usb_modeswitch") - (string-append "RUN+=\"" script "/usb_modeswitch")))))))))) + (match-record config <usb-modeswitch-configuration> + (usb-modeswitch usb-modeswitch-data config-file) + (computed-file + "usb_modeswitch.rules" + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (let ((in (string-append #$usb-modeswitch-data + "/udev/40-usb_modeswitch.rules")) + (out (string-append #$output "/lib/udev/rules.d")) + (script #$(usb-modeswitch-sh usb-modeswitch config-file))) + (mkdir-p out) + (chdir out) + (install-file in out) + (substitute* "40-usb_modeswitch.rules" + (("PROGRAM=\"usb_modeswitch") + (string-append "PROGRAM=\"" script "/usb_modeswitch")) + (("RUN\\+=\"usb_modeswitch") + (string-append "RUN+=\"" script "/usb_modeswitch"))))))))) (define usb-modeswitch-service-type (service-type @@ -1437,40 +1475,39 @@ whatever the thing is supposed to do)."))) (extra-options wpa-supplicant-configuration-extra-options ;list of strings (default '()))) -(define wpa-supplicant-shepherd-service - (match-lambda - (($ <wpa-supplicant-configuration> wpa-supplicant requirement pid-file dbus? - interface config-file extra-options) - (list (shepherd-service - (documentation "Run the WPA supplicant daemon") - (provision '(wpa-supplicant)) - (requirement (if dbus? - (cons 'dbus-system requirement) - requirement)) - (start #~(make-forkexec-constructor - (list (string-append #$wpa-supplicant - "/sbin/wpa_supplicant") - (string-append "-P" #$pid-file) - "-B" ;run in background - "-s" ;log to syslogd - #$@(if dbus? - #~("-u") - #~()) - #$@(if interface - #~((string-append "-i" #$interface)) - #~()) - #$@(if config-file - #~((string-append "-c" #$config-file)) - #~()) - #$@extra-options) - #:pid-file #$pid-file)) - (stop #~(make-kill-destructor))))))) +(define (wpa-supplicant-shepherd-service config) + (match-record config <wpa-supplicant-configuration> + (wpa-supplicant requirement pid-file dbus? + interface config-file extra-options) + (list (shepherd-service + (documentation "Run the WPA supplicant daemon") + (provision '(wpa-supplicant)) + (requirement (if dbus? + (cons 'dbus-system requirement) + requirement)) + (start #~(make-forkexec-constructor + (list (string-append #$wpa-supplicant + "/sbin/wpa_supplicant") + (string-append "-P" #$pid-file) + "-B" ;run in background + "-s" ;log to syslogd + #$@(if dbus? + #~("-u") + #~()) + #$@(if interface + #~((string-append "-i" #$interface)) + #~()) + #$@(if config-file + #~((string-append "-c" #$config-file)) + #~()) + #$@extra-options) + #:pid-file #$pid-file)) + (stop #~(make-kill-destructor)))))) (define wpa-supplicant-service-type (let ((config->package - (match-lambda - (($ <wpa-supplicant-configuration> wpa-supplicant) - (list wpa-supplicant))))) + (lambda (config) + (list (wpa-supplicant-configuration-wpa-supplicant config))))) (service-type (name 'wpa-supplicant) (extensions (list (service-extension shepherd-root-service-type @@ -1592,41 +1629,38 @@ simulation." (package openvswitch-configuration-package (default openvswitch))) -(define openvswitch-activation - (match-lambda - (($ <openvswitch-configuration> package) - (let ((ovsdb-tool (file-append package "/bin/ovsdb-tool"))) - (with-imported-modules '((guix build utils)) - #~(begin - (use-modules (guix build utils)) - (mkdir-p "/var/run/openvswitch") - (mkdir-p "/var/lib/openvswitch") - (let ((conf.db "/var/lib/openvswitch/conf.db")) - (unless (file-exists? conf.db) - (system* #$ovsdb-tool "create" conf.db))))))))) - -(define openvswitch-shepherd-service - (match-lambda - (($ <openvswitch-configuration> package) - (let ((ovsdb-server (file-append package "/sbin/ovsdb-server")) - (ovs-vswitchd (file-append package "/sbin/ovs-vswitchd"))) - (list - (shepherd-service - (provision '(ovsdb)) - (documentation "Run the Open vSwitch database server.") - (start #~(make-forkexec-constructor - (list #$ovsdb-server "--pidfile" - "--remote=punix:/var/run/openvswitch/db.sock") - #:pid-file "/var/run/openvswitch/ovsdb-server.pid")) - (stop #~(make-kill-destructor))) - (shepherd-service - (provision '(vswitchd)) - (requirement '(ovsdb)) - (documentation "Run the Open vSwitch daemon.") - (start #~(make-forkexec-constructor - (list #$ovs-vswitchd "--pidfile") - #:pid-file "/var/run/openvswitch/ovs-vswitchd.pid")) - (stop #~(make-kill-destructor)))))))) +(define (openvswitch-activation config) + (let ((ovsdb-tool (file-append (openvswitch-configuration-package config) + "/bin/ovsdb-tool"))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/run/openvswitch") + (mkdir-p "/var/lib/openvswitch") + (let ((conf.db "/var/lib/openvswitch/conf.db")) + (unless (file-exists? conf.db) + (system* #$ovsdb-tool "create" conf.db))))))) + +(define (openvswitch-shepherd-service config) + (let* ((package (openvswitch-configuration-package config)) + (ovsdb-server (file-append package "/sbin/ovsdb-server")) + (ovs-vswitchd (file-append package "/sbin/ovs-vswitchd"))) + (list (shepherd-service + (provision '(ovsdb)) + (documentation "Run the Open vSwitch database server.") + (start #~(make-forkexec-constructor + (list #$ovsdb-server "--pidfile" + "--remote=punix:/var/run/openvswitch/db.sock") + #:pid-file "/var/run/openvswitch/ovsdb-server.pid")) + (stop #~(make-kill-destructor))) + (shepherd-service + (provision '(vswitchd)) + (requirement '(ovsdb)) + (documentation "Run the Open vSwitch daemon.") + (start #~(make-forkexec-constructor + (list #$ovs-vswitchd "--pidfile") + #:pid-file "/var/run/openvswitch/ovs-vswitchd.pid")) + (stop #~(make-kill-destructor)))))) (define openvswitch-service-type (service-type @@ -1666,20 +1700,20 @@ COMMIT (ipv6-rules iptables-configuration-ipv6-rules (default %iptables-accept-all-rules))) -(define iptables-shepherd-service - (match-lambda - (($ <iptables-configuration> iptables ipv4-rules ipv6-rules) - (let ((iptables-restore (file-append iptables "/sbin/iptables-restore")) - (ip6tables-restore (file-append iptables "/sbin/ip6tables-restore"))) - (shepherd-service - (documentation "Packet filtering framework") - (provision '(iptables)) - (start #~(lambda _ - (invoke #$iptables-restore #$ipv4-rules) - (invoke #$ip6tables-restore #$ipv6-rules))) - (stop #~(lambda _ - (invoke #$iptables-restore #$%iptables-accept-all-rules) - (invoke #$ip6tables-restore #$%iptables-accept-all-rules)))))))) +(define (iptables-shepherd-service config) + (match-record config <iptables-configuration> + (iptables ipv4-rules ipv6-rules) + (let ((iptables-restore (file-append iptables "/sbin/iptables-restore")) + (ip6tables-restore (file-append iptables "/sbin/ip6tables-restore"))) + (shepherd-service + (documentation "Packet filtering framework") + (provision '(iptables)) + (start #~(lambda _ + (invoke #$iptables-restore #$ipv4-rules) + (invoke #$ip6tables-restore #$ipv6-rules))) + (stop #~(lambda _ + (invoke #$iptables-restore #$%iptables-accept-all-rules) + (invoke #$ip6tables-restore #$%iptables-accept-all-rules))))))) (define iptables-service-type (service-type @@ -1738,17 +1772,17 @@ table inet filter { (ruleset nftables-configuration-ruleset ; file-like object (default %default-nftables-ruleset))) -(define nftables-shepherd-service - (match-lambda - (($ <nftables-configuration> package ruleset) - (let ((nft (file-append package "/sbin/nft"))) - (shepherd-service - (documentation "Packet filtering and classification") - (provision '(nftables)) - (start #~(lambda _ - (invoke #$nft "--file" #$ruleset))) - (stop #~(lambda _ - (invoke #$nft "flush" "ruleset")))))))) +(define (nftables-shepherd-service config) + (match-record config <nftables-configuration> + (package ruleset) + (let ((nft (file-append package "/sbin/nft"))) + (shepherd-service + (documentation "Packet filtering and classification") + (provision '(nftables)) + (start #~(lambda _ + (invoke #$nft "--file" #$ruleset))) + (stop #~(lambda _ + (invoke #$nft "flush" "ruleset"))))))) (define nftables-service-type (service-type @@ -2121,23 +2155,22 @@ of the IPFS peer-to-peer storage network."))) (config-file keepalived-configuration-config-file ;file-like (default #f))) -(define keepalived-shepherd-service - (match-lambda - (($ <keepalived-configuration> keepalived config-file) - (list - (shepherd-service - (provision '(keepalived)) - (documentation "Run keepalived.") - (requirement '(loopback)) - (start #~(make-forkexec-constructor - (list (string-append #$keepalived "/sbin/keepalived") - "--dont-fork" "--log-console" "--log-detail" - "--pid=/var/run/keepalived.pid" - (string-append "--use-file=" #$config-file)) - #:pid-file "/var/run/keepalived.pid" - #:log-file "/var/log/keepalived.log")) - (respawn? #f) - (stop #~(make-kill-destructor))))))) +(define (keepalived-shepherd-service config) + (match-record config <keepalived-configuration> + (keepalived config-file) + (list (shepherd-service + (provision '(keepalived)) + (documentation "Run keepalived.") + (requirement '(loopback)) + (start #~(make-forkexec-constructor + (list (string-append #$keepalived "/sbin/keepalived") + "--dont-fork" "--log-console" "--log-detail" + "--pid=/var/run/keepalived.pid" + (string-append "--use-file=" #$config-file)) + #:pid-file "/var/run/keepalived.pid" + #:log-file "/var/log/keepalived.log")) + (respawn? #f) + (stop #~(make-kill-destructor)))))) (define %keepalived-log-rotation (list (log-rotation diff --git a/gnu/services/nix.scm b/gnu/services/nix.scm index df04a85c22..82853253f6 100644 --- a/gnu/services/nix.scm +++ b/gnu/services/nix.scm @@ -54,6 +54,8 @@ (default nix)) (sandbox nix-configuration-sandbox ;boolean (default #t)) + (build-directory nix-configuration-build-directory ;string + (default "/tmp")) (build-sandbox-items nix-configuration-build-sandbox-items ;list of strings (default '())) (extra-config nix-configuration-extra-config ;list of strings @@ -106,7 +108,7 @@ GID." (define nix-service-etc (match-lambda - (($ <nix-configuration> package sandbox build-sandbox-items extra-config) + (($ <nix-configuration> package sandbox build-directory build-sandbox-items extra-config) (let ((ref-file (references-file package))) `(("nix/nix.conf" ,(computed-file @@ -130,7 +132,7 @@ GID." (define nix-shepherd-service ;; Return a <shepherd-service> for Nix. (match-lambda - (($ <nix-configuration> package _ _ _ extra-options) + (($ <nix-configuration> package _ build-directory _ _ extra-options) (list (shepherd-service (provision '(nix-daemon)) @@ -138,7 +140,10 @@ GID." (requirement '()) (start #~(make-forkexec-constructor (list (string-append #$package "/bin/nix-daemon") - #$@extra-options))) + #$@extra-options) + #:environment-variables + (list (string-append "TMPDIR=" #$build-directory) + "PATH=/run/current-system/profile/bin"))) (respawn? #f) (stop #~(make-kill-destructor))))))) diff --git a/gnu/services/samba.scm b/gnu/services/samba.scm index 4e930d61dc..dfc7778570 100644 --- a/gnu/services/samba.scm +++ b/gnu/services/samba.scm @@ -17,14 +17,12 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (gnu services samba) - #:use-module (gnu packages) #:use-module (gnu packages base) #:use-module (gnu packages admin) #:use-module (gnu packages samba) #:use-module (gnu services) - #:use-module (gnu services configuration) #:use-module (gnu services shepherd) #:use-module (gnu services base) #:use-module (gnu system shadow) @@ -41,20 +39,10 @@ #:export (samba-service-type samba-configuration - samba-smb-conf wsdd-service-type wsdd-configuration)) -(define %smb-conf - (plain-file "smb.conf" "[global] - workgroup = WORKGROUP - server string = Samba Server - server role = standalone server - log file = /var/log/samba/log.%m - logging = file -")) - (define-record-type* <samba-configuration> samba-configuration make-samba-configuration diff --git a/gnu/services/security.scm b/gnu/services/security.scm index 15fae7a628..8116072920 100644 --- a/gnu/services/security.scm +++ b/gnu/services/security.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2022 muradm <mail@muradm.net> +;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -41,11 +42,11 @@ (max-count integer "Cache size.") (max-time integer "Cache time.")) -(define serialize-fail2ban-ignore-cache-configuration - (match-lambda - (($ <fail2ban-ignore-cache-configuration> _ key max-count max-time) - (format #f "key=\"~a\", max-count=~d, max-time=~d" - key max-count max-time)))) +(define (serialize-fail2ban-ignore-cache-configuration config) + (match-record config <fail2ban-ignore-cache-configuration> + (key max-count max-time) + (format #f "key=\"~a\", max-count=~d, max-time=~d" + key max-count max-time))) (define-maybe/no-serialization string) @@ -53,10 +54,10 @@ (name string "Filter to use.") (mode maybe-string "Mode for filter.")) -(define serialize-fail2ban-jail-filter-configuration - (match-lambda - (($ <fail2ban-jail-filter-configuration> _ name mode) - (format #f "~a~@[[mode=~a]~]" name (maybe-value mode))))) +(define (serialize-fail2ban-jail-filter-configuration config) + (match-record config <fail2ban-jail-filter-configuration> + (name mode) + (format #f "~a~@[[mode=~a]~]" name (maybe-value mode)))) (define (argument? a) (and (pair? a) @@ -85,17 +86,17 @@ (format #f "~a=~a" (car e) (any-value (cdr e)))))) (format #f "~a" (string-join (map key-value args) ",")))) -(define serialize-fail2ban-jail-action-configuration - (match-lambda - (($ <fail2ban-jail-action-configuration> _ name arguments) - (format - #f "~a~a" - name - (if (null? arguments) "" - (format - #f "[~a]" - (serialize-fail2ban-jail-action-configuration-arguments - arguments))))))) +(define (serialize-fail2ban-jail-action-configuration config) + (match-record config <fail2ban-jail-action-configuration> + (name arguments) + (format + #f "~a~a" + name + (if (null? arguments) "" + (format + #f "[~a]" + (serialize-fail2ban-jail-action-configuration-arguments + arguments)))))) (define fail2ban-backend->string (match-lambda @@ -351,28 +352,27 @@ provided as a list of file-like objects.")) (match-record config <fail2ban-configuration> (fail2ban run-directory) (let* ((fail2ban-server (file-append fail2ban "/bin/fail2ban-server")) + (fail2ban-client (file-append fail2ban "/bin/fail2ban-client")) (pid-file (in-vicinity run-directory "fail2ban.pid")) (socket-file (in-vicinity run-directory "fail2ban.sock")) (config-dir (file-append (config->fail2ban-etc-directory config) "/etc/fail2ban")) (fail2ban-action (lambda args - #~(lambda _ - (invoke #$fail2ban-server - "-c" #$config-dir - "-p" #$pid-file - "-s" #$socket-file - "-b" - #$@args))))) - - ;; TODO: Add 'reload' action. + #~(invoke #$fail2ban-client #$@args)))) + + ;; TODO: Add 'reload' action (see 'fail2ban.service.in' in the source). (list (shepherd-service (provision '(fail2ban)) (documentation "Run the fail2ban daemon.") (requirement '(user-processes)) - (modules `((ice-9 match) - ,@%default-modules)) - (start (fail2ban-action "start")) - (stop (fail2ban-action "stop"))))))) + (start #~(make-forkexec-constructor + (list #$fail2ban-server + "-c" #$config-dir "-s" #$socket-file + "-p" #$pid-file "-xf" "start") + #:pid-file #$pid-file)) + (stop #~(lambda (_) + #$(fail2ban-action "stop") + #f))))))) ;successfully stopped (define fail2ban-service-type (service-type (name 'fail2ban) diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm index 61f759a19d..b2601c0128 100644 --- a/gnu/services/shepherd.scm +++ b/gnu/services/shepherd.scm @@ -66,6 +66,8 @@ shepherd-action-documentation shepherd-action-procedure + shepherd-configuration-action + %default-modules shepherd-service-file @@ -107,14 +109,15 @@ (symlink (canonicalize-path "/run/current-system") "/run/booted-system") - ;; Close any remaining open file descriptors to be on the safe - ;; side. This must be the very last thing we do, because - ;; Guile has internal FDs such as 'sleep_pipe' that need to be - ;; alive. + ;; Ensure open file descriptors are close-on-exec so shepherd doesn't + ;; inherit them. (let loop ((fd 3)) (when (< fd 1024) - (false-if-exception (close-fdes fd)) - (loop (+ 1 fd)))) + (false-if-exception + (let ((flags (fcntl fd F_GETFD))) + (when (zero? (logand flags FD_CLOEXEC)) + (fcntl fd F_SETFD (logior FD_CLOEXEC flags))))) + (loop (+ fd 1)))) ;; Start shepherd. (execl #$(file-append shepherd "/bin/shepherd") @@ -332,6 +335,16 @@ and return the resulting '.go' file. SHEPHERD is used as shepherd package." #:options '(#:local-build? #t #:substitutable? #f))))) +(define (shepherd-configuration-action file) + "Return a 'configuration' action to display FILE, which should be the name +of the service's configuration file." + (shepherd-action + (name 'configuration) + (documentation "Display the name of this service's configuration file.") + (procedure #~(lambda (_) + (format #t "~a~%" #$file) + #$file)))) + (define (shepherd-configuration-file services shepherd) "Return the shepherd configuration file for SERVICES. SHEPHERD is used as shepherd package." diff --git a/gnu/services/sound.scm b/gnu/services/sound.scm index 8410ba2418..3e778f3cea 100644 --- a/gnu/services/sound.scm +++ b/gnu/services/sound.scm @@ -204,17 +204,13 @@ computed-file object~%") file)))) '() `(("default.pa.d" ,(extra-script-files->file-union extra-script-files)))) - ,@(if (null? daemon-conf) - '() - `(("daemon.conf" - ,(apply mixed-text-file "daemon.conf" - "default-script-file = " default-script-file "\n" - (map pulseaudio-conf-entry daemon-conf))))) - ,@(if (null? client-conf) - '() - `(("client.conf" - ,(apply mixed-text-file "client.conf" - (map pulseaudio-conf-entry client-conf)))))))))))) + ("daemon.conf" + ,(apply mixed-text-file "daemon.conf" + "default-script-file = /etc/pulse/default.pa\n" + (map pulseaudio-conf-entry daemon-conf))) + ("client.conf" + ,(apply mixed-text-file "client.conf" + (map pulseaudio-conf-entry client-conf)))))))))) (define pulseaudio-service-type (service-type diff --git a/gnu/services/ssh.scm b/gnu/services/ssh.scm index 72e7183590..7b038e6ac6 100644 --- a/gnu/services/ssh.scm +++ b/gnu/services/ssh.scm @@ -524,9 +524,12 @@ of user-name/file-like tuples." (define max-connections (openssh-configuration-max-connections config)) + (define config-file + (openssh-config-file config)) + (define openssh-command #~(list (string-append #$(openssh-configuration-openssh config) "/sbin/sshd") - "-D" "-f" #$(openssh-config-file config))) + "-D" "-f" #$config-file)) (define inetd-style? ;; Whether to use 'make-inetd-constructor'. That procedure appeared in @@ -568,6 +571,7 @@ of user-name/file-like tuples." (stop #~(if #$inetd-style? (make-inetd-destructor) (make-kill-destructor))) + (actions (list (shepherd-configuration-action config-file))) (auto-start? (openssh-auto-start? config))))) (define (openssh-pam-services config) diff --git a/gnu/services/version-control.scm b/gnu/services/version-control.scm index 17a5f9c867..14ff0a59a6 100644 --- a/gnu/services/version-control.scm +++ b/gnu/services/version-control.scm @@ -29,6 +29,7 @@ #:use-module (gnu system shadow) #:use-module (gnu packages version-control) #:use-module (gnu packages admin) + #:use-module (guix deprecation) #:use-module (guix records) #:use-module (guix gexp) #:use-module (guix store) @@ -54,6 +55,7 @@ <gitolite-rc-file> gitolite-rc-file + gitolite-rc-file-local-code gitolite-rc-file-umask gitolite-rc-file-unsafe-pattern gitolite-rc-file-git-config-keys @@ -177,7 +179,8 @@ protocol.") (default-value (git-daemon-configuration)))) -(define* (git-daemon-service #:key (config (git-daemon-configuration))) +(define-deprecated (git-daemon-service #:key (config (git-daemon-configuration))) + git-daemon-service-type "Return a service that runs @command{git daemon}, a simple TCP server to expose repositories over the Git protocol for anonymous access. @@ -242,6 +245,8 @@ access to exported repositories under @file{/srv/git}." gitolite-rc-file? (umask gitolite-rc-file-umask (default #o0077)) + (local-code gitolite-rc-file-local-code + (default "$rc{GL_ADMIN_BASE}/local")) (unsafe-pattern gitolite-rc-file-unsafe-pattern (default #f)) (git-config-keys gitolite-rc-file-git-config-keys @@ -263,11 +268,14 @@ access to exported repositories under @file{/srv/git}." (define-gexp-compiler (gitolite-rc-file-compiler (file <gitolite-rc-file>) system target) (match file - (($ <gitolite-rc-file> umask unsafe-pattern git-config-keys roles enable) + (($ <gitolite-rc-file> umask local-code unsafe-pattern git-config-keys roles enable) (apply text-file* "gitolite.rc" `("%RC = (\n" " UMASK => " ,(format #f "~4,'0o" umask) ",\n" " GIT_CONFIG_KEYS => '" ,git-config-keys "',\n" + ,(if local-code + (simple-format #f " LOCAL_CODE => \"~A\",\n" local-code) + "") " ROLES => {\n" ,@(map (match-lambda ((role . value) @@ -307,7 +315,7 @@ access to exported repositories under @file{/srv/git}." (($ <gitolite-configuration> package user group home-directory rc-file admin-pubkey) ;; User group and account to run Gitolite. - (list (user-group (name user) (system? #t)) + (list (user-group (name group) (system? #t)) (user-account (name user) (group group) @@ -405,7 +413,7 @@ access to exported repositories under @file{/srv/git}." (list (gitolite-configuration-package config)))))) (description - "Setup @command{gitolite}, a Git hosting tool providing access over SSH.. + "Set up @command{gitolite}, a Git hosting tool providing access over SSH. By default, the @code{git} user is used, but this is configurable. Additionally, Gitolite can integrate with with tools like gitweb or cgit to provide a web interface to view selected repositories."))) diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm index cb6227403b..601c11b0d1 100644 --- a/gnu/services/virtualization.scm +++ b/gnu/services/virtualization.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2020,2021 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2021 Timotej Lazar <timotej.lazar@araneo.si> ;;; Copyright © 2022 Oleg Pykhalov <go.wigust@gmail.com> +;;; Copyright © 2022 Leo Nikkilä <hello@lnikki.la> ;;; ;;; This file is part of GNU Guix. ;;; @@ -611,6 +612,13 @@ used to manage logs from @acronym{VM, virtual machine} consoles."))) (magic (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x03\x00")) (mask (bv "\xff\xff\xff\xff\xff\xfe\xfe\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))) +(define %x86_64 + (qemu-platform + (name "x86_64") + (family "i386") + (magic (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x3e\x00")) + (mask (bv "\xff\xff\xff\xff\xff\xfe\xfe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))) + (define %alpha (qemu-platform (name "alpha") @@ -767,7 +775,7 @@ used to manage logs from @acronym{VM, virtual machine} consoles."))) (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))) (define %qemu-platforms - (list %i386 %alpha %arm %sparc32plus %ppc %ppc64 %ppc64le %m68k + (list %i386 %x86_64 %alpha %arm %sparc32plus %ppc %ppc64 %ppc64le %m68k %mips %mipsel %mipsn32 %mipsn32el %mips64 %mips64el %riscv32 %riscv64 %sh4 %sh4eb %s390x %aarch64 %hppa)) diff --git a/gnu/services/vnc.scm b/gnu/services/vnc.scm new file mode 100644 index 0000000000..15c3c14fee --- /dev/null +++ b/gnu/services/vnc.scm @@ -0,0 +1,247 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gnu services vnc) + #:use-module (gnu packages vnc) + #:use-module ((gnu services) #:hide (delete)) + #:use-module (gnu system shadow) + #:use-module (gnu services configuration) + #:use-module (gnu services shepherd) + #:use-module (guix gexp) + #:use-module (guix records) + + #:export (xvnc-configuration + xvnc-configuration-xvnc + xvnc-configuration-display-number + xvnc-configuration-geometry + xvnc-configuration-depth + xvnc-configuration-port + xvnc-configuration-ipv4? + xvnc-configuration-ipv6? + xvnc-configuration-password-file + xvnc-configuration-xdmcp? + xvnc-configuration-inetd? + xvnc-configuration-frame-rate + xvnc-configuration-security-types + xvnc-configuration-localhost? + xvnc-configuration-log-level + xvnc-configuration-extra-options + + xvnc-service-type)) + +;;; +;;; Xvnc. +;;; + +(define (color-depth? x) + (member x '(16 24 32))) + +(define (port? x) + (and (number? x) + (and (>= x 0) (<= x 65535)))) + +(define-maybe/no-serialization port) + +(define-maybe/no-serialization string) + +(define %security-types '("None" "VncAuth" "Plain" "TLSNone" "TLSVnc" "TLSPlain" + "X509None" "X509Vnc")) + +(define (security-type? x) + (member x %security-types)) + +(define (security-types? x) + (and (list? x) + (and-map security-type? x))) + +(define (log-level? x) + (and (number? x) + (and (>= x 0) (<= x 100)))) + +(define (strings? x) + (and (list? x) + (and-map string? x))) + +(define-configuration/no-serialization xvnc-configuration + (xvnc + (file-like tigervnc-server) + "The package that provides the Xvnc binary.") + (display-number + (number 0) + "The display number used by Xvnc. You should set this to a number not +already used by a Xorg server. When remoting a complete desktop session via +XDMCP and using a compatible VNC viewer as provided by the +@code{tigervnc-client} or @code{turbovnc} packages, the geometry is +automatically adjusted.") + (geometry + (string "1024x768") + "The size of the desktop to be created.") + (depth + (color-depth 24) + "The pixel depth in bits of the desktop to be created. Accepted values are +16, 24 or 32.") + (port + maybe-port + "The port on which to listen for connections from viewers. When left +unspecified, it defaults to 5900 plus the display number.") + (ipv4? + (boolean #t) + "Use IPv4 for incoming and outgoing connections.") + (ipv6? + (boolean #t) + "Use IPv6 for incoming and outgoing connections.") + (password-file + maybe-string + "The password file to use, if any. Refer to vncpasswd(1) to learn how to +generate such a file.") + (xdmcp? + (boolean #f) + "Query the XDMCP server for a session. This enables users to log in a +desktop session from the login manager screen. For a multiple users scenario, +you'll want to enable the @code{inetd?} option as well, so that each +connection to the VNC server is handled separately rather than shared.") + (inetd? + (boolean #f) + "Use an Inetd-style service, which runs the Xvnc server on demand.") + (frame-rate + (number 60) + "The maximum number of updates per second sent to each client.") + (security-types + (security-types (list "None")) + (format #f "The allowed security schemes to use for incoming connections. +The default is \"None\", which is safe given that Xvnc is configured to +authenticate the user via the display manager, and only for local connections. +Accepted values are any of the following: ~s" %security-types)) + (localhost? + (boolean #t) + "Only allow connections from the same machine. It is set to @code{#true} +by default for security, which means SSH or another secure means should be +used to expose the remote port.") + (log-level + (log-level 30) + "The log level, a number between 0 and 100, 100 meaning most verbose +output. The log messages are output to syslog.") + (extra-options + (strings '()) + "This can be used to provide extra Xvnc options not exposed via this +<xvnc-configuration> record.")) + +(define (xvnc-configuration->command-line-arguments config) + "Derive the command line arguments to used to launch the Xvnc daemon from +CONFIG, a <xvnc-configuration> object." + (match-record config <xvnc-configuration> + (xvnc display-number geometry depth port ipv4? ipv6? password-file xdmcp? + inetd? frame-rate security-types localhost? log-level extra-options) + #~(list #$(file-append xvnc "/bin/Xvnc") + #$(format #f ":~a" display-number) + "-geometry" #$geometry + "-depth" #$(number->string depth) + #$@(if inetd? + (list "-inetd") + '()) + #$@(if (not inetd?) + (if (maybe-value-set? port) + (list "-rfbport" (number->string port)) + '()) + '()) + #$@(if (not inetd?) + (if ipv4? + (list "-UseIPv4") + '()) + '()) + #$@(if (not inetd?) + (if ipv6? + (list "-UseIPv6") + '()) + '()) + #$@(if (maybe-value-set? password-file) + (list "-PasswordFile" password-file) + '()) + "-FrameRate" #$(number->string frame-rate) + "-SecurityTypes" #$(string-join security-types ",") + #$@(if localhost? + (list "-localhost") + '()) + "-Log" #$(format #f "*:syslog:~a" log-level) + #$@(if xdmcp? + (list "-query" "localhost" "-once") + '()) + #$@extra-options))) + +(define %xvnc-accounts + (list (user-group + (name "xvnc") + (system? #t)) + (user-account + (name "xvnc") + (group "xvnc") + (system? #t) + (comment "User for Xvnc server")))) + +(define (xvnc-shepherd-service config) + "Return a <shepherd-service> for Xvnc with CONFIG." + (let* ((display-number (xvnc-configuration-display-number config)) + (port (if (maybe-value-set? (xvnc-configuration-port config)) + (xvnc-configuration-port config) + #f)) + (port* (or port (+ 5900 display-number)))) + (shepherd-service + (provision '(xvnc vncserver)) + (documentation "Run the Xvnc server.") + (requirement '(networking syslogd)) + (start (if (xvnc-configuration-inetd? config) + #~(let* ((inaddr (if #$(xvnc-configuration-localhost? config) + INADDR_LOOPBACK + INADDR_ANY)) + (in6addr (if #$(xvnc-configuration-localhost? config) + IN6ADDR_LOOPBACK + IN6ADDR_ANY)) + (ipv4-socket (and #$(xvnc-configuration-ipv4? config) + (make-socket-address AF_INET inaddr + #$port*))) + (ipv6-socket (and #$(xvnc-configuration-ipv6? config) + (make-socket-address AF_INET6 in6addr + #$port*)))) + (make-inetd-constructor + #$(xvnc-configuration->command-line-arguments config) + `(,@(if ipv4-socket + (list (endpoint ipv4-socket)) + '()) + ,@(if ipv6-socket + (list (endpoint ipv6-socket)) + '())) + #:user "xvnc" + #:group "xvnc")) + #~(make-forkexec-constructor + #$(xvnc-configuration->command-line-arguments config) + #:user "xvnc" + #:group "xvnc"))) + (stop #~(make-inetd-destructor))))) + +(define xvnc-service-type + (service-type + (name 'xvnc) + (default-value (xvnc-configuration)) + (description "Run the Xvnc server, which creates a virtual X11 session and +allow remote clients connecting to it via the remote framebuffer (RFB) +protocol.") + (extensions (list (service-extension + shepherd-root-service-type + (compose list xvnc-shepherd-service)) + (service-extension account-service-type + (const %xvnc-accounts)))))) diff --git a/gnu/services/vpn.scm b/gnu/services/vpn.scm index 82ff05b351..4103f89ecf 100644 --- a/gnu/services/vpn.scm +++ b/gnu/services/vpn.scm @@ -10,6 +10,7 @@ ;;; Copyright © 2021 jgart <jgart@dismail.de> ;;; Copyright © 2021 Nathan Dehnel <ncdehnel@gmail.com> ;;; Copyright © 2022 Cameron V Chaparro <cameron@cameronchaparro.com> +;;; Copyright © 2022 Timo Wilken <guix@twilken.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -61,6 +62,7 @@ wireguard-peer-endpoint wireguard-peer-allowed-ips wireguard-peer-public-key + wireguard-peer-preshared-key wireguard-peer-keep-alive wireguard-configuration @@ -72,6 +74,11 @@ wireguard-configuration-dns wireguard-configuration-private-key wireguard-configuration-peers + wireguard-configuration-pre-up + wireguard-configuration-post-up + wireguard-configuration-pre-down + wireguard-configuration-post-down + wireguard-configuration-table wireguard-service-type)) @@ -704,6 +711,8 @@ strongSwan."))) (endpoint wireguard-peer-endpoint (default #f)) ;string (public-key wireguard-peer-public-key) ;string + (preshared-key wireguard-peer-preshared-key + (default #f)) ;string (allowed-ips wireguard-peer-allowed-ips) ;list of strings (keep-alive wireguard-peer-keep-alive (default #f))) ;integer @@ -724,7 +733,17 @@ strongSwan."))) (peers wireguard-configuration-peers ;list of <wiregard-peer> (default '())) (dns wireguard-configuration-dns ;list of strings - (default #f))) + (default #f)) + (pre-up wireguard-configuration-pre-up ;list of strings + (default '())) + (post-up wireguard-configuration-post-up ;list of strings + (default '())) + (pre-down wireguard-configuration-pre-down ;list of strings + (default '())) + (post-down wireguard-configuration-post-down ;list of strings + (default '())) + (table wireguard-configuration-table ;string + (default "auto"))) (define (wireguard-configuration-file config) (define (peer->config peer) @@ -747,9 +766,18 @@ AllowedIPs = ~a (format #f "PersistentKeepalive = ~a\n" keep-alive) "\n")))) + (define (peers->preshared-keys peer keys) + (let ((public-key (wireguard-peer-public-key peer)) + (preshared-key (wireguard-peer-preshared-key peer))) + (if preshared-key + (cons* public-key preshared-key keys) + keys))) + (match-record config <wireguard-configuration> - (wireguard interface addresses port private-key peers dns) + (wireguard interface addresses port private-key peers dns + pre-up post-up pre-down post-down table) (let* ((config-file (string-append interface ".conf")) + (peer-keys (fold peers->preshared-keys (list) peers)) (peers (map peer->config peers)) (config (computed-file @@ -762,13 +790,50 @@ AllowedIPs = ~a (let ((format (@ (ice-9 format) format))) (format port "[Interface] Address = ~a -PostUp = ~a set %i private-key ~a +~a +~a +PostUp = ~a set %i private-key ~a~{ peer ~a preshared-key ~a~} +~a +~a +~a ~a ~a ~{~a~^~%~}" #$(string-join addresses ",") + #$(if table + (format #f "Table = ~a" table) + "") + #$(if (null? pre-up) + "" + (string-join + (map (lambda (command) + (format #f "PreUp = ~a" command)) + pre-up) + "\n")) #$(file-append wireguard "/bin/wg") #$private-key + '#$peer-keys + #$(if (null? post-up) + "" + (string-join + (map (lambda (command) + (format #f "PostUp = ~a" command)) + post-up) + "\n")) + #$(if (null? pre-down) + "" + (string-join + (map (lambda (command) + (format #f "PreDown = ~a" command)) + pre-down) + "\n")) + #$(if (null? post-down) + "" + (string-join + (map (lambda (command) + (format #f "PostDown = ~a" command)) + post-down) + "\n")) #$(if port (format #f "ListenPort = ~a" port) "") @@ -781,7 +846,7 @@ PostUp = ~a set %i private-key ~a (define (wireguard-activation config) (match-record config <wireguard-configuration> - (private-key) + (private-key wireguard) #~(begin (use-modules (guix build utils) (ice-9 popen) @@ -790,7 +855,7 @@ PostUp = ~a set %i private-key ~a (unless (file-exists? #$private-key) (let* ((pipe (open-input-pipe (string-append - #$(file-append wireguard-tools "/bin/wg") + #$(file-append wireguard "/bin/wg") " genkey"))) (key (read-line pipe))) (call-with-output-file #$private-key @@ -823,6 +888,9 @@ PostUp = ~a set %i private-key ~a (list (service-extension shepherd-root-service-type wireguard-shepherd-service) (service-extension activation-service-type - wireguard-activation))) + wireguard-activation) + (service-extension profile-service-type + (compose list + wireguard-configuration-wireguard)))) (description "Set up Wireguard @acronym{VPN, Virtual Private Network} tunnels."))) diff --git a/gnu/services/web.scm b/gnu/services/web.scm index e347f5dbcc..d56e893527 100644 --- a/gnu/services/web.scm +++ b/gnu/services/web.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson <davet@gnu.org> -;;; Copyright © 2015-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Nikita <nikita@n0.is> ;;; Copyright © 2016, 2017, 2018 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2017, 2018, 2019 Christopher Baines <mail@cbaines.net> @@ -790,13 +790,11 @@ of index files." (nginx file run-directory shepherd-requirement) (let* ((nginx-binary (file-append nginx "/sbin/nginx")) (pid-file (in-vicinity run-directory "pid")) + (config-file (or file (default-nginx-config config))) (nginx-action (lambda args #~(lambda _ - (invoke #$nginx-binary "-c" - #$(or file - (default-nginx-config config)) - #$@args) + (invoke #$nginx-binary "-c" #$config-file #$@args) (match '#$args (("-s" . _) #f) (_ @@ -807,7 +805,6 @@ of index files." #~#t #~(read-pid-file #$pid-file)))))))) - ;; TODO: Add 'reload' action. (list (shepherd-service (provision '(nginx)) (documentation "Run the nginx daemon.") @@ -815,7 +812,18 @@ of index files." (modules `((ice-9 match) ,@%default-modules)) (start (nginx-action "-p" run-directory)) - (stop (nginx-action "-s" "stop"))))))) + (stop (nginx-action "-s" "stop")) + (actions + (list + (shepherd-configuration-action config-file) + (shepherd-action + (name 'reload) + (documentation "Reload nginx configuration file and restart worker processes. +This has the effect of killing old worker processes and starting new ones, using +the same configuration file. It is useful for situations where the same nginx +configuration file can point to different things after a reload, such as +renewed TLS certificates, or @code{include}d files.") + (procedure (nginx-action "-s" "reload")))))))))) (define nginx-service-type (service-type (name 'nginx) @@ -978,7 +986,7 @@ and the back-end of a Web service."))) (define php-fpm-accounts (match-lambda - (($ <php-fpm-configuration> php socket user group socket-user socket-group _ _ _ _ _ _) + (($ <php-fpm-configuration> php socket user group socket-user socket-group) `(,@(if (equal? group "php-fpm") '() (list (user-group (name "php-fpm") (system? #t)))) @@ -1147,8 +1155,7 @@ a webserver.") (package hpcguix-web-package (default hpcguix-web)) ;file-like - ;; Specs is gexp of hpcguix-web configuration file - (specs hpcguix-web-configuration-specs) + (specs hpcguix-web-configuration-specs (default #f)) ;#f | gexp (address hpcguix-web-configuration-address (default "127.0.0.1")) (port hpcguix-web-configuration-port (default 5000))) @@ -1209,8 +1216,11 @@ a webserver.") "-p" #$(number->string (hpcguix-web-configuration-port config)) - (string-append "--config=" - #$(scheme-file "hpcguix-web.scm" specs))) + #$@(if specs + #~((string-append "--config=" + #$(scheme-file + "hpcguix-web.scm" specs))) + #~())) #:user "hpcguix-web" #:group "hpcguix-web" #:environment-variables @@ -1231,7 +1241,8 @@ a webserver.") (service-extension rottlog-service-type (const %hpcguix-web-log-rotations)) (service-extension shepherd-root-service-type - (compose list hpcguix-web-shepherd-service)))))) + (compose list hpcguix-web-shepherd-service)))) + (default-value (hpcguix-web-configuration)))) ;;; @@ -1438,32 +1449,40 @@ files.") (documentation "Anonimyze the given log file location with anonip.") (start - #~(lambda _ - (unless (file-exists? #$input) - (mknod #$input 'fifo #o600 0)) - (let ((pid - (fork+exec-command - (append - (list #$(file-append (anonip-configuration-anonip config) - "/bin/anonip") - (string-append "--input=" #$input) - (string-append "--output=" #$output)) - (if #$(anonip-configuration-skip-private? config) - '("--skip-private") (list)) - '#$(optional anonip-configuration-column "--column") - '#$(optional anonip-configuration-ipv4mask "--ipv4mask") - '#$(optional anonip-configuration-ipv6mask "--ipv6mask") - '#$(optional anonip-configuration-increment "--increment") - '#$(optional anonip-configuration-replacement - "--replacement") - '#$(optional anonip-configuration-delimiter "--delimiter") - '#$(optional anonip-configuration-regex "--regex")) - ;; Run in a UTF-8 locale - #:environment-variables - (list (string-append "GUIX_LOCPATH=" #$glibc-utf8-locales - "/lib/locale") - "LC_ALL=en_US.utf8")))) - pid))) + #~(lambda () + (define (spawn) + (fork+exec-command + (append + (list #$(file-append (anonip-configuration-anonip config) + "/bin/anonip") + (string-append "--input=" #$input) + (string-append "--output=" #$output)) + (if #$(anonip-configuration-skip-private? config) + '("--skip-private") (list)) + '#$(optional anonip-configuration-column "--column") + '#$(optional anonip-configuration-ipv4mask "--ipv4mask") + '#$(optional anonip-configuration-ipv6mask "--ipv6mask") + '#$(optional anonip-configuration-increment "--increment") + '#$(optional anonip-configuration-replacement + "--replacement") + '#$(optional anonip-configuration-delimiter "--delimiter") + '#$(optional anonip-configuration-regex "--regex")) + ;; Run in a UTF-8 locale + #:environment-variables + (list (string-append "GUIX_LOCPATH=" #$glibc-utf8-locales + "/lib/locale") + "LC_ALL=en_US.utf8"))) + + (let ((stat (stat #$input #f))) + (cond ((not stat) + (mknod #$input 'fifo #o600 0) + (spawn)) + ((eq? 'fifo (stat:type stat)) + (spawn)) + (else + (format #t "'~a' is not a FIFO; bailing out~%" + #$input) + #f))))) (stop #~(make-kill-destructor)))))) (define anonip-service-type @@ -2126,24 +2145,23 @@ root=/srv/gemini (stop #~(make-kill-destructor))))))) (define agate-accounts - (match-lambda - (($ <agate-configuration> _ _ _ _ _ - _ _ _ _ - _ user group _) - `(,@(if (equal? group "agate") - '() - (list (user-group (name "agate") (system? #t)))) - ,(user-group - (name group) - (system? #t)) - ,(user-account - (name user) - (group group) - (supplementary-groups '("agate")) - (system? #t) - (comment "agate server user") - (home-directory "/var/empty") - (shell (file-append shadow "/sbin/nologin"))))))) + (lambda (config) + (let ((group (agate-configuration-group config)) + (user (agate-configuration-user config))) + `(,@(if (equal? group "agate") + '() + (list (user-group (name "agate") (system? #t)))) + ,(user-group + (name group) + (system? #t)) + ,(user-account + (name user) + (group group) + (supplementary-groups '("agate")) + (system? #t) + (comment "agate server user") + (home-directory "/var/empty") + (shell (file-append shadow "/sbin/nologin"))))))) (define agate-service-type (service-type diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm index 3ff290c197..5f073d05d3 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Andy Wingo <wingo@igalia.com> -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013-2017, 2019-2020, 2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com> ;;; Copyright © 2018, 2019 Timothy Sample <samplet@ngyro.com> ;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> @@ -12,6 +12,7 @@ ;;; Copyright © 2021 Oleg Pykhalov <go.wigust@gmail.com> ;;; Copyright © 2021 Josselin Poiret <josselin.poiret@protonmail.ch> ;;; Copyright © 2022 Chris Marusich <cmmarusich@gmail.com> +;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -32,6 +33,7 @@ #:autoload (gnu services sddm) (sddm-service-type) #:use-module (gnu artwork) #:use-module (gnu services) + #:use-module (gnu services configuration) #:use-module (gnu services shepherd) #:use-module (gnu system pam) #:use-module (gnu system setuid) @@ -63,6 +65,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) + #:use-module (ice-9 format) #:use-module (ice-9 match) #:export (xorg-configuration xorg-configuration? @@ -113,6 +116,13 @@ localed-configuration? localed-service-type + dconf-keyfile + dconf-profile + dconf-profile-name + dconf-profile-content + dconf-profile-keyfile + dconf-service-type + gdm-configuration gdm-service-type @@ -663,13 +673,7 @@ reboot_cmd " shepherd "/sbin/reboot\n" (list (service-extension shepherd-root-service-type slim-shepherd-service) (service-extension pam-root-service-type - slim-pam-service) - - ;; Unconditionally add xterm to the system profile, to - ;; avoid bad surprises. - (service-extension profile-service-type - (const (list xterm))))) - + slim-pam-service))) (default-value (slim-configuration)) (description "Run the SLiM graphical login manager for X11.")))) @@ -804,6 +808,106 @@ the GNOME desktop environment.") ;;; +;;; Dconf. +;;; + +(define-maybe text-config) + +(define-configuration/no-serialization dconf-keyfile + (name string + "The file name of the associated keyfile, e.g. \"00-login-screen\".") + (content text-config "The content of the associated keyfile.")) + +(define-configuration/no-serialization dconf-profile + (name string "The file name of the dconf system profile, which should match +the name of a user for which the profile is to be used with. To have the +profile used, the environment variable \"DCONF_PROFILE\" should be set to the +profile file, e.g.: +@example + export DCONF_PROFILE=/etc/dconf/profile/gdm +@end example") + (content maybe-text-config "The content of the Dconf profile. Unless +provided, it defaults to include the user database (\"user-db:NAME\") as well +as the system database (\"system-db:NAME\"), which corresponds to the +generated database, @file{/etc/dconf/db/NAME}.") + (keyfile dconf-keyfile "The keyfile associated with the profile")) + +(define dconf-profiles? + (list-of dconf-profile?)) + +(define-configuration/no-serialization dconf-configuration + (profiles dconf-profiles "The list of <dconf-profile> objects to populate.")) + +(define (dconf-profile->profile-file profile) + "Given PROFILE, a <dconf-profile> object, return a dconf profile file." + (let ((name (dconf-profile-name profile)) + (content (dconf-profile-content profile))) + (apply mixed-text-file + name + (if (maybe-value-set? content) + (interpose content "\n" 'suffix) + (interpose (list (string-append "user-db:" name) + (string-append "system-db:" name)) + "\n" 'suffix))))) + +(define (dconf-profile->db-keyfile profile) + "Given PROFILE, a <dconf-profile> object, return a dconf profile file." + (let ((keyfile (dconf-profile-keyfile profile))) + (apply mixed-text-file (dconf-keyfile-name keyfile) + (interpose (dconf-keyfile-content keyfile) "\n" 'suffix)))) + +(define (dconf-profile->db-keyfile-dir profile) + "Wrap the keyfile in a directory, to satisfy 'dconf compile'." + (let ((name (dconf-profile-name profile)) + (keyfile-name (dconf-keyfile-name (dconf-profile-keyfile profile)))) + (computed-file name + #~(begin + (mkdir #$output) + (symlink #$(dconf-profile->db-keyfile profile) + (string-append #$output "/" #$keyfile-name)))))) + +(define (dconf-profile->db profile) + "Compile the a <dconf-profile> object into a GVariant Database file." + (let ((name (dconf-profile-name profile))) + (computed-file + name + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (setenv "DCONF_PROFILE" #$(dconf-profile->profile-file profile)) + (invoke #$(file-append dconf "/bin/dconf") "compile" + #$output #$(dconf-profile->db-keyfile-dir profile))))))) + +(define (dconf-profile->files profile) + "Given PROFILE, a <dconf-profile> object, return a dconf directory +containing the associated profile, keyfile and database files to be assembled +under /etc." + (let ((name (dconf-profile-name profile)) + (keyfile-name (dconf-keyfile-name (dconf-profile-keyfile profile)))) + (list (list (string-append "dconf/profile/" name) + (dconf-profile->profile-file profile)) + (list (string-append "dconf/db/" name ".d/" keyfile-name) + (dconf-profile->db-keyfile profile)) + (list (string-append "dconf/db/" name) + (dconf-profile->db profile))))) + +(define dconf-service-type + (service-type + (name 'dconf-profile) + (extensions + (list (service-extension etc-service-type + (lambda (dconf-profiles) + (append-map dconf-profile->files + dconf-profiles))))) + (compose concatenate) + (extend append) + (default-value '()) + (description "Extend the @code{etc-service-type} to populate the file +hierarchy under @file{/etc/dconf} with the <dconf-profile> objects provided as +argument."))) + + +;;; ;;; GNOME Desktop Manager. ;;; @@ -876,6 +980,7 @@ the GNOME desktop environment.") (gdm gdm-configuration-gdm (default gdm)) (allow-empty-passwords? gdm-configuration-allow-empty-passwords? (default #t)) (auto-login? gdm-configuration-auto-login? (default #f)) + (auto-suspend? gdm-configuration-auto-suspend? (default #t)) (dbus-daemon gdm-configuration-dbus-daemon (default dbus-daemon-wrapper)) (debug? gdm-configuration-debug? (default #f)) (default-user gdm-configuration-default-user (default #f)) @@ -885,10 +990,36 @@ the GNOME desktop environment.") (default (xorg-configuration))) (x-session gdm-configuration-x-session (default (xinitrc))) + (xdmcp? gdm-configuration-xdmcp? + (default #f)) (wayland? gdm-configuration-wayland? (default #f)) (wayland-session gdm-configuration-wayland-session (default gdm-wayland-session-wrapper))) +(define (gdm-dconf-profiles config) + (if (gdm-configuration-auto-suspend? config) + '() + ;; This custom gconf profile works around a lack of configuration option + ;; to disable auto-suspend when no users are physically logged in (see: + ;; https://gitlab.gnome.org/GNOME/gnome-control-center/-/issues/22). + (list (dconf-profile + (name "gdm") + (content (list #~(begin + (use-modules (ice-9 textual-ports)) + (string-trim + (call-with-input-file + #$(file-append gdm "/share/dconf/profile/gdm") + get-string-all))) + "system-db:gdm")) + (keyfile (dconf-keyfile + (name "00-disable-suspend") + (content + (list "[org/gnome/settings-daemon/plugins/power]" + "sleep-inactive-ac-type='nothing'" + "sleep-inactive-battery-type='nothing'" + "sleep-inactive-ac-timeout=0" + "sleep-inactive-battery-timeout=0")))))))) + (define (gdm-configuration-file config) (mixed-text-file "gdm-custom.conf" "[daemon]\n" @@ -913,18 +1044,20 @@ the GNOME desktop environment.") ;; See also ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=39281>. "InitialSetupEnable=false\n" - "WaylandEnable=" (if (gdm-configuration-wayland? config) - "true" - "false") "\n" + (format #f "WaylandEnable=~:[false~;true~]~%" + (gdm-configuration-wayland? config)) "\n" "[debug]\n" - "Enable=" (if (gdm-configuration-debug? config) - "true" - "false") "\n" + (format #f "Enable=~:[false~;true~]~%" + (gdm-configuration-debug? config)) "\n" "[security]\n" "#DisallowTCP=true\n" - "#AllowRemoteAutoLogin=false\n")) + "#AllowRemoteAutoLogin=false\n" + "\n" + "[xdmcp]\n" + (format #f "Enable=~:[false~;true~]~%" + (gdm-configuration-xdmcp? config)))) (define (gdm-pam-service config) "Return a PAM service for @command{gdm}." @@ -950,6 +1083,9 @@ the GNOME desktop environment.") (gdm-configuration-allow-empty-passwords? config)))) (define (gdm-shepherd-service config) + (define config-file + (gdm-configuration-file config)) + (list (shepherd-service (documentation "Xorg display server (GDM)") (provision '(xorg-server)) @@ -959,9 +1095,10 @@ the GNOME desktop environment.") (list #$(file-append (gdm-configuration-gdm config) "/bin/gdm")) #:environment-variables - (list (string-append - "GDM_CUSTOM_CONF=" - #$(gdm-configuration-file config)) + (list #$@(if (gdm-configuration-auto-suspend? config) + #~() + #~("DCONF_PROFILE=/etc/dconf/profile/gdm")) + (string-append "GDM_CUSTOM_CONF=" #$config-file) (string-append "GDM_DBUS_DAEMON=" #$(gdm-configuration-dbus-daemon config)) @@ -993,8 +1130,44 @@ the GNOME desktop environment.") "GDM_WAYLAND_SESSION=" #$(gdm-configuration-wayland-session config)))))) (stop #~(make-kill-destructor)) + (actions (list (shepherd-configuration-action config-file))) (respawn? #t)))) +(define gdm-polkit-rules + (lambda (config) + (if (gdm-configuration-xdmcp? config) + ;; Allow remote (XDMCP) users to use colord; otherwise an + ;; authentication dialog would appear on the GDM screen (see the + ;; upstream bug: + ;; https://gitlab.gnome.org/GNOME/gnome-settings-daemon/-/issues/273). + (list (computed-file + "02-allow-colord.rules" + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + + (let* ((rules.d + (string-append #$output + "/share/polkit-1" + "/rules.d")) + (allow-colord.rules (string-append + rules.d + "/02-allow-colord.rules"))) + (mkdir-p rules.d) + (call-with-output-file allow-colord.rules + (lambda (port) + ;; This workaround enables any local or remote in + ;; the "users" group to use colord (see: + ;; https://c-nergy.be/blog/?p=12073). + (format port "\ +polkit.addRule(function(action, subject) { + if (action.id.match(\"org.freedesktop.color-manager\")) { + polkit.log(\"POLKIT DEBUG returning YES for action: \" + action); + return polkit.Result.YES; + } +});~%")))))))) + '()))) + (define gdm-service-type (handle-xorg-configuration gdm-configuration (service-type (name 'gdm) @@ -1003,8 +1176,12 @@ the GNOME desktop environment.") gdm-shepherd-service) (service-extension account-service-type (const %gdm-accounts)) + (service-extension dconf-service-type + gdm-dconf-profiles) (service-extension pam-root-service-type gdm-pam-service) + (service-extension polkit-service-type + gdm-polkit-rules) (service-extension profile-service-type gdm-configuration-gnome-shell-assets) (service-extension dbus-root-service-type |