diff options
Diffstat (limited to 'gnu/services')
| -rw-r--r-- | gnu/services/audio.scm | 249 | ||||
| -rw-r--r-- | gnu/services/base.scm | 129 | ||||
| -rw-r--r-- | gnu/services/configuration.scm | 96 | ||||
| -rw-r--r-- | gnu/services/desktop.scm | 76 | ||||
| -rw-r--r-- | gnu/services/herd.scm | 24 | ||||
| -rw-r--r-- | gnu/services/linux.scm | 101 | ||||
| -rw-r--r-- | gnu/services/mcron.scm | 103 | ||||
| -rw-r--r-- | gnu/services/networking.scm | 67 | ||||
| -rw-r--r-- | gnu/services/sddm.scm | 6 | ||||
| -rw-r--r-- | gnu/services/security.scm | 6 | ||||
| -rw-r--r-- | gnu/services/vnc.scm | 5 | ||||
| -rw-r--r-- | gnu/services/web.scm | 25 | ||||
| -rw-r--r-- | gnu/services/xorg.scm | 23 |
13 files changed, 594 insertions, 316 deletions
diff --git a/gnu/services/audio.scm b/gnu/services/audio.scm index d55b804ba9..690409b7a1 100644 --- a/gnu/services/audio.scm +++ b/gnu/services/audio.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2017 Peter Mikkelsen <petermikkelsen10@gmail.com> ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org> -;;; Copyright © 2022 Bruno Victal <mirai@makinata.eu> +;;; Copyright © 2022–2023 Bruno Victal <mirai@makinata.eu> ;;; ;;; This file is part of GNU Guix. ;;; @@ -137,12 +137,22 @@ str) #\-) "_"))) -(define list-of-string? - (list-of string?)) - (define list-of-symbol? (list-of symbol?)) +;; Helpers for deprecated field types, to be removed later. +(define %lazy-group (make-symbol "%lazy-group")) + +(define (%set-user-group user group) + (user-account + (inherit user) + (group (user-group-name group)))) + + +;;; +;;; MPD +;;; + (define (mpd-serialize-field field-name value) (let ((field (if (string? field-name) field-name (uglify-field-name field-name))) @@ -159,13 +169,34 @@ (define mpd-serialize-string mpd-serialize-field) (define mpd-serialize-boolean mpd-serialize-field) -(define (mpd-serialize-list-of-string field-name value) +(define (mpd-serialize-list-of-strings field-name value) #~(string-append #$@(map (cut mpd-serialize-string field-name <>) value))) +(define (mpd-serialize-user-account field-name value) + (mpd-serialize-string field-name (user-account-name value))) + +(define (mpd-serialize-user-group field-name value) + (mpd-serialize-string field-name (user-group-name value))) + (define-maybe string (prefix mpd-)) -(define-maybe list-of-string (prefix mpd-)) +(define-maybe list-of-strings (prefix mpd-)) (define-maybe boolean (prefix mpd-)) +(define %mpd-user + (user-account + (name "mpd") + (group %lazy-group) + (system? #t) + (comment "Music Player Daemon (MPD) user") + ;; MPD can use $HOME (or $XDG_CONFIG_HOME) to place its data + (home-directory "/var/lib/mpd") + (shell (file-append shadow "/sbin/nologin")))) + +(define %mpd-group + (user-group + (name "mpd") + (system? #t))) + ;;; TODO: Procedures for deprecated fields, to be removed. (define mpd-deprecated-fields '((music-dir . music-directory) @@ -195,6 +226,33 @@ (define-maybe port (prefix mpd-)) +;;; Procedures for unsupported value types, to be removed. + +(define (mpd-user-sanitizer value) + (cond ((user-account? value) value) + ((string? value) + (warning (G_ "string value for 'user' is deprecated, use \ +user-account instead~%")) + (user-account + (inherit %mpd-user) + (name value) + ;; XXX: This is to be lazily substituted in (…-accounts) + ;; with the value from 'group'. + (group %lazy-group))) + (else + (configuration-field-error #f 'user value)))) + +(define (mpd-group-sanitizer value) + (cond ((user-group? value) value) + ((string? value) + (warning (G_ "string value for 'group' is deprecated, use \ +user-group instead~%")) + (user-group + (inherit %mpd-group) + (name value))) + (else + (configuration-field-error #f 'group value)))) + ;;; ;; Generic MPD plugin record, lists only the most prevalent fields. @@ -297,7 +355,17 @@ disconnect all listeners even when playback is accidentally stopped.") for this audio output: the @code{hardware} mixer, the @code{software} mixer, the @code{null} mixer (allows setting the volume, but with no effect; this can be used as a trick to implement an external mixer -External Mixer) or no mixer (@code{none}).") +External Mixer) or no mixer (@code{none})." + (sanitizer + (lambda (x) ; TODO: deprecated, remove me later. + (cond + ((symbol? x) + (warning (G_ "symbol value for 'mixer-type' is deprecated, \ +use string instead~%")) + (symbol->string x)) + ((string? x) x) + (else + (configuration-field-error #f 'mixer-type x)))))) (replay-gain-handler maybe-string @@ -335,12 +403,14 @@ to be appended to the audio output configuration.") empty-serializer) (user - (string "mpd") - "The user to run mpd as.") + (user-account %mpd-user) + "The user to run mpd as." + (sanitizer mpd-user-sanitizer)) (group - (string "mpd") - "The group to run mpd as.") + (user-group %mpd-group) + "The group to run mpd as." + (sanitizer mpd-group-sanitizer)) (shepherd-requirement (list-of-symbol '()) @@ -349,7 +419,8 @@ will depend on." empty-serializer) (environment-variables - (list-of-string '()) + (list-of-strings '("PULSE_CLIENTCONFIG=/etc/pulse/client.conf" + "PULSE_CONFIG=/etc/pulse/daemon.conf")) "A list of strings specifying environment variables." empty-serializer) @@ -372,7 +443,7 @@ Available values: @code{notice}, @code{info}, @code{verbose}, (music-dir ; TODO: deprecated, remove later maybe-string "The directory to scan for music files." - mpd-serialize-deprecated-field) + (serializer mpd-serialize-deprecated-field)) (playlist-directory maybe-string @@ -381,7 +452,7 @@ Available values: @code{notice}, @code{info}, @code{verbose}, (playlist-dir ; TODO: deprecated, remove later maybe-string "The directory to store playlists." - mpd-serialize-deprecated-field) + (serializer mpd-serialize-deprecated-field)) (db-file maybe-string @@ -400,23 +471,24 @@ Available values: @code{notice}, @code{info}, @code{verbose}, "The default port to run mpd on.") (endpoints - maybe-list-of-string + maybe-list-of-strings "The addresses that mpd will bind to. A port different from @var{default-port} may be specified, e.g. @code{localhost:6602} and IPv6 addresses must be enclosed in square brackets when a different port is used. To use a Unix domain socket, an absolute path or a path starting with @code{~} can be specified here." - (lambda (_ endpoints) - (if (maybe-value-set? endpoints) - (mpd-serialize-list-of-string "bind_to_address" endpoints) - ""))) + (serializer + (lambda (_ endpoints) + (if (maybe-value-set? endpoints) + (mpd-serialize-list-of-strings "bind_to_address" endpoints) + "")))) (address ; TODO: deprecated, remove later maybe-string "The address that mpd will bind to. To use a Unix domain socket, an absolute path can be specified here." - mpd-serialize-deprecated-field) + (serializer mpd-serialize-deprecated-field)) (database maybe-mpd-plugin @@ -433,29 +505,29 @@ To use a Unix domain socket, an absolute path can be specified here." (inputs (list-of-mpd-plugin '()) "List of MPD input plugin configurations." - (lambda (_ x) - (mpd-serialize-list-of-mpd-plugin "input" x))) + (serializer (lambda (_ x) + (mpd-serialize-list-of-mpd-plugin "input" x)))) (archive-plugins (list-of-mpd-plugin '()) "List of MPD archive plugin configurations." - (lambda (_ x) - (mpd-serialize-list-of-mpd-plugin "archive_plugin" x))) + (serializer (lambda (_ x) + (mpd-serialize-list-of-mpd-plugin "archive_plugin" x)))) (input-cache-size maybe-string "MPD input cache size." - (lambda (_ x) - (if (maybe-value-set? x) - #~(string-append "\ninput_cache {\n" - #$(mpd-serialize-string "size" x) - "}\n") ""))) + (serializer (lambda (_ x) + (if (maybe-value-set? x) + #~(string-append "\ninput_cache {\n" + #$(mpd-serialize-string "size" x) + "}\n") "")))) (decoders (list-of-mpd-plugin '()) "List of MPD decoder plugin configurations." - (lambda (_ x) - (mpd-serialize-list-of-mpd-plugin "decoder" x))) + (serializer (lambda (_ x) + (mpd-serialize-list-of-mpd-plugin "decoder" x)))) (resampler maybe-mpd-plugin @@ -464,8 +536,8 @@ To use a Unix domain socket, an absolute path can be specified here." (filters (list-of-mpd-plugin '()) "List of MPD filter plugin configurations." - (lambda (_ x) - (mpd-serialize-list-of-mpd-plugin "filter" x))) + (serializer (lambda (_ x) + (mpd-serialize-list-of-mpd-plugin "filter" x)))) (outputs (list-of-mpd-plugin-or-output (list (mpd-output))) @@ -475,8 +547,8 @@ By default this is a single output using pulseaudio.") (playlist-plugins (list-of-mpd-plugin '()) "List of MPD playlist plugin configurations." - (lambda (_ x) - (mpd-serialize-list-of-mpd-plugin "playlist_plugin" x))) + (serializer (lambda (_ x) + (mpd-serialize-list-of-mpd-plugin "playlist_plugin" x)))) (extra-options (alist '()) @@ -503,7 +575,8 @@ appended to the configuration.") log-file playlist-directory db-file state-file sticker-file environment-variables) - (let* ((config-file (mpd-serialize-configuration config))) + (let ((config-file (mpd-serialize-configuration config)) + (username (user-account-name user))) (shepherd-service (documentation "Run the MPD (Music Player Daemon)") (requirement `(user-processes loopback ,@shepherd-requirement)) @@ -512,7 +585,7 @@ appended to the configuration.") (and=> #$(maybe-value log-file) (compose mkdir-p dirname)) - (let ((user (getpw #$user))) + (let ((user (getpw #$username))) (for-each (lambda (x) (when (and x (not (file-exists? x))) @@ -546,17 +619,11 @@ appended to the configuration.") (define (mpd-accounts config) (match-record config <mpd-configuration> (user group) - (list (user-group - (name group) - (system? #t)) - (user-account - (name user) - (group group) - (system? #t) - (comment "Music Player Daemon (MPD) user") - ;; MPD can use $HOME (or $XDG_CONFIG_HOME) to place its data - (home-directory "/var/lib/mpd") - (shell (file-append shadow "/sbin/nologin")))))) + ;; TODO: Deprecation code, to be removed. + (let ((user (if (eq? (user-account-group user) %lazy-group) + (%set-user-group user group) + user))) + (list user group)))) (define mpd-service-type (service-type @@ -581,16 +648,58 @@ appended to the configuration.") (define-configuration/no-serialization mympd-ip-acl (allow - (list-of-string '()) + (list-of-strings '()) "Allowed IP addresses.") (deny - (list-of-string '()) + (list-of-strings '()) "Disallowed IP addresses.")) (define-maybe/no-serialization integer) (define-maybe/no-serialization mympd-ip-acl) +(define %mympd-user + (user-account + (name "mympd") + (group %lazy-group) + (system? #t) + (comment "myMPD user") + (home-directory "/var/empty") + (shell (file-append shadow "/sbin/nologin")))) + +(define %mympd-group + (user-group + (name "mympd") + (system? #t))) + +;;; TODO: Procedures for unsupported value types, to be removed. +(define (mympd-user-sanitizer value) + (cond ((user-account? value) value) + ((string? value) + (warning (G_ "string value for 'user' is not supported, use \ +user-account instead~%")) + (user-account + (inherit %mympd-user) + (name value) + ;; XXX: this is to be lazily substituted in (…-accounts) + ;; with the value from 'group'. + (group %lazy-group))) + (else + (configuration-field-error #f 'user value)))) + +(define (mympd-group-sanitizer value) + (cond ((user-group? value) value) + ((string? value) + (warning (G_ "string value for 'group' is not supported, use \ +user-group instead~%")) + (user-group + (inherit %mympd-group) + (name value))) + (else + (configuration-field-error #f 'group value)))) +;;; + + ;; XXX: The serialization procedures are insufficient since we require ;; access to multiple fields at once. ;; Fields marked with empty-serializer are never serialized and are @@ -608,13 +717,15 @@ will depend on." empty-serializer) (user - (string "mympd") + (user-account %mympd-user) "Owner of the @command{mympd} process." + (sanitizer mympd-user-sanitizer) empty-serializer) (group - (string "nogroup") + (user-group %mympd-group) "Owner group of the @command{mympd} process." + (sanitizer mympd-group-sanitizer) empty-serializer) (work-directory @@ -707,12 +818,12 @@ prompting a pin from the user.") ((? string? val) val))) (define (ip-acl-serialize-configuration config) - (define (serialize-list-of-string prefix lst) + (define (serialize-list-of-strings prefix lst) (map (cut format #f "~a~a" prefix <>) lst)) (string-join (append - (serialize-list-of-string "+" (mympd-ip-acl-allow config)) - (serialize-list-of-string "-" (mympd-ip-acl-deny config))) ",")) + (serialize-list-of-strings "+" (mympd-ip-acl-allow config)) + (serialize-list-of-strings "-" (mympd-ip-acl-deny config))) ",")) ;; myMPD configuration fields are serialized as individual files under ;; <work-directory>/config/. @@ -749,13 +860,18 @@ prompting a pin from the user.") (match-record config <mympd-configuration> (package shepherd-requirement user work-directory cache-directory log-level log-to) - (let ((log-level* (format #f "MYMPD_LOGLEVEL=~a" log-level))) + (let ((log-level* (format #f "MYMPD_LOGLEVEL=~a" log-level)) + (username (user-account-name user))) (shepherd-service (documentation "Run the myMPD daemon.") - (requirement `(loopback user-processes ,@shepherd-requirement)) + (requirement `(loopback user-processes + ,@(if (eq? log-to 'syslog) + '(syslog) + '()) + ,@shepherd-requirement)) (provision '(mympd)) (start #~(begin - (let* ((pw (getpwnam #$user)) + (let* ((pw (getpwnam #$username)) (uid (passwd:uid pw)) (gid (passwd:gid pw))) (for-each (lambda (dir) @@ -765,8 +881,8 @@ prompting a pin from the user.") (make-forkexec-constructor `(#$(file-append package "/bin/mympd") - "--user" #$user - #$@(if (eqv? log-to 'syslog) '("--syslog") '()) + "--user" #$username + #$@(if (eq? log-to 'syslog) '("--syslog") '()) "--workdir" #$work-directory "--cachedir" #$cache-directory) #:environment-variables (list #$log-level*) @@ -775,14 +891,11 @@ prompting a pin from the user.") (define (mympd-accounts config) (match-record config <mympd-configuration> (user group) - (list (user-group (name group) - (system? #t)) - (user-account (name user) - (group group) - (system? #t) - (comment "myMPD user") - (home-directory "/var/empty") - (shell (file-append shadow "/sbin/nologin")))))) + ;; TODO: Deprecation code, to be removed. + (let ((user (if (eq? (user-account-group user) %lazy-group) + (%set-user-group user group) + user))) + (list user group)))) (define (mympd-log-rotation config) (match-record config <mympd-configuration> (log-to) diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 190bb8fe24..e5c6bf5335 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2015, 2016, 2020 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com> @@ -40,7 +40,7 @@ (define-module (gnu services base) #:use-module (guix store) #:use-module (guix deprecation) - #:autoload (guix diagnostics) (warning &fix-hint) + #:autoload (guix diagnostics) (warning formatted-message &fix-hint) #:autoload (guix i18n) (G_) #:use-module (guix combinators) #:use-module (gnu services) @@ -223,7 +223,6 @@ guix-publish-configuration-port guix-publish-configuration-host guix-publish-configuration-compression - guix-publish-configuration-compression-level ;deprecated guix-publish-configuration-nar-path guix-publish-configuration-cache guix-publish-configuration-ttl @@ -246,7 +245,7 @@ kmscon-service-type pam-limits-service-type - pam-limits-service + pam-limits-service ; deprecated greetd-service-type greetd-configuration @@ -703,9 +702,10 @@ to add @var{device} to the kernel's entropy pool. The service will fail if ;;; /etc/hosts ;;; -(define (valid-name? name) - "Return true if @var{name} is likely to be a valid host name." - (false-if-exception (not (string-any char-set:whitespace name)))) +(eval-when (expand load eval) + (define (valid-name? name) + "Return true if @var{name} is likely to be a valid host name." + (false-if-exception (not (string-any char-set:whitespace name))))) (define-compile-time-procedure (assert-valid-name (name valid-name?)) "Ensure @var{name} is likely to be a valid host name." @@ -813,21 +813,6 @@ host names." #t ;default to UTF-8 (description "Ensure the Linux virtual terminals run in UTF-8 mode."))) -(define console-keymap-service-type - (shepherd-service-type - 'console-keymap - (lambda (files) - (shepherd-service - (documentation (string-append "Load console keymap (loadkeys).")) - (provision '(console-keymap)) - (start #~(lambda _ - (zero? (system* #$(file-append kbd "/bin/loadkeys") - #$@files)))) - (respawn? #f))) - (description "@emph{This service is deprecated in favor of the -@code{keyboard-layout} field of @code{operating-system}.} Load the given list -of console keymaps with @command{loadkeys}."))) - (define %default-console-font ;; Note: the 'font-gnu-unifont' package cannot be cross-compiled (yet), but ;; its "psf" output is the same whether it's built natively or not, hence @@ -900,14 +885,6 @@ package or any valid argument to @command{setfont}, as in this example: \"/share/consolefonts/ter-132n\"))) ; for HDPI @end example\n"))) -(define* (console-font-service tty #:optional (font "LatGrkCyr-8x16")) - "This procedure is deprecated in favor of @code{console-font-service-type}. - -Return a service that sets up Unicode support in @var{tty} and loads -@var{font} for that tty (fonts are per virtual console in Linux.)" - (simple-service (symbol-append 'console-font- (string->symbol tty)) - console-font-service-type `((,tty . ,font)))) - (define %default-motd (plain-file "motd" "This is the GNU operating system, welcome!\n\n")) @@ -1553,14 +1530,17 @@ Service Switch}, for an example." (shepherd-service-type 'syslog (lambda (config) + (define config-file + (syslog-configuration-config-file config)) + (shepherd-service (documentation "Run the syslog daemon (syslogd).") (provision '(syslogd)) (requirement '(user-processes)) + (actions (list (shepherd-configuration-action config-file))) (start #~(let ((spawn (make-forkexec-constructor (list #$(syslog-configuration-syslogd config) - "--rcfile" - #$(syslog-configuration-config-file config)) + "--rcfile" #$config-file) #:pid-file "/var/run/syslog.pid"))) (lambda () ;; Set the umask such that file permissions are #o640. @@ -1584,17 +1564,13 @@ information on the configuration file syntax." (define pam-limits-service-type - (let ((security-limits - ;; Create /etc/security containing the provided "limits.conf" file. - (lambda (limits-file) - `(("security/limits.conf" - ,limits-file)))) - (pam-extension + (let ((pam-extension (lambda (pam) (let ((pam-limits (pam-entry (control "required") (module "pam_limits.so") - (arguments '("conf=/etc/security/limits.conf"))))) + (arguments + '("conf=/etc/security/limits.conf"))))) (if (member (pam-service-name pam) '("login" "greetd" "su" "slim" "gdm-password" "sddm" "sudo" "sshd")) @@ -1602,7 +1578,27 @@ information on the configuration file syntax." (inherit pam) (session (cons pam-limits (pam-service-session pam)))) - pam))))) + pam)))) + + ;; XXX: Using file-like objects is deprecated, use lists instead. + ;; This is to be reduced into the list? case when the deprecated + ;; code gets removed. + ;; Create /etc/security containing the provided "limits.conf" file. + (security-limits + (match-lambda + ((? file-like? obj) + (warning (G_ "Using file-like value for \ +'pam-limits-service-type' is deprecated~%")) + `(("security/limits.conf" ,obj))) + ((? list? lst) + `(("security/limits.conf" + ,(plain-file "limits.conf" + (string-join (map pam-limits-entry->string lst) + "\n" 'suffix))))) + (_ (raise + (formatted-message + (G_ "invalid input for 'pam-limits-service-type'~%"))))))) + (service-type (name 'limits) (extensions @@ -1612,9 +1608,11 @@ information on the configuration file syntax." (description "Install the specified resource usage limits by populating @file{/etc/security/limits.conf} and using the @code{pam_limits} -authentication module.")))) +authentication module.") + (default-value '())))) -(define* (pam-limits-service #:optional (limits '())) +(define-deprecated (pam-limits-service #:optional (limits '())) + pam-limits-service-type "Return a service that makes selected programs respect the list of pam-limits-entry specified in LIMITS via pam_limits.so." (service pam-limits-service-type @@ -1987,10 +1985,7 @@ proxy of 'guix-daemon'...~%") (default #f)) (compression guix-publish-configuration-compression (thunked) - (default (default-compression this-record - (current-source-location)))) - (compression-level %guix-publish-configuration-compression-level ;deprecated - (default #f)) + (default (default-compression this-record))) (nar-path guix-publish-configuration-nar-path ;string (default "nar")) (cache guix-publish-configuration-cache ;#f | string @@ -2004,25 +1999,14 @@ proxy of 'guix-daemon'...~%") (negative-ttl guix-publish-configuration-negative-ttl ;#f | integer (default #f))) -(define-deprecated (guix-publish-configuration-compression-level config) - "Return a compression level, the old way." - (match (guix-publish-configuration-compression config) - (((_ level) _ ...) level))) - -(define (default-compression config properties) +(define (default-compression config) "Return the default 'guix publish' compression according to CONFIG, and raise a deprecation warning if the 'compression-level' field was used." - (match (%guix-publish-configuration-compression-level config) - (#f - ;; Default to low compression levels when there's no cache so that users - ;; get good bandwidth by default. - (if (guix-publish-configuration-cache config) - '(("gzip" 5) ("zstd" 19)) - '(("gzip" 3) ("zstd" 3)))) ;zstd compresses faster - (level - (warn-about-deprecation 'compression-level properties - #:replacement 'compression) - `(("gzip" ,level))))) + ;; Default to low compression levels when there's no cache so that users + ;; get good bandwidth by default. + (if (guix-publish-configuration-cache config) + '(("gzip" 5) ("zstd" 19)) + '(("gzip" 3) ("zstd" 3)))) ;zstd compresses faster (define (guix-publish-shepherd-service config) (define (config->compression-options config) @@ -2664,16 +2648,17 @@ Write, say, @samp{\"~a/24\"} for a 24-bit network mask.") ipv6-address?)))) (gateway network-route-gateway (default #f))) -(define* (cidr->netmask str #:optional (family AF_INET)) - "Given @var{str}, a string in CIDR notation (e.g., \"1.2.3.4/24\"), return +(eval-when (expand load eval) + (define* (cidr->netmask str #:optional (family AF_INET)) + "Given @var{str}, a string in CIDR notation (e.g., \"1.2.3.4/24\"), return the netmask as a string like \"255.255.255.0\"." - (match (string-split str #\/) - ((ip (= string->number bits)) - (let ((mask (ash (- (expt 2 bits) 1) - (- (if (= family AF_INET6) 128 32) - bits)))) - (inet-ntop family mask))) - (_ #f))) + (match (string-split str #\/) + ((ip (= string->number bits)) + (let ((mask (ash (- (expt 2 bits) 1) + (- (if (= family AF_INET6) 128 32) + bits)))) + (inet-ntop family mask))) + (_ #f)))) (define (cidr->ip str) "Strip the netmask bit of @var{str}, a CIDR-notation IP/netmask address." diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm index 02d1aa1796..367b85c1be 100644 --- a/gnu/services/configuration.scm +++ b/gnu/services/configuration.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2021 Andrew Tropin <andrew@trop.in> ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be> +;;; Copyright © 2023 Bruno Victal <mirai@makinata.eu> ;;; ;;; This file is part of GNU Guix. ;;; @@ -28,7 +29,8 @@ #:use-module (guix gexp) #:use-module ((guix utils) #:select (source-properties->location)) #:use-module ((guix diagnostics) - #:select (formatted-message location-file &error-location)) + #:select (formatted-message location-file &error-location + warning)) #:use-module ((guix modules) #:select (file-name->module-name)) #:use-module (guix i18n) #:autoload (texinfo) (texi-fragment->stexi) @@ -37,6 +39,7 @@ #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:export (configuration-field @@ -44,6 +47,7 @@ configuration-field-type configuration-missing-field configuration-field-error + configuration-field-sanitizer configuration-field-serializer configuration-field-getter configuration-field-default-value-thunk @@ -116,6 +120,7 @@ does not have a default value" field kind))) (type configuration-field-type) (getter configuration-field-getter) (predicate configuration-field-predicate) + (sanitizer configuration-field-sanitizer) (serializer configuration-field-serializer) (default-value-thunk configuration-field-default-value-thunk) (documentation configuration-field-documentation)) @@ -181,11 +186,44 @@ does not have a default value" field kind))) (values #'(field-type %unset-value))))) (define (define-configuration-helper serialize? serializer-prefix syn) + + (define (normalize-extra-args s) + "Extract and normalize arguments following @var{doc}." + (let loop ((s s) + (sanitizer* %unset-value) + (serializer* %unset-value)) + (syntax-case s (sanitizer serializer empty-serializer) + (((sanitizer proc) tail ...) + (if (maybe-value-set? sanitizer*) + (syntax-violation 'sanitizer "duplicate entry" + #'proc) + (loop #'(tail ...) #'proc serializer*))) + (((serializer proc) tail ...) + (if (maybe-value-set? serializer*) + (syntax-violation 'serializer "duplicate or conflicting entry" + #'proc) + (loop #'(tail ...) sanitizer* #'proc))) + ((empty-serializer tail ...) + (if (maybe-value-set? serializer*) + (syntax-violation 'empty-serializer + "duplicate or conflicting entry" #f) + (loop #'(tail ...) sanitizer* #'empty-serializer))) + (() ; stop condition + (values (list sanitizer* serializer*))) + ((proc) ; TODO: deprecated, to be removed. + (null? (filter-map maybe-value-set? (list sanitizer* serializer*))) + (begin + (warning #f (G_ "specifying serializers after documentation is \ +deprecated, use (serializer ~a) instead~%") (syntax->datum #'proc)) + (values (list %unset-value #'proc))))))) + (syntax-case syn () - ((_ stem (field field-type+def doc custom-serializer ...) ...) + ((_ stem (field field-type+def doc extra-args ...) ...) (with-syntax ((((field-type def) ...) - (map normalize-field-type+def #'(field-type+def ...)))) + (map normalize-field-type+def #'(field-type+def ...))) + (((sanitizer* serializer*) ...) + (map normalize-extra-args #'((extra-args ...) ...)))) (with-syntax (((field-getter ...) (map (lambda (field) @@ -200,21 +238,18 @@ does not have a default value" field kind))) ((field-type default-value) default-value)) #'((field-type def) ...))) + ((field-sanitizer ...) + (map maybe-value #'(sanitizer* ...))) ((field-serializer ...) - (map (lambda (type custom-serializer) + (map (lambda (type proc) (and serialize? - (match custom-serializer - ((serializer) - serializer) - (() - (if serializer-prefix - (id #'stem - serializer-prefix - #'serialize- type) - (id #'stem #'serialize- type)))))) + (or (maybe-value proc) + (if serializer-prefix + (id #'stem serializer-prefix #'serialize- type) + (id #'stem #'serialize- type))))) #'(field-type ...) - #'((custom-serializer ...) ...)))) - (define (field-sanitizer name pred) + #'(serializer* ...)))) + (define (default-field-sanitizer name pred) ;; Define a macro for use as a record field sanitizer, where NAME ;; is the name of the field and PRED is the predicate that tells ;; whether a value is valid for this field. @@ -235,21 +270,29 @@ does not have a default value" field kind))) #`(begin ;; Define field validation macros. - #,@(map field-sanitizer - #'(field ...) - #'(field-predicate ...)) + #,@(filter-map (lambda (name pred sanitizer) + (if sanitizer + #f + (default-field-sanitizer name pred))) + #'(field ...) + #'(field-predicate ...) + #'(field-sanitizer ...)) (define-record-type* #,(id #'stem #'< #'stem #'>) stem #,(id #'stem #'make- #'stem) #,(id #'stem #'stem #'?) - #,@(map (lambda (name getter def) - #`(#,name #,getter (default #,def) + #,@(map (lambda (name getter def sanitizer) + #`(#,name #,getter + (default #,def) (sanitize - #,(id #'stem #'validate- #'stem #'- name)))) + #,(or sanitizer + (id #'stem + #'validate- #'stem #'- name))))) #'(field ...) #'(field-getter ...) - #'(field-default ...)) + #'(field-default ...) + #'(field-sanitizer ...)) (%location #,(id #'stem #'stem #'-source-location) (default (and=> (current-source-location) source-properties->location)) @@ -261,10 +304,12 @@ does not have a default value" field kind))) (type 'field-type) (getter field-getter) (predicate field-predicate) + (sanitizer + (or field-sanitizer + (id #'stem #'validate- #'stem #'- #'field))) (serializer field-serializer) (default-value-thunk (lambda () - (display '#,(id #'stem #'% #'stem)) (if (maybe-value-set? (syntax->datum field-default)) field-default (configuration-missing-default-value @@ -440,10 +485,7 @@ the list result in @code{#t} when applying PRED? on them." (list-of string?)) (define alist? - (match-lambda - (() #t) - ((head . tail) (and (pair? head) (alist? tail))) - (_ #f))) + (list-of pair?)) (define serialize-file-like empty-serializer) diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm index c0178135b0..adea5b38dd 100644 --- a/gnu/services/desktop.scm +++ b/gnu/services/desktop.scm @@ -14,6 +14,7 @@ ;;; Copyright © 2020 Reza Alizadeh Majd <r.majd@pantherx.org> ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re> ;;; Copyright © 2021, 2022 muradm <mail@muradm.net> +;;; Copyright © 2023 Bruno Victal <mirai@makinata.eu> ;;; ;;; This file is part of GNU Guix. ;;; @@ -154,7 +155,8 @@ xfce-desktop-service xfce-desktop-service-type - x11-socket-directory-service + x11-socket-directory-service ;deprecated + x11-socket-directory-service-type enlightenment-desktop-configuration enlightenment-desktop-configuration? @@ -1421,15 +1423,10 @@ rules." (default-value (gnome-desktop-configuration)) (description "Run the GNOME desktop environment."))) -(define-deprecated (gnome-desktop-service #:key (config - (gnome-desktop-configuration))) - gnome-desktop-service-type - "Return a service that adds the @code{gnome} package to the system profile, -and extends polkit with the actions from @code{gnome-settings-daemon}." - (service gnome-desktop-service-type config)) - -;; MATE Desktop service. -;; TODO: Add mate-screensaver. + +;;; +;;; MATE Desktop service. +;;; TODO: Add mate-screensaver. (define-record-type* <mate-desktop-configuration> mate-desktop-configuration make-mate-desktop-configuration @@ -1459,14 +1456,6 @@ and extends polkit with the actions from @code{gnome-settings-daemon}." (default-value (mate-desktop-configuration)) (description "Run the MATE desktop environment."))) -(define-deprecated (mate-desktop-service #:key - (config - (mate-desktop-configuration))) - mate-desktop-service-type - "Return a service that adds the @code{mate} package to the system profile, -and extends polkit with the actions from @code{mate-settings-daemon}." - (service mate-desktop-service-type config)) - ;;; ;;; XFCE desktop service. @@ -1497,16 +1486,7 @@ rules." (default-value (xfce-desktop-configuration)) (description "Run the Xfce desktop environment."))) -(define-deprecated (xfce-desktop-service #:key (config - (xfce-desktop-configuration))) - xfce-desktop-service-type - "Return a service that adds the @code{xfce} package to the system profile, -and extends polkit with the ability for @code{thunar} to manipulate the file -system as root from within a user session, after the user has authenticated -with the administrator's password." - (service xfce-desktop-service-type config)) - -+ + ;;; ;;; Lxqt desktop service. ;;; @@ -1573,18 +1553,38 @@ rules." ;;; X11 socket directory service ;;; -(define x11-socket-directory-service +(define x11-socket-directory-service-type + (let ((x11-socket-directory-shepherd-service + (shepherd-service + (documentation "Create @file{/tmp/.X11-unix} for XWayland.") + (requirement '(file-systems)) + (provision '(x11-socket-directory)) + (one-shot? #t) + (start #~(lambda _ + (let ((directory "/tmp/.X11-unix")) + (mkdir-p directory) + (chmod directory #o1777))))))) + (service-type + (name 'x11-socket-directory-service) + (extensions + (list + (service-extension shepherd-root-service-type + (compose + list + (const x11-socket-directory-shepherd-service))))) + (default-value #f) ; no default value required + (description + "Create @file{/tmp/.X11-unix} for XWayland. When using X11, libxcb +takes care of creating that directory however, when using XWayland, we +need to create it beforehand.")))) + +(define-deprecated x11-socket-directory-service + x11-socket-directory-service-type ;; Return a service that creates /tmp/.X11-unix. When using X11, libxcb ;; takes care of creating that directory. However, when using XWayland, we ;; need to create beforehand. Thus, create it unconditionally here. - (simple-service 'x11-socket-directory - activation-service-type - (with-imported-modules '((guix build utils)) - #~(begin - (use-modules (guix build utils)) - (let ((directory "/tmp/.X11-unix")) - (mkdir-p directory) - (chmod directory #o1777)))))) + (service x11-socket-directory-service-type)) + ;;; ;;; Enlightenment desktop service. @@ -1889,7 +1889,7 @@ applications needing access to be root.") (service ntp-service-type) - x11-socket-directory-service + (service x11-socket-directory-service-type) (service pulseaudio-service-type) (service alsa-service-type) diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm index a7c845b4b0..e489ce2b9a 100644 --- a/gnu/services/herd.scm +++ b/gnu/services/herd.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016-2019, 2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016-2019, 2022-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -284,22 +284,12 @@ returns a shepherd <service> object." (define (load-services/safe files) "This is like 'load-services', but make sure only the subset of FILES that -can be safely reloaded is actually reloaded. - -This is done to accommodate the Shepherd < 0.15.0 where services lacked the -'replacement' slot, and where 'register-services' would throw an exception -when passed a service with an already-registered name." - (eval-there `(let* ((services (map primitive-load ',files)) - (slots (map slot-definition-name - (class-slots <service>))) - (can-replace? (memq 'replacement slots))) - (define (registered? service) - (not (null? (lookup-services (canonical-name service))))) - - (apply register-services - (if can-replace? - services - (remove registered? services)))))) +can be safely reloaded is actually reloaded." + (eval-there `(let ((services (map primitive-load ',files))) + ;; Since version 0.5.0 of the Shepherd, registering a service + ;; that has the same name as an already-registered service + ;; makes it a "replacement" of that previous service. + (apply register-services services)))) (define* (start-service name #:optional (arguments '())) (invoke-action name 'start arguments diff --git a/gnu/services/linux.scm b/gnu/services/linux.scm index 60e2093e1d..4f28044112 100644 --- a/gnu/services/linux.scm +++ b/gnu/services/linux.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2021 raid5atemyhomework <raid5atemyhomework@protonmail.com> ;;; Copyright © 2021 B. Wilson <elaexuotee@wilsonb.com> ;;; Copyright © 2022 Josselin Poiret <dev@jpoiret.xyz> +;;; Copyright © 2023 Bruno Victal <mirai@makinata.eu> ;;; ;;; This file is part of GNU Guix. ;;; @@ -30,12 +31,15 @@ #:use-module (guix ui) #:use-module (gnu services) #:use-module (gnu services base) + #:use-module (gnu services configuration) + #:use-module (gnu services mcron) #:use-module (gnu services shepherd) #:use-module (gnu packages linux) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (ice-9 format) #:use-module (ice-9 match) #:export (earlyoom-configuration earlyoom-configuration? @@ -50,6 +54,16 @@ earlyoom-configuration-send-notification-command earlyoom-service-type + fstrim-configuration + fstrim-configuration? + fstrim-configuration-package + fstrim-configuration-schedule + fstrim-configuration-listed-in + fstrim-configuration-verbose? + fstrim-configuration-quiet-unsupported? + fstrim-configuration-extra-arguments + fstrim-service-type + kernel-module-loader-service-type rasdaemon-configuration @@ -152,6 +166,93 @@ representation." ;;; +;;; fstrim +;;; + +(define (mcron-time? x) + (or (procedure? x) (string? x) (list? x))) + +(define-maybe list-of-strings (prefix fstrim-)) + +(define (fstrim-serialize-boolean field-name value) + (list (format #f "~:[~;--~a~]" value + ;; Drop trailing '?' character. + (string-drop-right (symbol->string field-name) 1)))) + +(define (fstrim-serialize-list-of-strings field-name value) + (list (string-append "--" (symbol->string field-name)) + #~(string-join '#$value ":"))) + +(define-configuration fstrim-configuration + (package + (file-like util-linux) + "The package providing the @command{fstrim} command." + empty-serializer) + (schedule + (mcron-time "0 0 * * 0") + "Schedule for launching @command{fstrim}. This can be a procedure, a list +or a string. For additional information, see @ref{Guile Syntax,, +Job specification, mcron, the mcron manual}. By default this is set to run +weekly on Sunday at 00:00." + empty-serializer) + ;; The following are fstrim-related options. + (listed-in + (maybe-list-of-strings '("/etc/fstab" "/proc/self/mountinfo")) + ;; Note: documentation sourced from the fstrim manpage. + "List of files in fstab or kernel mountinfo format. All missing or +empty files are silently ignored. The evaluation of the list @emph{stops} +after the first non-empty file. File systems with @code{X-fstrim.notrim} mount +option in fstab are skipped.") + (verbose? + (boolean #t) + "Verbose execution.") + (quiet-unsupported? + (boolean #t) + "Suppress error messages if trim operation (ioctl) is unsupported.") + (extra-arguments + maybe-list-of-strings + "Extra options to append to @command{fstrim} (run @samp{man fstrim} for +more information)." + (serializer + (lambda (_ value) + (if (maybe-value-set? value) + value '())))) + (prefix fstrim-)) + +(define (serialize-fstrim-configuration config) + (concatenate + (filter list? + (map (lambda (field) + ((configuration-field-serializer field) + (configuration-field-name field) + ((configuration-field-getter field) config))) + fstrim-configuration-fields)))) + +(define (fstrim-mcron-job config) + (match-record config <fstrim-configuration> (package schedule) + #~(job + ;; Note: The “if” below is to ensure that + ;; lists are ungexp'd correctly since @var{schedule} + ;; can be either a procedure, a string or a list. + #$(if (list? schedule) + #~'(#$@schedule) + schedule) + (lambda () + (system* #$(file-append package "/sbin/fstrim") + #$@(serialize-fstrim-configuration config))) + "fstrim"))) + +(define fstrim-service-type + (service-type + (name 'fstrim) + (extensions + (list (service-extension mcron-service-type + (compose list fstrim-mcron-job)))) + (description "Discard unused blocks from file systems.") + (default-value (fstrim-configuration)))) + + +;;; ;;; Kernel module loader. ;;; diff --git a/gnu/services/mcron.scm b/gnu/services/mcron.scm index 52332d6123..2ef5980e09 100644 --- a/gnu/services/mcron.scm +++ b/gnu/services/mcron.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2023 Bruno Victal <mirai@makinata.eu> ;;; ;;; This file is part of GNU Guix. ;;; @@ -33,7 +34,9 @@ mcron-configuration-mcron mcron-configuration-jobs mcron-configuration-log? + mcron-configuration-log-file mcron-configuration-log-format + mcron-configuration-date-format mcron-service-type)) @@ -55,20 +58,37 @@ (define list-of-gexps? (list-of gexp?)) +(define-maybe/no-serialization string) + (define-configuration/no-serialization mcron-configuration - (mcron (file-like mcron) "The mcron package to use.") + (mcron + (file-like mcron) + "The mcron package to use.") + (jobs (list-of-gexps '()) "This is a list of gexps (@pxref{G-Expressions}), where each gexp corresponds to an mcron job specification (@pxref{Syntax, mcron job specifications,, mcron, GNU@tie{}mcron}).") - (log? (boolean #t) "Log messages to standard output.") + + (log? + (boolean #t) + "Log messages to standard output.") + + (log-file + (string "/var/log/mcron.log") + "Log file location.") + (log-format (string "~1@*~a ~a: ~a~%") "@code{(ice-9 format)} format string for log messages. The default value -produces messages like \"@samp{@var{pid} @var{name}: -@var{message}\"} (@pxref{Invoking mcron, Invoking,, mcron, GNU@tie{}mcron}). -Each message is also prefixed by a timestamp by GNU Shepherd.")) +produces messages like @samp{@var{pid} @var{name}: @var{message}} +(@pxref{Invoking mcron, Invoking,, mcron, GNU@tie{}mcron}). +Each message is also prefixed by a timestamp by GNU Shepherd.") + + (date-format + maybe-string + "@code{(srfi srfi-19)} format string for date.")) (define (job-files mcron jobs) "Return a list of file-like object for JOBS, a list of gexps." @@ -136,41 +156,44 @@ files." (display line) (loop))))))))) -(define mcron-shepherd-services - (match-lambda - (($ <mcron-configuration> mcron ()) ;nothing to do! - '()) - (($ <mcron-configuration> mcron jobs log? log-format) - (let ((files (job-files mcron jobs))) - (list (shepherd-service - (provision '(mcron)) - (requirement '(user-processes)) - (modules `((srfi srfi-1) - (srfi srfi-26) - (ice-9 popen) ;for the 'schedule' action - (ice-9 rdelim) - (ice-9 match) - ,@%default-modules)) - (start #~(make-forkexec-constructor - (list (string-append #$mcron "/bin/mcron") - #$@(if log? - #~("--log" "--log-format" #$log-format) - #~()) - #$@files) - - ;; Disable auto-compilation of the job files and set a - ;; sane value for 'PATH'. - #:environment-variables - (cons* "GUILE_AUTO_COMPILE=0" - "PATH=/run/current-system/profile/bin" - (remove (cut string-prefix? "PATH=" <>) - (environ))) - - #:log-file "/var/log/mcron.log")) - (stop #~(make-kill-destructor)) - - (actions - (list (shepherd-schedule-action mcron files))))))))) +(define (mcron-shepherd-services config) + (match-record config <mcron-configuration> + (mcron jobs log? log-file log-format date-format) + (if (eq? jobs '()) + '() ;nothing to do + (let ((files (job-files mcron jobs))) + (list (shepherd-service + (provision '(mcron)) + (requirement '(user-processes)) + (modules `((srfi srfi-1) + (srfi srfi-26) + (ice-9 popen) ;for the 'schedule' action + (ice-9 rdelim) + (ice-9 match) + ,@%default-modules)) + (start #~(make-forkexec-constructor + (list #$(file-append mcron "/bin/mcron") + #$@(if log? + `("--log" "--log-format" ,log-format + ,@(if (maybe-value-set? date-format) + (list "--date-format" + date-format) + '())) + '()) + #$@files) + + ;; Disable auto-compilation of the job files and + ;; set a sane value for 'PATH'. + #:environment-variables + (cons* "GUILE_AUTO_COMPILE=0" + "PATH=/run/current-system/profile/bin" + (remove (cut string-prefix? "PATH=" <>) + (environ))) + + #:log-file #$log-file)) + (stop #~(make-kill-destructor)) + (actions + (list (shepherd-schedule-action mcron files))))))))) (define mcron-service-type (service-type (name 'mcron) diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm index 4632498357..19c109d238 100644 --- a/gnu/services/networking.scm +++ b/gnu/services/networking.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2016, 2018, 2020 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2016 John Darrington <jmd@gnu.org> @@ -486,36 +486,19 @@ daemon is responsible for allocating IP addresses to its client."))) ntp-configuration? (ntp ntp-configuration-ntp (default ntp)) - (servers %ntp-configuration-servers ;list of <ntp-server> objects + (servers ntp-configuration-servers ;list of <ntp-server> objects (default %ntp-servers)) (allow-large-adjustment? ntp-allow-large-adjustment? (default #t))) ;as recommended in the ntpd manual -(define (ntp-configuration-servers ntp-configuration) - ;; A wrapper to support the deprecated form of this field. - (let ((ntp-servers (%ntp-configuration-servers ntp-configuration))) - (match ntp-servers - (((? string?) (? string?) ...) - (format (current-error-port) "warning: Defining NTP servers as strings is \ -deprecated. Please use <ntp-server> records instead.\n") - (map (lambda (addr) - (ntp-server - (type 'server) - (address addr) - (options '()))) ntp-servers)) - ((($ <ntp-server>) ($ <ntp-server>) ...) - ntp-servers)))) - (define (ntp-shepherd-service config) (match-record config <ntp-configuration> (ntp servers allow-large-adjustment?) - (let ((servers (ntp-configuration-servers config))) - ;; TODO: Add authentication support. - (define config - (string-append "driftfile /var/run/ntpd/ntp.drift\n" - (string-join (map ntp-server->string servers) - "\n") - " + ;; TODO: Add authentication support. + (define config + (string-append "driftfile /var/run/ntpd/ntp.drift\n" + (string-join (map ntp-server->string servers) "\n") + " # Disable status queries as a workaround for CVE-2013-5211: # <http://support.ntp.org/bin/view/Main/SecurityNotice#DRDoS_Amplification_Attack_using>. restrict default kod nomodify notrap nopeer noquery limited @@ -529,21 +512,22 @@ restrict -6 ::1 # option by default, as documented in the 'ntp.conf' manual. restrict source notrap nomodify noquery\n")) - (define ntpd.conf - (plain-file "ntpd.conf" config)) + (define ntpd.conf + (plain-file "ntpd.conf" config)) - (list (shepherd-service - (provision '(ntpd)) - (documentation "Run the Network Time Protocol (NTP) daemon.") - (requirement '(user-processes networking)) - (start #~(make-forkexec-constructor - (list (string-append #$ntp "/bin/ntpd") "-n" - "-c" #$ntpd.conf "-u" "ntpd" - #$@(if allow-large-adjustment? - '("-g") - '())) - #:log-file "/var/log/ntpd.log")) - (stop #~(make-kill-destructor))))))) + (list (shepherd-service + (provision '(ntpd)) + (documentation "Run the Network Time Protocol (NTP) daemon.") + (requirement '(user-processes networking)) + (actions (list (shepherd-configuration-action ntpd.conf))) + (start #~(make-forkexec-constructor + (list (string-append #$ntp "/bin/ntpd") "-n" + "-c" #$ntpd.conf "-u" "ntpd" + #$@(if allow-large-adjustment? + '("-g") + '())) + #:log-file "/var/log/ntpd.log")) + (stop #~(make-kill-destructor)))))) (define %ntp-accounts (list (user-account @@ -1235,6 +1219,7 @@ project's documentation} for more information." ;; TODO: iwd? is deprecated and should be passed ;; with shepherd-requirement, remove later. ,@(if iwd? '(iwd) '()))) + (actions (list (shepherd-configuration-action conf))) (start #~(lambda _ (let ((pid @@ -1248,7 +1233,11 @@ project's documentation} for more information." "/lib/NetworkManager/VPN") ;; Override non-existent default users "NM_OPENVPN_USER=" - "NM_OPENVPN_GROUP=")))) + "NM_OPENVPN_GROUP=" + ;; Allow NetworkManager to find the modules. + (string-append + "LINUX_MODULE_DIRECTORY=" + "/run/booted-system/kernel/lib/modules"))))) ;; XXX: Despite the "online" name, this doesn't guarantee ;; WAN connectivity, it merely waits for NetworkManager ;; to finish starting-up. This is required otherwise diff --git a/gnu/services/sddm.scm b/gnu/services/sddm.scm index 694ad736dc..9e02f1cc81 100644 --- a/gnu/services/sddm.scm +++ b/gnu/services/sddm.scm @@ -324,9 +324,3 @@ Relogin=" (if (sddm-configuration-relogin? config) (description "Run SDDM, a display and log-in manager for X11 and Wayland.")))) - -(define-deprecated (sddm-service #:optional (config (sddm-configuration))) - sddm-service-type - "Run the @uref{https://github.com/sddm/sddm,SDDM display manager} -with the given @var{config}, a @code{<sddm-configuration>} object." - (service sddm-service-type config)) diff --git a/gnu/services/security.scm b/gnu/services/security.scm index 8116072920..e750bb468b 100644 --- a/gnu/services/security.scm +++ b/gnu/services/security.scm @@ -200,7 +200,7 @@ "Backend to use to detect changes in the @code{log-path}. The default is 'auto. To consult the defaults of the jail configuration, refer to the @file{/etc/fail2ban/jail.conf} file of the @code{fail2ban} package." - fail2ban-jail-configuration-serialize-backend) + (serializer fail2ban-jail-configuration-serialize-backend)) (max-retry maybe-integer "The number of failures before a host get banned @@ -269,7 +269,7 @@ names matching their filter name.") maybe-symbol "The encoding of the log files handled by the jail. Possible values are: @code{'ascii}, @code{'utf-8} and @code{'auto}." - fail2ban-jail-configuration-serialize-log-encoding) + (serializer fail2ban-jail-configuration-serialize-log-encoding)) (log-path (list-of-strings '()) "The file names of the log files to be monitored.") @@ -280,7 +280,7 @@ Possible values are: @code{'ascii}, @code{'utf-8} and @code{'auto}." (text-config '()) "Extra content for the jail configuration, provided as a list of file-like objects." - serialize-text-config) + (serializer serialize-text-config)) (prefix fail2ban-jail-configuration-)) (define list-of-fail2ban-jail-configurations? diff --git a/gnu/services/vnc.scm b/gnu/services/vnc.scm index 15c3c14fee..d57cf51af2 100644 --- a/gnu/services/vnc.scm +++ b/gnu/services/vnc.scm @@ -17,6 +17,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (gnu services vnc) + #:use-module (gnu packages admin) #:use-module (gnu packages vnc) #:use-module ((gnu services) #:hide (delete)) #:use-module (gnu system shadow) @@ -191,7 +192,9 @@ CONFIG, a <xvnc-configuration> object." (name "xvnc") (group "xvnc") (system? #t) - (comment "User for Xvnc server")))) + (comment "User for Xvnc server") + (home-directory "/var/empty") + (shell (file-append shadow "/sbin/nologin"))))) (define (xvnc-shepherd-service config) "Return a <shepherd-service> for Xvnc with CONFIG." diff --git a/gnu/services/web.scm b/gnu/services/web.scm index d56e893527..45897d7d6f 100644 --- a/gnu/services/web.scm +++ b/gnu/services/web.scm @@ -15,6 +15,7 @@ ;;; Copyright © 2020 Oleg Pykhalov <go.wigust@gmail.com> ;;; Copyright © 2020, 2021 Alexandru-Sergiu Marton <brown121407@posteo.ro> ;;; Copyright © 2022 Simen Endsjø <simendsjo@gmail.com> +;;; Copyright © 2023 Bruno Victal <mirai@makinata.eu> ;;; ;;; This file is part of GNU Guix. ;;; @@ -51,6 +52,8 @@ #:use-module (gnu packages logging) #:use-module (gnu packages mail) #:use-module (gnu packages rust-apps) + #:autoload (guix i18n) (G_) + #:use-module (guix diagnostics) #:use-module (guix packages) #:use-module (guix records) #:use-module (guix modules) @@ -61,6 +64,7 @@ #:use-module ((guix packages) #:select (package-version)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-34) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (httpd-configuration @@ -96,6 +100,7 @@ nginx-configuration-nginx nginx-configuration-shepherd-requirement nginx-configuration-log-directory + nginx-configuration-log-level nginx-configuration-run-directory nginx-configuration-server-blocks nginx-configuration-upstream-blocks @@ -562,6 +567,9 @@ (default '())) ;list of symbols (log-directory nginx-configuration-log-directory ;string (default "/var/log/nginx")) + (log-level nginx-configuration-log-level + (sanitize assert-valid-log-level) + (default 'error)) (run-directory nginx-configuration-run-directory ;string (default "/var/run/nginx")) (server-blocks nginx-configuration-server-blocks @@ -584,6 +592,14 @@ (file nginx-configuration-file ;#f | string | file-like (default #f))) +(define (assert-valid-log-level level) + "Ensure @var{level} is one of @code{'debug}, @code{'info}, @code{'notice}, +@code{'warn}, @code{'error}, @code{'crit}, @code{'alert}, or @code{'emerg}." + (unless (memq level '(debug info notice warn error crit alert emerg)) + (raise + (formatted-message (G_ "unknown log level '~a'~%") level))) + level) + (define (config-domain-strings names) "Return a string denoting the nginx config representation of NAMES, a list of domain names." @@ -692,6 +708,7 @@ of index files." (match-record config <nginx-configuration> (nginx log-directory run-directory + log-level server-blocks upstream-blocks server-names-hash-bucket-size server-names-hash-bucket-max-size @@ -704,7 +721,7 @@ of index files." (flatten "user nginx nginx;\n" "pid " run-directory "/pid;\n" - "error_log " log-directory "/error.log info;\n" + "error_log " log-directory "/error.log " (symbol->string log-level) ";\n" (map emit-load-module modules) (map emit-global-directive global-directives) "http {\n" @@ -823,7 +840,11 @@ This has the effect of killing old worker processes and starting new ones, using the same configuration file. It is useful for situations where the same nginx configuration file can point to different things after a reload, such as renewed TLS certificates, or @code{include}d files.") - (procedure (nginx-action "-s" "reload")))))))))) + (procedure (nginx-action "-s" "reload"))) + (shepherd-action + (name 'reopen) + (documentation "Re-open log files.") + (procedure (nginx-action "-s" "reopen")))))))))) (define nginx-service-type (service-type (name 'nginx) diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm index c4745cecf5..7295a45b59 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.scm @@ -358,6 +358,22 @@ in @var{modules}." files) #t)))) +(define (xorg-configuration-server-package-path config input path) + "Lookup the direct @var{input} in the xorg server package of @var{config} +and append @var{path} to it." + (let* ((server (xorg-configuration-server config)) + (package (lookup-package-direct-input server input))) + (when package (file-append package path)))) + +(define (xorg-configuration-dri-driver-path config) + (xorg-configuration-server-package-path config "mesa" "/lib/dri")) + +(define (xorg-configuration-xkb-bin-dir config) + (xorg-configuration-server-package-path config "xkbcomp" "/bin")) + +(define (xorg-configuration-xkb-dir config) + (xorg-configuration-server-package-path config "xkeyboard-config" "/share/X11/xkb")) + (define* (xorg-wrapper #:optional (config (xorg-configuration))) "Return a derivation that builds a script to start the X server with the given @var{config}. The resulting script should be used in place of @@ -365,12 +381,13 @@ given @var{config}. The resulting script should be used in place of (define exp ;; Write a small wrapper around the X server. #~(begin - (setenv "XORG_DRI_DRIVER_PATH" (string-append #$mesa "/lib/dri")) - (setenv "XKB_BINDIR" (string-append #$xkbcomp "/bin")) + (setenv "XORG_DRI_DRIVER_PATH" + #$(xorg-configuration-dri-driver-path config)) + (setenv "XKB_BINDIR" #$(xorg-configuration-xkb-bin-dir config)) (let ((X (string-append #$(xorg-configuration-server config) "/bin/X"))) (apply execl X X - "-xkbdir" (string-append #$xkeyboard-config "/share/X11/xkb") + "-xkbdir" #$(xorg-configuration-xkb-dir config) "-config" #$(xorg-configuration->file config) "-configdir" #$(xorg-configuration-directory (xorg-configuration-modules config)) |