aboutsummaryrefslogtreecommitdiff
path: root/gnu/services
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/services')
-rw-r--r--gnu/services/authentication.scm16
-rw-r--r--gnu/services/base.scm32
-rw-r--r--gnu/services/certbot.scm40
-rw-r--r--gnu/services/dbus.scm48
-rw-r--r--gnu/services/desktop.scm70
-rw-r--r--gnu/services/dns.scm87
-rw-r--r--gnu/services/mail.scm45
-rw-r--r--gnu/services/networking.scm15
-rw-r--r--gnu/services/sddm.scm14
-rw-r--r--gnu/services/shepherd.scm26
-rw-r--r--gnu/services/ssh.scm3
-rw-r--r--gnu/services/web.scm1
-rw-r--r--gnu/services/xorg.scm320
13 files changed, 501 insertions, 216 deletions
diff --git a/gnu/services/authentication.scm b/gnu/services/authentication.scm
index ab54aaf698..73969a5a6d 100644
--- a/gnu/services/authentication.scm
+++ b/gnu/services/authentication.scm
@@ -42,17 +42,21 @@
nslcd-configuration?
nslcd-service-type))
-(define-record-type* <fprintd-configuration>
- fprintd-configuration make-fprintd-configuration
- fprintd-configuration?
- (ntp fprintd-configuration-fprintd
- (default fprintd)))
+(define-configuration fprintd-configuration
+ (fprintd (package fprintd)
+ "The fprintd package"))
+
+(define (fprintd-dbus-service config)
+ (list (fprintd-configuration-fprintd config)))
(define fprintd-service-type
(service-type (name 'fprintd)
(extensions
(list (service-extension dbus-root-service-type
- list)))
+ fprintd-dbus-service)
+ (service-extension polkit-service-type
+ fprintd-dbus-service)))
+ (default-value (fprintd-configuration))
(description
"Run fprintd, a fingerprint management daemon.")))
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 04b123b833..952f6f9ab2 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -510,13 +510,30 @@ FILE-SYSTEM."
(cons* sink user-unmount
(map file-system-shepherd-service file-systems))))
+(define (file-system-fstab-entries file-systems)
+ "Return the subset of @var{file-systems} that should have an entry in
+@file{/etc/fstab}."
+ ;; /etc/fstab is about telling fsck(8), mount(8), and umount(8) about
+ ;; relevant file systems they'll have to deal with. That excludes "pseudo"
+ ;; file systems.
+ ;;
+ ;; In particular, things like GIO (part of GLib) use it to determine the set
+ ;; of mounts, which is then used by graphical file managers and desktop
+ ;; environments to display "volume" icons. Thus, we really need to exclude
+ ;; those pseudo file systems from the list.
+ (remove (lambda (file-system)
+ (or (member (file-system-type file-system)
+ %pseudo-file-system-types)
+ (memq 'bind-mount (file-system-flags file-system))))
+ file-systems))
+
(define file-system-service-type
(service-type (name 'file-systems)
(extensions
(list (service-extension shepherd-root-service-type
file-system-shepherd-services)
(service-extension fstab-service-type
- identity)
+ file-system-fstab-entries)
;; Have 'user-processes' depend on 'file-systems'.
(service-extension user-processes-service-type
@@ -719,7 +736,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 +1533,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/certbot.scm b/gnu/services/certbot.scm
index 7565bc97ca..ae34ad17bb 100644
--- a/gnu/services/certbot.scm
+++ b/gnu/services/certbot.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2016 ng0 <ng0@n0.is>
;;; Copyright © 2016 Sou Bunnbu <iyzsong@member.fsf.org>
;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -50,6 +51,12 @@
(default #f))
(domains certificate-configuration-domains
(default '()))
+ (challenge certificate-configuration-challenge
+ (default #f))
+ (authentication-hook certificate-authentication-hook
+ (default #f))
+ (cleanup-hook certificate-cleanup-hook
+ (default #f))
(deploy-hook certificate-configuration-deploy-hook
(default #f)))
@@ -81,17 +88,32 @@
(commands
(map
(match-lambda
- (($ <certificate-configuration> custom-name domains
+ (($ <certificate-configuration> custom-name domains challenge
+ authentication-hook cleanup-hook
deploy-hook)
(let ((name (or custom-name (car domains))))
- (append
- (list name certbot "certonly" "-n" "--agree-tos"
- "-m" email
- "--webroot" "-w" webroot
- "--cert-name" name
- "-d" (string-join domains ","))
- (if rsa-key-size `("--rsa-key-size" ,rsa-key-size) '())
- (if deploy-hook `("--deploy-hook" ,deploy-hook) '())))))
+ (if challenge
+ (append
+ (list name certbot "certonly" "-n" "--agree-tos"
+ "-m" email
+ "--manual"
+ (string-append "--preferred-challenges=" challenge)
+ "--cert-name" name
+ "-d" (string-join domains ","))
+ (if rsa-key-size `("--rsa-key-size" ,rsa-key-size) '())
+ (if authentication-hook
+ `("--manual-auth-hook" ,authentication-hook)
+ '())
+ (if cleanup-hook `("--manual-cleanup-hook" ,cleanup-hook) '())
+ (if deploy-hook `("--deploy-hook" ,deploy-hook) '()))
+ (append
+ (list name certbot "certonly" "-n" "--agree-tos"
+ "-m" email
+ "--webroot" "-w" webroot
+ "--cert-name" name
+ "-d" (string-join domains ","))
+ (if rsa-key-size `("--rsa-key-size" ,rsa-key-size) '())
+ (if deploy-hook `("--deploy-hook" ,deploy-hook) '()))))))
certificates)))
(program-file
"certbot-command"
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 b912c208cc..f31dbc112e 100644
--- a/gnu/services/desktop.scm
+++ b/gnu/services/desktop.scm
@@ -103,6 +103,8 @@
accountsservice-service-type
accountsservice-service
+ cups-pk-helper-service-type
+
gnome-desktop-configuration
gnome-desktop-configuration?
gnome-desktop-service
@@ -150,46 +152,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 +219,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 +351,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 +704,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
@@ -884,9 +846,12 @@ rules."
(service-extension profile-service-type
(compose list
gnome-package))))
+ (default-value (gnome-desktop-configuration))
(description "Run the GNOME desktop environment.")))
-(define* (gnome-desktop-service #:key (config (gnome-desktop-configuration)))
+(define-deprecated (gnome-desktop-service #:key (config
+ (gnome-desktop-configuration)))
+ gnome-desktop-service-type
"Return a service that adds the @code{gnome} package to the system profile,
and extends polkit with the actions from @code{gnome-settings-daemon}."
(service gnome-desktop-service-type config))
@@ -942,10 +907,13 @@ and extends polkit with the actions from @code{mate-settings-daemon}."
"thunar")
xfce-package))
(service-extension profile-service-type
- (compose list
- xfce-package))))))
+ (compose list xfce-package))))
+ (default-value (xfce-desktop-configuration))
+ (description "Run the Xfce desktop environment.")))
-(define* (xfce-desktop-service #:key (config (xfce-desktop-configuration)))
+(define-deprecated (xfce-desktop-service #:key (config
+ (xfce-desktop-configuration)))
+ xfce-desktop-service-type
"Return a service that adds the @code{xfce} package to the system profile,
and extends polkit with the ability for @code{thunar} to manipulate the file
system as root from within a user session, after the user has authenticated
@@ -1072,7 +1040,7 @@ dispatches events from it.")))
(define %desktop-services
;; List of services typically useful for a "desktop" use case.
- (cons* (service slim-service-type)
+ (cons* (service gdm-service-type)
;; Screen lockers are a pretty useful thing and these are small.
(screen-locker-service slock)
diff --git a/gnu/services/dns.scm b/gnu/services/dns.scm
index 1ef754b360..5f37cb0782 100644
--- a/gnu/services/dns.scm
+++ b/gnu/services/dns.scm
@@ -163,30 +163,40 @@
(define-record-type* <knot-zone-configuration>
knot-zone-configuration make-knot-zone-configuration
knot-zone-configuration?
- (domain knot-zone-configuration-domain
- (default ""))
- (file knot-zone-configuration-file
- (default "")) ; the file where this zone is saved.
- (zone knot-zone-configuration-zone
- (default (zone-file))) ; initial content of the zone file
- (master knot-zone-configuration-master
- (default '()))
- (ddns-master knot-zone-configuration-ddns-master
- (default #f))
- (notify knot-zone-configuration-notify
- (default '()))
- (acl knot-zone-configuration-acl
- (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))
- (dnssec-policy knot-zone-configuration-dnssec-policy
- (default #f))
- (serial-policy knot-zone-configuration-serial-policy
- (default 'increment)))
+ (domain knot-zone-configuration-domain
+ (default ""))
+ (file knot-zone-configuration-file
+ (default "")) ; the file where this zone is saved.
+ (zone knot-zone-configuration-zone
+ (default (zone-file))) ; initial content of the zone file
+ (master knot-zone-configuration-master
+ (default '()))
+ (ddns-master knot-zone-configuration-ddns-master
+ (default #f))
+ (notify knot-zone-configuration-notify
+ (default '()))
+ (acl knot-zone-configuration-acl
+ (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
+ (default #f))
+ (journal-content knot-zone-configuration-journal-content
+ (default #f))
+ (max-journal-usage knot-zone-configuration-max-journal-usage
+ (default #f))
+ (max-journal-depth knot-zone-configuration-max-journal-depth
+ (default #f))
+ (max-zone-size knot-zone-configuration-max-zone-size
+ (default #f))
+ (dnssec-policy knot-zone-configuration-dnssec-policy
+ (default #f))
+ (serial-policy knot-zone-configuration-serial-policy
+ (default 'increment)))
(define-record-type* <knot-remote-configuration>
knot-remote-configuration make-knot-remote-configuration
@@ -207,6 +217,8 @@
(default knot))
(run-directory knot-configuration-run-directory
(default "/var/run/knot"))
+ (includes knot-configuration-includes
+ (default '()))
(listen-v4 knot-configuration-listen-v4
(default "0.0.0.0"))
(listen-v6 knot-configuration-listen-v6
@@ -296,6 +308,8 @@
(error-out "knot configuration field must be a package."))
(unless (string? (knot-configuration-run-directory config))
(error-out "run-directory must be a string."))
+ (unless (list? (knot-configuration-includes config))
+ (error-out "includes must be a list of strings or file-like objects."))
(unless (list? (knot-configuration-keys config))
(error-out "keys must be a list of knot-key-configuration."))
(for-each (lambda (key) (verify-knot-key-configuration key))
@@ -332,7 +346,7 @@
(fold (lambda (x1 x2)
(string-append (if (symbol? x1) (symbol->string x1) x1) ", "
(if (symbol? x2) (symbol->string x2) x2)))
- (car l) (cdr l))
+ (if (symbol? (car l)) (symbol->string (car l)) (car l)) (cdr l))
"]"))))
(define (knot-acl-config acls)
@@ -490,6 +504,12 @@
(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))
+ (max-journal-usage #$(knot-zone-configuration-max-journal-usage zone))
+ (max-journal-depth #$(knot-zone-configuration-max-journal-depth zone))
+ (max-zone-size #$(knot-zone-configuration-max-zone-size zone))
(dnssec-policy #$(knot-zone-configuration-dnssec-policy zone))
(serial-policy '#$(knot-zone-configuration-serial-policy zone)))
(format #t " - domain: ~a\n" domain)
@@ -516,6 +536,20 @@
(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
+ (format #t " zonefile-load: ~a\n"
+ (symbol->string zonefile-load)))
+ (if journal-content
+ (format #t " journal-content: ~a\n"
+ (symbol->string journal-content)))
+ (if max-journal-usage
+ (format #t " max-journal-usage: ~a\n" max-journal-usage))
+ (if max-journal-depth
+ (format #t " max-journal-depth: ~a\n" max-journal-depth))
+ (if max-zone-size
+ (format #t " max-zone-size: ~a\n" max-zone-size))
(if dnssec-policy
(begin
(format #t " dnssec-signing: on\n")
@@ -529,6 +563,9 @@
#~(begin
(call-with-output-file #$output
(lambda (port)
+ (for-each (lambda (inc)
+ (format port "include: ~a\n" inc))
+ '#$(knot-configuration-includes config))
(format port "server:\n")
(format port " rundir: ~a\n" #$(knot-configuration-run-directory config))
(format port " user: knot\n")
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 cab129e0c3..03b2c6e1ec 100644
--- a/gnu/services/networking.scm
+++ b/gnu/services/networking.scm
@@ -985,7 +985,14 @@ wireless networking."))))
(list (string-append #$connman
"/sbin/connmand")
"-n" "-r"
- #$@(if disable-vpn? '("--noplugin=vpn") '()))))
+ #$@(if disable-vpn? '("--noplugin=vpn") '()))
+
+ ;; As connman(8) notes, when passing '-n', connman
+ ;; "directs log output to the controlling terminal in
+ ;; addition to syslog." Redirect stdout and stderr
+ ;; to avoid spamming the console (XXX: for some reason
+ ;; redirecting to /dev/null doesn't work.)
+ #:log-file "/var/log/connman.log"))
(stop #~(make-kill-destructor)))))))
(define connman-service-type
@@ -1060,12 +1067,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")
#~())
@@ -1154,7 +1162,8 @@ implements authentication, key negotiation and more for wireless networks.")
(description
"Run @uref{http://www.openvswitch.org, Open vSwitch}, a multilayer virtual
switch designed to enable massive network automation through programmatic
-extension.")))
+extension.")
+ (default-value (openvswitch-configuration))))
;;;
;;; iptables
diff --git a/gnu/services/sddm.scm b/gnu/services/sddm.scm
index 2ebfe22016..b433c59e12 100644
--- a/gnu/services/sddm.scm
+++ b/gnu/services/sddm.scm
@@ -1,5 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 David Craven <david@craven.ch>
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019 Jesse Gildersleve <jessejohngildersleve@protonmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -83,8 +85,8 @@
(sessions-directory sddm-configuration-sessions-directory
(default "/run/current-system/profile/share/wayland-sessions"))
;; [X11]
- (xorg-server-path sddm-configuration-xorg-server-path
- (default (xorg-start-command)))
+ (xorg-configuration sddm-configuration-xorg
+ (default (xorg-configuration)))
(xauth-path sddm-configuration-xauth-path
(default (file-append xauth "/bin/xauth")))
(xephyr-path sddm-configuration-xephyr-path
@@ -99,8 +101,6 @@
(default "/run/current-system/profile/share/xsessions"))
(minimum-vt sddm-configuration-minimum-vt
(default 7))
- (xserver-arguments sddm-configuration-xserver-arguments
- (default "-nolisten tcp"))
;; [Autologin]
(auto-login-user sddm-configuration-auto-login-user
@@ -140,7 +140,7 @@ SessionCommand=" (sddm-configuration-session-command config) "
SessionDir=" (sddm-configuration-sessions-directory config) "
[X11]
-ServerPath=" (sddm-configuration-xorg-server-path config) "
+ServerPath=" (xorg-start-command (sddm-configuration-xorg config)) "
XauthPath=" (sddm-configuration-xauth-path config) "
XephyrPath=" (sddm-configuration-xephyr-path config) "
DisplayCommand=" (sddm-configuration-xdisplay-start config) "
@@ -148,7 +148,9 @@ DisplayStopCommand=" (sddm-configuration-xdisplay-stop config) "
SessionCommand=" (sddm-configuration-xsession-command config) "
SessionDir=" (sddm-configuration-xsessions-directory config) "
MinimumVT=" (number->string (sddm-configuration-minimum-vt config)) "
-ServerArguments=" (sddm-configuration-xserver-arguments config) "
+ServerArguments=" (string-join
+ (xorg-configuration-server-arguments
+ (sddm-configuration-xorg config))) "
[Autologin]
User=" (sddm-configuration-auto-login-user config) "
diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm
index 12d649f542..45c67e04eb 100644
--- a/gnu/services/shepherd.scm
+++ b/gnu/services/shepherd.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2018 Carlo Zancanaro <carlo@zancanaro.id.au>
;;;
@@ -44,6 +44,7 @@
shepherd-service-provision
shepherd-service-canonical-name
shepherd-service-requirement
+ shepherd-service-one-shot?
shepherd-service-respawn?
shepherd-service-start
shepherd-service-stop
@@ -59,7 +60,6 @@
%default-modules
shepherd-service-file
- %containerized-shepherd-service
shepherd-service-lookup-procedure
shepherd-service-back-edges
@@ -149,6 +149,8 @@ DEFAULT is given, use it as the service's default value."
(provision shepherd-service-provision) ;list of symbols
(requirement shepherd-service-requirement ;list of symbols
(default '()))
+ (one-shot? shepherd-service-one-shot? ;Boolean
+ (default #f))
(respawn? shepherd-service-respawn? ;Boolean
(default #t))
(start shepherd-service-start) ;g-expression (procedure)
@@ -238,6 +240,11 @@ stored."
#:docstring '#$(shepherd-service-documentation service)
#:provides '#$(shepherd-service-provision service)
#:requires '#$(shepherd-service-requirement service)
+
+ ;; The 'one-shot?' slot is new in Shepherd 0.6.0.
+ ;; Older versions ignore it.
+ #:one-shot? '#$(shepherd-service-one-shot? service)
+
#:respawn? '#$(shepherd-service-respawn? service)
#:start #$(shepherd-service-start service)
#:stop #$(shepherd-service-stop service)
@@ -338,21 +345,6 @@ symbols provided/required by a service."
(lambda (service)
(vhash-foldq* cons '() service edges)))
-(define %containerized-shepherd-service
- ;; XXX: This service works around a bug in the Shepherd 0.5.0: shepherd
- ;; calls reboot(2) (via 'disable-reboot-on-ctrl-alt-del') when it starts,
- ;; but in a container that fails with EINVAL. This was fixed in Shepherd
- ;; commit 92e806bac1abaeeaf5d60f0ab50d1ae85ba6a62f.
- (simple-service 'containerized-shepherd
- shepherd-root-service-type
- (list (shepherd-service
- (provision '(containerized-shepherd))
- (start #~(lambda ()
- (set! (@@ (shepherd)
- disable-reboot-on-ctrl-alt-del)
- (const #t))
- #t))))))
-
(define (shepherd-service-upgrade live target)
"Return two values: the subset of LIVE (a list of <live-service>) that needs
to be unloaded, and the subset of TARGET (a list of <shepherd-service>) that
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/web.scm b/gnu/services/web.scm
index b6ebe90774..84294db53b 100644
--- a/gnu/services/web.scm
+++ b/gnu/services/web.scm
@@ -34,7 +34,6 @@
#:use-module (gnu packages admin)
#:use-module (gnu packages web)
#:use-module (gnu packages php)
- #:use-module (gnu packages guile)
#:use-module (gnu packages logging)
#:use-module (guix records)
#:use-module (guix modules)
diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm
index f2a3c28c90..44dcec4ec9 100644
--- a/gnu/services/xorg.scm
+++ b/gnu/services/xorg.scm
@@ -4,6 +4,7 @@
;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
;;; Copyright © 2018, 2019 Timothy Sample <samplet@ngyro.com>
;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2019 Tim Gesthuizen <tim.gesthuizen@yahoo.de>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -25,6 +26,8 @@
#:use-module (gnu services)
#: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)
@@ -33,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)
@@ -48,7 +52,16 @@
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
- #:export (xorg-configuration-file
+ #:export (xorg-configuration
+ xorg-configuration?
+ xorg-configuration-modules
+ xorg-configuration-fonts
+ xorg-configuration-drivers
+ xorg-configuration-resolutions
+ xorg-configuration-extra-config
+ xorg-configuration-server
+ xorg-configuration-server-arguments
+
%default-xorg-modules
%default-xorg-fonts
xorg-wrapper
@@ -69,7 +82,8 @@
slim-configuration-xauth
slim-configuration-shepherd
slim-configuration-auto-login-session
- slim-configuration-startx
+ slim-configuration-xorg
+ slim-configuration-sessreg
slim-service-type
slim-service
@@ -79,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:
;;;
@@ -122,33 +141,38 @@
"/share/fonts/X11/misc")
(file-append font-adobe75dpi "/share/fonts/X11/75dpi")))
-(define* (xorg-configuration-file #:key
- (modules %default-xorg-modules)
- (fonts %default-xorg-fonts)
- (drivers '()) (resolutions '())
- (extra-config '()))
- "Return a configuration file for the Xorg server containing search paths for
-all the common drivers.
-
-@var{modules} must be a list of @dfn{module packages} loaded by the Xorg
-server---e.g., @code{xf86-video-vesa}, @code{xf86-input-keyboard}, and so on.
-@var{fonts} must be a list of font directories to add to the server's
-@dfn{font path}.
-
-@var{drivers} must be either the empty list, in which case Xorg chooses a
-graphics driver automatically, or a list of driver names that will be tried in
-this order---e.g., @code{(\"modesetting\" \"vesa\")}.
-
-Likewise, when @var{resolutions} is the empty list, Xorg chooses an
-appropriate screen resolution; otherwise, it must be a list of
-resolutions---e.g., @code{((1024 768) (640 480))}.
-
-Last, @var{extra-config} is a list of strings or objects appended to the
-configuration file. It is used to pass extra text to be
-added verbatim to the configuration file."
+(define %default-xorg-server-arguments
+ ;; Default command-line arguments for X.
+ '("-nolisten" "tcp"))
+
+;; Configuration of an Xorg server.
+(define-record-type* <xorg-configuration>
+ xorg-configuration make-xorg-configuration
+ xorg-configuration?
+ (modules xorg-configuration-modules ;list of packages
+ (default %default-xorg-modules))
+ (fonts xorg-configuration-fonts ;list of packges
+ (default %default-xorg-fonts))
+ (drivers xorg-configuration-drivers ;list of strings
+ (default '()))
+ (resolutions xorg-configuration-resolutions ;list of tuples
+ (default '()))
+ (keyboard-layout xorg-configuration-keyboard-layout ;#f | <keyboard-layout>
+ (default #f))
+ (extra-config xorg-configuration-extra-config ;list of strings
+ (default '()))
+ (server xorg-configuration-server ;package
+ (default xorg-server))
+ (server-arguments xorg-configuration-server-arguments ;list of strings
+ (default %default-xorg-server-arguments)))
+
+(define (xorg-configuration->file config)
+ "Compute an Xorg configuration file corresponding to CONFIG, an
+<xorg-configuration> record."
(define all-modules
;; 'xorg-server' provides 'fbdevhw.so' etc.
- (append modules (list xorg-server)))
+ (append (xorg-configuration-modules config)
+ (list xorg-server)))
(define build
#~(begin
@@ -159,7 +183,7 @@ added verbatim to the configuration file."
(call-with-output-file #$output
(lambda (port)
(define drivers
- '#$drivers)
+ '#$(xorg-configuration-drivers config))
(define (device-section driver)
(string-append "
@@ -183,6 +207,31 @@ Section \"Screen\"
EndSubSection
EndSection"))
+ (define (input-class-section layout variant model options)
+ (string-append "
+Section \"InputClass\"
+ Identifier \"evdev keyboard catchall\"
+ MatchIsKeyboard \"on\"
+ Option \"XkbLayout\" " (object->string layout)
+ (if variant
+ (string-append " Option \"XkbVariant\" \""
+ variant "\"")
+ "")
+ (if model
+ (string-append " Option \"XkbModel\" \""
+ model "\"")
+ "")
+ (match options
+ (()
+ "")
+ (_
+ (string-append " Option \"XkbOptions\" \""
+ (string-join options ",") "\""))) "
+
+ MatchDevicePath \"/dev/input/event*\"
+ Driver \"evdev\"
+EndSection\n"))
+
(define (expand modules)
;; Append to MODULES the relevant /lib/xorg/modules
;; sub-directories.
@@ -201,7 +250,7 @@ EndSection"))
(display "Section \"Files\"\n" port)
(for-each (lambda (font)
(format port " FontPath \"~a\"~%" font))
- '#$fonts)
+ '#$(xorg-configuration-fonts config))
(for-each (lambda (module)
(format port
" ModulePath \"~a\"~%"
@@ -221,19 +270,32 @@ EndSection\n" port)
port)
(newline port)
(display (string-join
- (map (cut screen-section <> '#$resolutions)
+ (map (cut screen-section <>
+ '#$(xorg-configuration-resolutions config))
drivers)
"\n")
port)
(newline port)
+ (let ((layout #$(and=> (xorg-configuration-keyboard-layout config)
+ keyboard-layout-name))
+ (variant #$(and=> (xorg-configuration-keyboard-layout config)
+ keyboard-layout-variant))
+ (model #$(and=> (xorg-configuration-keyboard-layout config)
+ keyboard-layout-model))
+ (options '#$(and=> (xorg-configuration-keyboard-layout config)
+ keyboard-layout-options)))
+ (when layout
+ (display (input-class-section layout variant model options)
+ port)
+ (newline port)))
+
(for-each (lambda (config)
(display config port))
- '#$extra-config)))))
+ '#$(xorg-configuration-extra-config config))))))
(computed-file "xserver.conf" build))
-
(define (xorg-configuration-directory modules)
"Return a directory that contains the @code{.conf} files for X.org that
includes the @code{share/X11/xorg.conf.d} directories of each package listed
@@ -260,61 +322,43 @@ in @var{modules}."
files)
#t))))
-(define* (xorg-wrapper #:key
- (guile (canonical-package guile-2.0))
- (modules %default-xorg-modules)
- (configuration-file (xorg-configuration-file
- #:modules modules))
- (xorg-server xorg-server))
- "Return a derivation that builds a @var{guile} script to start the X server
-from @var{xorg-server}. @var{configuration-file} is the server configuration
-file or a derivation that builds it; when omitted, the result of
-@code{xorg-configuration-file} is used. The resulting script should be used
-in place of @code{/usr/bin/X}."
+(define* (xorg-wrapper #:optional (config (xorg-configuration)))
+ "Return a derivation that builds a script to start the X server with the
+given @var{config}. The resulting script should be used in place of
+@code{/usr/bin/X}."
(define exp
;; Write a small wrapper around the X server.
#~(begin
(setenv "XORG_DRI_DRIVER_PATH" (string-append #$mesa "/lib/dri"))
(setenv "XKB_BINDIR" (string-append #$xkbcomp "/bin"))
- (let ((X (string-append #$xorg-server "/bin/X")))
+ (let ((X (string-append #$(xorg-configuration-server config) "/bin/X")))
(apply execl X X
"-xkbdir" (string-append #$xkeyboard-config "/share/X11/xkb")
- "-config" #$configuration-file
- "-configdir" #$(xorg-configuration-directory modules)
+ "-config" #$(xorg-configuration->file config)
+ "-configdir" #$(xorg-configuration-directory
+ (xorg-configuration-modules config))
(cdr (command-line))))))
(program-file "X-wrapper" exp))
-(define* (xorg-start-command #:key
- (guile (canonical-package guile-2.0))
- (modules %default-xorg-modules)
- (fonts %default-xorg-fonts)
- (configuration-file
- (xorg-configuration-file #:modules modules
- #:fonts fonts))
- (xorg-server xorg-server)
- (xserver-arguments '("-nolisten" "tcp")))
- "Return a @code{startx} script in which @var{modules}, a list of X module
-packages, and @var{fonts}, a list of X font directories, are available. See
-@code{xorg-wrapper} for more details on the arguments. The result should be
-used in place of @code{startx}."
+(define* (xorg-start-command #:optional (config (xorg-configuration)))
+ "Return a @code{startx} script in which the modules, fonts, etc. specified
+in @var{config}, are available. The result should be used in place of
+@code{startx}."
(define X
- (xorg-wrapper #:guile guile
- #:configuration-file configuration-file
- #:modules modules
- #:xorg-server xorg-server))
+ (xorg-wrapper config))
+
(define exp
;; Write a small wrapper around the X server.
#~(apply execl #$X #$X ;; Second #$X is for argv[0].
- "-logverbose" "-verbose" "-terminate" #$@xserver-arguments
+ "-logverbose" "-verbose" "-terminate"
+ #$@(xorg-configuration-server-arguments config)
(cdr (command-line))))
(program-file "startx" exp))
-(define* (xinitrc #:key
- (guile (canonical-package guile-2.0))
- fallback-session)
+(define* (xinitrc #:key fallback-session)
"Return a system-wide xinitrc script that starts the specified X session,
which should be passed to this script as the first argument. If not, the
@var{fallback-session} will be used or, if @var{fallback-session} is false, a
@@ -442,8 +486,8 @@ desktop session from the system or user profile will be used."
(default shepherd))
(auto-login-session slim-configuration-auto-login-session
(default #f))
- (startx slim-configuration-startx
- (default (xorg-start-command)))
+ (xorg-configuration slim-configuration-xorg
+ (default (xorg-configuration)))
(sessreg slim-configuration-sessreg
(default sessreg)))
@@ -458,9 +502,8 @@ desktop session from the system or user profile will be used."
(define slim.cfg
(let ((xinitrc (xinitrc #:fallback-session
(slim-configuration-auto-login-session config)))
- (slim (slim-configuration-slim config))
(xauth (slim-configuration-xauth config))
- (startx (slim-configuration-startx config))
+ (startx (xorg-start-command (slim-configuration-xorg config)))
(shepherd (slim-configuration-shepherd config))
(theme-name (slim-configuration-theme-name config))
(sessreg (slim-configuration-sessreg config)))
@@ -503,7 +546,9 @@ reboot_cmd " shepherd "/sbin/reboot\n"
(false-if-exception (delete-file "/var/run/slim.lock"))
(fork+exec-command
- (list (string-append #$slim "/bin/slim") "-nodaemon")
+ (list (string-append #$(slim-configuration-slim config)
+ "/bin/slim")
+ "-nodaemon")
#:environment-variables
(list (string-append "SLIM_CFGFILE=" #$slim.cfg)
#$@(if theme
@@ -567,8 +612,7 @@ theme."
(auto-login? auto-login?) (default-user default-user)
(theme theme) (theme-name theme-name)
(xauth xauth) (shepherd shepherd)
- (auto-login-session auto-login-session)
- (startx startx))))
+ (auto-login-session auto-login-session))))
;;;
@@ -617,6 +661,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
@@ -647,8 +773,8 @@ makes the good ol' XlockMore usable."
(default-user gdm-configuration-default-user (default #f))
(gnome-shell-assets gdm-configuration-gnome-shell-assets
(default (list adwaita-icon-theme font-cantarell)))
- (x-server gdm-configuration-x-server
- (default (xorg-wrapper)))
+ (xorg-configuration gdm-configuration-xorg
+ (default (xorg-configuration)))
(x-session gdm-configuration-x-session
(default (xinitrc))))
@@ -720,7 +846,8 @@ makes the good ol' XlockMore usable."
#$(gdm-configuration-dbus-daemon config))
(string-append
"GDM_X_SERVER="
- #$(gdm-configuration-x-server config))
+ #$(xorg-wrapper
+ (gdm-configuration-xorg config)))
(string-append
"GDM_X_SESSION="
#$(gdm-configuration-x-session config))
@@ -750,15 +877,31 @@ 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
you to log in in a graphical session, whether or not you use GNOME.")))
-;; This service isn't working yet; it gets as far as starting to run the
-;; greeter from gnome-shell but doesn't get any further. It is here because
-;; it doesn't hurt anyone and perhaps it inspires someone to fix it :)
(define-deprecated (gdm-service #:key (gdm gdm)
(allow-empty-passwords? #t)
(x-server (xorg-wrapper)))
@@ -785,7 +928,16 @@ password."
(service gdm-service-type
(gdm-configuration
(gdm gdm)
- (allow-empty-passwords? allow-empty-passwords?)
- (x-server x-server))))
+ (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
generated by cgit v1.2.3 (git 2.45.0) at 2024-11-16 18:02:26 +0000