diff options
Diffstat (limited to 'gnu/services')
42 files changed, 989 insertions, 326 deletions
diff --git a/gnu/services/admin.scm b/gnu/services/admin.scm index 763a4434e4..043517262f 100644 --- a/gnu/services/admin.scm +++ b/gnu/services/admin.scm @@ -149,7 +149,7 @@ for ROTATION." (define-record-type* <rottlog-configuration> rottlog-configuration make-rottlog-configuration rottlog-configuration? - (rottlog rottlog-rottlog ;package + (rottlog rottlog-rottlog ;file-like (default rottlog)) (rc-file rottlog-rc-file ;file-like (default (file-append rottlog "/etc/rc"))) diff --git a/gnu/services/auditd.scm b/gnu/services/auditd.scm index cffc226ec9..abde811f51 100644 --- a/gnu/services/auditd.scm +++ b/gnu/services/auditd.scm @@ -46,7 +46,7 @@ ignore\ndisk_error_action = syslog\n")) (define-record-type* <auditd-configuration> auditd-configuration make-auditd-configuration auditd-configuration? - (audit auditd-configuration-audit ; package + (audit auditd-configuration-audit ; file-like (default audit)) (configuration-directory auditd-configuration-configuration-directory)) ; file-like diff --git a/gnu/services/authentication.scm b/gnu/services/authentication.scm index d7efc48cd0..cb0ef6d85a 100644 --- a/gnu/services/authentication.scm +++ b/gnu/services/authentication.scm @@ -45,7 +45,7 @@ nslcd-service-type)) (define-configuration fprintd-configuration - (fprintd (package fprintd) + (fprintd (file-like fprintd) "The fprintd package")) (define (fprintd-dbus-service config) @@ -213,7 +213,7 @@ (define-configuration nslcd-configuration (nss-pam-ldapd - (package nss-pam-ldapd) + (file-like nss-pam-ldapd) "The NSS-PAM-LDAPD package to use.") ;; Runtime options diff --git a/gnu/services/avahi.scm b/gnu/services/avahi.scm index 2dcf1d9c1b..3b8d0512c7 100644 --- a/gnu/services/avahi.scm +++ b/gnu/services/avahi.scm @@ -52,7 +52,7 @@ (define-record-type* <avahi-configuration> avahi-configuration make-avahi-configuration avahi-configuration? - (avahi avahi-configuration-avahi ;<package> + (avahi avahi-configuration-avahi ;file-like (default avahi)) (debug? avahi-configuration-debug? ;Boolean (default #f)) diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 50865055fe..fbd01e84d6 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <[email protected]> +;;; Copyright © 2013-2022 Ludovic Courtès <[email protected]> ;;; Copyright © 2015, 2016 Alex Kost <[email protected]> ;;; Copyright © 2015, 2016, 2020 Mark H Weaver <[email protected]> ;;; Copyright © 2015 Sou Bunnbu <[email protected]> @@ -16,6 +16,7 @@ ;;; Copyright © 2021 qblade <[email protected]> ;;; Copyright © 2021 Hui Lu <[email protected]> ;;; Copyright © 2021 Maxim Cournoyer <[email protected]> +;;; Copyright © 2022 Guillaume Le Vaillant <[email protected]> ;;; ;;; This file is part of GNU Guix. ;;; @@ -35,6 +36,9 @@ (define-module (gnu services base) #:use-module (guix store) #:use-module (guix deprecation) + #:autoload (guix diagnostics) (warning &fix-hint) + #:autoload (guix i18n) (G_) + #:use-module (guix combinators) #:use-module (gnu services) #:use-module (gnu services admin) #:use-module (gnu services shepherd) @@ -52,19 +56,27 @@ #:select (alsa-utils crda eudev e2fsprogs fuse gpm kbd lvm2 rng-tools)) #:use-module (gnu packages bash) #:use-module ((gnu packages base) - #:select (coreutils glibc glibc-utf8-locales)) + #:select (coreutils glibc glibc-utf8-locales tar)) + #:use-module ((gnu packages compression) #:select (gzip)) + #:autoload (gnu packages guile-xyz) (guile-netlink) + #:autoload (gnu packages hurd) (hurd) #:use-module (gnu packages package-management) #:use-module ((gnu packages gnupg) #:select (guile-gcrypt)) #:use-module (gnu packages linux) #:use-module (gnu packages terminals) #:use-module ((gnu build file-systems) - #:select (mount-flags->bit-mask)) + #:select (mount-flags->bit-mask + swap-space->flags-bit-mask)) #:use-module (guix gexp) #:use-module (guix records) #:use-module (guix modules) #:use-module ((guix self) #:select (make-config.scm)) + #:use-module (guix diagnostics) + #:use-module (guix i18n) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (ice-9 match) #:use-module (ice-9 format) #:re-export (user-processes-service-type ;backwards compatibility @@ -80,17 +92,38 @@ virtual-terminal-service-type static-networking - static-networking? - static-networking-interface - static-networking-ip - static-networking-netmask - static-networking-gateway + static-networking-addresses + static-networking-links + static-networking-routes static-networking-requirement + network-address + network-address? + network-address-device + network-address-value + network-address-ipv6? + + network-link + network-link? + network-link-name + network-link-type + network-link-arguments + + network-route + network-route? + network-route-destination + network-route-source + network-route-device + network-route-ipv6? + network-route-gateway + static-networking-service static-networking-service-type + %loopback-static-networking + %qemu-static-networking + udev-configuration udev-configuration? udev-configuration-rules @@ -164,6 +197,7 @@ guix-publish-configuration-nar-path guix-publish-configuration-cache guix-publish-configuration-ttl + guix-publish-configuration-negative-ttl guix-publish-service-type gpm-configuration @@ -557,7 +591,7 @@ down."))) (define-record-type* <rngd-configuration> rngd-configuration make-rngd-configuration rngd-configuration? - (rng-tools rngd-configuration-rng-tools) ;package + (rng-tools rngd-configuration-rng-tools) ;file-like (device rngd-configuration-device)) ;string (define rngd-service-type @@ -772,7 +806,7 @@ the message of the day, among other things." (define-record-type* <agetty-configuration> agetty-configuration make-agetty-configuration agetty-configuration? - (agetty agetty-configuration-agetty ;<package> + (agetty agetty-configuration-agetty ;file-like (default util-linux)) (tty agetty-configuration-tty) ;string | #f (term agetty-term ;string | #f @@ -1040,7 +1074,7 @@ the tty to run, among other things." (define-record-type* <mingetty-configuration> mingetty-configuration make-mingetty-configuration mingetty-configuration? - (mingetty mingetty-configuration-mingetty ;<package> + (mingetty mingetty-configuration-mingetty ;file-like (default mingetty)) (tty mingetty-configuration-tty) ;string (auto-login mingetty-auto-login ;string | #f @@ -1112,9 +1146,9 @@ the tty to run, among other things." ;; TODO: See nscd.conf in glibc for other options to add. (caches nscd-configuration-caches ;list of <nscd-cache> (default %nscd-default-caches)) - (name-services nscd-configuration-name-services ;list of <packages> + (name-services nscd-configuration-name-services ;list of file-like (default '())) - (glibc nscd-configuration-glibc ;<package> + (glibc nscd-configuration-glibc ;file-like (default glibc))) (define-record-type* <nscd-cache> nscd-cache make-nscd-cache @@ -1513,7 +1547,7 @@ archive' public keys, with GUIX." (define-record-type* <guix-configuration> guix-configuration make-guix-configuration guix-configuration? - (guix guix-configuration-guix ;<package> + (guix guix-configuration-guix ;file-like (default guix)) (build-group guix-configuration-build-group ;string (default "guixbuild")) @@ -1534,7 +1568,7 @@ archive' public keys, with GUIX." (timeout guix-configuration-timeout ;integer (default 0)) (log-compression guix-configuration-log-compression - (default 'bzip2)) + (default 'gzip)) (discover? guix-configuration-discover? (default #f)) (extra-options guix-configuration-extra-options ;list of strings @@ -1678,7 +1712,14 @@ proxy of 'guix-daemon'...~%") (string-append "GUIX_LOCPATH=" #$glibc-utf8-locales "/lib/locale") - "LC_ALL=en_US.utf8") + "LC_ALL=en_US.utf8" + ;; Make 'tar' and 'gzip' available so + ;; that 'guix perform-download' can use + ;; them when downloading from Software + ;; Heritage via '(guix swh)'. + (string-append "PATH=" + #$(file-append tar "/bin") ":" + #$(file-append gzip "/bin"))) (if proxy (list (string-append "http_proxy=" proxy) (string-append "https_proxy=" proxy)) @@ -1766,7 +1807,7 @@ proxy of 'guix-daemon'...~%") (define-record-type* <guix-publish-configuration> guix-publish-configuration make-guix-publish-configuration guix-publish-configuration? - (guix guix-publish-configuration-guix ;package + (guix guix-publish-configuration-guix ;file-like (default guix)) (port guix-publish-configuration-port ;number (default 80)) @@ -1789,7 +1830,9 @@ proxy of 'guix-daemon'...~%") (workers guix-publish-configuration-workers ;#f | integer (default #f)) (ttl guix-publish-configuration-ttl ;#f | integer - (default #f))) + (default #f)) + (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." @@ -1824,8 +1867,8 @@ raise a deprecation warning if the 'compression-level' field was used." lst)))) (match-record config <guix-publish-configuration> - (guix port host nar-path cache workers ttl cache-bypass-threshold - advertise?) + (guix port host nar-path cache workers ttl negative-ttl + cache-bypass-threshold advertise?) (list (shepherd-service (provision '(guix-publish)) (requirement `(user-processes @@ -1851,6 +1894,11 @@ raise a deprecation warning if the 'compression-level' field was used." #$(number->string ttl) "s")) #~()) + #$@(if negative-ttl + #~((string-append "--negative-ttl=" + #$(number->string negative-ttl) + "s")) + #~()) #$@(if cache #~((string-append "--cache=" #$cache) #$(string-append @@ -1921,9 +1969,9 @@ command that allows you to share pre-built binaries with others over HTTP."))) (define-record-type* <udev-configuration> udev-configuration make-udev-configuration udev-configuration? - (udev udev-configuration-udev ;<package> + (udev udev-configuration-udev ;file-like (default eudev)) - (rules udev-configuration-rules ;list of <package> + (rules udev-configuration-rules ;list of file-like (default '()))) (define (udev-rules-union packages) @@ -2146,62 +2194,98 @@ instance." udev-service-type udev-extension)))))) (service type #f))) +(define (swap-space->shepherd-service-name space) + (let ((target (swap-space-target space))) + (symbol-append 'swap- + (string->symbol + (cond ((uuid? target) + (uuid->string target)) + ((file-system-label? target) + (file-system-label->string target)) + (else + target)))))) + +; TODO Remove after deprecation +(define (swap-deprecated->shepherd-service-name sdep) + (symbol-append 'swap- + (string->symbol + (cond ((uuid? sdep) + (string-take (uuid->string sdep) 6)) + ((file-system-label? sdep) + (file-system-label->string sdep)) + (else + sdep))))) + +(define swap->shepherd-service-name + (match-lambda ((? swap-space? space) + (swap-space->shepherd-service-name space)) + (sdep + (swap-deprecated->shepherd-service-name sdep)))) + (define swap-service-type (shepherd-service-type 'swap - (lambda (device) - (define requirement - (if (and (string? device) - (string-prefix? "/dev/mapper/" device)) - (list (symbol-append 'device-mapping- - (string->symbol (basename device)))) - '())) - - (define (device-lookup device) + (lambda (swap) + (define requirements + (cond ((swap-space? swap) + (map dependency->shepherd-service-name + (swap-space-dependencies swap))) + ; TODO Remove after deprecation + ((and (string? swap) (string-prefix? "/dev/mapper/" swap)) + (list (symbol-append 'device-mapping- + (string->symbol (basename swap))))) + (else + '()))) + + (define device-lookup ;; The generic 'find-partition' procedures could return a partition ;; that's not swap space, but that's unlikely. - (cond ((uuid? device) - #~(find-partition-by-uuid #$(uuid-bytevector device))) - ((file-system-label? device) + (cond ((swap-space? swap) + (let ((target (swap-space-target swap))) + (cond ((uuid? target) + #~(find-partition-by-uuid #$(uuid-bytevector target))) + ((file-system-label? target) + #~(find-partition-by-label + #$(file-system-label->string target))) + (else + target)))) + ; TODO Remove after deprecation + ((uuid? swap) + #~(find-partition-by-uuid #$(uuid-bytevector swap))) + ((file-system-label? swap) #~(find-partition-by-label - #$(file-system-label->string device))) + #$(file-system-label->string swap))) (else - device))) - - (define service-name - (symbol-append 'swap- - (string->symbol - (cond ((uuid? device) - (string-take (uuid->string device) 6)) - ((file-system-label? device) - (file-system-label->string device)) - (else - device))))) + swap))) (with-imported-modules (source-module-closure '((gnu build file-systems))) (shepherd-service - (provision (list service-name)) - (requirement `(udev ,@requirement)) - (documentation "Enable the given swap device.") + (provision (list (swap->shepherd-service-name swap))) + (requirement `(udev ,@requirements)) + (documentation "Enable the given swap space.") (modules `((gnu build file-systems) ,@%default-modules)) (start #~(lambda () - (let ((device #$(device-lookup device))) + (let ((device #$device-lookup)) (and device (begin - (restart-on-EINTR (swapon device)) + (restart-on-EINTR (swapon device + #$(if (swap-space? swap) + (swap-space->flags-bit-mask + swap) + 0))) #t))))) (stop #~(lambda _ - (let ((device #$(device-lookup device))) + (let ((device #$device-lookup)) (when device (restart-on-EINTR (swapoff device))) #f))) (respawn? #f)))) (description "Turn on the virtual memory swap area."))) -(define (swap-service device) - "Return a service that uses @var{device} as a swap device." - (service swap-service-type device)) +(define (swap-service swap) + "Return a service that uses @var{swap} as a swap space." + (service swap-service-type swap)) (define %default-gpm-options ;; Default options for GPM. @@ -2209,7 +2293,7 @@ instance." (define-record-type* <gpm-configuration> gpm-configuration make-gpm-configuration gpm-configuration? - (gpm gpm-configuration-gpm ;package + (gpm gpm-configuration-gpm ;file-like (default gpm)) (options gpm-configuration-options ;list of strings (default %default-gpm-options))) @@ -2315,72 +2399,285 @@ notably to select, copy, and paste text. The default options use the (description "Start the @command{kmscon} virtual terminal emulator for the Linux @dfn{kernel mode setting} (KMS)."))) + +;;; +;;; Static networking. +;;; + +(define (ipv6-address? str) + "Return true if STR denotes an IPv6 address." + (false-if-exception (->bool (inet-pton AF_INET6 str)))) + +(define-compile-time-procedure (assert-valid-address (address string?)) + "Ensure ADDRESS has a valid netmask." + (unless (cidr->netmask address) + (raise + (make-compound-condition + (formatted-message (G_ "address '~a' lacks a network mask") + address) + (condition (&error-location + (location + (source-properties->location procedure-call-location)))) + (condition (&fix-hint + (hint (format #f (G_ "\ +Write, say, @samp{\"~a/24\"} for a 24-bit network mask.") + address))))))) + address) + (define-record-type* <static-networking> static-networking make-static-networking static-networking? - (interface static-networking-interface) - (ip static-networking-ip) - (netmask static-networking-netmask - (default #f)) - (gateway static-networking-gateway ;FIXME: doesn't belong here - (default #f)) + (addresses static-networking-addresses) ;list of <network-address> + (links static-networking-links (default '())) ;list of <network-link> + (routes static-networking-routes (default '())) ;list of <network-routes> (provision static-networking-provision - (default #f)) + (default '(networking))) (requirement static-networking-requirement - (default '())) + (default '(udev))) (name-servers static-networking-name-servers ;FIXME: doesn't belong here (default '()))) -(define static-networking-shepherd-service +(define-record-type* <network-address> + network-address make-network-address + network-address? + (device network-address-device) ;string--e.g., "en01" + (value network-address-value ;string--CIDR notation + (sanitize assert-valid-address)) + (ipv6? network-address-ipv6? ;Boolean + (thunked) + (default + (ipv6-address? (cidr->ip (network-address-value this-record)))))) + +(define-record-type* <network-link> + network-link make-network-link + network-link? + (name network-link-name) ;string--e.g, "v0p0" + (type network-link-type) ;symbol--e.g.,'veth + (arguments network-link-arguments)) ;list + +(define-record-type* <network-route> + network-route make-network-route + network-route? + (destination network-route-destination) + (source network-route-source (default #f)) + (device network-route-device (default #f)) + (ipv6? network-route-ipv6? (thunked) + (default + (or (ipv6-address? (network-route-destination this-record)) + (and=> (network-route-gateway this-record) + 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 +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))) + +(define (cidr->ip str) + "Strip the netmask bit of @var{str}, a CIDR-notation IP/netmask address." + (match (string-split str #\/) + ((or (ip _) (ip)) + ip))) + +(define* (ip+netmask->cidr ip netmask #:optional (family AF_INET)) + "Return the CIDR notation (a string) for @var{ip} and @var{netmask}, two +@var{family} address strings, where @var{family} is @code{AF_INET} or +@code{AF_INET6}." + (let* ((netmask (inet-pton family netmask)) + (bits (logcount netmask))) + (string-append ip "/" (number->string bits)))) + +(define (static-networking->hurd-pfinet-options config) + "Return command-line options for the Hurd's pfinet translator corresponding +to CONFIG." + (unless (null? (static-networking-links config)) + ;; XXX: Presumably this is not supported, or perhaps could be approximated + ;; by running separate pfinet instances in some cases? + (warning (G_ "network links are currently ignored on GNU/Hurd~%"))) + + (match (static-networking-addresses config) + ((and addresses (first _ ...)) + `("--ipv6" "/servers/socket/26" + "--interface" ,(network-address-device first) + ,@(append-map (lambda (address) + `(,(if (network-address-ipv6? address) + "--address6" + "--address") + ,(cidr->ip (network-address-value address)) + ,@(match (cidr->netmask (network-address-value address) + (if (network-address-ipv6? address) + AF_INET6 + AF_INET)) + (#f '()) + (mask (list "--netmask" mask))))) + addresses) + ,@(append-map (lambda (route) + (match route + (($ <network-route> "default" #f device _ gateway) + (if (network-route-ipv6? route) + `("--gateway6" ,gateway) + `("--gateway" ,gateway))) + (($ <network-route> destination) + (warning (G_ "ignoring network route for '~a'~%") + destination) + '()))) + (static-networking-routes config)))))) + +(define (network-set-up/hurd config) + "Set up networking for the Hurd." + ;; The Hurd implements SIOCGIFADDR and other old-style ioctls, but the only + ;; way to set up IPv6 is by starting pfinet with the right options. + (if (equal? (static-networking-provision config) '(loopback)) + (scheme-file "set-up-pflocal" #~(begin 'nothing-to-do! #t)) + (scheme-file "set-up-pfinet" + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (ice-9 format)) + + ;; TODO: Do that without forking. + (let ((options '#$(static-networking->hurd-pfinet-options + config))) + (format #t "starting '~a~{ ~s~}'~%" + #$(file-append hurd "/hurd/pfinet") + options) + (apply invoke #$(file-append hurd "/bin/settrans") "-fac" + "/servers/socket/2" + #$(file-append hurd "/hurd/pfinet") + options))))))) + +(define (network-tear-down/hurd config) + (scheme-file "tear-down-pfinet" + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + + ;; Forcefully terminate pfinet. XXX: In theory this + ;; should just undo the addresses and routes of CONFIG; + ;; this could be done using ioctls like SIOCDELRT, but + ;; these are IPv4-only; another option would be to use + ;; fsysopts but that seems to crash pfinet. + (invoke #$(file-append hurd "/bin/settrans") "-fg" + "/servers/socket/2") + #f)))) + +(define network-set-up/linux + (match-lambda + (($ <static-networking> addresses links routes) + (scheme-file "set-up-network" + (with-extensions (list guile-netlink) + #~(begin + (use-modules (ip addr) (ip link) (ip route)) + + #$@(map (lambda (address) + #~(begin + (addr-add #$(network-address-device address) + #$(network-address-value address) + #:ipv6? + #$(network-address-ipv6? address)) + ;; FIXME: loopback? + (link-set #$(network-address-device address) + #:multicast-on #t + #:up #t))) + addresses) + #$@(map (match-lambda + (($ <network-link> name type arguments) + #~(link-add #$name #$type + #:type-args '#$arguments))) + links) + #$@(map (lambda (route) + #~(route-add #$(network-route-destination route) + #:device + #$(network-route-device route) + #:ipv6? + #$(network-route-ipv6? route) + #:via + #$(network-route-gateway route) + #:src + #$(network-route-source route))) + routes) + #t)))))) + +(define network-tear-down/linux (match-lambda - (($ <static-networking> interface ip netmask gateway provision - requirement name-servers) + (($ <static-networking> addresses links routes) + (scheme-file "tear-down-network" + (with-extensions (list guile-netlink) + #~(begin + (use-modules (ip addr) (ip link) (ip route) + (netlink error) + (srfi srfi-34)) + + (define-syntax-rule (false-if-netlink-error exp) + (guard (c ((netlink-error? c) #f)) + exp)) + + ;; Wrap calls in 'false-if-netlink-error' so this + ;; script goes as far as possible undoing the effects + ;; of "set-up-network". + + #$@(map (lambda (route) + #~(false-if-netlink-error + (route-del #$(network-route-destination route) + #:device + #$(network-route-device route) + #:ipv6? + #$(network-route-ipv6? route) + #:via + #$(network-route-gateway route) + #:src + #$(network-route-source route)))) + routes) + #$@(map (match-lambda + (($ <network-link> name type arguments) + #~(false-if-netlink-error + (link-del #$name)))) + links) + #$@(map (lambda (address) + #~(false-if-netlink-error + (addr-del #$(network-address-device + address) + #$(network-address-value address) + #:ipv6? + #$(network-address-ipv6? address)))) + addresses) + #f)))))) + +(define (static-networking-shepherd-service config) + (match config + (($ <static-networking> addresses links routes + provision requirement name-servers) (let ((loopback? (and provision (memq 'loopback provision)))) (shepherd-service (documentation "Bring up the networking interface using a static IP address.") (requirement requirement) - (provision (or provision - (list (symbol-append 'networking- - (string->symbol interface))))) + (provision provision) (start #~(lambda _ ;; Return #t if successfully started. - (let* ((addr (inet-pton AF_INET #$ip)) - (sockaddr (make-socket-address AF_INET addr 0)) - (mask (and #$netmask - (inet-pton AF_INET #$netmask))) - (maskaddr (and mask - (make-socket-address AF_INET - mask 0))) - (gateway (and #$gateway - (inet-pton AF_INET #$gateway))) - (gatewayaddr (and gateway - (make-socket-address AF_INET - gateway 0)))) - (configure-network-interface #$interface sockaddr - (logior IFF_UP - #$(if loopback? - #~IFF_LOOPBACK - 0)) - #:netmask maskaddr) - (when gateway - (let ((sock (socket AF_INET SOCK_DGRAM 0))) - (add-network-route/gateway sock gatewayaddr) - (close-port sock)))))) + (load #$(let-system (system target) + (if (string-contains (or target system) "-linux") + (network-set-up/linux config) + (network-set-up/hurd config)))))) (stop #~(lambda _ ;; Return #f is successfully stopped. - (let ((sock (socket AF_INET SOCK_STREAM 0))) - (when #$gateway - (delete-network-route sock - (make-socket-address - AF_INET INADDR_ANY 0))) - (set-network-interface-flags sock #$interface 0) - (close-port sock) - #f))) + (load #$(let-system (system target) + (if (string-contains (or target system) "-linux") + (network-tear-down/linux config) + (network-tear-down/hurd config)))))) (respawn? #f)))))) +(define (static-networking-shepherd-services networks) + (map static-networking-shepherd-service networks)) + (define (static-networking-etc-files interfaces) "Return a /etc/resolv.conf entry for INTERFACES or the empty list." (match (delete-duplicates @@ -2399,30 +2696,6 @@ Linux @dfn{kernel mode setting} (KMS)."))) # Generated by 'static-networking-service'.\n" content)))))))) -(define (static-networking-shepherd-services interfaces) - "Return the list of Shepherd services to bring up INTERFACES, a list of -<static-networking> objects." - (define (loopback? service) - (memq 'loopback (shepherd-service-provision service))) - - (let ((services (map static-networking-shepherd-service interfaces))) - (match (remove loopback? services) - (() - ;; There's no interface other than 'loopback', so we assume that the - ;; 'networking' service will be provided by dhclient or similar. - services) - ((non-loopback ...) - ;; Assume we're providing all the interfaces, and thus, provide a - ;; 'networking' service. - (cons (shepherd-service - (provision '(networking)) - (requirement (append-map shepherd-service-provision - services)) - (start #~(const #t)) - (stop #~(const #f)) - (documentation "Bring up all the networking interfaces.")) - services))))) - (define static-networking-service-type ;; The service type for statically-defined network interfaces. (service-type (name 'static-networking) @@ -2440,12 +2713,13 @@ with the given IP address, gateway, netmask, and so on. The value for services of this type is a list of @code{static-networking} objects, one per network interface."))) -(define* (static-networking-service interface ip - #:key - netmask gateway provision - ;; Most interfaces require udev to be usable. - (requirement '(udev)) - (name-servers '())) +(define-deprecated (static-networking-service interface ip + #:key + netmask gateway provision + ;; Most interfaces require udev to be usable. + (requirement '(udev)) + (name-servers '())) + static-networking-service-type "Return a service that starts @var{interface} with address @var{ip}. If @var{netmask} is true, use it as the network mask. If @var{gateway} is true, it must be a string specifying the default network gateway. @@ -2456,11 +2730,47 @@ interface of interest. Behind the scenes what it does is extend to handle." (simple-service 'static-network-interface static-networking-service-type - (list (static-networking (interface interface) (ip ip) - (netmask netmask) (gateway gateway) - (provision provision) - (requirement requirement) - (name-servers name-servers))))) + (list (static-networking + (addresses + (list (network-address + (device interface) + (value (if netmask + (ip+netmask->cidr ip netmask) + ip)) + (ipv6? #f)))) + (routes + (if gateway + (list (network-route + (destination "default") + (gateway gateway) + (ipv6? #f))) + '())) + (requirement requirement) + (provision (or provision '(networking))) + (name-servers name-servers))))) + +(define %loopback-static-networking + ;; The loopback device. + (static-networking + (addresses (list (network-address + (device "lo") + (value "127.0.0.1/8")))) + (requirement '()) + (provision '(loopback)))) + +(define %qemu-static-networking + ;; Networking configuration for QEMU's user-mode network stack (info "(QEMU) + ;; Using the user mode network stack"). + (static-networking + (addresses (list (network-address + (device "eth0") + (value "10.0.2.15/24")))) + (routes (list (network-route + (destination "default") + (gateway "10.0.2.2")))) + (requirement '()) + (provision '(networking)) + (name-servers '("10.0.2.3")))) (define %base-services @@ -2492,10 +2802,7 @@ to handle." (tty "tty6"))) (service static-networking-service-type - (list (static-networking (interface "lo") - (ip "127.0.0.1") - (requirement '()) - (provision '(loopback))))) + (list %loopback-static-networking)) (syslog-service) (service urandom-seed-service-type) (service guix-service-type) diff --git a/gnu/services/cgit.scm b/gnu/services/cgit.scm index 94ca9e281a..bfc89a40a4 100644 --- a/gnu/services/cgit.scm +++ b/gnu/services/cgit.scm @@ -319,7 +319,7 @@ after this option will inherit the current section name.") ;; <repository-cgit-configuration>, <nginx-server-configuration>, <package>. (define-configuration cgit-configuration (package - (package cgit) + (file-like cgit) "The CGIT package.") (nginx (nginx-server-configuration-list (list %cgit-configuration-nginx)) @@ -673,7 +673,7 @@ for cgit to allow access to that repository.") (define-configuration opaque-cgit-configuration (cgit - (package cgit) + (file-like cgit) "The cgit package.") (cgitrc (string (configuration-missing-field 'opaque-cgit-configuration 'cgitrc)) diff --git a/gnu/services/ci.scm b/gnu/services/ci.scm index 0c3566bcaf..172f85fe8e 100644 --- a/gnu/services/ci.scm +++ b/gnu/services/ci.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018, 2019, 2020, 2021 Christopher Baines <[email protected]> -;;; Copyright © 2021 Arun Isaac <[email protected]> +;;; Copyright © 2021, 2022 Arun Isaac <[email protected]> ;;; ;;; This file is part of GNU Guix. ;;; @@ -84,6 +84,8 @@ #$home-directory) ,(string-append "LAMINAR_BIND_HTTP=" #$bind-http) + ,(string-append "LAMINAR_BIND_RPC=" + #$bind-rpc) ,(string-append "LAMINAR_TITLE=" #$title) ,(string-append "LAMINAR_KEEP_RUNDIRS=" diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm index df3d3b6f9b..0de350a4df 100644 --- a/gnu/services/configuration.scm +++ b/gnu/services/configuration.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2017, 2018 Clément Lassieur <[email protected]> ;;; Copyright © 2021 Xinglu Chen <[email protected]> ;;; Copyright © 2021 Maxim Cournoyer <[email protected]> +;;; Copyright © 2021 Andrew Tropin <[email protected]> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,10 +26,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 diagnostics) #:select (formatted-message location-file)) #:use-module ((guix modules) #:select (file-name->module-name)) + #:use-module (guix i18n) #:autoload (texinfo) (texi-fragment->stexi) #:autoload (texinfo serialize) (stexi->texi) + #:use-module (ice-9 curried-definitions) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-34) @@ -56,7 +59,20 @@ generate-documentation configuration->documentation empty-serializer - serialize-package)) + serialize-package + + filter-configuration-fields + + interpose + list-of + + list-of-strings? + alist? + serialize-file-like + text-config? + serialize-text-config + generic-serialize-alist-entry + generic-serialize-alist)) ;;; Commentary: ;;; @@ -323,3 +339,79 @@ Texinfo documentation of its fields." '-fields)))) (display (generate-documentation `((,configuration-symbol ,fields-getter)) configuration-symbol)))) + +(define* (filter-configuration-fields configuration-fields fields + #:optional negate?) + "Retrieve the fields listed in FIELDS from CONFIGURATION-FIELDS. +If NEGATE? is @code{#t}, retrieve all fields except FIELDS." + (filter (lambda (field) + (let ((member? (member (configuration-field-name field) fields))) + (if (not negate?) member? (not member?)))) + configuration-fields)) + + +(define* (interpose ls #:optional (delimiter "\n") (grammar 'infix)) + "Same as @code{string-join}, but without join and string, returns an +DELIMITER interposed LS. Support 'infix and 'suffix GRAMMAR values." + (when (not (member grammar '(infix suffix))) + (raise + (formatted-message + (G_ "The GRAMMAR value must be 'infix or 'suffix, but ~a provided.") + grammar))) + (fold-right (lambda (e acc) + (cons e + (if (and (null? acc) (eq? grammar 'infix)) + acc + (cons delimiter acc)))) + '() ls)) + +(define (list-of pred?) + "Return a procedure that takes a list and check if all the elements of +the list result in @code{#t} when applying PRED? on them." + (lambda (x) + (if (list? x) + (every pred? x) + #f))) + + +(define list-of-strings? + (list-of string?)) + +(define alist? list?) + +(define serialize-file-like empty-serializer) + +(define (text-config? config) + (list-of file-like?)) +(define (serialize-text-config field-name val) + #~(string-append + #$@(interpose + (map + (lambda (e) + #~(begin + (use-modules (ice-9 rdelim)) + (with-fluids ((%default-port-encoding "UTF-8")) + (with-input-from-file #$e read-string)))) + val) + "\n" 'suffix))) + +(define ((generic-serialize-alist-entry serialize-field) entry) + "Apply the SERIALIZE-FIELD procedure on the field and value of ENTRY." + (match entry + ((field . val) (serialize-field field val)))) + +(define (generic-serialize-alist combine serialize-field fields) + "Generate a configuration from an association list FIELDS. + +SERIALIZE-FIELD is a procedure that takes two arguments, it will be +applied on the fields and values of FIELDS using the +@code{generic-serialize-alist-entry} procedure. + +COMBINE is a procedure that takes one or more arguments and combines +all the alist entries into one value, @code{string-append} or +@code{append} are usually good candidates for this. + +See the @code{serialize-alist} procedure in `@code{(gnu home services +version-control}' for an example usage.)}" + (apply combine + (map (generic-serialize-alist-entry serialize-field) fields))) diff --git a/gnu/services/cuirass.scm b/gnu/services/cuirass.scm index 83e63fe79c..96f28a9670 100644 --- a/gnu/services/cuirass.scm +++ b/gnu/services/cuirass.scm @@ -58,7 +58,7 @@ ;;;; Code: (define %cuirass-default-database - "dbname=cuirass host=/tmp") + "dbname=cuirass") (define-record-type* <cuirass-remote-server-configuration> cuirass-remote-server-configuration make-cuirass-remote-server-configuration @@ -85,7 +85,7 @@ (define-record-type* <cuirass-configuration> cuirass-configuration make-cuirass-configuration cuirass-configuration? - (cuirass cuirass-configuration-cuirass ;package + (cuirass cuirass-configuration-cuirass ;file-like (default cuirass)) (log-file cuirass-configuration-log-file ;string (default "/var/log/cuirass.log")) @@ -327,7 +327,7 @@ (define-record-type* <cuirass-remote-worker-configuration> cuirass-remote-worker-configuration make-cuirass-remote-worker-configuration cuirass-remote-worker-configuration? - (cuirass cuirass-remote-worker-configuration-cuirass ;package + (cuirass cuirass-remote-worker-configuration-cuirass ;file-like (default cuirass)) (workers cuirass-remote-worker-workers ;int (default 1)) diff --git a/gnu/services/cups.scm b/gnu/services/cups.scm index 8bcb450ddf..2e86845e51 100644 --- a/gnu/services/cups.scm +++ b/gnu/services/cups.scm @@ -419,6 +419,9 @@ queues. The URI @url{file:///dev/null} is always allowed.") (string "lp") "Specifies the group name or ID that will be used when executing external programs.") + (log-file-group + (string "lpadmin") + "Specifies the group name or ID that will be used for log files.") (log-file-perm (string "0644") "Specifies the permissions for all log files that the scheduler writes.") @@ -482,13 +485,13 @@ programs.") (serialize-space-separated-string-list field-name vars))) (define (package-list? val) - (and (list? val) (and-map package? val))) + (and (list? val) (and-map file-like? val))) (define (serialize-package-list field-name val) #f) (define-configuration cups-configuration (cups - (package cups) + (file-like cups) "The CUPS package.") (extensions (package-list (list brlaser cups-filters epson-inkjet-printer-escpr @@ -702,7 +705,7 @@ in seconds. Set to 0 to disable cancellation of \"stuck\" jobs.") "Specifies the maximum size of the log files before they are rotated, in bytes. The value 0 disables log rotation.") (multiple-operation-timeout - (non-negative-integer 300) + (non-negative-integer 900) "Specifies the maximum amount of time to allow between files in a multiple file print job, in seconds.") (page-log-format @@ -847,7 +850,7 @@ protocol version to TLS v1.1.") "Specifies whether the scheduler requires clients to strictly adhere to the IPP specifications.") (timeout - (non-negative-integer 300) + (non-negative-integer 900) "Specifies the HTTP request timeout, in seconds.") (web-interface? (boolean #f) diff --git a/gnu/services/databases.scm b/gnu/services/databases.scm index eba88cdb68..39225a4bd6 100644 --- a/gnu/services/databases.scm +++ b/gnu/services/databases.scm @@ -116,7 +116,7 @@ host all all ::1/128 md5")) (ident-file postgresql-config-file-ident-file (default %default-postgres-ident)) (socket-directory postgresql-config-file-socket-directory - (default #false)) + (default "/var/run/postgresql")) (extra-config postgresql-config-file-extra-config (default '()))) @@ -164,7 +164,7 @@ host all all ::1/128 md5")) (define-record-type* <postgresql-configuration> postgresql-configuration make-postgresql-configuration postgresql-configuration? - (postgresql postgresql-configuration-postgresql) ;<package> + (postgresql postgresql-configuration-postgresql) ;file-like (port postgresql-configuration-port (default 5432)) (locale postgresql-configuration-locale @@ -364,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 "/tmp")) + (default "/var/run/postgresql")) (log postgresql-role-configuration-log ;string (default "/var/log/postgresql_roles.log")) (roles postgresql-role-configuration-roles @@ -448,7 +448,7 @@ created after the PostgreSQL database is started."))) (define-record-type* <memcached-configuration> memcached-configuration make-memcached-configuration memcached-configuration? - (memcached memcached-configuration-memcached ;<package> + (memcached memcached-configuration-memcached ;file-like (default memcached)) (interfaces memcached-configuration-interfaces (default '("0.0.0.0"))) @@ -693,7 +693,7 @@ FLUSH PRIVILEGES; (define-record-type* <redis-configuration> redis-configuration make-redis-configuration redis-configuration? - (redis redis-configuration-redis ;<package> + (redis redis-configuration-redis ;file-like (default redis)) (bind redis-configuration-bind (default "127.0.0.1")) diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm index e7b3dac166..d2daf60497 100644 --- a/gnu/services/dbus.scm +++ b/gnu/services/dbus.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <[email protected]> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <[email protected]> ;;; Copyright © 2015 Sou Bunnbu <[email protected]> ;;; Copyright © 2021 Maxime Devos <[email protected]> ;;; Copyright © 2021 Brice Waegeneire <[email protected]> @@ -50,7 +50,7 @@ (define-record-type* <dbus-configuration> dbus-configuration make-dbus-configuration dbus-configuration? - (dbus dbus-configuration-dbus ;<package> + (dbus dbus-configuration-dbus ;file-like (default dbus)) (services dbus-configuration-services ;list of <package> (default '()))) @@ -106,6 +106,10 @@ includes the @code{etc/dbus-1/system.d} directories of each package listed in (define (services->sxml services) ;; Return the SXML 'includedir' clauses for DIRS. `(busconfig + ;; Increase this timeout to 60 seconds to work around race-y + ;; failures such as <https://issues.guix.gnu.org/52051> on slow + ;; computers with slow I/O. + (limit (@ (name "auth_timeout")) "60000") (servicehelper "/run/setuid-programs/dbus-daemon-launch-helper") ;; First, the '.service' files of services subject to activation. @@ -300,11 +304,20 @@ tuples, are all set as environment variables when the bus daemon launches it." (define-record-type* <polkit-configuration> polkit-configuration make-polkit-configuration polkit-configuration? - (polkit polkit-configuration-polkit ;<package> - (default polkit)) - (actions polkit-configuration-actions ;list of <package> + (polkit polkit-configuration-polkit ;file-like + (default %default-polkit)) + (actions polkit-configuration-actions ;list of file-like (default '()))) +(define %default-polkit + ;; The default polkit package. + (let-system (system target) + ;; Since mozjs depends on Rust, which is currently x86_64-only, use + ;; polkit-duktape on other systems. + (if (string-prefix? "x86_64-" (or target system)) + polkit-mozjs + polkit-duktape))) + (define %polkit-accounts (list (user-group (name "polkitd") (system? #t)) (user-account diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm index 64d0e85301..c2ee3a3d80 100644 --- a/gnu/services/desktop.scm +++ b/gnu/services/desktop.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <[email protected]> +;;; Copyright © 2014-2021 Ludovic Courtès <[email protected]> ;;; Copyright © 2015 Andy Wingo <[email protected]> ;;; Copyright © 2015 Mark H Weaver <[email protected]> ;;; Copyright © 2016 Sou Bunnbu <[email protected]> @@ -40,6 +40,7 @@ #:use-module (gnu services sound) #:use-module ((gnu system file-systems) #:select (%elogind-file-systems file-system)) + #:autoload (gnu services sddm) (sddm-service-type) #:use-module (gnu system) #:use-module (gnu system setuid) #:use-module (gnu system shadow) @@ -867,22 +868,34 @@ rules.") gnome-desktop-configuration? (gnome gnome-package (default gnome))) -(define (gnome-polkit-settings config) - "Return the list of GNOME dependencies that provide polkit actions and -rules." +(define (gnome-packages config packages) + "Return the list of GNOME dependencies from CONFIG which names are part of +the given PACKAGES list." (let ((gnome (gnome-package config))) (map (lambda (name) ((package-direct-input-selector name) gnome)) - '("gnome-settings-daemon" - "gnome-control-center" - "gnome-system-monitor" - "gvfs")))) + packages))) + +(define (gnome-udev-rules config) + "Return the list of GNOME dependencies that provide udev rules." + (gnome-packages config '("gnome-settings-daemon"))) + +(define (gnome-polkit-settings config) + "Return the list of GNOME dependencies that provide polkit actions and +rules." + (gnome-packages config + '("gnome-settings-daemon" + "gnome-control-center" + "gnome-system-monitor" + "gvfs"))) (define gnome-desktop-service-type (service-type (name 'gnome-desktop) (extensions - (list (service-extension polkit-service-type + (list (service-extension udev-service-type + gnome-udev-rules) + (service-extension polkit-service-type gnome-polkit-settings) (service-extension profile-service-type (compose list @@ -1021,7 +1034,7 @@ rules." (use-modules (guix build utils)) (let ((directory "/tmp/.X11-unix")) (mkdir-p directory) - (chmod directory #o777)))))) + (chmod directory #o1777)))))) ;;; ;;; Enlightenment desktop service. @@ -1187,9 +1200,17 @@ or setting its password with passwd."))) ;;; The default set of desktop services. ;;; -(define %desktop-services +(define* (desktop-services-for-system #:optional + (system (or (%current-target-system) + (%current-system)))) ;; List of services typically useful for a "desktop" use case. - (cons* (service gdm-service-type) + + ;; Since GDM depends on Rust (gdm -> gnome-shell -> gjs -> mozjs -> rust) + ;; and Rust is currently unavailable on non-x86_64 platforms, default to + ;; SDDM there (FIXME). + (cons* (if (string-prefix? "x86_64" system) + (service gdm-service-type) + (service sddm-service-type)) ;; Screen lockers are a pretty useful thing and these are small. (screen-locker-service slock) @@ -1248,4 +1269,7 @@ or setting its password with passwd."))) %base-services)) +(define-syntax %desktop-services + (identifier-syntax (desktop-services-for-system))) + ;;; desktop.scm ends here diff --git a/gnu/services/dns.scm b/gnu/services/dns.scm index aeb2bfdc86..9b8603cc95 100644 --- a/gnu/services/dns.scm +++ b/gnu/services/dns.scm @@ -185,8 +185,6 @@ (default '())) (semantic-checks? knot-zone-configuration-semantic-checks? (default #f)) - (disable-any? knot-zone-configuration-disable-any? - (default #f)) (zonefile-sync knot-zone-configuration-zonefile-sync (default 0)) (zonefile-load knot-zone-configuration-zonefile-load @@ -310,8 +308,8 @@ (error-out "remote id must be a non empty string.")))) (define (verify-knot-configuration config) - (unless (package? (knot-configuration-knot config)) - (error-out "knot configuration field must be a package.")) + (unless (file-like? (knot-configuration-knot config)) + (error-out "knot configuration field must be a file-like object.")) (unless (string? (knot-configuration-run-directory config)) (error-out "run-directory must be a string.")) (unless (list? (knot-configuration-includes config)) @@ -509,7 +507,6 @@ (notify (list #$@(knot-zone-configuration-notify zone))) (acl (list #$@(knot-zone-configuration-acl zone))) (semantic-checks? #$(knot-zone-configuration-semantic-checks? zone)) - (disable-any? #$(knot-zone-configuration-disable-any? zone)) (zonefile-sync #$(knot-zone-configuration-zonefile-sync zone)) (zonefile-load '#$(knot-zone-configuration-zonefile-load zone)) (journal-content #$(knot-zone-configuration-journal-content zone)) @@ -541,7 +538,6 @@ #$(format-string-list (knot-zone-configuration-acl zone)))) (format #t " semantic-checks: ~a\n" (if semantic-checks? "on" "off")) - (format #t " disable-any: ~a\n" (if disable-any? "on" "off")) (if zonefile-sync (format #t " zonefile-sync: ~a\n" zonefile-sync)) (if zonefile-load @@ -736,7 +732,7 @@ cache.size = 100 * MB dnsmasq-configuration make-dnsmasq-configuration dnsmasq-configuration? (package dnsmasq-configuration-package - (default dnsmasq)) ;package + (default dnsmasq)) ;file-like (no-hosts? dnsmasq-configuration-no-hosts? (default #f)) ;boolean (port dnsmasq-configuration-port @@ -909,7 +905,7 @@ cache.size = 100 * MB (define-configuration ddclient-configuration (ddclient - (package ddclient) + (file-like ddclient) "The ddclient package.") (daemon (integer 300) diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm index ef551480aa..846ebe8334 100644 --- a/gnu/services/docker.scm +++ b/gnu/services/docker.scm @@ -41,16 +41,16 @@ (define-configuration docker-configuration (docker - (package docker) + (file-like docker) "Docker daemon package.") (docker-cli - (package docker-cli) + (file-like docker-cli) "Docker client package.") (containerd - (package containerd) + (file-like containerd) "containerd package.") (proxy - (package docker-libnetwork-cmd-proxy) + (file-like docker-libnetwork-cmd-proxy) "The proxy package to support inter-container and outside-container loop-back communications.") (enable-proxy? @@ -62,6 +62,9 @@ loop-back communications.") (enable-iptables? (boolean #t) "Enable addition of iptables rules (enabled by default).") + (environment-variables + (list '()) + "Environment variables to set for dockerd") (no-serialization)) (define %docker-accounts @@ -102,6 +105,7 @@ loop-back communications.") (let* ((docker (docker-configuration-docker config)) (enable-proxy? (docker-configuration-enable-proxy? config)) (enable-iptables? (docker-configuration-enable-iptables? config)) + (environment-variables (docker-configuration-environment-variables config)) (proxy (docker-configuration-proxy config)) (debug? (docker-configuration-debug? config))) (shepherd-service @@ -132,6 +136,8 @@ loop-back communications.") (if #$enable-iptables? "--iptables" "--iptables=false")) + #:environment-variables + (list #$@environment-variables) #:pid-file "/var/run/docker.pid" #:log-file "/var/log/docker.log")) (stop #~(make-kill-destructor))))) diff --git a/gnu/services/file-sharing.scm b/gnu/services/file-sharing.scm index 72cd6478d6..e3d681b08f 100644 --- a/gnu/services/file-sharing.scm +++ b/gnu/services/file-sharing.scm @@ -259,7 +259,7 @@ type generated and used by Transmission clients, suitable for passing to the (define-configuration transmission-daemon-configuration ;; Settings internal to this service definition. (transmission - (package transmission) + (file-like transmission) "The Transmission package to use.") (stop-wait-period (non-negative-integer 10) diff --git a/gnu/services/ganeti.scm b/gnu/services/ganeti.scm index 0a34ea6a5e..85adbd7362 100644 --- a/gnu/services/ganeti.scm +++ b/gnu/services/ganeti.scm @@ -190,7 +190,7 @@ (define-record-type* <ganeti-noded-configuration> ganeti-noded-configuration make-ganeti-noded-configuration ganeti-noded-configuration? - (ganeti ganeti-noded-configuration-ganeti ;<package> + (ganeti ganeti-noded-configuration-ganeti ;file-like (default ganeti)) (port ganeti-noded-configuration-port ;integer (default 1811)) @@ -256,7 +256,7 @@ for the node functions in the Ganeti system."))) (define-record-type* <ganeti-confd-configuration> ganeti-confd-configuration make-ganeti-confd-configuration ganeti-confd-configuration? - (ganeti ganeti-confd-configuration-ganeti ;<package> + (ganeti ganeti-confd-configuration-ganeti ;file-like (default ganeti)) (port ganeti-confd-configuration-port ;integer (default 1814)) @@ -298,7 +298,7 @@ related to the configuration of a Ganeti cluster."))) (define-record-type* <ganeti-wconfd-configuration> ganeti-wconfd-configuration make-ganeti-wconfd-configuration ganeti-wconfd-configuration? - (ganeti ganeti-wconfd-configuration-ganeti ;<package> + (ganeti ganeti-wconfd-configuration-ganeti ;file-like (default ganeti)) (no-voting? ganeti-wconfd-configuration-no-voting? ;Boolean (default #f)) @@ -389,7 +389,7 @@ appropriate requests to this daemon."))) (define-record-type* <ganeti-luxid-configuration> ganeti-luxid-configuration make-ganeti-luxid-configuration ganeti-luxid-configuration? - (ganeti ganeti-luxid-configuration-ganeti ;<package> + (ganeti ganeti-luxid-configuration-ganeti ;file-like (default ganeti)) (no-voting? ganeti-luxid-configuration-no-voting? ;Boolean (default #f)) @@ -436,7 +436,7 @@ be submitted via this daemon and it schedules and starts them."))) (define-record-type* <ganeti-rapi-configuration> ganeti-rapi-configuration make-ganeti-rapi-configuration ganeti-rapi-configuration? - (ganeti ganeti-rapi-configuration-ganeti ;<package> + (ganeti ganeti-rapi-configuration-ganeti ;file-like (default ganeti)) (require-authentication? ganeti-rapi-configuration-require-authentication? ;Boolean @@ -509,7 +509,7 @@ for Ganeti clusters."))) (define-record-type* <ganeti-kvmd-configuration> ganeti-kvmd-configuration make-ganeti-kvmd-configuration ganeti-kvmd-configuration? - (ganeti ganeti-kvmd-configuration-ganeti ;<package> + (ganeti ganeti-kvmd-configuration-ganeti ;file-like (default ganeti)) (debug? ganeti-kvmd-configuration-debug? ;Boolean (default #f))) @@ -555,7 +555,7 @@ communicated to Ganeti via a special file in the file system."))) (define-record-type* <ganeti-mond-configuration> ganeti-mond-configuration make-ganeti-mond-configuration ganeti-mond-configuration? - (ganeti ganeti-mond-configuration-ganeti ;<package> + (ganeti ganeti-mond-configuration-ganeti ;file-like (default ganeti)) (port ganeti-mond-configuration-port ;integer (default 1815)) @@ -596,7 +596,7 @@ provide the collected information through a HTTP interface."))) (define-record-type* <ganeti-metad-configuration> ganeti-metad-configuration make-ganeti-metad-configuration ganeti-metad-configuration? - (ganeti ganeti-metad-configuration-ganeti ;<package> + (ganeti ganeti-metad-configuration-ganeti ;file-like (default ganeti)) (port ganeti-metad-configuration-port ;integer (default 80)) @@ -612,7 +612,11 @@ provide the collected information through a HTTP interface."))) (documentation "Run the Ganeti metadata daemon.") (provision '(ganeti-metad)) (requirement '(user-processes networking)) + + ;; This service is started on demand. + (auto-start? #f) (respawn? #f) + (start #~(make-forkexec-constructor (list #$(file-append ganeti "/sbin/ganeti-metad") #$(string-append "--port=" (number->string port)) @@ -638,7 +642,7 @@ information to OS install scripts or instances."))) (define-record-type* <ganeti-watcher-configuration> ganeti-watcher-configuration make-ganeti-watcher-configuration ganeti-watcher-configuration? - (ganeti ganeti-watcher-configuration-ganeti ;<package> + (ganeti ganeti-watcher-configuration-ganeti ;file-like (default ganeti)) (schedule ganeti-watcher-configuration-schedule ;list | string (default '(next-second-from @@ -701,7 +705,7 @@ is declared offline by known master candidates."))) (define-record-type* <ganeti-cleaner-configuration> ganeti-cleaner-configuration make-ganeti-cleaner-configuration ganeti-cleaner-configuration? - (ganeti ganeti-cleaner-configuration-ganeti ;<package> + (ganeti ganeti-cleaner-configuration-ganeti ;file-like (default ganeti)) (master-schedule ganeti-cleaner-configuration-master-schedule ;list | string ;; Run the master cleaner at 01:45 every day. diff --git a/gnu/services/getmail.scm b/gnu/services/getmail.scm index 933d820bc5..ce124f6b11 100644 --- a/gnu/services/getmail.scm +++ b/gnu/services/getmail.scm @@ -246,7 +246,7 @@ lines.") (symbol "unset") "A symbol to identify the getmail service.") (package - (package getmail) + (file-like getmail) "The getmail package to use.") (user (string "getmail") diff --git a/gnu/services/guix.scm b/gnu/services/guix.scm index a5ed28647f..df5fa13bea 100644 --- a/gnu/services/guix.scm +++ b/gnu/services/guix.scm @@ -146,7 +146,7 @@ make-guix-build-coordinator-agent-configuration guix-build-coordinator-agent-configuration? (package guix-build-coordinator-agent-configuration-package - (default guix-build-coordinator)) + (default guix-build-coordinator/agent-only)) (user guix-build-coordinator-agent-configuration-user (default "guix-build-coordinator-agent")) (coordinator guix-build-coordinator-agent-configuration-coordinator diff --git a/gnu/services/hurd.scm b/gnu/services/hurd.scm index 61d92b4bda..5cf37adeaf 100644 --- a/gnu/services/hurd.scm +++ b/gnu/services/hurd.scm @@ -42,7 +42,7 @@ (define-record-type* <hurd-console-configuration> hurd-console-configuration make-hurd-console-configuration hurd-console-configuration? - (hurd hurd-console-configuration-hurd ;package + (hurd hurd-console-configuration-hurd ;file-like (default hurd))) (define (hurd-console-shepherd-service config) @@ -80,7 +80,7 @@ (define-record-type* <hurd-getty-configuration> hurd-getty-configuration make-hurd-getty-configuration hurd-getty-configuration? - (hurd hurd-getty-configuration-hurd ;<package> + (hurd hurd-getty-configuration-hurd ;file-like (default hurd)) (tty hurd-getty-configuration-tty) ;string (baud-rate hurd-getty-configuration-baud-rate diff --git a/gnu/services/lirc.scm b/gnu/services/lirc.scm index e95f54280d..1f5adcdd5f 100644 --- a/gnu/services/lirc.scm +++ b/gnu/services/lirc.scm @@ -38,7 +38,7 @@ (define-record-type* <lirc-configuration> lirc-configuration make-lirc-configuration lirc-configuation? - (lirc lirc-configuration-lirc ;<package> + (lirc lirc-configuration-lirc ;file-like (default lirc)) (device lirc-configuration-device) ;string (driver lirc-configuration-driver) ;string diff --git a/gnu/services/mail.scm b/gnu/services/mail.scm index 72dc123f41..4ad6ddb534 100644 --- a/gnu/services/mail.scm +++ b/gnu/services/mail.scm @@ -498,7 +498,7 @@ as @code{#t}.)") (define-configuration dovecot-configuration (dovecot - (package dovecot) + (file-like dovecot) "The dovecot package.") (listen @@ -1472,7 +1472,7 @@ greyed out, instead of only later giving \"not selectable\" popup error. (define-configuration opaque-dovecot-configuration (dovecot - (package dovecot) + (file-like dovecot) "The dovecot package.") (string @@ -1764,7 +1764,7 @@ match from local for any action outbound (define-record-type* <exim-configuration> exim-configuration make-exim-configuration exim-configuration? - (package exim-configuration-package ;<package> + (package exim-configuration-package ;file-like (default exim)) (config-file exim-configuration-config-file ;file-like (default #f))) diff --git a/gnu/services/mcron.scm b/gnu/services/mcron.scm index 0e675607f3..23760ebda4 100644 --- a/gnu/services/mcron.scm +++ b/gnu/services/mcron.scm @@ -51,7 +51,7 @@ (define-record-type* <mcron-configuration> mcron-configuration make-mcron-configuration mcron-configuration? - (mcron mcron-configuration-mcron ;package + (mcron mcron-configuration-mcron ;file-like (default mcron)) (jobs mcron-configuration-jobs ;list of <mcron-job> (default '()))) diff --git a/gnu/services/messaging.scm b/gnu/services/messaging.scm index 0fcb7faf89..6ed55453db 100644 --- a/gnu/services/messaging.scm +++ b/gnu/services/messaging.scm @@ -333,7 +333,7 @@ can create such a file with: (define-all-configurations prosody-configuration (prosody - (package prosody) + (file-like prosody) "The Prosody package." global) @@ -623,7 +623,7 @@ See also @url{https://prosody.im/doc/modules/mod_muc}." (define-configuration opaque-prosody-configuration (prosody - (package prosody) + (file-like prosody) "The prosody package.") (prosody.cfg.lua diff --git a/gnu/services/monitoring.scm b/gnu/services/monitoring.scm index 5123a8c441..f15450eed5 100644 --- a/gnu/services/monitoring.scm +++ b/gnu/services/monitoring.scm @@ -247,7 +247,7 @@ Prometheus.") (define-configuration zabbix-server-configuration (zabbix-server - (package zabbix-server) + (file-like zabbix-server) "The zabbix-server package.") (user (string "zabbix") @@ -385,7 +385,7 @@ configuration file.")) (define-configuration zabbix-agent-configuration (zabbix-agent - (package zabbix-agentd) + (file-like zabbix-agentd) "The zabbix-agent package.") (user (string "zabbix") @@ -529,7 +529,7 @@ fastcgi_param PHP_VALUE \"post_max_size = 16M (define-configuration zabbix-front-end-configuration ;; TODO: Specify zabbix front-end package. ;; (zabbix- - ;; (package zabbix-front-end) + ;; (file-like zabbix-front-end) ;; "The zabbix-front-end package.") (nginx (nginx-server-configuration-list diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm index 7e310b70ec..5bb8638930 100644 --- a/gnu/services/networking.scm +++ b/gnu/services/networking.scm @@ -311,7 +311,7 @@ Protocol (DHCP) client, on all the non-loopback network interfaces."))) (define-record-type* <dhcpd-configuration> dhcpd-configuration make-dhcpd-configuration dhcpd-configuration? - (package dhcpd-configuration-package ;<package> + (package dhcpd-configuration-package ;file-like (default isc-dhcp)) (config-file dhcpd-configuration-config-file ;file-like (default #f)) @@ -427,6 +427,8 @@ daemon is responsible for allocating IP addresses to its client."))) ;; Default set of NTP servers. These URLs are managed by the NTP Pool project. ;; Within Guix, Leo Famulari <[email protected]> is the administrative contact ;; for this NTP pool "zone". + ;; The full list of available URLs are 0.guix.pool.ntp.org, + ;; 1.guix.pool.ntp.org, 2.guix.pool.ntp.org, and 3.guix.pool.ntp.org. (list (ntp-server (type 'pool) @@ -743,7 +745,7 @@ demand."))) ;;; can evaluate: (configuration->documentation 'opendht-configuration) (define-configuration/no-serialization opendht-configuration (opendht - (package opendht) + (file-like opendht) "The @code{opendht} package to use.") (peer-discovery? (boolean #false) @@ -1149,7 +1151,7 @@ and @command{wicd-curses} user interfaces." (default network-manager)) (dns network-manager-configuration-dns (default "default")) - (vpn-plugins network-manager-configuration-vpn-plugins ;list of <package> + (vpn-plugins network-manager-configuration-vpn-plugins ;list of file-like (default '()))) (define network-manager-activation @@ -1452,7 +1454,7 @@ whatever the thing is supposed to do)."))) (define-record-type* <wpa-supplicant-configuration> wpa-supplicant-configuration make-wpa-supplicant-configuration wpa-supplicant-configuration? - (wpa-supplicant wpa-supplicant-configuration-wpa-supplicant ;<package> + (wpa-supplicant wpa-supplicant-configuration-wpa-supplicant ;file-like (default wpa-supplicant)) (requirement wpa-supplicant-configuration-requirement ;list of symbols (default '(user-processes loopback syslogd))) @@ -2124,7 +2126,7 @@ of the IPFS peer-to-peer storage network."))) (define-record-type* <keepalived-configuration> keepalived-configuration make-keepalived-configuration keepalived-configuration? - (keepalived keepalived-configuration-keepalived ;<package> + (keepalived keepalived-configuration-keepalived ;file-like (default keepalived)) (config-file keepalived-configuration-config-file ;file-like (default #f))) diff --git a/gnu/services/nfs.scm b/gnu/services/nfs.scm index 277178c058..0d1617354e 100644 --- a/gnu/services/nfs.scm +++ b/gnu/services/nfs.scm @@ -304,7 +304,7 @@ '()) "--foreground" #$@(if rpcstatd-port - '("--port" (number->string rpcstatd-port)) + #~("--port" #$(number->string rpcstatd-port)) '())) #:pid-file "/var/run/rpc.statd.pid")) (stop #~(make-kill-destructor))) @@ -320,7 +320,7 @@ '("--debug" "all") '()) #$@(if rpcmountd-port - '("--port" (number->string rpcmountd-port)) + #~("--port" #$(number->string rpcmountd-port)) '())))) (stop #~(make-kill-destructor))) (shepherd-service diff --git a/gnu/services/nix.scm b/gnu/services/nix.scm index 619e3cae54..df04a85c22 100644 --- a/gnu/services/nix.scm +++ b/gnu/services/nix.scm @@ -50,7 +50,7 @@ (define-record-type* <nix-configuration> nix-configuration make-nix-configuration nix-configuration? - (package nix-configuration-package ;package + (package nix-configuration-package ;file-like (default nix)) (sandbox nix-configuration-sandbox ;boolean (default #t)) diff --git a/gnu/services/pam-mount.scm b/gnu/services/pam-mount.scm index 98611462c2..33649b0f7c 100644 --- a/gnu/services/pam-mount.scm +++ b/gnu/services/pam-mount.scm @@ -90,7 +90,7 @@ (module #~(string-append #$pam-mount "/lib/security/pam_mount.so")))) (list (lambda (pam) (if (member (pam-service-name pam) - '("login" "su" "slim" "gdm-password")) + '("login" "su" "slim" "gdm-password" "sddm")) (pam-service (inherit pam) (auth (append (pam-service-auth pam) diff --git a/gnu/services/pm.scm b/gnu/services/pm.scm index 256c6a7fa7..d91f2b69ce 100644 --- a/gnu/services/pm.scm +++ b/gnu/services/pm.scm @@ -84,7 +84,7 @@ (define-configuration tlp-configuration (tlp - (package tlp) + (file-like tlp) "The TLP package.") (tlp-enable? @@ -421,7 +421,7 @@ shutdown on system startup.")) thermald-configuration? (ignore-cpuid-check? thermald-ignore-cpuid-check? ;boolean (default #f)) - (thermald thermald-thermald ;package + (thermald thermald-thermald ;file-like (default thermald))) (define (thermald-shepherd-service config) diff --git a/gnu/services/rsync.scm b/gnu/services/rsync.scm index 6c117bbda4..d456911563 100644 --- a/gnu/services/rsync.scm +++ b/gnu/services/rsync.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Oleg Pykhalov <[email protected]> +;;; Copyright © 2021 Ludovic Courtès <[email protected]> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,11 +26,23 @@ #:use-module (gnu packages admin) #:use-module (guix records) #:use-module (guix gexp) + #:use-module (guix diagnostics) + #:use-module (guix i18n) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:export (rsync-configuration rsync-configuration? + rsync-configuration-modules + + rsync-module + rsync-module? + rsync-module-name + rsync-module-file-name + rsync-module-comment + rsync-module-read-only + rsync-module-timeout + rsync-service-type)) ;;;; Commentary: @@ -39,12 +52,21 @@ ;;; ;;;; Code: +(define-with-syntax-properties (warn-share-field-deprecation (value properties)) + (unless (unspecified? value) + (warning (source-properties->location properties) + (G_ "the 'share-path' and 'share-comment' fields is deprecated, \ +please use 'modules' instead~%"))) + value) + (define-record-type* <rsync-configuration> rsync-configuration make-rsync-configuration rsync-configuration? - (package rsync-configuration-package ; package + (package rsync-configuration-package ; file-like (default rsync)) + (address rsync-configuration-address ; string | #f + (default #f)) (port-number rsync-configuration-port-number ; integer (default 873)) (pid-file rsync-configuration-pid-file ; string @@ -54,15 +76,22 @@ (log-file rsync-configuration-log-file ; string (default "/var/log/rsyncd.log")) (use-chroot? rsync-configuration-use-chroot? ; boolean - (default #t)) + (sanitize warn-share-field-deprecation) + (default *unspecified*)) + (modules rsync-configuration-actual-modules ;list of <rsync-module> + (default %default-modules)) ;TODO: eventually remove default (share-path rsync-configuration-share-path ; string - (default "/srv/rsyncd")) + (sanitize warn-share-field-deprecation) + (default *unspecified*)) (share-comment rsync-configuration-share-comment ; string - (default "Rsync share")) + (sanitize warn-share-field-deprecation) + (default *unspecified*)) (read-only? rsync-configuration-read-only? ; boolean - (default #f)) + (sanitize warn-share-field-deprecation) + (default *unspecified*)) (timeout rsync-configuration-timeout ; integer - (default 300)) + (sanitize warn-share-field-deprecation) + (default *unspecified*)) (user rsync-configuration-user ; string (default "root")) (group rsync-configuration-group ; string @@ -72,6 +101,45 @@ (gid rsync-configuration-gid ; string (default "rsyncd"))) +;; Rsync "module": a directory exported the rsync protocol. +(define-record-type* <rsync-module> + rsync-module make-rsync-module + rsync-module? + (name rsync-module-name) ;string + (file-name rsync-module-file-name) ;string + (comment rsync-module-comment ;string + (default "")) + (read-only? rsync-module-read-only? ;boolean + (default #t)) + (chroot? rsync-module-chroot? ;boolean + (default #t)) + (timeout rsync-module-timeout ;integer + (default 300))) + +(define %default-modules + ;; Default modules, provided for backward compatibility. + (list (rsync-module (name "files") + (file-name "/srv/rsyncd") + (comment "Rsync share") + (read-only? #f)))) ;yes, that was the default + +(define (rsync-configuration-modules config) + (match-record config <rsync-configuration> + (modules + share-path share-comment use-chroot? read-only? timeout) ;deprecated + (if (unspecified? share-path) + (rsync-configuration-actual-modules config) + (list (rsync-module ;backward compatibility + (name "files") + (file-name share-path) + (comment "Rsync share") + (chroot? + (if (unspecified? use-chroot?) #t use-chroot?)) + (read-only? + (if (unspecified? read-only?) #f read-only?)) + (timeout + (if (unspecified? timeout) 300 timeout))))))) + (define (rsync-account config) "Return the user accounts and user groups for CONFIG." (let ((rsync-user (if (rsync-configuration-uid config) @@ -94,54 +162,62 @@ "Return the activation GEXP for CONFIG." (with-imported-modules '((guix build utils)) #~(begin - (let ((share-directory #$(rsync-configuration-share-path config)) - (user (getpw (if #$(rsync-configuration-uid config) + (let ((user (getpw (if #$(rsync-configuration-uid config) #$(rsync-configuration-uid config) #$(rsync-configuration-user config)))) (group (getpw (if #$(rsync-configuration-gid config) #$(rsync-configuration-gid config) #$(rsync-configuration-group config))))) (mkdir-p (dirname #$(rsync-configuration-pid-file config))) - (and=> share-directory mkdir-p) - (chown share-directory - (passwd:uid user) - (group:gid group)))))) + (for-each (lambda (directory) + (mkdir-p directory) + (chown directory (passwd:uid user) (group:gid group))) + '#$(map rsync-module-file-name + (rsync-configuration-modules config))))))) -(define rsync-config-file +(define (rsync-config-file config) ;; Return the rsync configuration file corresponding to CONFIG. - (match-lambda - (($ <rsync-configuration> package port-number pid-file lock-file log-file - use-chroot? share-path share-comment read-only? - timeout user group uid gid) - (if (not (string=? user "root")) - (cond - ((<= port-number 1024) - (error (string-append "rsync-service: to run on port " - (number->string port-number) - ", user must be root."))) - (use-chroot? - (error (string-append "rsync-service: to run in a chroot" - ", user must be root."))) - (uid - (error "rsync-service: to use uid, user must be root.")) - (gid - (error "rsync-service: to use gid, user must be root.")))) - (mixed-text-file - "rsync.conf" - "# Generated by 'rsync-service'.\n\n" - "pid file = " pid-file "\n" - "lock file = " lock-file "\n" - "log file = " log-file "\n" - "port = " (number->string port-number) "\n" - "use chroot = " (if use-chroot? "true" "false") "\n" - (if uid (string-append "uid = " uid "\n") "") - "gid = " (if gid gid "nogroup") "\n" ; no group nobody - "\n" - "[files]\n" - "path = " share-path "\n" - "comment = " share-comment "\n" - "read only = " (if read-only? "true" "false") "\n" - "timeout = " (number->string timeout) "\n")))) + (define (module-config module) + (match-record module <rsync-module> + (name file-name comment chroot? read-only? timeout) + (list "[" name "]\n" + " path = " file-name "\n" + " use chroot = " (if chroot? "true" "false") "\n" + " comment = " comment "\n" + " read only = " (if read-only? "true" "false") "\n" + " timeout = " (number->string timeout) "\n"))) + + (define modules + (rsync-configuration-modules config)) + + (match-record config <rsync-configuration> + (package address port-number pid-file lock-file log-file + user group uid gid) + (unless (string=? user "root") + (cond + ((<= port-number 1024) + (error (string-append "rsync-service: to run on port " + (number->string port-number) + ", user must be root."))) + ((find rsync-module-chroot? modules) + (error (string-append "rsync-service: to run in a chroot" + ", user must be root."))) + (uid + (error "rsync-service: to use uid, user must be root.")) + (gid + (error "rsync-service: to use gid, user must be root.")))) + + (apply mixed-text-file "rsync.conf" + "# Generated by 'rsync-service'.\n\n" + "pid file = " pid-file "\n" + "lock file = " lock-file "\n" + "log file = " log-file "\n" + (if address (string-append "address = " address "\n") "") + "port = " (number->string port-number) "\n" + (if uid (string-append "uid = " uid "\n") "") + "gid = " (if gid gid "nogroup") "\n" ; no group nobody + "\n\n" + (append-map module-config modules)))) (define (rsync-shepherd-service config) "Return a <shepherd-service> for rsync with CONFIG." @@ -169,4 +245,7 @@ (list (service-extension shepherd-root-service-type rsync-shepherd-service) (service-extension account-service-type rsync-account) (service-extension activation-service-type rsync-activation))) - (default-value (rsync-configuration)))) + (default-value (rsync-configuration)) + (description + "Run the rsync file copying tool in daemon mode. This allows remote hosts +to keep synchronized copies of the files exported by rsync."))) diff --git a/gnu/services/science.scm b/gnu/services/science.scm index 6f7ac91154..1414789de9 100644 --- a/gnu/services/science.scm +++ b/gnu/services/science.scm @@ -35,7 +35,7 @@ rshiny-configuration make-rshiny-configuration rshiny-configuration? - (package rshiny-configuration-package ; package + (package rshiny-configuration-package ; file-like (default r-shiny)) (binary rshiny-configuration-binary ; string (default "rshiny"))) diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm index 7277273686..b44dbf9d9f 100644 --- a/gnu/services/shepherd.scm +++ b/gnu/services/shepherd.scm @@ -88,7 +88,7 @@ shepherd-configuration make-shepherd-configuration shepherd-configuration? (shepherd shepherd-configuration-shepherd - (default shepherd)) ; package + (default shepherd)) ; file-like (services shepherd-configuration-services (default '()))) ; list of <shepherd-service> diff --git a/gnu/services/sound.scm b/gnu/services/sound.scm index 55610f27e0..1217223a0c 100644 --- a/gnu/services/sound.scm +++ b/gnu/services/sound.scm @@ -55,7 +55,7 @@ (define-record-type* <alsa-configuration> alsa-configuration make-alsa-configuration alsa-configuration? - (alsa-plugins alsa-configuration-alsa-plugins ;<package> + (alsa-plugins alsa-configuration-alsa-plugins ;file-like (default alsa-plugins)) (pulseaudio? alsa-configuration-pulseaudio? ;boolean (default #t)) diff --git a/gnu/services/ssh.scm b/gnu/services/ssh.scm index a018052eeb..97f74a00f7 100644 --- a/gnu/services/ssh.scm +++ b/gnu/services/ssh.scm @@ -39,6 +39,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (ice-9 match) + #:use-module (ice-9 vlist) #:export (lsh-configuration lsh-configuration? lsh-service @@ -282,7 +283,7 @@ The other options should be self-descriptive." (define-record-type* <openssh-configuration> openssh-configuration make-openssh-configuration openssh-configuration? - ;; <package> + ;; file-like object (openssh openssh-configuration-openssh (default openssh)) ;; string @@ -535,7 +536,15 @@ of user-name/file-like tuples." (openssh-configuration (inherit config) (authorized-keys - (append (openssh-authorized-keys config) keys)))) + (match (openssh-authorized-keys config) + (((users _ ...) ...) + ;; Build a user/key-list mapping. + (let ((user-keys (alist->vhash (openssh-authorized-keys config)))) + ;; Coalesce the key lists associated with each user. + (map (lambda (user) + `(,user + ,@(concatenate (vhash-fold* cons '() user user-keys)))) + users))))))) (define openssh-service-type (service-type (name 'openssh) @@ -754,7 +763,7 @@ object." (define-record-type* <webssh-configuration> webssh-configuration make-webssh-configuration webssh-configuration? - (package webssh-configuration-package ;package + (package webssh-configuration-package ;file-like (default webssh)) (user-name webssh-configuration-user-name ;string (default "webssh")) diff --git a/gnu/services/syncthing.scm b/gnu/services/syncthing.scm index 12ebe7c107..7c3d5b027d 100644 --- a/gnu/services/syncthing.scm +++ b/gnu/services/syncthing.scm @@ -37,7 +37,7 @@ (define-record-type* <syncthing-configuration> syncthing-configuration make-syncthing-configuration syncthing-configuration? - (syncthing syncthing-configuration-syncthing ;<package> + (syncthing syncthing-configuration-syncthing ;file-like (default syncthing)) (arguments syncthing-configuration-arguments ;list of strings (default '())) diff --git a/gnu/services/telephony.scm b/gnu/services/telephony.scm index fd90840324..e678bae87c 100644 --- a/gnu/services/telephony.scm +++ b/gnu/services/telephony.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 nee <[email protected]> -;;; Copyright © 2021 Maxim Cournoyer <[email protected]> +;;; Copyright © 2021, 2022 Maxim Cournoyer <[email protected]> ;;; ;;; This file is part of GNU Guix. ;;; @@ -227,13 +227,13 @@ SET-ACCOUNT-DETAILS." (define-configuration/no-serialization jami-configuration (jamid - (package libring) + (file-like libjami) "The Jami daemon package to use.") (dbus - (package dbus) + (file-like dbus) "The D-Bus package to use to start the required D-Bus session.") (nss-certs - (package nss-certs) + (file-like nss-certs) "The nss-certs package to use to provide TLS certificates.") (enable-logging? (boolean #t) @@ -265,7 +265,7 @@ consistent state.")) CONFIG, a <jami-configuration> object." (match-record config <jami-configuration> (jamid dbus enable-logging? debug? auto-answer?) - `(,(file-append jamid "/lib/ring/dring") + `(,(file-append jamid "/libexec/jamid") "--persistent" ;stay alive after client quits ,@(if enable-logging? '() ;logs go to syslog by default @@ -739,7 +739,7 @@ argument, either a registered username or the fingerprint of the account.") (const %jami-accounts)) (service-extension activation-service-type jami-dbus-session-activation))) - (description "Run the Jami daemon (@command{dring}). This service is + (description "Run the Jami daemon (@command{jamid}). 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 @@ -755,7 +755,7 @@ normal user D-Bus session bus."))) (define-record-type* <murmur-configuration> murmur-configuration make-murmur-configuration murmur-configuration? - (package murmur-configuration-package ;<package> + (package murmur-configuration-package ;file-like (default mumble)) (user murmur-configuration-user (default "murmur")) diff --git a/gnu/services/version-control.scm b/gnu/services/version-control.scm index 3315e80c6f..defbd65c36 100644 --- a/gnu/services/version-control.scm +++ b/gnu/services/version-control.scm @@ -91,7 +91,7 @@ git-daemon-configuration make-git-daemon-configuration git-daemon-configuration? - (package git-daemon-configuration-package ;package + (package git-daemon-configuration-package ;file-like (default git)) (export-all? git-daemon-configuration-export-all ;boolean (default #f)) @@ -197,7 +197,7 @@ access to exported repositories under @file{/srv/git}." git-http-configuration make-git-http-configuration git-http-configuration? - (package git-http-configuration-package ;package + (package git-http-configuration-package ;file-like (default git)) (git-root git-http-configuration-git-root ;string (default "/srv/git")) diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm index bca5f56b87..66ae1a1565 100644 --- a/gnu/services/virtualization.scm +++ b/gnu/services/virtualization.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2017 Ryan Moe <[email protected]> ;;; Copyright © 2018, 2020, 2021 Ludovic Courtès <[email protected]> ;;; Copyright © 2020,2021 Jan (janneke) Nieuwenhuizen <[email protected]> +;;; Copyright © 2021 Timotej Lazar <[email protected]> ;;; ;;; This file is part of GNU Guix. ;;; @@ -82,7 +83,11 @@ qemu-binfmt-configuration qemu-binfmt-configuration? - qemu-binfmt-service-type)) + qemu-binfmt-service-type + + qemu-guest-agent-configuration + qemu-guest-agent-configuration? + qemu-guest-agent-service-type)) (define (uglify-field-name field-name) (let ((str (symbol->string field-name))) @@ -129,10 +134,10 @@ (define-configuration libvirt-configuration (libvirt - (package libvirt) + (file-like libvirt) "Libvirt package.") (qemu - (package qemu) + (file-like qemu) "Qemu package.") (listen-tls? @@ -849,26 +854,88 @@ functionality of the kernel Linux."))) ;;; +;;; QEMU guest agent service. +;;; + +(define-configuration qemu-guest-agent-configuration + (qemu + (file-like qemu-minimal) + "QEMU package.") + (device + (string "") + "Path to device or socket used to communicate with the host. If not +specified, the QEMU default path is used.")) + +(define qemu-guest-agent-shepherd-service + (match-lambda + (($ <qemu-guest-agent-configuration> qemu device) + (list + (shepherd-service + (provision '(qemu-guest-agent)) + (documentation "Run the QEMU guest agent.") + (start #~(make-forkexec-constructor + `(,(string-append #$qemu "/bin/qemu-ga") "--daemon" + "--pidfile=/var/run/qemu-ga.pid" + "--statedir=/var/run" + ,@(if #$device + (list (string-append "--path=" #$device)) + '())) + #:pid-file "/var/run/qemu-ga.pid" + #:log-file "/var/log/qemu-ga.log")) + (stop #~(make-kill-destructor))))))) + +(define qemu-guest-agent-service-type + (service-type + (name 'qemu-guest-agent) + (extensions + (list (service-extension shepherd-root-service-type + qemu-guest-agent-shepherd-service))) + (default-value (qemu-guest-agent-configuration)) + (description "Run the QEMU guest agent."))) + + +;;; ;;; Secrets for guest VMs. ;;; -(define (secret-service-activation port) - "Return an activation snippet that fetches sensitive material at local PORT, +(define (secret-service-shepherd-services port) + "Return a Shepherd service that fetches sensitive material at local PORT, over TCP. Reboot upon failure." - (with-imported-modules '((gnu build secret-service) - (guix build utils)) - #~(begin - (use-modules (gnu build secret-service)) - (let ((sent (secret-service-receive-secrets #$port))) - (unless sent - (sleep 3) - (reboot)))))) + ;; This is a Shepherd service, rather than an activation snippet, to make + ;; sure it is started once 'networking' is up so it can accept incoming + ;; connections. + (list + (shepherd-service + (documentation "Fetch secrets from the host at startup time.") + (provision '(secret-service-client)) + (requirement '(loopback networking)) + (modules '((gnu build secret-service) + (guix build utils))) + (start (with-imported-modules '((gnu build secret-service) + (guix build utils)) + #~(lambda () + ;; Since shepherd's output port goes to /dev/log, write this + ;; message to stderr so it's visible on the Mach console. + (format (current-error-port) + "receiving secrets from the host...~%") + (force-output (current-error-port)) + + (let ((sent (secret-service-receive-secrets #$port))) + (unless sent + (sleep 3) + (reboot)))))) + (stop #~(const #f))))) (define secret-service-type (service-type (name 'secret-service) - (extensions (list (service-extension activation-service-type - secret-service-activation))) + (extensions (list (service-extension shepherd-root-service-type + secret-service-shepherd-services) + + ;; Make every Shepherd service depend on + ;; 'secret-service-client'. + (service-extension user-processes-service-type + (const '(secret-service-client))))) (description "This service fetches secret key and other sensitive material over TCP at boot time. This service is meant to be used by virtual machines (VMs) that @@ -928,7 +995,7 @@ that will be listening to receive secret keys on port 1004, TCP." hurd-vm-configuration? (os hurd-vm-configuration-os ;<operating-system> (default %hurd-vm-operating-system)) - (qemu hurd-vm-configuration-qemu ;<package> + (qemu hurd-vm-configuration-qemu ;file-like (default qemu-minimal)) (image hurd-vm-configuration-image ;string (thunked) diff --git a/gnu/services/vpn.scm b/gnu/services/vpn.scm index df84905eb3..3e370ba4be 100644 --- a/gnu/services/vpn.scm +++ b/gnu/services/vpn.scm @@ -8,6 +8,7 @@ ;;; Copyright © 2021 Tobias Geerinckx-Rice <[email protected]> ;;; Copyright © 2021 Raghav Gururajan <[email protected]> ;;; Copyright © 2021 jgart <[email protected]> +;;; Copyright © 2021 Nathan Dehnel <[email protected]> ;;; ;;; This file is part of GNU Guix. ;;; @@ -67,6 +68,7 @@ wireguard-configuration-interface wireguard-configuration-addresses wireguard-configuration-port + wireguard-configuration-dns wireguard-configuration-private-key wireguard-configuration-peers @@ -302,7 +304,7 @@ client. Each file is named after the name of the client." (define-split-configuration openvpn-client-configuration openvpn-server-configuration ((openvpn - (package openvpn) + (file-like openvpn) "The OpenVPN package.") (pid-file @@ -561,7 +563,7 @@ is truncated and rewritten every minute.") (define-record-type* <strongswan-configuration> strongswan-configuration make-strongswan-configuration strongswan-configuration? - (strongswan strongswan-configuration-strongswan ;<package> + (strongswan strongswan-configuration-strongswan ;file-like (default strongswan)) (ipsec-conf strongswan-configuration-ipsec-conf ;string|#f (default #f)) @@ -704,7 +706,7 @@ strongSwan."))) (define-record-type* <wireguard-configuration> wireguard-configuration make-wireguard-configuration wireguard-configuration? - (wireguard wireguard-configuration-wireguard ;<package> + (wireguard wireguard-configuration-wireguard ;file-like (default wireguard-tools)) (interface wireguard-configuration-interface ;string (default "wg0")) @@ -715,7 +717,9 @@ strongSwan."))) (private-key wireguard-configuration-private-key ;string (default "/etc/wireguard/private.key")) (peers wireguard-configuration-peers ;list of <wiregard-peer> - (default '()))) + (default '())) + (dns wireguard-configuration-dns ;list of strings + (default #f))) (define (wireguard-configuration-file config) (define (peer->config peer) @@ -739,7 +743,7 @@ AllowedIPs = ~a "\n")))) (match-record config <wireguard-configuration> - (wireguard interface addresses port private-key peers) + (wireguard interface addresses port private-key peers dns) (let* ((config-file (string-append interface ".conf")) (peers (map peer->config peers)) (config @@ -755,6 +759,7 @@ AllowedIPs = ~a Address = ~a PostUp = ~a set %i private-key ~a ~a +~a ~{~a~^~%~}" #$(string-join addresses ",") #$(file-append wireguard "/bin/wg") @@ -762,6 +767,10 @@ PostUp = ~a set %i private-key ~a #$(if port (format #f "ListenPort = ~a" port) "") + #$(if dns + (format #f "DNS = ~a" + (string-join dns ",")) + "") (list #$@peers))))))))) (file-append config "/" config-file)))) diff --git a/gnu/services/web.scm b/gnu/services/web.scm index bb42eacf83..e5cc6343b5 100644 --- a/gnu/services/web.scm +++ b/gnu/services/web.scm @@ -535,7 +535,7 @@ (define-record-type* <nginx-configuration> nginx-configuration make-nginx-configuration nginx-configuration? - (nginx nginx-configuration-nginx ;<package> + (nginx nginx-configuration-nginx ;file-like (default nginx)) (log-directory nginx-configuration-log-directory ;string (default "/var/log/nginx")) @@ -552,9 +552,9 @@ (modules nginx-configuration-modules (default '())) (global-directives nginx-configuration-global-directives (default '((events . ())))) - (lua-package-path nginx-lua-package-path ;list of <package> + (lua-package-path nginx-lua-package-path ;list of file-like (default #f)) - (lua-package-cpath nginx-lua-package-cpath ;list of <package> + (lua-package-cpath nginx-lua-package-cpath ;list of file-like (default #f)) (extra-content nginx-configuration-extra-content (default "")) @@ -803,7 +803,7 @@ of index files." (define-record-type* <fcgiwrap-configuration> fcgiwrap-configuration make-fcgiwrap-configuration fcgiwrap-configuration? - (package fcgiwrap-configuration-package ;<package> + (package fcgiwrap-configuration-package ;file-like (default fcgiwrap)) (socket fcgiwrap-configuration-socket (default "tcp:127.0.0.1:9000")) @@ -872,7 +872,7 @@ of index files." (define-record-type* <php-fpm-configuration> php-fpm-configuration make-php-fpm-configuration php-fpm-configuration? - (php php-fpm-configuration-php ;<package> + (php php-fpm-configuration-php ;file-like (default php)) (socket php-fpm-configuration-socket (default (string-append "/var/run/php" @@ -1107,10 +1107,12 @@ a webserver.") hpcguix-web-configuration make-hpcguix-web-configuration hpcguix-web-configuration? - (package hpcguix-web-package (default hpcguix-web)) ;<package> + (package hpcguix-web-package (default hpcguix-web)) ;file-like ;; Specs is gexp of hpcguix-web configuration file - (specs hpcguix-web-configuration-specs)) + (specs hpcguix-web-configuration-specs) + (address hpcguix-web-configuration-address (default "127.0.0.1")) + (port hpcguix-web-configuration-port (default 5000))) (define %hpcguix-web-accounts (list (user-group @@ -1163,6 +1165,12 @@ a webserver.") (requirement '(networking)) (start #~(make-forkexec-constructor (list #$(file-append hpcguix-web "/bin/hpcguix-web") + (string-append "--listen=" + #$(hpcguix-web-configuration-address + config)) + "-p" + #$(number->string + (hpcguix-web-configuration-port config)) (string-append "--config=" #$(scheme-file "hpcguix-web.scm" specs))) #:user "hpcguix-web" @@ -1340,7 +1348,7 @@ files.") (define-record-type* <varnish-configuration> varnish-configuration make-varnish-configuration varnish-configuration? - (package varnish-configuration-package ;<package> + (package varnish-configuration-package ;file-like (default varnish)) (name varnish-configuration-name ;string (default "default")) diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm index d5c5316d3f..a5e1a1471d 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.scm @@ -10,6 +10,8 @@ ;;; Copyright © 2020 Alex Griffin <[email protected]> ;;; Copyright © 2021 Brice Waegeneire <[email protected]> ;;; Copyright © 2021 Oleg Pykhalov <[email protected]> +;;; Copyright © 2021 Josselin Poiret <[email protected]> +;;; Copyright © 2022 Chris Marusich <[email protected]> ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,6 +29,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (gnu services xorg) + #:autoload (gnu services sddm) (sddm-service-type) #:use-module (gnu artwork) #:use-module (gnu services) #:use-module (gnu services shepherd) @@ -48,6 +51,7 @@ #:use-module (gnu packages admin) #:use-module (gnu packages bash) #:use-module (gnu system shadow) + #:use-module (guix build-system glib-or-gtk) #:use-module (guix build-system trivial) #:use-module (guix gexp) #:use-module (guix store) @@ -55,6 +59,7 @@ #:use-module (guix derivations) #:use-module (guix records) #:use-module (guix deprecation) + #:use-module (guix utils) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) @@ -161,7 +166,7 @@ (define-record-type* <xorg-configuration> xorg-configuration make-xorg-configuration xorg-configuration? - (modules xorg-configuration-modules ;list of packages + (modules xorg-configuration-modules ;list of file-like (thunked) ; filter out modules not supported on current system (default (filter @@ -179,7 +184,7 @@ (default #f)) (extra-config xorg-configuration-extra-config ;list of strings (default '())) - (server xorg-configuration-server ;package + (server xorg-configuration-server ;file-like (default xorg-server)) (server-arguments xorg-configuration-server-arguments ;list of strings (default %default-xorg-server-arguments))) @@ -869,6 +874,24 @@ the GNOME desktop environment.") (apply execl (string-append #$dbus "/bin/dbus-daemon") (program-arguments))))) +;; Wrapper script for Wayland sessions, similar to Xsession. +;; +;; See `xinitrc`. By default, it launches the specified session through a +;; login shell. With the default Guix configuration, this should source +;; /etc/profile, setting up the Guix profile environment variables. However, +;; gdm launches its own graphical session through the same method, so we need +;; to ignore this case, since `gdm` doesn't have a login shell. +(define gdm-wayland-session-wrapper + (program-file + "gdm-wayland-session-wrapper" + #~((let* ((user (getpw (getuid))) + (name (passwd:name user)) + (shell (passwd:shell user)) + (args (cdr (command-line)))) + (if (string=? name "gdm") + (apply execl (cons (car args) args)) + (execl shell shell "--login" "-c" (string-join args))))))) + (define-record-type* <gdm-configuration> gdm-configuration make-gdm-configuration gdm-configuration? @@ -879,11 +902,14 @@ the GNOME desktop environment.") (debug? gdm-configuration-debug? (default #f)) (default-user gdm-configuration-default-user (default #f)) (gnome-shell-assets gdm-configuration-gnome-shell-assets - (default (list adwaita-icon-theme font-cantarell))) + (default (list adwaita-icon-theme font-abattis-cantarell))) (xorg-configuration gdm-configuration-xorg (default (xorg-configuration))) (x-session gdm-configuration-x-session - (default (xinitrc)))) + (default (xinitrc))) + (wayland? gdm-configuration-wayland? (default #f)) + (wayland-session gdm-configuration-wayland-session + (default gdm-wayland-session-wrapper))) (define (gdm-configuration-file config) (mixed-text-file "gdm-custom.conf" @@ -909,8 +935,9 @@ the GNOME desktop environment.") ;; See also ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=39281>. "InitialSetupEnable=false\n" - ;; Enable me once X is working. - "WaylandEnable=false\n" + "WaylandEnable=" (if (gdm-configuration-wayland? config) + "true" + "false") "\n" "\n" "[debug]\n" "Enable=" (if (gdm-configuration-debug? config) @@ -976,7 +1003,17 @@ the GNOME desktop environment.") ;; can depend on GNOME Shell directly. (cons #$gnome-shell '#$(gdm-configuration-gnome-shell-assets - config))))))))) + config))))) + ;; Add XCURSOR_PATH so that mutter can find its + ;; cursors. gdm doesn't login so doesn't source + ;; the corresponding line in /etc/profile. + "XCURSOR_PATH=/run/current-system/profile/share/icons" + (string-append + "GDK_PIXBUF_MODULE_FILE=" + #$gnome-shell "/" #$%gdk-pixbuf-loaders-cache-file) + (string-append + "GDM_WAYLAND_SESSION=" + #$(gdm-configuration-wayland-session config)))))) (stop #~(make-kill-destructor)) (respawn? #t)))) @@ -1006,10 +1043,15 @@ 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.")))) +;; Since GDM depends on Rust (gdm -> gnome-shell -> gjs -> mozjs -> rust) +;; and Rust is currently unavailable on non-x86_64 platforms, default to +;; SDDM there (FIXME). (define* (set-xorg-configuration config #:optional (login-manager-service-type - gdm-service-type)) + (if (target-x86-64?) + gdm-service-type + sddm-service-type))) "Tell the log-in manager (of type @var{login-manager-service-type}) to use @var{config}, an <xorg-configuration> record." (simple-service 'set-xorg-configuration |