diff options
Diffstat (limited to 'gnu/services')
| -rw-r--r-- | gnu/services/base.scm | 13 | ||||
| -rw-r--r-- | gnu/services/dbus.scm | 48 | ||||
| -rw-r--r-- | gnu/services/desktop.scm | 52 | ||||
| -rw-r--r-- | gnu/services/mail.scm | 45 | ||||
| -rw-r--r-- | gnu/services/networking.scm | 3 | ||||
| -rw-r--r-- | gnu/services/ssh.scm | 3 | ||||
| -rw-r--r-- | gnu/services/xorg.scm | 122 |
7 files changed, 224 insertions, 62 deletions
diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 04b123b833..65f7ff29c8 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -719,7 +719,8 @@ to add @var{device} to the kernel's entropy pool. The service will fail if #$@files)))) (respawn? #f))))) -(define (console-keymap-service . files) +(define-deprecated (console-keymap-service #:rest files) + #f "Return a service to load console keymaps from @var{files}." (service console-keymap-service-type files)) @@ -1515,19 +1516,9 @@ GID." (define (hydra-key-authorization keys guix) "Return a gexp with code to register KEYS, a list of files containing 'guix archive' public keys, with GUIX." - (define aaa - ;; XXX: Terrible hack to work around <https://bugs.gnu.org/15602>: this - ;; forces (guix config) and (guix utils) to be loaded upfront, so that - ;; their run-time symbols are defined. - (scheme-file "aaa.scm" - #~(define-module (guix aaa) - #:use-module (guix config) - #:use-module (guix memoization)))) - (define default-acl (with-extensions (list guile-gcrypt) (with-imported-modules `(((guix config) => ,(make-config.scm)) - ((guix aaa) => ,aaa) ,@(source-module-closure '((guix pki)) #:select? not-config?)) (computed-file "acl" diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm index 606ee0c2f5..35d7ff3c9c 100644 --- a/gnu/services/dbus.scm +++ b/gnu/services/dbus.scm @@ -26,6 +26,7 @@ #:use-module (gnu packages polkit) #:use-module (gnu packages admin) #:use-module (guix gexp) + #:use-module ((guix packages) #:select (package-name)) #:use-module (guix records) #:use-module (srfi srfi-1) #:use-module (ice-9 match) @@ -33,6 +34,7 @@ dbus-configuration? dbus-root-service-type dbus-service + wrapped-dbus-service polkit-service-type polkit-service)) @@ -229,6 +231,52 @@ and policy files. For example, to allow avahi-daemon to use the system bus, (dbus-configuration (dbus dbus) (services services)))) +(define (wrapped-dbus-service service program variables) + "Return a wrapper for @var{service}, a package containing a D-Bus service, +where @var{program} is wrapped such that @var{variables}, a list of name/value +tuples, are all set as environment variables when the bus daemon launches it." + (define wrapper + (program-file (string-append (package-name service) "-program-wrapper") + #~(begin + (use-modules (ice-9 match)) + + (for-each (match-lambda + ((variable value) + (setenv variable value))) + '#$variables) + + (apply execl (string-append #$service "/" #$program) + (string-append #$service "/" #$program) + (cdr (command-line)))))) + + (define build + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + + (define service-directory + "/share/dbus-1/system-services") + + (mkdir-p (dirname (string-append #$output + service-directory))) + (copy-recursively (string-append #$service + service-directory) + (string-append #$output + service-directory)) + (symlink (string-append #$service "/etc") ;for etc/dbus-1 + (string-append #$output "/etc")) + + (for-each (lambda (file) + (substitute* file + (("Exec[[:blank:]]*=[[:blank:]]*([[:graph:]]+)(.*)$" + _ original-program arguments) + (string-append "Exec=" #$wrapper arguments + "\n")))) + (find-files #$output "\\.service$"))))) + + (computed-file (string-append (package-name service) "-wrapper") + build)) + ;;; ;;; Polkit privilege management service. diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm index dcab950822..578095b146 100644 --- a/gnu/services/desktop.scm +++ b/gnu/services/desktop.scm @@ -150,46 +150,6 @@ ((package . _) package)))) -(define (wrapped-dbus-service service program variable value) - "Return a wrapper for @var{service}, a package containing a D-Bus service, -where @var{program} is wrapped such that environment variable @var{variable} -is set to @var{value} when the bus daemon launches it." - (define wrapper - (program-file (string-append (package-name service) "-program-wrapper") - #~(begin - (setenv #$variable #$value) - (apply execl (string-append #$service "/" #$program) - (string-append #$service "/" #$program) - (cdr (command-line)))))) - - (define build - (with-imported-modules '((guix build utils)) - #~(begin - (use-modules (guix build utils)) - - (define service-directory - "/share/dbus-1/system-services") - - (mkdir-p (dirname (string-append #$output - service-directory))) - (copy-recursively (string-append #$service - service-directory) - (string-append #$output - service-directory)) - (symlink (string-append #$service "/etc") ;for etc/dbus-1 - (string-append #$output "/etc")) - - (for-each (lambda (file) - (substitute* file - (("Exec[[:blank:]]*=[[:blank:]]*([[:graph:]]+)(.*)$" - _ original-program arguments) - (string-append "Exec=" #$wrapper arguments - "\n")))) - (find-files #$output "\\.service$"))))) - - (computed-file (string-append (package-name service) "-wrapper") - build)) - ;;; ;;; Upower D-Bus service. @@ -257,8 +217,8 @@ is set to @var{value} when the bus daemon launches it." (define (upower-dbus-service config) (list (wrapped-dbus-service (upower-configuration-upower config) "libexec/upowerd" - "UPOWER_CONF_FILE_NAME" - (upower-configuration-file config)))) + `(("UPOWER_CONF_FILE_NAME" + ,(upower-configuration-file config)))))) (define (upower-shepherd-service config) "Return a shepherd service for UPower with CONFIG." @@ -389,8 +349,8 @@ users are allowed." (define (geoclue-dbus-service config) (list (wrapped-dbus-service (geoclue-configuration-geoclue config) "libexec/geoclue" - "GEOCLUE_CONFIG_FILE" - (geoclue-configuration-file config)))) + `(("GEOCLUE_CONFIG_FILE" + ,(geoclue-configuration-file config)))))) (define %geoclue-accounts (list (user-group (name "geoclue") (system? #t)) @@ -742,8 +702,8 @@ include the @command{udisksctl} command, part of UDisks, and GNOME Disks." (define (elogind-dbus-service config) (list (wrapped-dbus-service (elogind-package config) "libexec/elogind/elogind" - "ELOGIND_CONF_FILE" - (elogind-configuration-file config)))) + `(("ELOGIND_CONF_FILE" + ,(elogind-configuration-file config)))))) (define (pam-extension-procedure config) "Return an extension for PAM-ROOT-SERVICE-TYPE that ensures that all the PAM diff --git a/gnu/services/mail.scm b/gnu/services/mail.scm index a7e8c41d3a..0dabfed4cb 100644 --- a/gnu/services/mail.scm +++ b/gnu/services/mail.scm @@ -64,7 +64,12 @@ exim-configuration exim-configuration? exim-service-type - %default-exim-config-file)) + %default-exim-config-file + + imap4d-configuration + imap4d-configuration? + imap4d-service-type + %defualt-imap4d-config-file)) ;;; Commentary: ;;; @@ -1776,3 +1781,41 @@ exim_group = exim (service-extension activation-service-type exim-activation) (service-extension profile-service-type exim-profile) (service-extension mail-aliases-service-type (const '())))))) + + +;;; +;;; GNU Mailutils IMAP4 Daemon. +;;; + +(define %default-imap4d-config-file + (plain-file "imap4d.conf" "server localhost {};\n")) + +(define-record-type* <imap4d-configuration> + imap4d-configuration make-imap4d-configuration imap4d-configuration? + (package imap4d-configuration-package + (default mailutils)) + (config-file imap4d-configuration-config-file + (default %default-imap4d-config-file))) + +(define imap4d-shepherd-service + (match-lambda + (($ <imap4d-configuration> package config-file) + (list (shepherd-service + (provision '(imap4d)) + (requirement '(networking syslogd)) + (documentation "Run the imap4d daemon.") + (start (let ((imap4d (file-append package "/sbin/imap4d"))) + #~(make-forkexec-constructor + (list #$imap4d "--daemon" "--foreground" + "--config-file" #$config-file)))) + (stop #~(make-kill-destructor))))))) + +(define imap4d-service-type + (service-type + (name 'imap4d) + (description + "Run the GNU @command{imap4d} to serve e-mail messages through IMAP.") + (extensions + (list (service-extension + shepherd-root-service-type imap4d-shepherd-service))) + (default-value (imap4d-configuration)))) diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm index 5fbbf25789..61561a40dd 100644 --- a/gnu/services/networking.scm +++ b/gnu/services/networking.scm @@ -1060,12 +1060,13 @@ networking.")))) (list (shepherd-service (documentation "Run the WPA supplicant daemon") (provision '(wpa-supplicant)) - (requirement '(user-processes dbus-system loopback)) + (requirement '(user-processes dbus-system loopback syslogd)) (start #~(make-forkexec-constructor (list (string-append #$wpa-supplicant "/sbin/wpa_supplicant") (string-append "-P" #$pid-file) "-B" ;run in background + "-s" ;log to syslogd #$@(if dbus? #~("-u") #~()) diff --git a/gnu/services/ssh.scm b/gnu/services/ssh.scm index 362a7f1490..25db783420 100644 --- a/gnu/services/ssh.scm +++ b/gnu/services/ssh.scm @@ -617,7 +617,8 @@ of user-name/file-like tuples." (list (service-extension shepherd-root-service-type dropbear-shepherd-service) (service-extension activation-service-type - dropbear-activation))))) + dropbear-activation))) + (default-value (dropbear-configuration)))) (define* (dropbear-service #:optional (config (dropbear-configuration))) "Run the @uref{https://matt.ucc.asn.au/dropbear/dropbear.html,Dropbear SSH diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm index 29c7f30013..d4e73c13b4 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.scm @@ -27,6 +27,7 @@ #:use-module (gnu services shepherd) #:use-module (gnu system pam) #:use-module (gnu system keyboard) + #:use-module (gnu services base) #:use-module (gnu services dbus) #:use-module ((gnu packages base) #:select (canonical-package)) #:use-module (gnu packages guile) @@ -35,6 +36,7 @@ #:use-module (gnu packages gl) #:use-module (gnu packages glib) #:use-module (gnu packages display-managers) + #:use-module (gnu packages freedesktop) #:use-module (gnu packages gnustep) #:use-module (gnu packages gnome) #:use-module (gnu packages admin) @@ -91,9 +93,14 @@ screen-locker-service-type screen-locker-service + localed-configuration + localed-configuration? + localed-service-type + gdm-configuration gdm-service-type - gdm-service)) + gdm-service + set-xorg-configuration)) ;;; Commentary: ;;; @@ -653,6 +660,88 @@ makes the good ol' XlockMore usable." (file-append package "/bin/" program) allow-empty-passwords?))) + +;;; +;;; Locale service. +;;; + +(define-record-type* <localed-configuration> + localed-configuration make-localed-configuration + localed-configuration? + (localed localed-configuration-localed + (default localed)) + (keyboard-layout localed-configuration-keyboard-layout + (default #f))) + +(define (localed-dbus-service config) + "Return the 'localed' D-Bus service for @var{config}, a +@code{<localed-configuration>} record." + (define keyboard-layout + (localed-configuration-keyboard-layout config)) + + ;; The primary purpose of 'localed' is to tell GDM what the "current" Xorg + ;; keyboard layout is. If 'localed' is missing, or if it's unable to + ;; determine the current XKB layout, then GDM forcefully installs its + ;; default XKB config (US English). Here we communicate the configured + ;; layout through environment variables. + + (if keyboard-layout + (let* ((layout (keyboard-layout-name keyboard-layout)) + (variant (keyboard-layout-variant keyboard-layout)) + (model (keyboard-layout-model keyboard-layout)) + (options (keyboard-layout-options keyboard-layout))) + (list (wrapped-dbus-service + (localed-configuration-localed config) + "libexec/localed/localed" + `(("GUIX_XKB_LAYOUT" ,layout) + ,@(if variant + `(("GUIX_XKB_VARIANT" ,variant)) + '()) + ,@(if model + `(("GUIX_XKB_MODEL" ,model)) + '()) + ,@(if (null? options) + '() + `(("GUIX_XKB_OPTIONS" + ,(string-join options ",")))))))) + '())) + +(define localed-service-type + (let ((package (lambda (config) + ;; Don't bother if the user didn't specify any keyboard + ;; layout. + (if (localed-configuration-keyboard-layout config) + (list (localed-configuration-localed config)) + '())))) + (service-type (name 'localed) + (extensions + (list (service-extension dbus-root-service-type + localed-dbus-service) + (service-extension udev-service-type package) + (service-extension polkit-service-type package) + + ;; Add 'localectl' to the profile. + (service-extension profile-service-type package))) + + ;; This service can be extended, typically by the X login + ;; manager, to communicate the chosen Xorg keyboard layout. + (compose (lambda (extensions) + (find keyboard-layout? extensions))) + (extend (lambda (config keyboard-layout) + (localed-configuration + (inherit config) + (keyboard-layout keyboard-layout)))) + (description + "Run the locale daemon, @command{localed}, which can be used +to control the system locale and keyboard mapping from user programs such as +the GNOME desktop environment.") + (default-value (localed-configuration))))) + + +;;; +;;; GNOME Desktop Manager. +;;; + (define %gdm-accounts (list (user-group (name "gdm") (system? #t)) (user-account @@ -787,7 +876,26 @@ makes the good ol' XlockMore usable." gdm-configuration-gnome-shell-assets) (service-extension dbus-root-service-type (compose list - gdm-configuration-gdm)))) + gdm-configuration-gdm)) + (service-extension localed-service-type + (compose + xorg-configuration-keyboard-layout + gdm-configuration-xorg)))) + + ;; For convenience, this service can be extended with an + ;; <xorg-configuration> record. Take the first one that + ;; comes. + (compose (lambda (extensions) + (match extensions + (() #f) + ((config . _) config)))) + (extend (lambda (config xorg-configuration) + (if xorg-configuration + (gdm-configuration + (inherit config) + (xorg-configuration xorg-configuration)) + config))) + (default-value (gdm-configuration)) (description "Run the GNOME Desktop Manager (GDM), a program that allows @@ -821,4 +929,14 @@ password." (gdm gdm) (allow-empty-passwords? allow-empty-passwords?)))) +(define* (set-xorg-configuration config + #:optional + (login-manager-service-type + gdm-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 + login-manager-service-type + config)) + ;;; xorg.scm ends here |