diff options
| author | Maxim Cournoyer <maxim.cournoyer@gmail.com> | 2021-10-01 17:10:49 -0400 |
|---|---|---|
| committer | Maxim Cournoyer <maxim.cournoyer@gmail.com> | 2021-10-01 17:10:49 -0400 |
| commit | 2e65e4834a226c570866f2e8976ed7f252b45cd1 (patch) | |
| tree | 21d625bce8d03627680214df4a6622bf8eb79dc9 /gnu/services | |
| parent | 9c68ecb24dd1660ce736cdcdea0422a73ec318a2 (diff) | |
| parent | f1a3c11407b52004e523ec5de20d326c5661681f (diff) | |
Merge remote-tracking branch 'origin/master' into staging
With resolved conflicts in:
gnu/packages/bittorrent.scm
gnu/packages/databases.scm
gnu/packages/geo.scm
gnu/packages/gnupg.scm
gnu/packages/gstreamer.scm
gnu/packages/gtk.scm
gnu/packages/linux.scm
gnu/packages/python-xyz.scm
gnu/packages/xorg.scm
guix/build/qt-utils.scm
Diffstat (limited to 'gnu/services')
29 files changed, 1711 insertions, 543 deletions
diff --git a/gnu/services/avahi.scm b/gnu/services/avahi.scm index 7812191cb2..2dcf1d9c1b 100644 --- a/gnu/services/avahi.scm +++ b/gnu/services/avahi.scm @@ -40,7 +40,6 @@ avahi-configuration-wide-area? avahi-configuration-domains-to-browse - avahi-service avahi-service-type)) ;;; Commentary: @@ -166,38 +165,4 @@ service switch (NSS) with support for @code{.local} host name resolution.") avahi-package))) (default-value (avahi-configuration))))) -(define-deprecated (avahi-service #:key (avahi avahi) debug? - host-name - (publish? #t) - (ipv4? #t) (ipv6? #t) - wide-area? - (domains-to-browse '())) - avahi-service-type - "Return a service that runs @command{avahi-daemon}, a system-wide -mDNS/DNS-SD responder that allows for service discovery and -\"zero-configuration\" host name lookups (see @uref{https://avahi.org/}), and -extends the name service cache daemon (nscd) so that it can resolve -@code{.local} host names using -@uref{http://0pointer.de/lennart/projects/nss-mdns/, nss-mdns}. Additionally, -add the @var{avahi} package to the system profile so that commands such as -@command{avahi-browse} are directly usable. - -If @var{host-name} is different from @code{#f}, use that as the host name to -publish for this machine; otherwise, use the machine's actual host name. - -When @var{publish?} is true, publishing of host names and services is allowed; -in particular, avahi-daemon will publish the machine's host name and IP -address via mDNS on the local network. - -When @var{wide-area?} is true, DNS-SD over unicast DNS is enabled. - -Boolean values @var{ipv4?} and @var{ipv6?} determine whether to use IPv4/IPv6 -sockets." - (service avahi-service-type - (avahi-configuration - (avahi avahi) (debug? debug?) (host-name host-name) - (publish? publish?) (ipv4? ipv4?) (ipv6? ipv6?) - (wide-area? wide-area?) - (domains-to-browse domains-to-browse)))) - ;;; avahi.scm ends here diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 24b3ea785b..50865055fe 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -12,8 +12,10 @@ ;;; Copyright © 2019 John Soo <jsoo1@asu.edu> ;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de> -;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re> +;;; Copyright © 2020, 2021 Brice Waegeneire <brice@waegenei.re> ;;; Copyright © 2021 qblade <qblade@protonmail.com> +;;; Copyright © 2021 Hui Lu <luhuins@163.com> +;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -41,6 +43,7 @@ #:use-module (gnu system shadow) ; 'user-account', etc. #:use-module (gnu system uuid) #:use-module (gnu system file-systems) ; 'file-system', etc. + #:use-module (gnu system keyboard) #:use-module (gnu system mapped-devices) #:use-module ((gnu system linux-initrd) #:select (file-system-packages)) @@ -71,7 +74,6 @@ file-system-service-type swap-service host-name-service - console-keymap-service %default-console-font console-font-service-type console-font-service @@ -151,7 +153,6 @@ guix-configuration-extra-options guix-configuration-log-file - guix-service guix-service-type guix-publish-configuration guix-publish-configuration? @@ -163,16 +164,13 @@ guix-publish-configuration-nar-path guix-publish-configuration-cache guix-publish-configuration-ttl - guix-publish-service guix-publish-service-type gpm-configuration gpm-configuration? gpm-service-type - gpm-service urandom-seed-service-type - urandom-seed-service rngd-configuration rngd-configuration? @@ -314,17 +312,20 @@ FILE-SYSTEM." (define (file-system-shepherd-service file-system) "Return the shepherd service for @var{file-system}, or @code{#f} if -@var{file-system} is not auto-mounted upon boot." +@var{file-system} is not auto-mounted or doesn't have its mount point created +upon boot." (let ((target (file-system-mount-point file-system)) (create? (file-system-create-mount-point? file-system)) + (mount? (file-system-mount? file-system)) (dependencies (file-system-dependencies file-system)) (packages (file-system-packages (list file-system)))) - (and (file-system-mount? file-system) + (and (or mount? create?) (with-imported-modules (source-module-closure '((gnu build file-systems))) (shepherd-service (provision (list (file-system->shepherd-service-name file-system))) - (requirement `(root-file-system udev + (requirement `(root-file-system + udev ,@(map dependency->shepherd-service-name dependencies))) (documentation "Check, mount, and unmount the given file system.") (start #~(lambda args @@ -332,24 +333,26 @@ FILE-SYSTEM." #~(mkdir-p #$target) #t) - (let (($PATH (getenv "PATH"))) - ;; Make sure fsck.ext2 & co. can be found. - (dynamic-wind - (lambda () - ;; Don’t display the PATH settings. - (with-output-to-port (%make-void-port "w") - (lambda () - (set-path-environment-variable "PATH" - '("bin" "sbin") - '#$packages)))) - (lambda () - (mount-file-system - (spec->file-system - '#$(file-system->spec file-system)) - #:root "/")) - (lambda () - (setenv "PATH" $PATH))) - #t))) + #$(if mount? + #~(let (($PATH (getenv "PATH"))) + ;; Make sure fsck.ext2 & co. can be found. + (dynamic-wind + (lambda () + ;; Don’t display the PATH settings. + (with-output-to-port (%make-void-port "w") + (lambda () + (set-path-environment-variable "PATH" + '("bin" "sbin") + '#$packages)))) + (lambda () + (mount-file-system + (spec->file-system + '#$(file-system->spec file-system)) + #:root "/")) + (lambda () + (setenv "PATH" $PATH)))) + #t) + #t)) (stop #~(lambda args ;; Normally there are no processes left at this point, so ;; TARGET can be safely unmounted. @@ -368,7 +371,10 @@ FILE-SYSTEM." (define (file-system-shepherd-services file-systems) "Return the list of Shepherd services for FILE-SYSTEMS." - (let* ((file-systems (filter file-system-mount? file-systems))) + (let* ((file-systems (filter (lambda (x) + (or (file-system-mount? x) + (file-system-create-mount-point? x))) + file-systems))) (define sink (shepherd-service (provision '(file-systems)) @@ -543,10 +549,6 @@ file systems, as well as corresponding @file{/etc/fstab} entries."))) generator (RNG) with the value recorded when the system was last shut down."))) -(define-deprecated (urandom-seed-service) - urandom-seed-service-type - (service urandom-seed-service-type)) - ;;; ;;; Add hardware random number generator to entropy pool. @@ -651,11 +653,6 @@ to add @var{device} to the kernel's entropy pool. The service will fail if @code{keyboard-layout} field of @code{operating-system}.} Load the given list of console keymaps with @command{loadkeys}."))) -(define-deprecated (console-keymap-service #:rest files) - #f - "Return a service to load console keymaps from @var{files}." - (service console-keymap-service-type files)) - (define %default-console-font ;; Note: 'LatGrkCyr-8x16' has the advantage of providing three common ;; scripts as well as glyphs for em dash, quotation marks, and other Unicode @@ -1395,14 +1392,8 @@ information on the configuration file syntax." (let ((security-limits ;; Create /etc/security containing the provided "limits.conf" file. (lambda (limits-file) - `(("security" - ,(computed-file - "security" - #~(begin - (mkdir #$output) - (stat #$limits-file) - (symlink #$limits-file - (string-append #$output "/limits.conf")))))))) + `(("security/limits.conf" + ,limits-file)))) (pam-extension (lambda (pam) (let ((pam-limits (pam-entry @@ -1516,7 +1507,8 @@ archive' public keys, with GUIX." (define %default-authorized-guix-keys ;; List of authorized substitute keys. - (list (file-append guix "/share/guix/berlin.guix.gnu.org.pub"))) + (list (file-append guix "/share/guix/berlin.guix.gnu.org.pub") + (file-append guix "/share/guix/bordeaux.guix.gnu.org.pub"))) (define-record-type* <guix-configuration> guix-configuration make-guix-configuration @@ -1711,21 +1703,21 @@ proxy of 'guix-daemon'...~%") (define (guix-activation config) "Return the activation gexp for CONFIG." - (match config - (($ <guix-configuration> guix build-group build-accounts authorize-key? keys) - ;; Assume that the store has BUILD-GROUP as its group. We could - ;; otherwise call 'chown' here, but the problem is that on a COW overlayfs, - ;; chown leads to an entire copy of the tree, which is a bad idea. + (match-record config <guix-configuration> + (guix authorize-key? authorized-keys) + #~(begin + ;; Assume that the store has BUILD-GROUP as its group. We could + ;; otherwise call 'chown' here, but the problem is that on a COW overlayfs, + ;; chown leads to an entire copy of the tree, which is a bad idea. - ;; Generate a key pair and optionally authorize substitute server keys. - #~(begin - (unless (file-exists? "/etc/guix/signing-key.pub") - (system* #$(file-append guix "/bin/guix") "archive" - "--generate-key")) + ;; Generate a key pair and optionally authorize substitute server keys. + (unless (file-exists? "/etc/guix/signing-key.pub") + (system* #$(file-append guix "/bin/guix") "archive" + "--generate-key")) - #$(if authorize-key? - (substitute-key-authorization keys guix) - #~#f))))) + #$(if authorize-key? + (substitute-key-authorization authorized-keys guix) + #~#f)))) (define* (references-file item #:optional (name "references")) "Return a file that contains the list of references of ITEM." @@ -1770,13 +1762,6 @@ proxy of 'guix-daemon'...~%") (description "Run the build daemon of GNU@tie{}Guix, aka. @command{guix-daemon}."))) -(define-deprecated (guix-service #:optional - (config %default-guix-configuration)) - guix-service-type - "Return a service that runs the Guix build daemon according to -@var{config}." - (service guix-service-type config)) - (define-record-type* <guix-publish-configuration> guix-publish-configuration make-guix-publish-configuration @@ -1928,19 +1913,6 @@ raise a deprecation warning if the 'compression-level' field was used." "Add a Shepherd service running @command{guix publish}, a command that allows you to share pre-built binaries with others over HTTP."))) -(define-deprecated (guix-publish-service #:key (guix guix) - (port 80) (host "localhost")) - guix-publish-service-type - "Return a service that runs @command{guix publish} listening on @var{host} -and @var{port} (@pxref{Invoking guix publish}). - -This assumes that @file{/etc/guix} already contains a signing key pair as -created by @command{guix archive --generate-key} (@pxref{Invoking guix -archive}). If that is not the case, the service will fail to start." - ;; Deprecated. - (service guix-publish-service-type - (guix-publish-configuration (guix guix) (port port) (host host)))) - ;;; ;;; Udev. @@ -2248,23 +2220,13 @@ instance." (list (shepherd-service (requirement '(udev)) (provision '(gpm)) - (start #~(lambda () - ;; 'gpm' runs in the background and sets a PID file. - ;; Note that it requires running as "root". - (false-if-exception (delete-file "/var/run/gpm.pid")) - (fork+exec-command (list #$(file-append gpm "/sbin/gpm") - #$@options)) - - ;; Wait for the PID file to appear; declare failure if - ;; it doesn't show up. - (let loop ((i 3)) - (or (file-exists? "/var/run/gpm.pid") - (if (zero? i) - #f - (begin - (sleep 1) - (loop (1- i)))))))) - + ;; '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") @@ -2282,19 +2244,6 @@ command-line options. GPM allows users to use the mouse in the console, notably to select, copy, and paste text. The default options use the @code{ps2} protocol, which works for both USB and PS/2 mice."))) -(define-deprecated (gpm-service #:key (gpm gpm) - (options %default-gpm-options)) - gpm-service-type - "Run @var{gpm}, the general-purpose mouse daemon, with the given -command-line @var{options}. GPM allows users to use the mouse in the console, -notably to select, copy, and paste text. The default value of @var{options} -uses the @code{ps2} protocol, which works for both USB and PS/2 mice. - -This service is not part of @var{%base-services}." - ;; To test in QEMU, use "-usbdevice mouse" and then, in the monitor, use - ;; "info mice" and "mouse_set X" to use the right mouse. - (service gpm-service-type - (gpm-configuration (gpm gpm) (options options)))) (define-record-type* <kmscon-configuration> kmscon-configuration make-kmscon-configuration @@ -2313,7 +2262,9 @@ This service is not part of @var{%base-services}." (font-engine kmscon-configuration-font-engine (default "pango")) (font-size kmscon-configuration-font-size - (default 12))) + (default 12)) + (keyboard-layout kmscon-configuration-keyboard-layout + (default #f))) ; #f | <keyboard-layout> (define kmscon-service-type (shepherd-service-type @@ -2326,7 +2277,8 @@ This service is not part of @var{%base-services}." (auto-login (kmscon-configuration-auto-login config)) (hardware-acceleration? (kmscon-configuration-hardware-acceleration? config)) (font-engine (kmscon-configuration-font-engine config)) - (font-size (kmscon-configuration-font-size config))) + (font-size (kmscon-configuration-font-size config)) + (keyboard-layout (kmscon-configuration-keyboard-layout config))) (define kmscon-command #~(list @@ -2335,6 +2287,18 @@ This service is not part of @var{%base-services}." "--no-switchvt" ;Prevent a switch to the virtual terminal. "--font-engine" #$font-engine "--font-size" #$(number->string font-size) + #$@(if keyboard-layout + (let* ((layout (keyboard-layout-name keyboard-layout)) + (variant (keyboard-layout-variant keyboard-layout)) + (model (keyboard-layout-model keyboard-layout)) + (options (keyboard-layout-options keyboard-layout))) + `("--xkb-layout" ,layout + ,@(if variant `("--xkb-variant" ,variant) '()) + ,@(if model `("--xkb-model" ,model) '()) + ,@(if (null? options) + '() + `("--xkb-options" ,(string-join options ","))))) + '()) #$@(if hardware-acceleration? '("--hwaccel") '()) "--login" "--" #$login-program #$@login-arguments diff --git a/gnu/services/certbot.scm b/gnu/services/certbot.scm index 1c67ff63f1..1c819bef48 100644 --- a/gnu/services/certbot.scm +++ b/gnu/services/certbot.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2020 Jack Hill <jackhill@jackhill.us> ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> +;;; Copyright © 2021 Raghav Gururajan <rg@raghavgururajan.name> ;;; ;;; This file is part of GNU Guix. ;;; @@ -55,6 +56,8 @@ (default '())) (challenge certificate-configuration-challenge (default #f)) + (csr certificate-configuration-csr + (default #f)) (authentication-hook certificate-authentication-hook (default #f)) (cleanup-hook certificate-cleanup-hook @@ -94,8 +97,8 @@ (map (match-lambda (($ <certificate-configuration> custom-name domains challenge - authentication-hook cleanup-hook - deploy-hook) + csr authentication-hook + cleanup-hook deploy-hook) (let ((name (or custom-name (car domains)))) (if challenge (append @@ -105,6 +108,7 @@ "--cert-name" name "--manual-public-ip-logging-ok" "-d" (string-join domains ",")) + (if csr `("--csr" ,csr) '()) (if email `("--email" ,email) '("--register-unsafely-without-email")) @@ -120,6 +124,7 @@ "--webroot" "-w" webroot "--cert-name" name "-d" (string-join domains ",")) + (if csr `("--csr" ,csr) '()) (if email `("--email" ,email) '("--register-unsafely-without-email")) diff --git a/gnu/services/ci.scm b/gnu/services/ci.scm index 0b18521e76..0c3566bcaf 100644 --- a/gnu/services/ci.scm +++ b/gnu/services/ci.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018, 2019, 2020, 2021 Christopher Baines <mail@cbaines.net> +;;; Copyright © 2021 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -115,13 +116,25 @@ (home-directory (laminar-configuration-home-directory config)) (shell #~(string-append #$shadow "/sbin/nologin"))))) +(define (laminar-activation config) + (let ((bind-http (laminar-configuration-bind-http config))) + #~(begin + ;; If listen is a unix socket, create its parent directory. + (when (string-prefix? "unix:" #$bind-http) + (let ((run-directory + (dirname (substring #$bind-http (string-length "unix:")))) + (user (getpw "laminar"))) + (mkdir-p run-directory) + (chown run-directory (passwd:uid user) (passwd:gid user))))))) + (define laminar-service-type (service-type (name 'laminar) (extensions (list (service-extension shepherd-root-service-type laminar-shepherd-service) - (service-extension account-service-type laminar-account))) + (service-extension account-service-type laminar-account) + (service-extension activation-service-type laminar-activation))) (default-value (laminar-configuration)) (description "Run the Laminar continuous integration service."))) diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm index 90f12a8d39..df3d3b6f9b 100644 --- a/gnu/services/configuration.scm +++ b/gnu/services/configuration.scm @@ -2,6 +2,8 @@ ;;; Copyright © 2015 Andy Wingo <wingo@igalia.com> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org> +;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,10 +25,12 @@ #:use-module (guix records) #:use-module (guix gexp) #:use-module ((guix utils) #:select (source-properties->location)) + #:use-module ((guix diagnostics) #:select (location-file)) + #:use-module ((guix modules) #:select (file-name->module-name)) #:autoload (texinfo) (texi-fragment->stexi) #:autoload (texinfo serialize) (stexi->texi) #:use-module (ice-9 match) - #:use-module ((srfi srfi-1) #:select (append-map)) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:export (configuration-field @@ -38,11 +42,20 @@ configuration-field-getter configuration-field-default-value-thunk configuration-field-documentation + + configuration-error? + + define-configuration + define-configuration/no-serialization + no-serialization + serialize-configuration define-maybe - define-configuration + define-maybe/no-serialization validate-configuration generate-documentation + configuration->documentation + empty-serializer serialize-package)) ;;; Commentary: @@ -63,6 +76,10 @@ (define (configuration-missing-field kind field) (configuration-error (format #f "~a configuration missing required field ~a" kind field))) +(define (configuration-no-default-value kind field) + (configuration-error + (format #f "The field `~a' of the `~a' configuration record \ +does not have a default value" field kind))) (define-record-type* <configuration-field> configuration-field make-configuration-field configuration-field? @@ -91,100 +108,218 @@ fields)) (define-syntax-rule (id ctx parts ...) - "Assemble PARTS into a raw (unhygienic) identifier." + "Assemble PARTS into a raw (unhygienic) identifier." (datum->syntax ctx (symbol-append (syntax->datum parts) ...))) +(define (define-maybe-helper serialize? prefix syn) + (syntax-case syn () + ((_ stem) + (with-syntax + ((stem? (id #'stem #'stem #'?)) + (maybe-stem? (id #'stem #'maybe- #'stem #'?)) + (serialize-stem (if prefix + (id #'stem prefix #'serialize- #'stem) + (id #'stem #'serialize- #'stem))) + (serialize-maybe-stem (if prefix + (id #'stem prefix #'serialize-maybe- #'stem) + (id #'stem #'serialize-maybe- #'stem)))) + #`(begin + (define (maybe-stem? val) + (or (eq? val 'disabled) (stem? val))) + #,@(if serialize? + (list #'(define (serialize-maybe-stem field-name val) + (if (stem? val) + (serialize-stem field-name val) + ""))) + '())))))) + (define-syntax define-maybe (lambda (x) - (syntax-case x () + (syntax-case x (no-serialization prefix) + ((_ stem (no-serialization)) + (define-maybe-helper #f #f #'(_ stem))) + ((_ stem (prefix serializer-prefix)) + (define-maybe-helper #t #'serializer-prefix #'(_ stem))) ((_ stem) - (with-syntax - ((stem? (id #'stem #'stem #'?)) - (maybe-stem? (id #'stem #'maybe- #'stem #'?)) - (serialize-stem (id #'stem #'serialize- #'stem)) - (serialize-maybe-stem (id #'stem #'serialize-maybe- #'stem))) - #'(begin - (define (maybe-stem? val) - (or (eq? val 'disabled) (stem? val))) - (define (serialize-maybe-stem field-name val) - (if (stem? val) (serialize-stem field-name val) "")))))))) + (define-maybe-helper #t #f #'(_ stem)))))) + +(define-syntax-rule (define-maybe/no-serialization stem) + (define-maybe stem (no-serialization))) + +(define (define-configuration-helper serialize? serializer-prefix syn) + (syntax-case syn () + ((_ stem (field (field-type def ...) doc custom-serializer ...) ...) + (with-syntax (((field-getter ...) + (map (lambda (field) + (id #'stem #'stem #'- field)) + #'(field ...))) + ((field-predicate ...) + (map (lambda (type) + (id #'stem type #'?)) + #'(field-type ...))) + ((field-default ...) + (map (match-lambda + ((field-type default-value) + default-value) + ((field-type) + ;; Quote `undefined' to prevent a possibly + ;; unbound warning. + (syntax 'undefined))) + #'((field-type def ...) ...))) + ((field-serializer ...) + (map (lambda (type custom-serializer) + (and serialize? + (match custom-serializer + ((serializer) + serializer) + (() + (if serializer-prefix + (id #'stem + serializer-prefix + #'serialize- type) + (id #'stem #'serialize- type)))))) + #'(field-type ...) + #'((custom-serializer ...) ...)))) + #`(begin + (define-record-type* #,(id #'stem #'< #'stem #'>) + #,(id #'stem #'% #'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) + (if (eq? (syntax->datum def) (quote 'undefined)) + #`(#,name #,getter) + #`(#,name #,getter (default #,def)))) + #'(field ...) + #'(field-getter ...) + #'(field-default ...))) + (define #,(id #'stem #'stem #'-fields) + (list (configuration-field + (name 'field) + (type 'field-type) + (getter field-getter) + (predicate field-predicate) + (serializer field-serializer) + (default-value-thunk + (lambda () + (display '#,(id #'stem #'% #'stem)) + (if (eq? (syntax->datum field-default) + 'undefined) + (configuration-no-default-value + '#,(id #'stem #'% #'stem) 'field) + field-default))) + (documentation doc)) + ...)) + (define-syntax-rule (stem arg (... ...)) + (let ((conf (#,(id #'stem #'% #'stem) arg (... ...)))) + (validate-configuration conf + #,(id #'stem #'stem #'-fields)) + conf))))))) + +(define no-serialization ;syntactic keyword for 'define-configuration' + '(no serialization)) (define-syntax define-configuration - (lambda (stx) - (syntax-case stx () - ((_ stem (field (field-type def) doc) ...) - (with-syntax (((field-getter ...) - (map (lambda (field) - (id #'stem #'stem #'- field)) - #'(field ...))) - ((field-predicate ...) - (map (lambda (type) - (id #'stem type #'?)) - #'(field-type ...))) - ((field-serializer ...) - (map (lambda (type) - (id #'stem #'serialize- type)) - #'(field-type ...)))) - #`(begin - (define-record-type* #,(id #'stem #'< #'stem #'>) - #,(id #'stem #'% #'stem) - #,(id #'stem #'make- #'stem) - #,(id #'stem #'stem #'?) - (%location #,(id #'stem #'-location) - (default (and=> (current-source-location) - source-properties->location)) - (innate)) - (field field-getter (default def)) - ...) - (define #,(id #'stem #'stem #'-fields) - (list (configuration-field - (name 'field) - (type 'field-type) - (getter field-getter) - (predicate field-predicate) - (serializer field-serializer) - (default-value-thunk (lambda () def)) - (documentation doc)) - ...)) - (define-syntax-rule (stem arg (... ...)) - (let ((conf (#,(id #'stem #'% #'stem) arg (... ...)))) - (validate-configuration conf - #,(id #'stem #'stem #'-fields)) - conf)))))))) - -(define (serialize-package field-name val) - "") + (lambda (s) + (syntax-case s (no-serialization prefix) + ((_ stem (field (field-type def ...) doc custom-serializer ...) ... + (no-serialization)) + (define-configuration-helper + #f #f #'(_ stem (field (field-type def ...) doc custom-serializer ...) + ...))) + ((_ stem (field (field-type def ...) doc custom-serializer ...) ... + (prefix serializer-prefix)) + (define-configuration-helper + #t #'serializer-prefix #'(_ stem (field (field-type def ...) + doc custom-serializer ...) + ...))) + ((_ stem (field (field-type def ...) doc custom-serializer ...) ...) + (define-configuration-helper + #t #f #'(_ stem (field (field-type def ...) doc custom-serializer ...) + ...)))))) + +(define-syntax-rule (define-configuration/no-serialization + stem (field (field-type def ...) + doc custom-serializer ...) ...) + (define-configuration stem (field (field-type def ...) + doc custom-serializer ...) ... + (no-serialization))) + +(define (empty-serializer field-name val) "") +(define serialize-package empty-serializer) ;; A little helper to make it easier to document all those fields. (define (generate-documentation documentation documentation-name) (define (str x) (object->string x)) + + (define (package->symbol package) + "Return the first symbol name of a package that matches PACKAGE, else #f." + (let* ((module (file-name->module-name + (location-file (package-location package)))) + (symbols (filter-map + identity + (module-map (lambda (symbol var) + (and (equal? package (variable-ref var)) + symbol)) + (resolve-module module))))) + (if (null? symbols) + #f + (first symbols)))) + (define (generate configuration-name) (match (assq-ref documentation configuration-name) ((fields . sub-documentation) - `((para "Available " (code ,(str configuration-name)) " fields are:") - ,@(map - (lambda (f) - (let ((field-name (configuration-field-name f)) - (field-type (configuration-field-type f)) - (field-docs (cdr (texi-fragment->stexi - (configuration-field-documentation f)))) - (default (catch #t - (configuration-field-default-value-thunk f) - (lambda _ '%invalid)))) - (define (show-default? val) - (or (string? val) (number? val) (boolean? val) - (and (symbol? val) (not (eq? val '%invalid))) - (and (list? val) (and-map show-default? val)))) - `(deftypevr (% (category - (code ,(str configuration-name)) " parameter") - (data-type ,(str field-type)) - (name ,(str field-name))) - ,@field-docs - ,@(if (show-default? default) - `((para "Defaults to " (samp ,(str default)) ".")) - '()) - ,@(append-map - generate - (or (assq-ref sub-documentation field-name) '()))))) - fields))))) + `((deftp (% (category "Data Type") (name ,(str configuration-name))) + (para "Available " (code ,(str configuration-name)) " fields are:") + (table + (% (formatter (asis))) + ,@(map + (lambda (f) + (let ((field-name (configuration-field-name f)) + (field-type (configuration-field-type f)) + (field-docs (cdr (texi-fragment->stexi + (configuration-field-documentation f)))) + (default (catch #t + (configuration-field-default-value-thunk f) + (lambda _ '%invalid)))) + (define (show-default? val) + (or (string? val) (number? val) (boolean? val) + (package? val) + (and (symbol? val) (not (eq? val '%invalid))) + (and (list? val) (and-map show-default? val)))) + + (define (show-default val) + (cond + ((package? val) + (symbol->string (package->symbol val))) + (else (str val)))) + + `(entry (% (heading + (code ,(str field-name)) + ,@(if (show-default? default) + `(" (default: " + (code ,(show-default default)) ")") + '()) + " (type: " ,(str field-type) ")")) + (para ,@field-docs) + ,@(append-map + generate + (or (assq-ref sub-documentation field-name) + '()))))) + fields))))))) (stexi->texi `(*fragment* . ,(generate documentation-name)))) + +(define (configuration->documentation configuration-symbol) + "Take CONFIGURATION-SYMBOL, the symbol corresponding to the name used when +defining a configuration record with DEFINE-CONFIGURATION, and output the +Texinfo documentation of its fields." + ;; This is helper for a simple, straight-forward application of + ;; GENERATE-DOCUMENTATION. + (let ((fields-getter (module-ref (current-module) + (symbol-append configuration-symbol + '-fields)))) + (display (generate-documentation `((,configuration-symbol ,fields-getter)) + configuration-symbol)))) diff --git a/gnu/services/cuirass.scm b/gnu/services/cuirass.scm index 9de36eb1c9..83e63fe79c 100644 --- a/gnu/services/cuirass.scm +++ b/gnu/services/cuirass.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org> -;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net> @@ -25,6 +25,7 @@ #:use-module (guix channels) #:use-module (guix gexp) #:use-module (guix records) + #:use-module (guix store) #:use-module (guix utils) #:use-module (gnu packages admin) #:use-module (gnu packages ci) @@ -38,16 +39,13 @@ #:use-module (gnu system shadow) #:use-module (srfi srfi-1) #:use-module (ice-9 match) - #:export (<cuirass-remote-server-configuration> - cuirass-remote-server-configuration + #:export (cuirass-remote-server-configuration cuirass-remote-server-configuration? - <cuirass-configuration> cuirass-configuration cuirass-configuration? cuirass-service-type - <cuirass-remote-worker-configuration> cuirass-remote-worker-configuration cuirass-remote-worker-configuration? cuirass-remote-worker-service-type)) @@ -60,7 +58,7 @@ ;;;; Code: (define %cuirass-default-database - "dbname=cuirass host=/var/run/postgresql") + "dbname=cuirass host=/tmp") (define-record-type* <cuirass-remote-server-configuration> cuirass-remote-server-configuration make-cuirass-remote-server-configuration @@ -75,6 +73,8 @@ (default "/var/log/cuirass-remote-server.log")) (cache cuirass-remote-server-configuration-cache ;string (default "/var/cache/cuirass/remote/")) + (publish? cuirass-remote-server-configuration-publish? ;boolean + (default #t)) (trigger-url cuirass-remote-server-trigger-url ;string (default #f)) (public-key cuirass-remote-server-configuration-public-key ;string @@ -194,8 +194,8 @@ (stop #~(make-kill-destructor))) ,@(if remote-server (match-record remote-server <cuirass-remote-server-configuration> - (backend-port publish-port log-file cache trigger-url - public-key private-key) + (backend-port publish-port log-file cache publish? + trigger-url public-key private-key) (list (shepherd-service (documentation "Run Cuirass remote build server.") @@ -228,6 +228,9 @@ "--trigger-substitute-url=" trigger-url)) '()) + #$@(if publish? + '() + (list "--no-publish")) #$@(if public-key (list (string-append "--public-key=" @@ -272,6 +275,8 @@ remote-server))) (user (cuirass-configuration-user config)) (log "/var/log/cuirass") + (profile (string-append "/var/guix/profiles/per-user/" user)) + (roots (string-append profile "/cuirass")) (group (cuirass-configuration-group config))) (with-imported-modules '((guix build utils)) #~(begin @@ -279,6 +284,7 @@ (mkdir-p #$cache) (mkdir-p #$log) + (mkdir-p #$roots) (when #$remote-cache (mkdir-p #$remote-cache)) @@ -287,6 +293,8 @@ (gid (group:gid (getgr #$group)))) (chown #$cache uid gid) (chown #$log uid gid) + (chown #$roots uid gid) + (chown #$profile uid gid) (when #$remote-cache (chown #$remote-cache uid gid))))))) @@ -331,6 +339,8 @@ (default "/var/log/cuirass-remote-worker.log")) (publish-port cuirass-remote-worker-configuration-publish-port ;int (default 5558)) + (substitute-urls cuirass-remote-worker-configuration-substitute-urls + (default %default-substitute-urls)) ;list of strings (public-key cuirass-remote-worker-configuration-public-key ;string (default #f)) (private-key cuirass-remote-worker-configuration-private-key ;string @@ -341,7 +351,7 @@ CONFIG." (match-record config <cuirass-remote-worker-configuration> (cuirass workers server systems log-file publish-port - public-key private-key) + substitute-urls public-key private-key) (list (shepherd-service (documentation "Run Cuirass remote build worker.") (provision '(cuirass-remote-worker)) @@ -364,6 +374,11 @@ CONFIG." "--publish-port=" (number->string publish-port))) '()) + #$@(if substitute-urls + (list (string-append + "--substitute-urls=" + (string-join substitute-urls))) + '()) #$@(if public-key (list (string-append "--public-key=" diff --git a/gnu/services/cups.scm b/gnu/services/cups.scm index 20e3917b93..8bcb450ddf 100644 --- a/gnu/services/cups.scm +++ b/gnu/services/cups.scm @@ -292,11 +292,12 @@ methods. Otherwise apply to only the listed methods.") "Name of the policy.") (job-private-access (string "@OWNER @SYSTEM") - "Specifies an access list for a job's private values. @code{@@ACL} maps to -the printer's requesting-user-name-allowed or requesting-user-name-denied -values. @code{@@OWNER} maps to the job's owner. @code{@@SYSTEM} maps to the -groups listed for the @code{system-group} field of the @code{files-config} -configuration, which is reified into the @code{cups-files.conf(5)} file. + "Specifies an access list for a job's private values. +@code{@@ACL} maps to the printer's requesting-user-name-allowed or +requesting-user-name-denied values. @code{@@OWNER} maps to the job's owner. +@code{@@SYSTEM} maps to the groups listed for the @code{system-group} field of +the @code{files-configuration}, which is reified into the +@code{cups-files.conf(5)} file. Other possible elements of the access list include specific user names, and @code{@@@var{group}} to indicate members of a specific group. The access list may also be simply @code{all} or @code{default}.") @@ -312,11 +313,11 @@ may also be simply @code{all} or @code{default}.") @code{@@ACL} maps to the printer's requesting-user-name-allowed or requesting-user-name-denied values. @code{@@OWNER} maps to the job's owner. @code{@@SYSTEM} maps to the groups listed for the @code{system-group} field of -the @code{files-config} configuration, which is reified into the -@code{cups-files.conf(5)} file. Other possible elements of the access list -include specific user names, and @code{@@@var{group}} to indicate members of a -specific group. The access list may also be simply @code{all} or -@code{default}.") +the @code{files-configuration}, which is reified into the +@code{cups-files.conf(5)} file. +Other possible elements of the access list include specific user names, and +@code{@@@var{group}} to indicate members of a specific group. The access list +may also be simply @code{all} or @code{default}.") (subscription-private-values (string (string-join '("notify-events" "notify-pull-method" "notify-recipient-uri" "notify-subscriber-user-name" @@ -614,9 +615,6 @@ policy is @code{retry-job} or @code{retry-current-job}.") (keep-alive? (boolean #t) "Specifies whether to support HTTP keep-alive connections.") - (keep-alive-timeout - (non-negative-integer 30) - "Specifies how long an idle client connection remains open, in seconds.") (limit-request-body (non-negative-integer 0) "Specifies the maximum size of print files, IPP requests, and HTML form diff --git a/gnu/services/databases.scm b/gnu/services/databases.scm index 6ef3f3383c..eba88cdb68 100644 --- a/gnu/services/databases.scm +++ b/gnu/services/databases.scm @@ -7,6 +7,7 @@ ;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.net> ;;; Copyright © 2020 Marius Bakke <marius@gnu.org> +;;; Copyright © 2021 David Larsson <david.larsson@selfhosted.xyz> ;;; ;;; This file is part of GNU Guix. ;;; @@ -363,7 +364,7 @@ and stores the database cluster in @var{data-directory}." postgresql-role-configuration make-postgresql-role-configuration postgresql-role-configuration? (host postgresql-role-configuration-host ;string - (default "/var/run/postgresql")) + (default "/tmp")) (log postgresql-role-configuration-log ;string (default "/var/log/postgresql_roles.log")) (roles postgresql-role-configuration-roles @@ -527,6 +528,7 @@ created after the PostgreSQL database is started."))) (port mysql-configuration-port (default 3306)) (socket mysql-configuration-socket (default "/run/mysqld/mysqld.sock")) (extra-content mysql-configuration-extra-content (default "")) + (extra-environment mysql-configuration-extra-environment (default #~'())) (auto-upgrade? mysql-configuration-auto-upgrade? (default #t))) (define %mysql-accounts @@ -611,11 +613,14 @@ FLUSH PRIVILEGES; (provision '(mysql)) (documentation "Run the MySQL server.") (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"))) + #:user "mysql" #:group "mysql" + #:log-file "/var/log/mysqld.log" + #:environment-variables #$extra-env))) (stop #~(make-kill-destructor))))) (define (mysql-upgrade-wrapper mysql socket-file) diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm index af1a1e4c3a..e7b3dac166 100644 --- a/gnu/services/dbus.scm +++ b/gnu/services/dbus.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com> ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> +;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re> ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,6 +22,7 @@ (define-module (gnu services dbus) #:use-module (gnu services) #:use-module (gnu services shepherd) + #:use-module (gnu system setuid) #:use-module (gnu system shadow) #:use-module (gnu system pam) #:use-module ((gnu packages glib) #:select (dbus)) @@ -156,10 +158,12 @@ includes the @code{etc/dbus-1/system.d} directories of each package listed in (shell (file-append shadow "/sbin/nologin"))))) (define dbus-setuid-programs - ;; Return the file name of the setuid program that we need. + ;; Return a list of <setuid-program> for the program that we need. (match-lambda (($ <dbus-configuration> dbus services) - (list (file-append dbus "/libexec/dbus-daemon-launch-helper"))))) + (list (setuid-program + (program (file-append + dbus "/libexec/dbus-daemon-launch-helper"))))))) (define (dbus-activation config) "Return an activation gexp for D-Bus using @var{config}." @@ -335,8 +339,9 @@ tuples, are all set as environment variables when the bus daemon launches it." (define polkit-setuid-programs (match-lambda (($ <polkit-configuration> polkit) - (list (file-append polkit "/lib/polkit-1/polkit-agent-helper-1") - (file-append polkit "/bin/pkexec"))))) + (map file-like->setuid-program + (list (file-append polkit "/lib/polkit-1/polkit-agent-helper-1") + (file-append polkit "/bin/pkexec")))))) (define polkit-service-type (service-type (name 'polkit) diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm index 265cf9f35f..64d0e85301 100644 --- a/gnu/services/desktop.scm +++ b/gnu/services/desktop.scm @@ -12,6 +12,7 @@ ;;; Copyright © 2019 David Wilson <david@daviwil.com> ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> ;;; Copyright © 2020 Reza Alizadeh Majd <r.majd@pantherx.org> +;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re> ;;; ;;; This file is part of GNU Guix. ;;; @@ -40,6 +41,7 @@ #:use-module ((gnu system file-systems) #:select (%elogind-file-systems file-system)) #:use-module (gnu system) + #:use-module (gnu system setuid) #:use-module (gnu system shadow) #:use-module (gnu system pam) #:use-module (gnu packages glib) @@ -82,7 +84,6 @@ upower-configuration-time-action upower-configuration-critical-power-action - upower-service upower-service-type udisks-configuration @@ -91,7 +92,6 @@ udisks-service-type colord-service-type - colord-service geoclue-application geoclue-configuration @@ -285,37 +285,6 @@ used by GNOME.") upower-package))) (default-value (upower-configuration))))) -(define-deprecated (upower-service #:key (upower upower) - (watts-up-pro? #f) - (poll-batteries? #t) - (ignore-lid? #f) - (use-percentage-for-policy? #f) - (percentage-low 10) - (percentage-critical 3) - (percentage-action 2) - (time-low 1200) - (time-critical 300) - (time-action 120) - (critical-power-action 'hybrid-sleep)) - upower-service-type - "Return a service that runs @uref{http://upower.freedesktop.org/, -@command{upowerd}}, a system-wide monitor for power consumption and battery -levels, with the given configuration settings. It implements the -@code{org.freedesktop.UPower} D-Bus interface, and is notably used by GNOME." - (let ((config (upower-configuration - (watts-up-pro? watts-up-pro?) - (poll-batteries? poll-batteries?) - (ignore-lid? ignore-lid?) - (use-percentage-for-policy? use-percentage-for-policy?) - (percentage-low percentage-low) - (percentage-critical percentage-critical) - (percentage-action percentage-action) - (time-low time-low) - (time-critical time-critical) - (time-action time-action) - (critical-power-action critical-power-action)))) - (service upower-service-type config))) - ;;; ;;; GeoClue D-Bus service. @@ -540,15 +509,6 @@ Users need to be in the @code{lp} group to access the D-Bus service. interface to manage the color profiles of input and output devices such as screens and scanners."))) -(define-deprecated (colord-service #:key (colord colord)) - colord-service-type - "Return a service that runs @command{colord}, a system service with a D-Bus -interface to manage the color profiles of input and output devices such as -screens and scanners. It is notably used by the GNOME Color Manager graphical -tool. See @uref{http://www.freedesktop.org/software/colord/, the colord web -site} for more information." - (service colord-service-type colord)) - ;;; ;;; UDisks. @@ -1076,14 +1036,15 @@ rules." (define (enlightenment-setuid-programs enlightenment-desktop-configuration) (match-record enlightenment-desktop-configuration - <enlightenment-desktop-configuration> - (enlightenment) - (list (file-append enlightenment - "/lib/enlightenment/utils/enlightenment_sys") - (file-append enlightenment - "/lib/enlightenment/utils/enlightenment_system") - (file-append enlightenment - "/lib/enlightenment/utils/enlightenment_ckpasswd")))) + <enlightenment-desktop-configuration> + (enlightenment) + (map file-like->setuid-program + (list (file-append enlightenment + "/lib/enlightenment/utils/enlightenment_sys") + (file-append enlightenment + "/lib/enlightenment/utils/enlightenment_system") + (file-append enlightenment + "/lib/enlightenment/utils/enlightenment_ckpasswd"))))) (define enlightenment-desktop-service-type (service-type @@ -1246,8 +1207,11 @@ or setting its password with passwd."))) ;; Allow desktop users to also mount NTFS and NFS file systems ;; without root. (simple-service 'mount-setuid-helpers setuid-program-service-type - (list (file-append nfs-utils "/sbin/mount.nfs") - (file-append ntfs-3g "/sbin/mount.ntfs-3g"))) + (map (lambda (program) + (setuid-program + (program program))) + (list (file-append nfs-utils "/sbin/mount.nfs") + (file-append ntfs-3g "/sbin/mount.ntfs-3g")))) ;; The global fontconfig cache directory can sometimes contain ;; stale entries, possibly referencing fonts that have been GC'd, diff --git a/gnu/services/dns.scm b/gnu/services/dns.scm index 55211cb08f..aeb2bfdc86 100644 --- a/gnu/services/dns.scm +++ b/gnu/services/dns.scm @@ -861,12 +861,20 @@ cache.size = 100 * MB #:pid-file "/run/dnsmasq.pid")) (stop #~(make-kill-destructor)))))) +(define (dnsmasq-activation config) + #~(begin + (use-modules (guix build utils)) + ;; create directory to store dnsmasq lease file + (mkdir-p "/var/lib/misc"))) + (define dnsmasq-service-type (service-type (name 'dnsmasq) (extensions (list (service-extension shepherd-root-service-type - (compose list dnsmasq-shepherd-service)))) + (compose list dnsmasq-shepherd-service)) + (service-extension activation-service-type + dnsmasq-activation))) (default-value (dnsmasq-configuration)) (description "Run the dnsmasq DNS server."))) diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm index 7acfbea49f..ef551480aa 100644 --- a/gnu/services/docker.scm +++ b/gnu/services/docker.scm @@ -1,9 +1,10 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Danny Milosavljevic <dannym@scratchpost.org> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> -;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2020 Jesse Dowell <jessedowell@gmail.com> +;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re> ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,6 +27,7 @@ #:use-module (gnu services base) #:use-module (gnu services dbus) #:use-module (gnu services shepherd) + #:use-module (gnu system setuid) #:use-module (gnu system shadow) #:use-module (gnu packages docker) #:use-module (gnu packages linux) ;singularity @@ -37,11 +39,6 @@ docker-service-type singularity-service-type)) -;;; We're not using serialize-configuration, but we must define this because -;;; the define-configuration macro validates it exists. -(define (serialize-boolean field-name val) - "") - (define-configuration docker-configuration (docker (package docker) @@ -64,7 +61,8 @@ loop-back communications.") "Enable or disable debug output.") (enable-iptables? (boolean #t) - "Enable addition of iptables rules (enabled by default).")) + "Enable addition of iptables rules (enabled by default).") + (no-serialization)) (define %docker-accounts (list (user-group (name "docker") (system? #t)))) @@ -199,9 +197,10 @@ bundles in Docker containers.") "-helper"))) '("action" "mount" "start"))))) - (list (file-append helpers "/singularity-action-helper") - (file-append helpers "/singularity-mount-helper") - (file-append helpers "/singularity-start-helper"))) + (map file-like->setuid-program + (list (file-append helpers "/singularity-action-helper") + (file-append helpers "/singularity-mount-helper") + (file-append helpers "/singularity-start-helper")))) (define singularity-service-type (service-type (name 'singularity) diff --git a/gnu/services/guix.scm b/gnu/services/guix.scm index d1d31febdc..a5ed28647f 100644 --- a/gnu/services/guix.scm +++ b/gnu/services/guix.scm @@ -58,6 +58,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-1min-load-average guix-build-coordinator-agent-configuration-derivation-substitute-urls guix-build-coordinator-agent-configuration-non-derivation-substitute-urls @@ -156,6 +157,9 @@ (max-parallel-builds guix-build-coordinator-agent-configuration-max-parallel-builds (default 1)) + (max-1min-load-average + guix-build-coordinator-agent-configuration-max-1min-load-average + (default #f)) (derivation-substitute-urls guix-build-coordinator-agent-configuration-derivation-substitute-urls (default #f)) @@ -201,7 +205,7 @@ (user guix-build-coordinator-queue-builds-configuration-user (default "guix-build-coordinator-queue-builds")) (coordinator guix-build-coordinator-queue-builds-coordinator - (default "http://localhost:8745")) + (default "http://localhost:8746")) (systems guix-build-coordinator-queue-builds-configuration-systems (default #f)) (systems-and-targets @@ -325,7 +329,9 @@ #~(begin (use-modules (guix build utils)) - (define %user (getpw "guix-build-coordinator")) + (define %user + (getpw #$(guix-build-coordinator-configuration-user + config))) (chmod "/var/lib/guix-build-coordinator" #o755) @@ -370,6 +376,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-1min-load-average derivation-substitute-urls non-derivation-substitute-urls systems) (list @@ -402,6 +409,10 @@ 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=" @@ -429,7 +440,9 @@ #~(begin (use-modules (guix build utils)) - (define %user (getpw "guix-build-coordinator-agent")) + (define %user + (getpw #$(guix-build-coordinator-agent-configuration-user + config))) (mkdir-p "/var/log/guix-build-coordinator") @@ -493,7 +506,6 @@ processed-commits-file)) #~())) #:user #$user - #:pid-file "/var/run/guix-build-coordinator-queue-builds/pid" #:environment-variables `(,(string-append "GUIX_LOCPATH=" #$glibc-utf8-locales "/lib/locale") @@ -505,11 +517,15 @@ #~(begin (use-modules (guix build utils)) + (define %user + (getpw #$(guix-build-coordinator-queue-builds-configuration-user + config))) + (mkdir-p "/var/log/guix-build-coordinator") - ;; Allow writing the PID file - (mkdir-p "/var/run/guix-build-coordinator-queue-builds") - (chown "/var/run/guix-build-coordinator-queue-builds" + ;; Allow writing the processed commits file + (mkdir-p "/var/cache/guix-build-coordinator-queue-builds") + (chown "/var/cache/guix-build-coordinator-queue-builds" (passwd:uid %user) (passwd:gid %user)))) diff --git a/gnu/services/linux.scm b/gnu/services/linux.scm index 340b330030..2eb02ac5a3 100644 --- a/gnu/services/linux.scm +++ b/gnu/services/linux.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re> ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2021 raid5atemyhomework <raid5atemyhomework@protonmail.com> +;;; Copyright © 2021 B. Wilson <elaexuotee@wilsonb.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -47,6 +48,11 @@ kernel-module-loader-service-type + rasdaemon-configuration + rasdaemon-configuration? + rasdaemon-configuration-record? + rasdaemon-service-type + zram-device-configuration zram-device-configuration? zram-device-configuration-size @@ -190,6 +196,49 @@ representation." ;;; +;;; Reliability, Availability, and Serviceability (RAS) daemon +;;; + +(define-record-type* <rasdaemon-configuration> + rasdaemon-configuration make-rasdaemon-configuration + rasdaemon-configuration? + (record? rasdaemon-configuration-record? (default #f))) + +(define (rasdaemon-configuration->command-line-args config) + "Translate <rasdaemon-configuration> to its command line arguments + representation" + (let ((record? (rasdaemon-configuration-record? config))) + `(,(file-append rasdaemon "/sbin/rasdaemon") + "--foreground" ,@(if record? '("--record") '())))) + +(define (rasdaemon-activation config) + (let ((record? (rasdaemon-configuration-record? config)) + (rasdaemon-dir "/var/lib/rasdaemon")) + (with-imported-modules '((guix build utils)) + #~(if #$record? (mkdir-p #$rasdaemon-dir))))) + +(define (rasdaemon-shepherd-service config) + (shepherd-service + (documentation "Run rasdaemon") + (provision '(rasdaemon)) + (requirement '(syslogd)) + (start #~(make-forkexec-constructor + '#$(rasdaemon-configuration->command-line-args config))) + (stop #~(make-kill-destructor)))) + +(define rasdaemon-service-type + (service-type + (name 'rasdaemon) + (default-value (rasdaemon-configuration)) + (extensions + (list (service-extension shepherd-root-service-type + (compose list rasdaemon-shepherd-service)) + (service-extension activation-service-type rasdaemon-activation))) + (compose concatenate) + (description "Run @command{rasdaemon}, the RAS monitor"))) + + +;;; ;;; Kernel module loader. ;;; diff --git a/gnu/services/mail.scm b/gnu/services/mail.scm index 81f692e437..72dc123f41 100644 --- a/gnu/services/mail.scm +++ b/gnu/services/mail.scm @@ -355,7 +355,28 @@ This is used by imap (for shared users) and lda.") (mail-max-userip-connections (non-negative-integer 10) "Maximum number of IMAP connections allowed for a user from each IP -address. NOTE: The username is compared case-sensitively.")) +address. NOTE: The username is compared case-sensitively.") + (imap-metadata? + (boolean #f) + "Whether to enable the @code{IMAP METADATA} extension as defined in +@uref{https://tools.ietf.org/html/rfc5464, RFC@tie{}5464}, which provides +a means for clients to set and retrieve per-mailbox, per-user metadata +and annotations over IMAP. + +If this is @samp{#t}, you must also specify a dictionary @i{via} the +@code{mail-attribute-dict} setting.") + (managesieve-notify-capability + (space-separated-string-list '()) + "Which NOTIFY capabilities to report to clients that first connect to +the ManageSieve service, before authentication. These may differ from the +capabilities offered to authenticated users. If this field is left empty, +report what the Sieve interpreter supports by default.") + (managesieve-sieve-capability + (space-separated-string-list '()) + "Which SIEVE capabilities to report to clients that first connect to +the ManageSieve service, before authentication. These may differ from the +capabilities offered to authenticated users. If this field is left empty, +report what the Sieve interpreter supports by default.")) (define (serialize-protocol-configuration field-name val) (format #t "protocol ~a {\n" (protocol-configuration-name val)) @@ -1133,6 +1154,14 @@ disabled.") @samp{mdbox-rotate-size}. This setting currently works only in Linux with some file systems (ext4, xfs).") + (mail-attribute-dict + (string "") + "The location of a dictionary used to store @code{IMAP METADATA} +as defined by @uref{https://tools.ietf.org/html/rfc5464, RFC@tie{}5464}. + +The IMAP METADATA commands are available only if the ``imap'' +protocol configuration's @code{imap-metadata?} field is @samp{#t}.") + (mail-attachment-dir (string "") "sdbox and mdbox support saving mail attachments to external files, diff --git a/gnu/services/mcron.scm b/gnu/services/mcron.scm index bd4e6e7410..0e675607f3 100644 --- a/gnu/services/mcron.scm +++ b/gnu/services/mcron.scm @@ -31,8 +31,7 @@ mcron-configuration-mcron mcron-configuration-jobs - mcron-service-type - mcron-service)) + mcron-service-type)) ;;; Commentary: ;;; @@ -173,18 +172,4 @@ files." jobs))))) (default-value (mcron-configuration)))) ;empty job list -(define-deprecated (mcron-service jobs #:optional (mcron mcron)) - mcron-service-type - "Return an mcron service running @var{mcron} that schedules @var{jobs}, a -list of gexps denoting mcron job specifications. - -This is a shorthand for: -@example - (service mcron-service-type - (mcron-configuration (mcron mcron) (jobs jobs))) -@end example -" - (service mcron-service-type - (mcron-configuration (mcron mcron) (jobs jobs)))) - ;;; mcron.scm ends here diff --git a/gnu/services/messaging.scm b/gnu/services/messaging.scm index 8f2f3914cf..0fcb7faf89 100644 --- a/gnu/services/messaging.scm +++ b/gnu/services/messaging.scm @@ -52,7 +52,6 @@ bitlbee-configuration bitlbee-configuration? - bitlbee-service bitlbee-service-type quassel-configuration @@ -889,26 +888,6 @@ string, you could instantiate a prosody service like this: "Run @url{http://bitlbee.org,BitlBee}, a daemon that acts as a gateway between IRC and chat networks."))) -(define-deprecated (bitlbee-service #:key (bitlbee bitlbee) - (interface "127.0.0.1") (port 6667) - (extra-settings "")) - bitlbee-service-type - "Return a service that runs @url{http://bitlbee.org,BitlBee}, a daemon that -acts as a gateway between IRC and chat networks. - -The daemon will listen to the interface corresponding to the IP address -specified in @var{interface}, on @var{port}. @code{127.0.0.1} means that only -local clients can connect, whereas @code{0.0.0.0} means that connections can -come from any networking interface. - -In addition, @var{extra-settings} specifies a string to append to the -configuration file." - (service bitlbee-service-type - (bitlbee-configuration - (bitlbee bitlbee) - (interface interface) (port port) - (extra-settings extra-settings)))) - ;;; ;;; Quassel. diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm index 761820ad2e..7e310b70ec 100644 --- a/gnu/services/networking.scm +++ b/gnu/services/networking.scm @@ -10,13 +10,14 @@ ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net> ;;; Copyright © 2019 Florian Pelz <pelzflorian@pelzflorian.de> -;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2019, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2019 Sou Bunnbu <iyzsong@member.fsf.org> ;;; Copyright © 2019 Alex Griffin <a@ajgrf.com> ;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re> ;;; Copyright © 2021 Oleg Pykhalov <go.wigust@gmail.com> -;;; Copyright © 2021 Christopher Lemmer Webber <cwebber@dustycloud.org> +;;; Copyright © 2021 Christine Lemmer-Webber <cwebber@dustycloud.org> ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> +;;; Copyright © 2021 Guillaume Le Vaillant <glv@posteo.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -73,7 +74,6 @@ #:re-export (static-networking-service static-networking-service-type) #:export (%facebook-host-aliases - dhcp-client-service dhcp-client-service-type dhcpd-service-type @@ -99,7 +99,6 @@ ntp-server-address ntp-server-options - ntp-service ntp-service-type %openntpd-servers @@ -111,10 +110,21 @@ inetd-entry inetd-service-type + opendht-configuration + opendht-configuration-peer-discovery? + opendht-configuration-verbose? + opendht-configuration-bootstrap-host + opendht-configuration-port + opendht-configuration-proxy-server-port + opendht-configuration-proxy-server-port-tls + opendht-configuration->command-line-arguments + + opendht-shepherd-service + opendht-service-type + tor-configuration tor-configuration? tor-hidden-service - tor-service tor-service-type wicd-service-type @@ -298,12 +308,6 @@ fe80::1%lo0 apps.facebook.com\n") (description "Run @command{dhcp}, a Dynamic Host Configuration Protocol (DHCP) client, on all the non-loopback network interfaces."))) -(define-deprecated (dhcp-client-service #:key (dhcp isc-dhcp)) - dhcp-client-service-type - "Return a service that runs @var{dhcp}, a Dynamic Host Configuration -Protocol (DHCP) client, on all the non-loopback network interfaces." - (service dhcp-client-service-type dhcp)) - (define-record-type* <dhcpd-configuration> dhcpd-configuration make-dhcpd-configuration dhcpd-configuration? @@ -360,8 +364,9 @@ Protocol (DHCP) client, on all the non-loopback network interfaces." (lambda _ (display "")))) ;; Validate the config. (invoke/quiet - #$(file-append package "/sbin/dhcpd") "-t" "-cf" - #$config-file)))))) + #$(file-append package "/sbin/dhcpd") + #$(string-append "-" version) + "-t" "-cf" #$config-file)))))) (define dhcpd-service-type (service-type @@ -489,7 +494,8 @@ restrict source notrap nomodify noquery\n")) "-c" #$ntpd.conf "-u" "ntpd" #$@(if allow-large-adjustment? '("-g") - '())))) + '())) + #:log-file "/var/log/ntpd.log")) (stop #~(make-kill-destructor))))))))) (define %ntp-accounts @@ -529,21 +535,6 @@ daemon of the @uref{http://www.ntp.org, Network Time Foundation}. The daemon will keep the system clock synchronized with that of the given servers.") (default-value (ntp-configuration)))) -(define-deprecated (ntp-service #:key (ntp ntp) - (servers %ntp-servers) - allow-large-adjustment?) - ntp-service-type - "Return a service that runs the daemon from @var{ntp}, the -@uref{http://www.ntp.org, Network Time Protocol package}. The daemon will -keep the system clock synchronized with that of @var{servers}. -@var{allow-large-adjustment?} determines whether @command{ntpd} is allowed to -make an initial adjustment of more than 1,000 seconds." - (service ntp-service-type - (ntp-configuration (ntp ntp) - (servers servers) - (allow-large-adjustment? - allow-large-adjustment?)))) - ;;; ;;; OpenNTPD. @@ -742,6 +733,127 @@ demand."))) ;;; +;;; OpenDHT, the distributed hash table network used by Jami +;;; + +(define-maybe/no-serialization number) +(define-maybe/no-serialization string) + +;;; To generate the documentation of the following configuration record, you +;;; can evaluate: (configuration->documentation 'opendht-configuration) +(define-configuration/no-serialization opendht-configuration + (opendht + (package opendht) + "The @code{opendht} package to use.") + (peer-discovery? + (boolean #false) + "Whether to enable the multicast local peer discovery mechanism.") + (enable-logging? + (boolean #false) + "Whether to enable logging messages to syslog. It is disabled by default +as it is rather verbose.") + (debug? + (boolean #false) + "Whether to enable debug-level logging messages. This has no effect if +logging is disabled.") + (bootstrap-host + (maybe-string "bootstrap.jami.net:4222") + "The node host name that is used to make the first connection to the +network. A specific port value can be provided by appending the @code{:PORT} +suffix. By default, it uses the Jami bootstrap nodes, but any host can be +specified here. It's also possible to disable bootstrapping by setting this +to the @code{'disabled} symbol.") + (port + (maybe-number 4222) + "The UDP port to bind to. When set to @code{'disabled}, an available port +is automatically selected.") + (proxy-server-port + (maybe-number 'disabled) + "Spawn a proxy server listening on the specified port.") + (proxy-server-port-tls + (maybe-number 'disabled) + "Spawn a proxy server listening to TLS connections on the specified +port.")) + +(define %opendht-accounts + ;; User account and groups for Tor. + (list (user-group (name "opendht") (system? #t)) + (user-account + (name "opendht") + (group "opendht") + (system? #t) + (comment "OpenDHT daemon user") + (home-directory "/var/empty") + (shell (file-append shadow "/sbin/nologin"))))) + +(define (opendht-configuration->command-line-arguments config) + "Derive the command line arguments used to launch the OpenDHT daemon from +CONFIG, an <opendht-configuration> object." + (match-record config <opendht-configuration> + (opendht bootstrap-host enable-logging? port debug? peer-discovery? + proxy-server-port proxy-server-port-tls) + (let ((dhtnode #~(string-append #$opendht:tools "/bin/dhtnode"))) + `(,dhtnode + "--service" ;non-forking mode + ,@(if (string? bootstrap-host) + (list "--bootstrap" bootstrap-host)) + ,@(if enable-logging? + (list "--syslog") + '()) + ,@(if (number? port) + (list "--port" (number->string port)) + '()) + ,@(if debug? + (list "--verbose") + '()) + ,@(if peer-discovery? + (list "--peer-discovery") + '()) + ,@(if (number? proxy-server-port) + (list "--proxyserver" (number->string proxy-server-port)) + '()) + ,@(if (number? proxy-server-port-tls) + (list "--proxyserverssl" (number->string proxy-server-port-tls)) + '()))))) + +(define (opendht-shepherd-service config) + "Return a <shepherd-service> running OpenDHT." + (with-imported-modules (source-module-closure + '((gnu build shepherd) + (gnu system file-systems))) + (shepherd-service + (documentation "Run an OpenDHT node.") + (provision '(opendht dhtnode dhtproxy)) + (requirement '(networking syslogd)) + (modules '((gnu build shepherd) + (gnu system file-systems))) + (start #~(make-forkexec-constructor/container + (list #$@(opendht-configuration->command-line-arguments config)) + #:mappings (list (file-system-mapping + (source "/dev/log") ;for syslog + (target source))) + #:user "opendht" + #:group "opendht")) + (stop #~(make-kill-destructor))))) + +(define opendht-service-type + (service-type + (name 'opendht) + (default-value (opendht-configuration)) + (extensions + (list (service-extension shepherd-root-service-type + (compose list opendht-shepherd-service)) + (service-extension account-service-type + (const %opendht-accounts)))) + (description "Run the OpenDHT @command{dhtnode} command that allows +participating in the distributed hash table based OpenDHT network. The +service can be configured to act as a proxy to the distributed network, which +can be useful for portable devices where minimizing energy consumption is +paramount. OpenDHT was originally based on Kademlia and adapted for +applications in communication. It is used by Jami, for example."))) + + +;;; ;;; Tor. ;;; @@ -851,6 +963,7 @@ HiddenServicePort ~a ~a~%" (start #~(make-forkexec-constructor/container (list #$(file-append tor "/bin/tor") "-f" #$torrc) + #:log-file "/var/log/tor.log" #:mappings (list (file-system-mapping (source "/var/lib/tor") (target source) @@ -926,21 +1039,6 @@ HiddenServicePort ~a ~a~%" "Run the @uref{https://torproject.org, Tor} anonymous networking daemon."))) -(define-deprecated (tor-service #:optional - (config-file (plain-file "empty" "")) - #:key (tor tor)) - tor-service-type - "Return a service to run the @uref{https://torproject.org, Tor} anonymous -networking daemon. - -The daemon runs as the @code{tor} unprivileged user. It is passed -@var{config-file}, a file-like object, with an additional @code{User tor} line -and lines for hidden services added via @code{tor-hidden-service}. Run -@command{man tor} for information about the configuration file." - (service tor-service-type - (tor-configuration (tor tor) - (config-file config-file)))) - (define tor-hidden-service-type ;; A type that extends Tor with hidden services. (service-type (name 'tor-hidden-service) @@ -1458,7 +1556,8 @@ extra-settings "\n")))) (requirement `(user-processes ,@requirement)) (documentation "Run the hostapd WiFi access point daemon.") (start #~(make-forkexec-constructor - (list #$(file-append hostapd "/sbin/hostapd") + (list #$(file-append (hostapd-configuration-package config) + "/sbin/hostapd") #$(hostapd-configuration-file config)) #:log-file "/var/log/hostapd.log")) (stop #~(make-kill-destructor))))) diff --git a/gnu/services/nix.scm b/gnu/services/nix.scm index 1aef47db0a..619e3cae54 100644 --- a/gnu/services/nix.scm +++ b/gnu/services/nix.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019, 2020 Oleg Pykhalov <go.wigust@gmail.com> +;;; Copyright © 2019, 2020, 2021 Oleg Pykhalov <go.wigust@gmail.com> ;;; Copyright © 2020 Peng Mei Yu <i@pengmeiyu.com> ;;; ;;; This file is part of GNU Guix. @@ -19,6 +19,7 @@ (define-module (gnu services nix) #:use-module (gnu packages admin) + #:use-module (gnu packages bash) #:use-module (gnu packages package-management) #:use-module (gnu services base) #:use-module (gnu services configuration) @@ -121,7 +122,8 @@ GID." (format #t "sandbox = ~a~%" (if #$sandbox "true" "false")) ;; config.nix captures store file names. (format #t "build-sandbox-paths = ~{~a ~}~%" - (append internal-sandbox-paths + (append (list (string-append "/bin/sh=" #$bash-minimal "/bin/sh")) + internal-sandbox-paths '#$build-sandbox-items)) (for-each (cut display <>) '#$extra-config))))))))))) diff --git a/gnu/services/security-token.scm b/gnu/services/security-token.scm index ec26006538..52afad84a6 100644 --- a/gnu/services/security-token.scm +++ b/gnu/services/security-token.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net> ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> +;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re> ;;; ;;; This file is part of GNU Guix. ;;; @@ -57,8 +58,13 @@ (requirement '(syslogd)) (modules '((gnu build shepherd))) (start #~(lambda _ - (invoke #$(file-append pcsc-lite "/sbin/pcscd")) - (call-with-input-file "/run/pcscd/pcscd.pid" read))) + (let ((socket "/run/pcscd/pcscd.comm")) + (when (file-exists? socket) + (delete-file socket))) + (fork+exec-command + (list #$(file-append pcsc-lite "/sbin/pcscd") + "--foreground") + #:log-file "/var/log/pcscd.log"))) (stop #~(make-kill-destructor))))))) (define pcscd-activation diff --git a/gnu/services/sound.scm b/gnu/services/sound.scm index bdf819b422..55610f27e0 100644 --- a/gnu/services/sound.scm +++ b/gnu/services/sound.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018, 2020 Oleg Pykhalov <go.wigust@gmail.com> -;;; Copyright © 2020 Leo Prikler <leo.prikler@student.tugraz.at> +;;; Copyright © 2020 Liliana Marie Prikler <liliana.prikler@gmail.com> ;;; Copyright © 2020 Marius Bakke <mbakke@fastmail.com> ;;; ;;; This file is part of GNU Guix. diff --git a/gnu/services/spice.scm b/gnu/services/spice.scm index fd85dc234f..3b88e29043 100644 --- a/gnu/services/spice.scm +++ b/gnu/services/spice.scm @@ -34,41 +34,42 @@ (spice-vdagent spice-vdagent-configuration-spice-vdagent (default spice-vdagent))) -(define (spice-vdagent-activation config) - "Return the activation gexp for CONFIG." - #~(begin - (use-modules (guix build utils)) - (mkdir-p "/var/run/spice-vdagentd"))) - (define (spice-vdagent-shepherd-service config) "Return a <shepherd-service> for spice-vdagentd with CONFIG." (define spice-vdagent (spice-vdagent-configuration-spice-vdagent config)) (define spice-vdagentd-command (list - (file-append spice-vdagent "/sbin/spice-vdagentd") - "-x")) + (file-append spice-vdagent "/sbin/spice-vdagentd") + "-x")) (list - (shepherd-service - (documentation "Spice vdagentd service") - (requirement '(udev)) - (provision '(spice-vdagentd)) - (start #~(make-forkexec-constructor '#$spice-vdagentd-command)) - (stop #~(make-kill-destructor))))) + (shepherd-service + (documentation "Spice vdagentd service") + (requirement '(dbus-system)) + (provision '(spice-vdagentd)) + (start #~(lambda args + ;; spice-vdagentd supports being activated upon the client + ;; connecting to its socket; when not using such feature, the + ;; socket should not exist before vdagentd creates it itself. + (mkdir-p "/run/spice-vdagentd") + (false-if-exception + (delete-file "/run/spice-vdagentd/spice-vdagent-sock")) + (fork+exec-command '#$spice-vdagentd-command))) + (stop #~(make-kill-destructor))))) (define spice-vdagent-profile (compose list spice-vdagent-configuration-spice-vdagent)) (define spice-vdagent-service-type - (service-type (name 'spice-vdagent) - (extensions - (list (service-extension shepherd-root-service-type - spice-vdagent-shepherd-service) - (service-extension activation-service-type - spice-vdagent-activation) - (service-extension profile-service-type - spice-vdagent-profile))))) + (service-type + (name 'spice-vdagent) + (default-value (spice-vdagent-configuration)) + (extensions + (list (service-extension shepherd-root-service-type + spice-vdagent-shepherd-service) + (service-extension profile-service-type + spice-vdagent-profile))))) (define* (spice-vdagent-service #:optional (config (spice-vdagent-configuration))) diff --git a/gnu/services/ssh.scm b/gnu/services/ssh.scm index 1891db0487..a018052eeb 100644 --- a/gnu/services/ssh.scm +++ b/gnu/services/ssh.scm @@ -6,6 +6,8 @@ ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2020 pinoaffe <pinoaffe@airmail.cc> ;;; Copyright © 2020 Oleg Pykhalov <go.wigust@gmail.com> +;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re> +;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr> ;;; ;;; This file is part of GNU Guix. ;;; @@ -30,6 +32,7 @@ #:use-module (gnu services web) #:use-module (gnu system pam) #:use-module (gnu system shadow) + #:use-module (guix deprecation) #:use-module (guix gexp) #:use-module (guix records) #:use-module (guix modules) @@ -288,7 +291,7 @@ The other options should be self-descriptive." ;; integer (port-number openssh-configuration-port-number (default 22)) - ;; Boolean | 'without-password + ;; Boolean | 'prohibit-password (permit-root-login openssh-configuration-permit-root-login (default #f)) ;; Boolean @@ -441,7 +444,11 @@ of user-name/file-like tuples." #$(match (openssh-configuration-permit-root-login config) (#t "yes") (#f "no") - ('without-password "without-password"))) + ('without-password (warn-about-deprecation + 'without-password #f + #:replacement 'prohibit-password) + "prohibit-password") + ('prohibit-password "prohibit-password"))) (format port "PermitEmptyPasswords ~a\n" #$(if (openssh-configuration-allow-empty-passwords? config) "yes" "no")) diff --git a/gnu/services/telephony.scm b/gnu/services/telephony.scm index e1259cc2df..fd90840324 100644 --- a/gnu/services/telephony.scm +++ b/gnu/services/telephony.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 nee <nee-git@hidamari.blue> +;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,16 +18,45 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (gnu services telephony) - #:use-module (gnu services) + #:use-module ((gnu build jami-service) #:select (account-fingerprint?)) + #:use-module ((gnu services) #:hide (delete)) + #:use-module (gnu services configuration) #:use-module (gnu services shepherd) #:use-module (gnu system shadow) #:use-module (gnu packages admin) + #:use-module (gnu packages certs) + #:use-module (gnu packages glib) + #:use-module (gnu packages jami) #:use-module (gnu packages telephony) #:use-module (guix records) + #:use-module (guix modules) + #:use-module (guix packages) #:use-module (guix gexp) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-2) + #:use-module (srfi srfi-26) + #:use-module (ice-9 format) #:use-module (ice-9 match) - #:export (murmur-configuration + #:export (jami-account + jami-account-archive + jami-account-allowed-contacts + jami-account-moderators + jami-account-rendezvous-point? + jami-account-discovery? + jami-account-bootstrap-uri + jami-account-name-server-uri + + jami-configuration + jami-configuration-jamid + jami-configuration-dbus + jami-configuration-enable-logging? + jami-configuration-debug? + jami-configuration-auto-answer? + jami-configuration-accounts + + jami-service-type + + murmur-configuration make-murmur-configuration murmur-configuration? murmur-configuration-package @@ -74,6 +104,652 @@ murmur-service-type)) + +;;; +;;; Jami daemon. +;;; + +;;; XXX: Passing a computed-file object as the account is used for tests. +(define (string-or-computed-file? val) + (or (string? val) + (computed-file? val))) + +(define (string-list? val) + (and (list? val) + (and-map string? val))) + +(define (account-fingerprint-list? val) + (and (list? val) + (and-map account-fingerprint? val))) + +(define-maybe string-list) + +(define-maybe/no-serialization account-fingerprint-list) + +(define-maybe boolean) + +(define-maybe string) + +;;; The following serializers are used to derive an account details alist from +;;; a <jami-account> record. +(define (serialize-string-list _ val) + (string-join val ";")) + +(define (serialize-boolean _ val) + (format #f "~:[false~;true~]" val)) + +(define (serialize-string _ val) + val) + +;;; Note: Serialization is used to produce an account details alist that can +;;; be passed to the SET-ACCOUNT-DETAILS procedure. Fields that do not map to +;;; a Jami account 'detail' should have their serialization disabled via the +;;; 'empty-serializer' procedure. +(define-configuration jami-account + (archive + (string-or-computed-file) + "The account archive (backup) file name of the account. This is used to +provision the account when the service starts. The account archive should +@emph{not} be encrypted. It is highly recommended to make it readable only to +the @samp{root} user (i.e., not in the store), to guard against leaking the +secret key material of the Jami account it contains." + empty-serializer) + (allowed-contacts + (maybe-account-fingerprint-list 'disabled) + "The list of allowed contacts for the account, entered as their 40 +characters long fingerprint. Messages or calls from accounts not in that list +will be rejected. When unspecified, the configuration of the account archive +is used as-is with respect to contacts and public inbound calls/messaging +allowance, which typically defaults to allow any contact to communicate with +the account." + empty-serializer) + (moderators + (maybe-account-fingerprint-list 'disabled) + "The list of contacts that should have moderation privileges (to ban, mute, +etc. other users) in rendezvous conferences, entered as their 40 characters +long fingerprint. When unspecified, the configuration of the account archive +is used as-is with respect to moderation, which typically defaults to allow +anyone to moderate." + empty-serializer) + ;; The serializable fields below are to be set with set-account-details. + (rendezvous-point? + (maybe-boolean 'disabled) + "Whether the account should operate in the rendezvous mode. In this mode, +all the incoming audio/video calls are mixed into a conference. When left +unspecified, the value from the account archive prevails.") + (peer-discovery? + (maybe-boolean 'disabled) + "Whether peer discovery should be enabled. Peer discovery is used to +discover other OpenDHT nodes on the local network, which can be useful to +maintain communication between devices on such network even when the +connection to the the Internet has been lost. When left unspecified, the +value from the account archive prevails.") + (bootstrap-hostnames + (maybe-string-list 'disabled) + "A list of hostnames or IPs pointing to OpenDHT nodes, that should be used +to initially join the OpenDHT network. When left unspecified, the value from +the account archive prevails.") + (name-server-uri + (maybe-string 'disabled) + "The URI of the name server to use, that can be used to retrieve the +account fingerprint for a registered username.")) + +(define (jami-account->alist jami-account-object) + "Serialize the JAMI-ACCOUNT object as an alist suitable to be passed to +SET-ACCOUNT-DETAILS." + (define (field-name->account-detail name) + (match name + ('rendezvous-point? "Account.rendezVous") + ('peer-discovery? "Account.peerDiscovery") + ('bootstrap-hostnames "Account.hostname") + ('name-server-uri "RingNS.uri") + (_ #f))) + + (filter-map (lambda (field) + (and-let* ((name (field-name->account-detail + (configuration-field-name field))) + (value ((configuration-field-serializer field) + name ((configuration-field-getter field) + jami-account-object))) + ;; The define-maybe default serializer produces an + ;; empty string for the 'disabled value. + (value* (if (string-null? value) + #f + value))) + (cons name value*))) + jami-account-fields)) + +(define (jami-account-list? val) + (and (list? val) + (and-map jami-account? val))) + +(define-maybe/no-serialization jami-account-list) + +(define-configuration/no-serialization jami-configuration + (jamid + (package libring) + "The Jami daemon package to use.") + (dbus + (package dbus) + "The D-Bus package to use to start the required D-Bus session.") + (nss-certs + (package nss-certs) + "The nss-certs package to use to provide TLS certificates.") + (enable-logging? + (boolean #t) + "Whether to enable logging to syslog.") + (debug? + (boolean #f) + "Whether to enable debug level messages.") + (auto-answer? + (boolean #f) + "Whether to force automatic answer to incoming calls.") + (accounts + (maybe-jami-account-list 'disabled) + "A list of Jami accounts to be (re-)provisioned every time the Jami daemon +service starts. When providing this field, the account directories under +@file{/var/lib/jami/} are recreated every time the service starts, ensuring a +consistent state.")) + +(define %jami-accounts + (list (user-group (name "jami") (system? #t)) + (user-account + (name "jami") + (group "jami") + (system? #t) + (comment "Jami daemon user") + (home-directory "/var/lib/jami")))) + +(define (jami-configuration->command-line-arguments config) + "Derive the command line arguments to used to launch the Jami daemon from +CONFIG, a <jami-configuration> object." + (match-record config <jami-configuration> + (jamid dbus enable-logging? debug? auto-answer?) + `(,(file-append jamid "/lib/ring/dring") + "--persistent" ;stay alive after client quits + ,@(if enable-logging? + '() ;logs go to syslog by default + (list "--console")) ;else stdout/stderr + ,@(if debug? + (list "--debug") + '()) + ,@(if auto-answer? + (list "--auto-answer") + '())))) + +(define (jami-dbus-session-activation config) + "Create a directory to hold the Jami D-Bus session socket." + (with-imported-modules (source-module-closure '((gnu build activation))) + #~(begin + (use-modules (gnu build activation)) + (let ((user (getpwnam "jami"))) + (mkdir-p/perms "/var/run/jami" user #o700))))) + +(define (jami-shepherd-services config) + "Return a <shepherd-service> running the Jami daemon." + (let* ((jamid (jami-configuration-jamid config)) + (nss-certs (jami-configuration-nss-certs config)) + (dbus (jami-configuration-dbus config)) + (dbus-daemon (file-append dbus "/bin/dbus-daemon")) + (dbus-send (file-append dbus "/bin/dbus-send")) + (accounts (jami-configuration-accounts config)) + (declarative-mode? (not (eq? 'disabled accounts)))) + + (with-imported-modules (source-module-closure + '((gnu build jami-service) + (gnu build shepherd) + (gnu system file-systems))) + + (define list-accounts-action + (shepherd-action + (name 'list-accounts) + (documentation "List the available Jami accounts. Return the account +details alists keyed by their account username.") + (procedure + #~(lambda _ + (parameterize ((%send-dbus-binary #$dbus-send) + (%send-dbus-bus "unix:path=/var/run/jami/bus") + (%send-dbus-user "jami") + (%send-dbus-group "jami")) + ;; Print the accounts summary or long listing, according to + ;; user-provided option. + (let* ((usernames (get-usernames)) + (accounts (map-in-order username->account usernames))) + (match accounts + (() ;empty list + (format #t "There is no Jami account available.~%")) + ((one two ...) + (format #t "The following Jami accounts are available:~%") + (for-each + (lambda (account) + (define fingerprint (assoc-ref account + "Account.username")) + (define human-friendly-name + (or (assoc-ref account + "Account.registeredName") + (assoc-ref account + "Account.displayName") + (assoc-ref account + "Account.alias"))) + (define disabled? + (and=> (assoc-ref account "Account.enable") + (cut string=? "false" <>))) + + (format #t " - ~a~@[ (~a)~] ~:[~;[disabled]~]~%" + fingerprint human-friendly-name disabled?)) + accounts) + (display "\n"))) + ;; Return the account-details-list alist. + (map cons usernames accounts))))))) + + (define list-account-details-action + (shepherd-action + (name 'list-account-details) + (documentation "Display the account details of the available Jami +accounts in the @code{recutils} format. Return the account details alists +keyed by their account username.") + (procedure + #~(lambda _ + (parameterize ((%send-dbus-binary #$dbus-send) + (%send-dbus-bus "unix:path=/var/run/jami/bus") + (%send-dbus-user "jami") + (%send-dbus-group "jami")) + (let* ((usernames (get-usernames)) + (accounts (map-in-order username->account usernames))) + (for-each (lambda (account) + (display (account-details->recutil account)) + (display "\n\n")) + accounts) + (map cons usernames accounts))))))) + + (define list-contacts-action + (shepherd-action + (name 'list-contacts) + (documentation "Display the contacts for each Jami account. Return +an alist containing the contacts keyed by the account usernames.") + (procedure + #~(lambda _ + (parameterize ((%send-dbus-binary #$dbus-send) + (%send-dbus-bus "unix:path=/var/run/jami/bus") + (%send-dbus-user "jami") + (%send-dbus-group "jami")) + (let* ((usernames (get-usernames)) + (contacts (map-in-order username->contacts usernames))) + (for-each (lambda (username contacts) + (format #t "Contacts for account ~a:~%" + username) + (format #t "~{ - ~a~%~}~%" contacts)) + usernames contacts) + (map cons usernames contacts))))))) + + (define list-moderators-action + (shepherd-action + (name 'list-moderators) + (documentation "Display the moderators for each Jami account. Return +an alist containing the moderators keyed by the account usernames.") + (procedure + #~(lambda _ + (parameterize ((%send-dbus-binary #$dbus-send) + (%send-dbus-bus "unix:path=/var/run/jami/bus") + (%send-dbus-user "jami") + (%send-dbus-group "jami")) + (let* ((usernames (get-usernames)) + (moderators (map-in-order username->moderators + usernames))) + (for-each + (lambda (username moderators) + (if (username->all-moderators? username) + (format #t "Anyone can moderate for account ~a~%" + username) + (begin + (format #t "Moderators for account ~a:~%" username) + (format #t "~{ - ~a~%~}~%" moderators)))) + usernames moderators) + (map cons usernames moderators))))))) + + (define add-moderator-action + (shepherd-action + (name 'add-moderator) + (documentation "Add a moderator for a given Jami account. The +MODERATOR contact must be given as its 40 characters fingerprint, while the +Jami account can be provided as its registered USERNAME or fingerprint. + +@example +herd add-moderator jami 1dbcb0f5f37324228235564b79f2b9737e9a008f username +@end example + +Return the moderators for the account known by USERNAME.") + (procedure + #~(lambda (_ moderator username) + (parameterize ((%send-dbus-binary #$dbus-send) + (%send-dbus-bus "unix:path=/var/run/jami/bus") + (%send-dbus-user "jami") + (%send-dbus-group "jami")) + (set-all-moderators #f username) + (add-contact moderator username) + (set-moderator moderator #t username) + (username->moderators username)))))) + + (define ban-contact-action + (shepherd-action + (name 'ban-contact) + (documentation "Ban a contact for a given or all Jami accounts, and +clear their moderator flag. The CONTACT must be given as its 40 characters +fingerprint, while the Jami account can be provided as its registered USERNAME +or fingerprint, or omitted. When the account is omitted, CONTACT is banned +from all accounts. + +@example +herd ban-contact jami 1dbcb0f5f37324228235564b79f2b9737e9a008f [username] +@end example") + (procedure + #~(lambda* (_ contact #:optional username) + (parameterize ((%send-dbus-binary #$dbus-send) + (%send-dbus-bus "unix:path=/var/run/jami/bus") + (%send-dbus-user "jami") + (%send-dbus-group "jami")) + (let ((usernames (or (and=> username list) + (get-usernames)))) + (for-each (lambda (username) + (set-moderator contact #f username) + (remove-contact contact username #:ban? #t)) + usernames))))))) + + (define list-banned-contacts-action + (shepherd-action + (name 'list-banned-contacts) + (documentation "List the banned contacts for each accounts. Return +an alist of the banned contacts, keyed by the account usernames.") + (procedure + #~(lambda _ + (parameterize ((%send-dbus-binary #$dbus-send) + (%send-dbus-bus "unix:path=/var/run/jami/bus") + (%send-dbus-user "jami") + (%send-dbus-group "jami")) + + (define banned-contacts + (let ((usernames (get-usernames))) + (map cons usernames + (map-in-order (lambda (x) + (receive (_ banned) + (username->contacts x) + banned)) + usernames)))) + + (for-each (match-lambda + ((username . banned) + (unless (null? banned) + (format #t "Banned contacts for account ~a:~%" + username) + (format #t "~{ - ~a~%~}~%" banned)))) + banned-contacts) + banned-contacts))))) + + (define enable-account-action + (shepherd-action + (name 'enable-account) + (documentation "Enable an account. It takes USERNAME as an argument, +either a registered username or the fingerprint of the account.") + (procedure + #~(lambda (_ username) + (parameterize ((%send-dbus-binary #$dbus-send) + (%send-dbus-bus "unix:path=/var/run/jami/bus") + (%send-dbus-user "jami") + (%send-dbus-group "jami")) + (enable-account username)))))) + + (define disable-account-action + (shepherd-action + (name 'disable-account) + (documentation "Disable an account. It takes USERNAME as an +argument, either a registered username or the fingerprint of the account.") + (procedure + #~(lambda (_ username) + (parameterize ((%send-dbus-binary #$dbus-send) + (%send-dbus-bus "unix:path=/var/run/jami/bus") + (%send-dbus-user "jami") + (%send-dbus-group "jami")) + (disable-account username)))))) + + (list (shepherd-service + (documentation "Run a D-Bus session for the Jami daemon.") + (provision '(jami-dbus-session)) + (modules `((gnu build shepherd) + (gnu build jami-service) + (gnu system file-systems) + ,@%default-modules)) + ;; The requirement on dbus-system is to ensure other required + ;; activation for D-Bus, such as a /etc/machine-id file. + (requirement '(dbus-system syslogd)) + (start + #~(lambda args + (define pid + ((make-forkexec-constructor/container + (list #$dbus-daemon "--session" + "--address=unix:path=/var/run/jami/bus" + "--nofork" "--syslog-only" "--nopidfile") + #:mappings (list (file-system-mapping + (source "/dev/log") ;for syslog + (target source)) + (file-system-mapping + (source "/var/run/jami") + (target source) + (writable? #t))) + #:user "jami" + #:group "jami" + #:environment-variables + ;; This is so that the cx.ring.Ring service D-Bus + ;; definition is found by dbus-send. + (list (string-append "XDG_DATA_DIRS=" + #$jamid "/share"))))) + + ;; XXX: This manual synchronization probably wouldn't be + ;; needed if we were using a PID file, but providing it via a + ;; customized config file with <pidfile> would not override + ;; the one inherited from the base config of D-Bus. + (let ((sock (socket PF_UNIX SOCK_STREAM 0))) + (with-retries 20 1 (catch 'system-error + (lambda () + (connect sock AF_UNIX + "/var/run/jami/bus") + (close-port sock) + #t) + (lambda args + #f)))) + + pid)) + (stop #~(make-kill-destructor))) + + (shepherd-service + (documentation "Run the Jami daemon.") + (provision '(jami)) + (actions (list list-accounts-action + list-account-details-action + list-contacts-action + list-moderators-action + add-moderator-action + ban-contact-action + list-banned-contacts-action + enable-account-action + disable-account-action)) + (requirement '(jami-dbus-session)) + (modules `((ice-9 format) + (ice-9 ftw) + (ice-9 match) + (ice-9 receive) + (srfi srfi-1) + (srfi srfi-26) + (gnu build jami-service) + (gnu build shepherd) + (gnu system file-systems) + ,@%default-modules)) + (start + #~(lambda args + (define (delete-file-recursively/safe file) + ;; Ensure we're not deleting things outside of + ;; /var/lib/jami. This prevents a possible attack in case + ;; the daemon is compromised and an attacker gains write + ;; access to /var/lib/jami. + (let ((parent-directory (dirname file))) + (if (eq? 'symlink (stat:type (stat parent-directory))) + (error "abnormality detected; unexpected symlink found at" + parent-directory) + (delete-file-recursively file)))) + + (when #$declarative-mode? + ;; Clear the Jami configuration and accounts, to enforce the + ;; declared state. + (catch #t + (lambda () + (for-each (cut delete-file-recursively/safe <>) + '("/var/lib/jami/.cache/jami" + "/var/lib/jami/.config/jami" + "/var/lib/jami/.local/share/jami" + "/var/lib/jami/accounts"))) + (lambda args + #t)) + ;; Copy the Jami account archives from somewhere readable + ;; by root to a place only the jami user can read. + (let* ((accounts-dir "/var/lib/jami/accounts/") + (pwd (getpwnam "jami")) + (user (passwd:uid pwd)) + (group (passwd:gid pwd))) + (mkdir-p accounts-dir) + (chown accounts-dir user group) + (for-each (lambda (f) + (let ((dest (string-append accounts-dir + (basename f)))) + (copy-file f dest) + (chown dest user group))) + '#$(and declarative-mode? + (map jami-account-archive accounts))))) + + ;; Start the daemon. + (define daemon-pid + ((make-forkexec-constructor/container + '#$(jami-configuration->command-line-arguments config) + #:mappings + (list (file-system-mapping + (source "/dev/log") ;for syslog + (target source)) + (file-system-mapping + (source "/var/lib/jami") + (target source) + (writable? #t)) + (file-system-mapping + (source "/var/run/jami") + (target source) + (writable? #t)) + ;; Expose TLS certificates for GnuTLS. + (file-system-mapping + (source #$(file-append nss-certs "/etc/ssl/certs")) + (target "/etc/ssl/certs"))) + #:user "jami" + #:group "jami" + #:environment-variables + (list (string-append "DBUS_SESSION_BUS_ADDRESS=" + "unix:path=/var/run/jami/bus") + ;; Expose TLS certificates for OpenSSL. + "SSL_CERT_DIR=/etc/ssl/certs")))) + + (parameterize ((%send-dbus-binary #$dbus-send) + (%send-dbus-bus "unix:path=/var/run/jami/bus") + (%send-dbus-user "jami") + (%send-dbus-group "jami")) + + ;; Wait until the service name has been acquired by D-Bus. + (with-retries 20 1 + (dbus-service-available? "cx.ring.Ring")) + + (when #$declarative-mode? + ;; Provision the accounts via the D-Bus API of the daemon. + (let* ((jami-account-archives + (map (cut string-append + "/var/lib/jami/accounts/" <>) + (scandir "/var/lib/jami/accounts/" + (lambda (f) + (not (member f '("." ".."))))))) + (usernames (map-in-order (cut add-account <>) + jami-account-archives))) + + (define (archive-name->username archive) + (list-ref + usernames + (list-index (lambda (f) + (string-suffix? (basename archive) f)) + jami-account-archives))) + + (for-each + (lambda (archive allowed-contacts moderators + account-details) + (let ((username (archive-name->username + archive))) + (when (not (eq? 'disabled allowed-contacts)) + ;; Reject calls from unknown contacts. + (set-account-details + '(("DHT.PublicInCalls" . "false")) username) + ;; Remove all contacts. + (for-each (cut remove-contact <> username) + (username->contacts username)) + ;; Add allowed ones. + (for-each (cut add-contact <> username) + allowed-contacts)) + (when (not (eq? 'disabled moderators)) + ;; Disable the 'AllModerators' property. + (set-all-moderators #f username) + ;; Remove all moderators. + (for-each (cut set-moderator <> #f username) + (username->moderators username)) + ;; Add declared moderators. + (for-each (cut set-moderator <> #t username) + moderators)) + ;; Set the various account parameters. + (set-account-details account-details username))) + '#$(and declarative-mode? + (map-in-order (cut jami-account-archive <>) + accounts)) + '#$(and declarative-mode? + (map-in-order + (cut jami-account-allowed-contacts <>) + accounts)) + '#$(and declarative-mode? + (map-in-order (cut jami-account-moderators <>) + accounts)) + '#$(and declarative-mode? + (map-in-order jami-account->alist accounts)))))) + + ;; Finally, return the PID of the daemon process. + daemon-pid)) + (stop + #~(lambda (pid . args) + (kill pid SIGKILL) + ;; Wait for the process to exit; this prevents overlapping + ;; processes when issuing 'herd restart'. + (waitpid pid) + #f))))))) + +(define jami-service-type + (service-type + (name 'jami) + (default-value (jami-configuration)) + (extensions + (list (service-extension shepherd-root-service-type + jami-shepherd-services) + (service-extension account-service-type + (const %jami-accounts)) + (service-extension activation-service-type + jami-dbus-session-activation))) + (description "Run the Jami daemon (@command{dring}). This service is +geared toward the use case of hosting Jami rendezvous points over a headless +server. If you use Jami on your local machine, you may prefer to setup a user +Shepherd service for it instead; this way, the daemon will be shared via your +normal user D-Bus session bus."))) + + +;;; +;;; Murmur. +;;; + ;; https://github.com/mumble-voip/mumble/blob/master/scripts/murmur.ini (define-record-type* <murmur-configuration> murmur-configuration @@ -305,3 +981,7 @@ suite.") (service-extension account-service-type murmur-accounts))) (default-value (murmur-configuration)))) + +;; Local Variables: +;; eval: (put 'with-retries 'scheme-indent-function 2) +;; End: diff --git a/gnu/services/version-control.scm b/gnu/services/version-control.scm index 8cb5633165..3315e80c6f 100644 --- a/gnu/services/version-control.scm +++ b/gnu/services/version-control.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2017 Oleg Pykhalov <go.wigust@gmail.com> ;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2018 Christopher Baines <mail@cbaines.net> +;;; Copyright © 2021 Julien Lepiller <julien@lepiller.eu> ;;; ;;; This file is part of GNU Guix. ;;; @@ -54,11 +55,26 @@ <gitolite-rc-file> gitolite-rc-file gitolite-rc-file-umask + gitolite-rc-file-unsafe-pattern gitolite-rc-file-git-config-keys gitolite-rc-file-roles gitolite-rc-file-enable - gitolite-service-type)) + gitolite-service-type + + gitile-configuration + gitile-configuration-package + gitile-configuration-host + gitile-configuration-port + gitile-configuration-database + gitile-configuration-repositories + gitile-configuration-git-base-url + gitile-configuration-index-title + gitile-configuration-intro + gitile-configuration-footer + gitile-configuration-nginx + + gitile-service-type)) ;;; Commentary: ;;; @@ -226,6 +242,8 @@ access to exported repositories under @file{/srv/git}." gitolite-rc-file? (umask gitolite-rc-file-umask (default #o0077)) + (unsafe-pattern gitolite-rc-file-unsafe-pattern + (default #f)) (git-config-keys gitolite-rc-file-git-config-keys (default "")) (roles gitolite-rc-file-roles @@ -245,7 +263,7 @@ 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 git-config-keys roles enable) + (($ <gitolite-rc-file> umask unsafe-pattern git-config-keys roles enable) (apply text-file* "gitolite.rc" `("%RC = (\n" " UMASK => " ,(format #f "~4,'0o" umask) ",\n" @@ -264,6 +282,9 @@ access to exported repositories under @file{/srv/git}." " ],\n" ");\n" "\n" + ,(if unsafe-pattern + (string-append "$UNSAFE_PATT = qr(" unsafe-pattern ");") + "") "1;\n"))))) (define-record-type* <gitolite-configuration> @@ -380,3 +401,114 @@ access to exported repositories under @file{/srv/git}." 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."))) + +;;; +;;; Gitile +;;; + +(define-record-type* <gitile-configuration> + gitile-configuration make-gitile-configuration gitile-configuration? + (package gitile-configuration-package + (default gitile)) + (host gitile-configuration-host + (default "127.0.0.1")) + (port gitile-configuration-port + (default 8080)) + (database gitile-configuration-database + (default "/var/lib/gitile/gitile-db.sql")) + (repositories gitile-configuration-repositories + (default "/var/lib/gitolite/repositories")) + (base-git-url gitile-configuration-base-git-url) + (index-title gitile-configuration-index-title + (default "Index")) + (intro gitile-configuration-intro + (default '())) + (footer gitile-configuration-footer + (default '())) + (nginx gitile-configuration-nginx)) + +(define (gitile-config-file host port database repositories base-git-url + index-title intro footer) + (define build + #~(write `(config + (port #$port) + (host #$host) + (database #$database) + (repositories #$repositories) + (base-git-url #$base-git-url) + (index-title #$index-title) + (intro #$intro) + (footer #$footer)) + (open-output-file #$output))) + + (computed-file "gitile.conf" build)) + +(define gitile-nginx-server-block + (match-lambda + (($ <gitile-configuration> package host port database repositories + base-git-url index-title intro footer nginx) + (list (nginx-server-configuration + (inherit nginx) + (locations + (append + (list + (nginx-location-configuration + (uri "/") + (body + (list + #~(string-append "proxy_pass http://" #$host + ":" (number->string #$port) + "/;"))))) + (map + (lambda (loc) + (nginx-location-configuration + (uri loc) + (body + (list + #~(string-append "root " #$package "/share/gitile/assets;"))))) + '("/css" "/js" "/images")) + (nginx-server-configuration-locations nginx)))))))) + +(define gitile-shepherd-service + (match-lambda + (($ <gitile-configuration> package host port database repositories + base-git-url index-title intro footer nginx) + (list (shepherd-service + (provision '(gitile)) + (requirement '(loopback)) + (documentation "gitile") + (start (let ((gitile (file-append package "/bin/gitile"))) + #~(make-forkexec-constructor + `(,#$gitile "-c" #$(gitile-config-file + host port database + repositories + base-git-url index-title + intro footer)) + #:user "gitile" + #:group "git"))) + (stop #~(make-kill-destructor))))))) + +(define %gitile-accounts + (list (user-group + (name "git") + (system? #t)) + (user-account + (name "gitile") + (group "git") + (system? #t) + (comment "Gitile user") + (home-directory "/var/empty") + (shell (file-append shadow "/sbin/nologin"))))) + +(define gitile-service-type + (service-type + (name 'gitile) + (description "Run Gitile, a small Git forge. Expose public repositories +on the web.") + (extensions + (list (service-extension account-service-type + (const %gitile-accounts)) + (service-extension shepherd-root-service-type + gitile-shepherd-service) + (service-extension nginx-service-type + gitile-nginx-server-block))))) diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm index 36e9feb05c..bca5f56b87 100644 --- a/gnu/services/virtualization.scm +++ b/gnu/services/virtualization.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Ryan Moe <ryan.moe@gmail.com> -;;; Copyright © 2018, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2020,2021 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -131,6 +131,10 @@ (libvirt (package libvirt) "Libvirt package.") + (qemu + (package qemu) + "Qemu package.") + (listen-tls? (boolean #t) "Flag listening for secure TLS connections on the public TCP/IP port. @@ -168,7 +172,7 @@ stopping the Avahi daemon.") "Default mDNS advertisement name. This must be unique on the immediate broadcast network.") (unix-sock-group - (string "root") + (string "libvirt") "UNIX domain socket group ownership. This can be used to allow a 'trusted' set of users access to management capabilities without becoming root.") @@ -485,7 +489,7 @@ potential infinite waits blocking libvirt.")) (lambda (config) (list (libvirt-configuration-libvirt config) - qemu))) + (libvirt-configuration-qemu config)))) (service-extension activation-service-type %libvirt-activation) (service-extension shepherd-root-service-type @@ -561,7 +565,17 @@ potential infinite waits blocking libvirt.")) (family qemu-platform-family) ;string (magic qemu-platform-magic) ;bytevector (mask qemu-platform-mask) ;bytevector - (flags qemu-platform-flags (default "F"))) ;string + + ;; Default flags: + ;; + ;; "F": fix binary. Open the qemu-user binary (statically linked) as soon + ;; as binfmt_misc interpretation is handled. + ;; + ;; "P": preserve argv[0]. QEMU 6.0 detects whether it's started with this + ;; flag and automatically does the right thing. Without this flag, + ;; argv[0] is replaced by the absolute file name of the executable, an + ;; observable difference that can cause discrepancies. + (flags qemu-platform-flags (default "FP"))) ;string (define-syntax bv (lambda (s) @@ -584,13 +598,6 @@ potential infinite waits blocking libvirt.")) (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 %i486 - (qemu-platform - (name "i486") - (family "i386") - (magic (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x06\x00")) - (mask (bv "\xff\xff\xff\xff\xff\xfe\xfe\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))) - (define %alpha (qemu-platform (name "alpha") @@ -747,7 +754,7 @@ potential infinite waits blocking libvirt.")) (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 %i486 %alpha %arm %sparc32plus %ppc %ppc64 %ppc64le %m68k + (list %i386 %alpha %arm %sparc32plus %ppc %ppc64 %ppc64le %m68k %mips %mipsel %mipsn32 %mipsn32el %mips64 %mips64el %riscv32 %riscv64 %sh4 %sh4eb %s390x %aarch64 %hppa)) @@ -891,7 +898,7 @@ that will be listening to receive secret keys on port 1004, TCP." (timezone "Europe/Amsterdam") (bootloader (bootloader-configuration (bootloader grub-minimal-bootloader) - (target "/dev/vda") + (targets '("/dev/vda")) (timeout 0))) (packages (cons* gdb-minimal (operating-system-packages diff --git a/gnu/services/vpn.scm b/gnu/services/vpn.scm index 3e315a6df2..df84905eb3 100644 --- a/gnu/services/vpn.scm +++ b/gnu/services/vpn.scm @@ -2,6 +2,12 @@ ;;; Copyright © 2017 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> +;;; Copyright © 2021 Guillaume Le Vaillant <glv@posteo.net> +;;; Copyright © 2021 Solene Rapenne <solene@perso.pw> +;;; Copyright © 2021 Domagoj Stolfa <ds815@gmx.com> +;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr> +;;; Copyright © 2021 Raghav Gururajan <rg@raghavgururajan.name> +;;; Copyright © 2021 jgart <jgart@dismail.de> ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,6 +27,7 @@ (define-module (gnu services vpn) #:use-module (gnu services) #:use-module (gnu services configuration) + #:use-module (gnu services dbus) #:use-module (gnu services shepherd) #:use-module (gnu system shadow) #:use-module (gnu packages admin) @@ -28,6 +35,7 @@ #:use-module (guix packages) #:use-module (guix records) #:use-module (guix gexp) + #:use-module (guix i18n) #:use-module (srfi srfi-1) #:use-module (ice-9 match) #:use-module (ice-9 regex) @@ -42,11 +50,16 @@ generate-openvpn-client-documentation generate-openvpn-server-documentation + strongswan-configuration + strongswan-service-type + wireguard-peer wireguard-peer? wireguard-peer-name wireguard-peer-endpoint wireguard-peer-allowed-ips + wireguard-peer-public-key + wireguard-peer-keep-alive wireguard-configuration wireguard-configuration? @@ -60,6 +73,22 @@ wireguard-service-type)) ;;; +;;; Bitmask. +;;; + +(define-public bitmask-service-type + (service-type + (name 'bitmask) + (description "Setup the @uref{https://bitmask.net, Bitmask} VPN application.") + (default-value bitmask) + (extensions + (list + ;; Add bitmask to the system profile. + (service-extension profile-service-type list) + ;; Configure polkit policy of bitmask. + (service-extension polkit-service-type list))))) + +;;; ;;; OpenVPN. ;;; @@ -525,7 +554,138 @@ is truncated and rewritten every minute.") (openvpn-remote-configuration ,openvpn-remote-configuration-fields)) 'openvpn-client-configuration)) - +;;; +;;; Strongswan. +;;; + +(define-record-type* <strongswan-configuration> + strongswan-configuration make-strongswan-configuration + strongswan-configuration? + (strongswan strongswan-configuration-strongswan ;<package> + (default strongswan)) + (ipsec-conf strongswan-configuration-ipsec-conf ;string|#f + (default #f)) + (ipsec-secrets strongswan-configuration-ipsec-secrets ;string|#f + (default #f))) + +;; In the future, it might be worth implementing a record type to configure +;; all of the plugins, but for *most* basic use cases, simply creating the +;; files will be sufficient. Same is true of charon-plugins. +(define strongswand-configuration-files + (list "charon" "charon-logging" "pki" "pool" "scepclient" + "swanctl" "tnc")) + +;; Plugins to load. All of these plugins end up as configuration files in +;; strongswan.d/charon/. +(define charon-plugins + (list "aes" "aesni" "attr" "attr-sql" "chapoly" "cmac" "constraints" + "counters" "curl" "curve25519" "dhcp" "dnskey" "drbg" "eap-aka-3gpp" + "eap-aka" "eap-dynamic" "eap-identity" "eap-md5" "eap-mschapv2" + "eap-peap" "eap-radius" "eap-simaka-pseudonym" "eap-simaka-reauth" + "eap-simaka-sql" "eap-sim" "eap-sim-file" "eap-tls" "eap-tnc" + "eap-ttls" "ext-auth" "farp" "fips-prf" "gmp" "ha" "hmac" + "kernel-netlink" "led" "md4" "md5" "mgf1" "nonce" "openssl" "pem" + "pgp" "pkcs12" "pkcs1" "pkcs7" "pkcs8" "pubkey" "random" "rc2" + "resolve" "revocation" "sha1" "sha2" "socket-default" "soup" "sql" + "sqlite" "sshkey" "tnc-tnccs" "vici" "x509" "xauth-eap" "xauth-generic" + "xauth-noauth" "xauth-pam" "xcbc")) + +(define (strongswan-configuration-file config) + (match-record config <strongswan-configuration> + (strongswan ipsec-conf ipsec-secrets) + (if (eq? (string? ipsec-conf) (string? ipsec-secrets)) + (let* ((strongswan-dir + (computed-file + "strongswan.d" + #~(begin + (mkdir #$output) + ;; Create all of the configuration files strongswan.d/. + (map (lambda (conf-file) + (let* ((filename (string-append + #$output "/" + conf-file ".conf"))) + (call-with-output-file filename + (lambda (port) + (display + "# Created by 'strongswan-service'\n" + port))))) + (list #$@strongswand-configuration-files)) + (mkdir (string-append #$output "/charon")) + ;; Create all of the plugin configuration files. + (map (lambda (plugin) + (let* ((filename (string-append + #$output "/charon/" + plugin ".conf"))) + (call-with-output-file filename + (lambda (port) + (format port "~a { + load = yes +}" + plugin))))) + (list #$@charon-plugins)))))) + ;; Generate our strongswan.conf to reflect the user configuration. + (computed-file + "strongswan.conf" + #~(begin + (call-with-output-file #$output + (lambda (port) + (display "# Generated by 'strongswan-service'.\n" port) + (format port "charon { + load_modular = yes + plugins { + include ~a/charon/*.conf" + #$strongswan-dir) + (if #$ipsec-conf + (format port " + stroke { + load = yes + secrets_file = ~a + } + } +} + +starter { + config_file = ~a +} + +include ~a/*.conf" + #$ipsec-secrets + #$ipsec-conf + #$strongswan-dir) + (format port " + } +} +include ~a/*.conf" + #$strongswan-dir))))))) + (throw 'error + (G_ "strongSwan ipsec-conf and ipsec-secrets must both be (un)set"))))) + +(define (strongswan-shepherd-service config) + (let* ((ipsec (file-append strongswan "/sbin/ipsec")) + (strongswan-conf-path (strongswan-configuration-file config))) + (list (shepherd-service + (requirement '(networking)) + (provision '(ipsec)) + (start #~(make-forkexec-constructor + (list #$ipsec "start" "--nofork") + #:environment-variables + (list (string-append "STRONGSWAN_CONF=" + #$strongswan-conf-path)))) + (stop #~(make-kill-destructor)) + (documentation + "strongSwan's charon IKE keying daemon for IPsec VPN."))))) + +(define strongswan-service-type + (service-type + (name 'strongswan) + (extensions + (list (service-extension shepherd-root-service-type + strongswan-shepherd-service))) + (default-value (strongswan-configuration)) + (description + "Connect to an IPsec @acronym{VPN, Virtual Private Network} with +strongSwan."))) + ;;; ;;; Wireguard. ;;; @@ -537,7 +697,9 @@ is truncated and rewritten every minute.") (endpoint wireguard-peer-endpoint (default #f)) ;string (public-key wireguard-peer-public-key) ;string - (allowed-ips wireguard-peer-allowed-ips)) ;list of strings + (allowed-ips wireguard-peer-allowed-ips) ;list of strings + (keep-alive wireguard-peer-keep-alive + (default #f))) ;integer (define-record-type* <wireguard-configuration> wireguard-configuration make-wireguard-configuration @@ -560,16 +722,20 @@ is truncated and rewritten every minute.") (let ((name (wireguard-peer-name peer)) (public-key (wireguard-peer-public-key peer)) (endpoint (wireguard-peer-endpoint peer)) - (allowed-ips (wireguard-peer-allowed-ips peer))) + (allowed-ips (wireguard-peer-allowed-ips peer)) + (keep-alive (wireguard-peer-keep-alive peer))) (format #f "[Peer] #~a PublicKey = ~a AllowedIPs = ~a -~a" +~a~a" name public-key (string-join allowed-ips ",") (if endpoint (format #f "Endpoint = ~a\n" endpoint) + "") + (if keep-alive + (format #f "PersistentKeepalive = ~a\n" keep-alive) "\n")))) (match-record config <wireguard-configuration> diff --git a/gnu/services/web.scm b/gnu/services/web.scm index bfcdfe7421..bb42eacf83 100644 --- a/gnu/services/web.scm +++ b/gnu/services/web.scm @@ -1,13 +1,12 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson <davet@gnu.org> -;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Nikita <nikita@n0.is> ;;; Copyright © 2016, 2017, 2018 Julien Lepiller <julien@lepiller.eu> -;;; Copyright © 2017 Christopher Baines <mail@cbaines.net> +;;; Copyright © 2017, 2018, 2019 Christopher Baines <mail@cbaines.net> ;;; Copyright © 2017 nee <nee-git@hidamari.blue> ;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2018 Pierre-Antoine Rouby <pierre-antoine.rouby@inria.fr> -;;; Copyright © 2017, 2018, 2019 Christopher Baines <mail@cbaines.net> ;;; Copyright © 2018 Marius Bakke <mbakke@fastmail.com> ;;; Copyright © 2019, 2020 Florian Pelz <pelzflorian@pelzflorian.de> ;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net> @@ -1163,7 +1162,7 @@ a webserver.") (provision '(hpcguix-web)) (requirement '(networking)) (start #~(make-forkexec-constructor - (list #$(file-append hpcguix-web "/bin/run") + (list #$(file-append hpcguix-web "/bin/hpcguix-web") (string-append "--config=" #$(scheme-file "hpcguix-web.scm" specs))) #:user "hpcguix-web" diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm index 17d983ff8d..d5c5316d3f 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.scm @@ -8,6 +8,8 @@ ;;; Copyright © 2020 shtwzrd <shtwzrd@protonmail.com> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; Copyright © 2020 Alex Griffin <a@ajgrf.com> +;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re> +;;; Copyright © 2021 Oleg Pykhalov <go.wigust@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,6 +31,7 @@ #:use-module (gnu services) #:use-module (gnu services shepherd) #:use-module (gnu system pam) + #:use-module (gnu system setuid) #:use-module (gnu system keyboard) #:use-module (gnu services base) #:use-module (gnu services dbus) @@ -95,7 +98,6 @@ slim-configuration-sessreg slim-service-type - slim-service screen-locker screen-locker? @@ -108,7 +110,6 @@ gdm-configuration gdm-service-type - gdm-service handle-xorg-configuration set-xorg-configuration)) @@ -161,6 +162,7 @@ xorg-configuration make-xorg-configuration xorg-configuration? (modules xorg-configuration-modules ;list of packages + (thunked) ; filter out modules not supported on current system (default (filter (lambda (p) @@ -543,6 +545,8 @@ a `service-extension', as used by `set-xorg-configuration'." (default slim)) (allow-empty-passwords? slim-configuration-allow-empty-passwords? (default #t)) + (gnupg? slim-configuration-gnupg? + (default #f)) (auto-login? slim-configuration-auto-login? (default #f)) (default-user slim-configuration-default-user @@ -572,7 +576,9 @@ a `service-extension', as used by `set-xorg-configuration'." "slim" #:login-uid? #t #:allow-empty-passwords? - (slim-configuration-allow-empty-passwords? config)))) + (slim-configuration-allow-empty-passwords? config) + #:gnupg? + (slim-configuration-gnupg? config)))) (define (slim-shepherd-service config) (let* ((xinitrc (xinitrc #:fallback-session @@ -664,49 +670,6 @@ reboot_cmd " shepherd "/sbin/reboot\n" (description "Run the SLiM graphical login manager for X11.")))) -(define-deprecated (slim-service #:key (slim slim) - (allow-empty-passwords? #t) auto-login? - (default-user "") - (theme %default-slim-theme) - (theme-name %default-slim-theme-name) - (xauth xauth) (shepherd shepherd) - (auto-login-session #f) - (startx (xorg-start-command))) - slim-service-type - "Return a service that spawns the SLiM graphical login manager, which in -turn starts the X display server with @var{startx}, a command as returned by -@code{xorg-start-command}. - -@cindex X session - -SLiM automatically looks for session types described by the @file{.desktop} -files in @file{/run/current-system/profile/share/xsessions} and allows users -to choose a session from the log-in screen using @kbd{F1}. Packages such as -@var{xfce}, @var{sawfish}, and @var{ratpoison} provide @file{.desktop} files; -adding them to the system-wide set of packages automatically makes them -available at the log-in screen. - -In addition, @file{~/.xsession} files are honored. When available, -@file{~/.xsession} must be an executable that starts a window manager -and/or other X clients. - -When @var{allow-empty-passwords?} is true, allow logins with an empty -password. When @var{auto-login?} is true, log in automatically as -@var{default-user} with @var{auto-login-session}. - -If @var{theme} is @code{#f}, the use the default log-in theme; otherwise -@var{theme} must be a gexp denoting the name of a directory containing the -theme to use. In that case, @var{theme-name} specifies the name of the -theme." - (service slim-service-type - (slim-configuration - (slim slim) - (allow-empty-passwords? allow-empty-passwords?) - (auto-login? auto-login?) (default-user default-user) - (theme theme) (theme-name theme-name) - (xauth xauth) (shepherd shepherd) - (auto-login-session auto-login-session)))) - ;;; ;;; Screen lockers & co. @@ -726,7 +689,7 @@ theme." #:allow-empty-passwords? empty?))))) (define screen-locker-setuid-programs - (compose list screen-locker-program)) + (compose list file-like->setuid-program screen-locker-program)) (define screen-locker-service-type (service-type (name 'screen-locker) @@ -1043,34 +1006,6 @@ the GNOME desktop environment.") "Run the GNOME Desktop Manager (GDM), a program that allows you to log in in a graphical session, whether or not you use GNOME.")))) -(define-deprecated (gdm-service #:key (gdm gdm) - (allow-empty-passwords? #t) - (x-server (xorg-wrapper))) - gdm-service-type - "Return a service that spawns the GDM graphical login manager, which in turn -starts the X display server with @var{X}, a command as returned by -@code{xorg-wrapper}. - -@cindex X session - -GDM automatically looks for session types described by the @file{.desktop} -files in @file{/run/current-system/profile/share/xsessions} and allows users -to choose a session from the log-in screen using @kbd{F1}. Packages such as -@var{xfce}, @var{sawfish}, and @var{ratpoison} provide @file{.desktop} files; -adding them to the system-wide set of packages automatically makes them -available at the log-in screen. - -In addition, @file{~/.xsession} files are honored. When available, -@file{~/.xsession} must be an executable that starts a window manager -and/or other X clients. - -When @var{allow-empty-passwords?} is true, allow logins with an empty -password." - (service gdm-service-type - (gdm-configuration - (gdm gdm) - (allow-empty-passwords? allow-empty-passwords?)))) - (define* (set-xorg-configuration config #:optional (login-manager-service-type |