diff options
Diffstat (limited to 'gnu/services')
| -rw-r--r-- | gnu/services/avahi.scm | 35 | ||||
| -rw-r--r-- | gnu/services/base.scm | 222 | ||||
| -rw-r--r-- | gnu/services/dbus.scm | 105 | ||||
| -rw-r--r-- | gnu/services/desktop.scm | 258 | ||||
| -rw-r--r-- | gnu/services/dmd.scm | 143 | ||||
| -rw-r--r-- | gnu/services/networking.scm | 221 | ||||
| -rw-r--r-- | gnu/services/ssh.scm | 7 | ||||
| -rw-r--r-- | gnu/services/xorg.scm | 66 |
8 files changed, 821 insertions, 236 deletions
diff --git a/gnu/services/avahi.scm b/gnu/services/avahi.scm index 18131fe561..49a737f090 100644 --- a/gnu/services/avahi.scm +++ b/gnu/services/avahi.scm @@ -107,19 +107,24 @@ (stop #~(make-kill-destructor)))))) (define avahi-service-type - (service-type (name 'avahi) - (extensions - (list (service-extension dmd-root-service-type - avahi-dmd-service) - (service-extension dbus-root-service-type - (compose list - avahi-configuration-avahi)) - (service-extension account-service-type - (const %avahi-accounts)) - (service-extension activation-service-type - (const %avahi-activation)) - (service-extension nscd-service-type - (const (list nss-mdns))))))) + (let ((avahi-package (compose list avahi-configuration-avahi))) + (service-type (name 'avahi) + (extensions + (list (service-extension dmd-root-service-type + avahi-dmd-service) + (service-extension dbus-root-service-type + avahi-package) + (service-extension account-service-type + (const %avahi-accounts)) + (service-extension activation-service-type + (const %avahi-activation)) + (service-extension nscd-service-type + (const (list nss-mdns))) + + ;; Provide 'avahi-browse', 'avahi-resolve', etc. in + ;; the system profile. + (service-extension profile-service-type + avahi-package)))))) (define* (avahi-service #:key (avahi avahi) host-name @@ -132,7 +137,9 @@ mDNS/DNS-SD responder that allows for service discovery and \"zero-configuration\" host name lookups (see @uref{http://avahi.org/}), and extends the name service cache daemon (nscd) so that it can resolve @code{.local} host names using -@uref{http://0pointer.de/lennart/projects/nss-mdns/, nss-mdns}. +@uref{http://0pointer.de/lennart/projects/nss-mdns/, nss-mdns}. Additionally, +add the @var{avahi} package to the system profile so that commands such as +@command{avahi-browse} are directly usable. If @var{host-name} is different from @code{#f}, use that as the host name to publish for this machine; otherwise, use the machine's actual host name. diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 336cc4dec9..a86e8e04c7 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,12 +24,12 @@ #:use-module (gnu services) #:use-module (gnu services dmd) #:use-module (gnu services networking) + #:use-module (gnu system pam) #:use-module (gnu system shadow) ; 'user-account', etc. - #:use-module (gnu system linux) ; 'pam-service', etc. #:use-module (gnu system file-systems) ; 'file-system', etc. #:use-module (gnu packages admin) #:use-module ((gnu packages linux) - #:select (eudev kbd e2fsprogs lvm2 fuse alsa-utils crda)) + #:select (eudev kbd e2fsprogs lvm2 fuse alsa-utils crda gpm)) #:use-module ((gnu packages base) #:select (canonical-package glibc)) #:use-module (gnu packages package-management) @@ -48,15 +49,23 @@ device-mapping-service swap-service user-processes-service + session-environment-service + session-environment-service-type host-name-service console-keymap-service console-font-service + + udev-configuration + udev-configuration? + udev-configuration-rules udev-service-type udev-service + udev-rule mingetty-configuration mingetty-configuration? mingetty-service + mingetty-service-type %nscd-default-caches %nscd-default-configuration @@ -74,6 +83,13 @@ guix-configuration guix-configuration? guix-service + guix-service-type + guix-publish-configuration + guix-publish-configuration? + guix-publish-service + guix-publish-service-type + gpm-service-type + gpm-service %base-services)) @@ -142,6 +158,18 @@ FILE-SYSTEM." (symbol-append 'file-system- (string->symbol (file-system-mount-point file-system)))) +(define (mapped-device->dmd-service-name md) + "Return the symbol that denotes the dmd service of MD, a <mapped-device>." + (symbol-append 'device-mapping- + (string->symbol (mapped-device-target md)))) + +(define dependency->dmd-service-name + (match-lambda + ((? mapped-device? md) + (mapped-device->dmd-service-name md)) + ((? file-system? fs) + (file-system->dmd-service-name fs)))) + (define file-system-service-type ;; TODO(?): Make this an extensible service that takes <file-system> objects ;; and returns a list of <dmd-service>. @@ -158,7 +186,7 @@ FILE-SYSTEM." (dmd-service (provision (list (file-system->dmd-service-name file-system))) (requirement `(root-file-system - ,@(map file-system->dmd-service-name dependencies))) + ,@(map dependency->dmd-service-name dependencies))) (documentation "Check, mount, and unmount the given file system.") (start #~(lambda args ;; FIXME: Use or factorize with 'mount-file-system'. @@ -198,7 +226,14 @@ FILE-SYSTEM." (chdir "/") (umount #$target) - #f))))))) + #f)) + + ;; We need an additional module. + (modules `(((gnu build file-systems) + #:select (check-file-system canonicalize-device-spec)) + ,@%default-modules)) + (imported-modules `((gnu build file-systems) + ,@%default-imported-modules))))))) (define* (file-system-service file-system) "Return a service that mounts @var{file-system}, a @code{<file-system>} @@ -336,6 +371,39 @@ stopped before 'kill' is called." ;;; +;;; System-wide environment variables. +;;; + +(define (environment-variables->environment-file vars) + "Return a file for pam_env(8) that contains environment variables VARS." + (apply mixed-text-file "environment" + (append-map (match-lambda + ((key . value) + (list key "=" value "\n"))) + vars))) + +(define session-environment-service-type + (service-type + (name 'session-environment) + (extensions + (list (service-extension + etc-service-type + (lambda (vars) + (list `("environment" + ,(environment-variables->environment-file vars))))))) + (compose concatenate) + (extend append))) + +(define (session-environment-service vars) + "Return a service that builds the @file{/etc/environment}, which can be read +by PAM-aware applications to set environment variables for sessions. + +VARS should be an association list in which both the keys and the values are +strings or string-valued gexps." + (service session-environment-service-type vars)) + + +;;; ;;; Console & co. ;;; @@ -691,6 +759,11 @@ If configuration file name @var{config-file} is not specified, use some reasonable default settings." (service syslog-service-type config-file)) + +;;; +;;; Guix services. +;;; + (define* (guix-build-accounts count #:key (group "guixbuild") (first-uid 30001) @@ -751,6 +824,8 @@ failed to register hydra.gnu.org public key: ~a~%" status)))))))) (default #t)) (use-substitutes? guix-configuration-use-substitutes? ;Boolean (default #t)) + (substitute-urls guix-configuration-substitute-urls ;list of strings + (default %default-substitute-urls)) (extra-options guix-configuration-extra-options ;list of strings (default '())) (lsof guix-configuration-lsof ;<package> @@ -765,7 +840,8 @@ failed to register hydra.gnu.org public key: ~a~%" status)))))))) "Return a <dmd-service> for the Guix daemon service with CONFIG." (match config (($ <guix-configuration> guix build-group build-accounts authorize-key? - use-substitutes? extra-options lsof lsh) + use-substitutes? substitute-urls extra-options + lsof lsh) (list (dmd-service (documentation "Run the Guix daemon.") (provision '(guix-daemon)) @@ -777,6 +853,7 @@ failed to register hydra.gnu.org public key: ~a~%" status)))))))) #$@(if use-substitutes? '() '("--no-substitutes")) + "--substitute-urls" #$(string-join substitute-urls) #$@extra-options) ;; Add 'lsof' (for the GC) and 'lsh' (for offloading) to the @@ -824,6 +901,58 @@ failed to register hydra.gnu.org public key: ~a~%" status)))))))) @var{config}." (service guix-service-type config)) + +(define-record-type* <guix-publish-configuration> + guix-publish-configuration make-guix-publish-configuration + guix-publish-configuration? + (guix guix-publish-configuration-guix ;package + (default guix)) + (port guix-publish-configuration-port ;number + (default 80)) + (host guix-publish-configuration-host ;string + (default "localhost"))) + +(define guix-publish-dmd-service + (match-lambda + (($ <guix-publish-configuration> guix port host) + (list (dmd-service + (provision '(guix-publish)) + (requirement '(guix-daemon)) + (start #~(make-forkexec-constructor + (list (string-append #$guix "/bin/guix") + "publish" "-u" "guix-publish" + "-p" #$(number->string port) + (string-append "--listen=" #$host)))) + (stop #~(make-kill-destructor))))))) + +(define %guix-publish-accounts + (list (user-group (name "guix-publish") (system? #t)) + (user-account + (name "guix-publish") + (group "guix-publish") + (system? #t) + (comment "guix publish user") + (home-directory "/var/empty") + (shell #~(string-append #$shadow "/sbin/nologin"))))) + +(define guix-publish-service-type + (service-type (name 'guix-publish) + (extensions + (list (service-extension dmd-root-service-type + guix-publish-dmd-service) + (service-extension account-service-type + (const %guix-publish-accounts)))))) + +(define* (guix-publish-service #:key (guix guix) (port 80) (host "localhost")) + "Return a service that runs @command{guix publish} listening on @var{host} +and @var{port} (@pxref{Invoking guix publish}). + +This assumes that @file{/etc/guix} already contains a signing key pair as +created by @command{guix archive --generate-key} (@pxref{Invoking guix +archive}). If that is not the case, the service will fail to start." + (service guix-publish-service-type + (guix-publish-configuration (guix guix) (port port) (host host)))) + ;;; ;;; Udev. @@ -864,12 +993,9 @@ item of @var{packages}." #:modules '((guix build union) (guix build utils)))) -(define* (kvm-udev-rule) - "Return a directory with a udev rule that changes the group of -@file{/dev/kvm} to \"kvm\" and makes it #o660." - ;; Apparently QEMU-KVM used to ship this rule, but now we have to add it by - ;; ourselves. - (computed-file "kvm-udev-rules" +(define (udev-rule file-name contents) + "Return a directory with a udev rule file FILE-NAME containing CONTENTS." + (computed-file file-name #~(begin (use-modules (guix build utils)) @@ -878,20 +1004,26 @@ item of @var{packages}." (mkdir-p rules.d) (call-with-output-file - (string-append rules.d "/90-kvm.rules") + (string-append rules.d "/" #$file-name) (lambda (port) - ;; Build users are part of the "kvm" group, so we - ;; can fearlessly make /dev/kvm 660 (see - ;; <http://bugs.gnu.org/18994>, for background.) - (display "\ -KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n" port)))) + (display #$contents port)))) #:modules '((guix build utils)))) +(define kvm-udev-rule + ;; Return a directory with a udev rule that changes the group of /dev/kvm to + ;; "kvm" and makes it #o660. Apparently QEMU-KVM used to ship this rule, + ;; but now we have to add it by ourselves. + + ;; Build users are part of the "kvm" group, so we can fearlessly make + ;; /dev/kvm 660 (see <http://bugs.gnu.org/18994>, for background.) + (udev-rule "90-kvm.rules" + "KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n")) + (define udev-dmd-service ;; Return a <dmd-service> for UDEV with RULES. (match-lambda (($ <udev-configuration> udev rules) - (let* ((rules (udev-rules-union (cons* udev (kvm-udev-rule) rules))) + (let* ((rules (udev-rules-union (cons* udev kvm-udev-rule rules))) (udev.conf (computed-file "udev.conf" #~(call-with-output-file #$output (lambda (port) @@ -1034,6 +1166,60 @@ gexp, to open it, and evaluate @var{close} to close it." "Return a service that uses @var{device} as a swap device." (service swap-service-type device)) + +(define-record-type* <gpm-configuration> + gpm-configuration make-gpm-configuration gpm-configuration? + (gpm gpm-configuration-gpm) ;package + (options gpm-configuration-options)) ;list of strings + +(define gpm-dmd-service + (match-lambda + (($ <gpm-configuration> gpm options) + (list (dmd-service + (requirement '(udev)) + (provision '(gpm)) + (start #~(lambda () + ;; 'gpm' runs in the background and sets a PID file. + ;; Note that it requires running as "root". + (false-if-exception (delete-file "/var/run/gpm.pid")) + (fork+exec-command (list (string-append #$gpm "/sbin/gpm") + #$@options)) + + ;; Wait for the PID file to appear; declare failure if + ;; it doesn't show up. + (let loop ((i 3)) + (or (file-exists? "/var/run/gpm.pid") + (if (zero? i) + #f + (begin + (sleep 1) + (loop (1- i)))))))) + + (stop #~(lambda (_) + ;; Return #f if successfully stopped. + (not (zero? (system* (string-append #$gpm "/sbin/gpm") + "-k")))))))))) + +(define gpm-service-type + (service-type (name 'gpm) + (extensions + (list (service-extension dmd-root-service-type + gpm-dmd-service))))) + +(define* (gpm-service #:key (gpm gpm) + (options '("-m" "/dev/input/mice" "-t" "ps2"))) + "Run @var{gpm}, the general-purpose mouse daemon, with the given +command-line @var{options}. GPM allows users to use the mouse in the console, +notably to select, copy, and paste text. The default value of @var{options} +uses the @code{ps2} protocol, which works for both USB and PS/2 mice. + +This service is not part of @var{%base-services}." + ;; To test in QEMU, use "-usbdevice mouse" and then, in the monitor, use + ;; "info mice" and "mouse_set X" to use the right mouse. + (service gpm-service-type + (gpm-configuration (gpm gpm) (options options)))) + + (define %base-services ;; Convenience variable holding the basic services. (let ((motd (plain-file "motd" " diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm index e4ecd961c5..9b0d198683 100644 --- a/gnu/services/dbus.scm +++ b/gnu/services/dbus.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,7 +21,7 @@ #:use-module (gnu services) #:use-module (gnu services dmd) #:use-module (gnu system shadow) - #:use-module (gnu packages glib) + #:use-module ((gnu packages glib) #:select (dbus/activation)) #:use-module (gnu packages admin) #:use-module (guix gexp) #:use-module (guix records) @@ -37,13 +38,38 @@ dbus-configuration make-dbus-configuration dbus-configuration? (dbus dbus-configuration-dbus ;<package> - (default dbus)) + (default dbus/activation)) (services dbus-configuration-services ;list of <package> (default '()))) -(define (dbus-configuration-directory dbus services) - "Return a configuration directory for @var{dbus} that includes the -@code{etc/dbus-1/system.d} directories of each package listed in +(define (system-service-directory services) + "Return the system service directory, containing @code{.service} files for +all the services that may be activated by the daemon." + (computed-file "dbus-system-services" + #~(begin + (use-modules (guix build utils) + (srfi srfi-1)) + + (define files + (append-map (lambda (service) + (find-files (string-append + service + "/share/dbus-1/system-services") + "\\.service$")) + (list #$@services))) + + (mkdir #$output) + (for-each (lambda (file) + (symlink file + (string-append #$output "/" + (basename file)))) + files) + #t) + #:modules '((guix build utils)))) + +(define (dbus-configuration-directory services) + "Return a directory contains the @code{system-local.conf} file for DBUS that +includes the @code{etc/dbus-1/system.d} directories of each package listed in @var{services}." (define build #~(begin @@ -53,24 +79,27 @@ (define (services->sxml services) ;; Return the SXML 'includedir' clauses for DIRS. `(busconfig + (servicehelper "/run/setuid-programs/dbus-daemon-launch-helper") + + ;; First, the '.service' files of services subject to activation. + ;; We use a fixed location under /etc because the setuid helper + ;; looks for them in that location and nowhere else. See + ;; <https://bugs.freedesktop.org/show_bug.cgi?id=92458>. + (servicedir "/etc/dbus-1/system-services") + ,@(append-map (lambda (dir) `((includedir ,(string-append dir "/etc/dbus-1/system.d")) - (servicedir ;for '.service' files - ,(string-append dir "/share/dbus-1/services")) - (servicedir ;likewise, for auto-activation - ,(string-append - dir - "/share/dbus-1/system-services")))) + (servicedir ;for '.service' files + ,(string-append dir "/share/dbus-1/services")))) services))) (mkdir #$output) - (copy-file (string-append #$dbus "/etc/dbus-1/system.conf") - (string-append #$output "/system.conf")) - ;; The default 'system.conf' has an <includedir> clause for - ;; 'system.d', so create it. - (mkdir (string-append #$output "/system.d")) + ;; Provide /etc/dbus-1/system-services, which is where the setuid + ;; helper looks for system service files. + (symlink #$(system-service-directory services) + (string-append #$output "/system-services")) ;; 'system-local.conf' is automatically included by the default ;; 'system.conf', so this is where we stuff our own things. @@ -81,6 +110,12 @@ (computed-file "dbus-configuration" build)) +(define (dbus-etc-files config) + "Return a list of FILES for @var{etc-service-type} to build the +@code{/etc/dbus-1} directory." + (list `("dbus-1" ,(dbus-configuration-directory + (dbus-configuration-services config))))) + (define %dbus-accounts ;; Accounts used by the system bus. (list (user-group (name "messagebus") (system? #t)) @@ -92,6 +127,12 @@ (home-directory "/var/run/dbus") (shell #~(string-append #$shadow "/sbin/nologin"))))) +(define dbus-setuid-programs + ;; Return the file name of the setuid program that we need. + (match-lambda + (($ <dbus-configuration> dbus services) + (list #~(string-append #$dbus "/libexec/dbus-daemon-launch-helper"))))) + (define (dbus-activation config) "Return an activation gexp for D-Bus using @var{config}." #~(begin @@ -120,18 +161,15 @@ (define dbus-dmd-service (match-lambda - (($ <dbus-configuration> dbus services) - (let ((conf (dbus-configuration-directory dbus services))) - (list (dmd-service - (documentation "Run the D-Bus system daemon.") - (provision '(dbus-system)) - (requirement '(user-processes)) - (start #~(make-forkexec-constructor - (list (string-append #$dbus "/bin/dbus-daemon") - "--nofork" - (string-append "--config-file=" #$conf - "/system.conf")))) - (stop #~(make-kill-destructor)))))))) + (($ <dbus-configuration> dbus) + (list (dmd-service + (documentation "Run the D-Bus system daemon.") + (provision '(dbus-system)) + (requirement '(user-processes)) + (start #~(make-forkexec-constructor + (list (string-append #$dbus "/bin/dbus-daemon") + "--nofork" "--system"))) + (stop #~(make-kill-destructor))))))) (define dbus-root-service-type (service-type (name 'dbus) @@ -140,14 +178,15 @@ dbus-dmd-service) (service-extension activation-service-type dbus-activation) + (service-extension etc-service-type + dbus-etc-files) (service-extension account-service-type - (const %dbus-accounts)))) + (const %dbus-accounts)) + (service-extension setuid-program-service-type + dbus-setuid-programs))) ;; Extensions consist of lists of packages (representing D-Bus ;; services) that we just concatenate. - ;; - ;; FIXME: We need 'dbus-daemon-launch-helper' to be - ;; setuid-root for auto-activation to work. (compose concatenate) ;; The service's parameters field is extended by augmenting @@ -159,7 +198,7 @@ (append (dbus-configuration-services config) services))))))) -(define* (dbus-service #:key (dbus dbus) (services '())) +(define* (dbus-service #:key (dbus dbus/activation) (services '())) "Return a service that runs the \"system bus\", using @var{dbus}, with support for @var{services}. diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm index 69edc6d9bb..694a8eda7e 100644 --- a/gnu/services/desktop.scm +++ b/gnu/services/desktop.scm @@ -27,13 +27,15 @@ #:use-module (gnu services xorg) #:use-module (gnu services networking) #:use-module (gnu system shadow) - #:use-module (gnu system linux) ; unix-pam-service + #:use-module (gnu system pam) #:use-module (gnu packages glib) #:use-module (gnu packages admin) #:use-module (gnu packages freedesktop) #:use-module (gnu packages gnome) #:use-module (gnu packages avahi) #:use-module (gnu packages polkit) + #:use-module (gnu packages xdisorg) + #:use-module (gnu packages suckless) #:use-module (guix records) #:use-module (guix packages) #:use-module (guix store) @@ -41,6 +43,7 @@ #:use-module (srfi srfi-1) #:use-module (ice-9 match) #:export (upower-service + udisks-service colord-service geoclue-application %standard-geoclue-applications @@ -224,65 +227,6 @@ levels, with the given configuration settings. It implements the ;;; -;;; Colord D-Bus service. -;;; - -(define %colord-activation - #~(begin - (use-modules (guix build utils)) - (mkdir-p "/var/lib/colord") - (let ((user (getpwnam "colord"))) - (chown "/var/lib/colord" - (passwd:uid user) (passwd:gid user))))) - -(define %colord-accounts - (list (user-group (name "colord") (system? #t)) - (user-account - (name "colord") - (group "colord") - (system? #t) - (comment "colord daemon user") - (home-directory "/var/empty") - (shell #~(string-append #$shadow "/sbin/nologin"))))) - -(define (colord-dmd-service colord) - "Return a dmd service for COLORD." - ;; TODO: Remove when D-Bus activation works. - (list (dmd-service - (documentation "Run the colord color management service.") - (provision '(colord-daemon)) - (requirement '(dbus-system udev)) - (start #~(make-forkexec-constructor - (list (string-append #$colord "/libexec/colord")))) - (stop #~(make-kill-destructor))))) - -(define colord-service-type - (service-type (name 'colord) - (extensions - (list (service-extension account-service-type - (const %colord-accounts)) - (service-extension activation-service-type - (const %colord-activation)) - (service-extension dmd-root-service-type - colord-dmd-service) - - ;; Colord is a D-Bus service that dbus-daemon can - ;; activate. - (service-extension dbus-root-service-type list) - - ;; Colord provides "color device" rules for udev. - (service-extension udev-service-type list))))) - -(define* (colord-service #:key (colord colord)) - "Return a service that runs @command{colord}, a system service with a D-Bus -interface to manage the color profiles of input and output devices such as -screens and scanners. It is notably used by the GNOME Color Manager graphical -tool. See @uref{http://www.freedesktop.org/software/colord/, the colord web -site} for more information." - (service colord-service-type colord)) - - -;;; ;;; GeoClue D-Bus service. ;;; @@ -343,23 +287,6 @@ users are allowed." "GEOCLUE_CONFIG_FILE" (geoclue-configuration-file config)))) -(define (geoclue-dmd-service config) - "Return a GeoClue dmd service for CONFIG." - ;; TODO: Remove when D-Bus activation works. - (let ((geoclue (geoclue-configuration-geoclue config)) - (config (geoclue-configuration-file config))) - (list (dmd-service - (documentation "Run the GeoClue location service.") - (provision '(geoclue-daemon)) - (requirement '(dbus-system)) - - (start #~(make-forkexec-constructor - (list (string-append #$geoclue "/libexec/geoclue")) - #:user "geoclue" - #:environment-variables - (list (string-append "GEOCLUE_CONFIG_FILE=" #$config)))) - (stop #~(make-kill-destructor)))))) - (define %geoclue-accounts (list (user-group (name "geoclue") (system? #t)) (user-account @@ -375,8 +302,6 @@ users are allowed." (extensions (list (service-extension dbus-root-service-type geoclue-dbus-service) - (service-extension dmd-root-service-type - geoclue-dmd-service) (service-extension account-service-type (const %geoclue-accounts)))))) @@ -413,6 +338,14 @@ site} for more information." ;;; Polkit privilege management service. ;;; +(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> + (default '()))) + (define %polkit-accounts (list (user-group (name "polkitd") (system? #t)) (user-account @@ -424,23 +357,34 @@ site} for more information." (shell "/run/current-system/profile/sbin/nologin")))) (define %polkit-pam-services - (list (unix-pam-service "polkitd"))) + (list (unix-pam-service "polkit-1"))) -(define (polkit-dmd-service polkit) - "Return the <dmd-service> for POLKIT." - ;; TODO: Remove when D-Bus activation works. - (list (dmd-service - (documentation "Run the polkit privilege management service.") - (provision '(polkit-daemon)) - (requirement '(dbus-system)) +(define (polkit-directory packages) + "Return a directory containing an @file{actions} and possibly a +@file{rules.d} sub-directory, for use as @file{/etc/polkit-1}." + (computed-file "etc-polkit-1" + #~(begin + (use-modules (guix build union) (srfi srfi-26)) + + (union-build #$output + (map (cut string-append <> + "/share/polkit-1") + (list #$@packages)))) + #:modules '((guix build union)))) - (start #~(make-forkexec-constructor - (list (string-append #$polkit "/lib/polkit-1/polkitd")))) - (stop #~(make-kill-destructor))))) +(define polkit-etc-files + (match-lambda + (($ <polkit-configuration> polkit packages) + `(("polkit-1" ,(polkit-directory packages)))))) + +(define polkit-setuid-programs + (match-lambda + (($ <polkit-configuration> polkit) + (list #~(string-append #$polkit + "/lib/polkit-1/polkit-agent-helper-1") + #~(string-append #$polkit "/bin/pkexec"))))) (define polkit-service-type - ;; TODO: Make it extensible so it can collect policy files from other - ;; services. (service-type (name 'polkit) (extensions (list (service-extension account-service-type @@ -448,17 +392,118 @@ site} for more information." (service-extension pam-root-service-type (const %polkit-pam-services)) (service-extension dbus-root-service-type - list) - (service-extension dmd-root-service-type - polkit-dmd-service))))) + (compose + list + polkit-configuration-polkit)) + (service-extension etc-service-type + polkit-etc-files) + (service-extension setuid-program-service-type + polkit-setuid-programs))) + + ;; Extensions are lists of packages that provide polkit rules + ;; or actions under share/polkit-1/{actions,rules.d}. + (compose concatenate) + (extend (lambda (config actions) + (polkit-configuration + (inherit config) + (actions + (append (polkit-configuration-actions config) + actions))))))) (define* (polkit-service #:key (polkit polkit)) - "Return a service that runs the @command{polkit} privilege management -service. By querying the @command{polkit} service, a privileged system -component can know when it should grant additional capabilities to ordinary -users. For example, an ordinary user can be granted the capability to suspend -the system if the user is logged in locally." - (service polkit-service-type polkit)) + "Return a service that runs the +@uref{http://www.freedesktop.org/wiki/Software/polkit/, Polkit privilege +management service}, which allows system administrators to grant access to +privileged operations in a structured way. By querying the Polkit service, a +privileged system component can know when it should grant additional +capabilities to ordinary users. For example, an ordinary user can be granted +the capability to suspend the system if the user is logged in locally." + (service polkit-service-type + (polkit-configuration (polkit polkit)))) + + +;;; +;;; Colord D-Bus service. +;;; + +(define %colord-activation + #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/lib/colord") + (let ((user (getpwnam "colord"))) + (chown "/var/lib/colord" + (passwd:uid user) (passwd:gid user))))) + +(define %colord-accounts + (list (user-group (name "colord") (system? #t)) + (user-account + (name "colord") + (group "colord") + (system? #t) + (comment "colord daemon user") + (home-directory "/var/empty") + (shell #~(string-append #$shadow "/sbin/nologin"))))) + +(define colord-service-type + (service-type (name 'colord) + (extensions + (list (service-extension account-service-type + (const %colord-accounts)) + (service-extension activation-service-type + (const %colord-activation)) + + ;; Colord is a D-Bus service that dbus-daemon can + ;; activate. + (service-extension dbus-root-service-type list) + + ;; Colord provides "color device" rules for udev. + (service-extension udev-service-type list) + + ;; It provides polkit "actions". + (service-extension polkit-service-type list))))) + +(define* (colord-service #:key (colord colord)) + "Return a service that runs @command{colord}, a system service with a D-Bus +interface to manage the color profiles of input and output devices such as +screens and scanners. It is notably used by the GNOME Color Manager graphical +tool. See @uref{http://www.freedesktop.org/software/colord/, the colord web +site} for more information." + (service colord-service-type colord)) + + +;;; +;;; UDisks. +;;; + +(define-record-type* <udisks-configuration> + udisks-configuration make-udisks-configuration + udisks-configuration? + (udisks udisks-configuration-udisks + (default udisks))) + +(define udisks-service-type + (let ((udisks-package (lambda (config) + (list (udisks-configuration-udisks config))))) + (service-type (name 'udisks) + (extensions + (list (service-extension polkit-service-type + udisks-package) + (service-extension dbus-root-service-type + udisks-package) + (service-extension udev-service-type + udisks-package) + + ;; Profile 'udisksctl' & co. in the system profile. + (service-extension profile-service-type + udisks-package)))))) + +(define* (udisks-service #:key (udisks udisks)) + "Return a service for @uref{http://udisks.freedesktop.org/docs/latest/, +UDisks}, a @dfn{disk management} daemon that provides user interfaces with +notifications and ways to mount/unmount disks. Programs that talk to UDisks +include the @command{udisksctl} command, part of UDisks, and GNOME Disks." + (service udisks-service-type + (udisks-configuration (udisks udisks)))) ;;; @@ -601,6 +646,8 @@ the system if the user is logged in locally." (define (elogind-dmd-service config) "Return a dmd service for elogind, using @var{config}." + ;; TODO: We could probably rely on service activation but the '.service' + ;; file currently contains an erroneous 'Exec' line. (let ((config-file (elogind-configuration-file config)) (elogind (elogind-package config))) (list (dmd-service @@ -623,7 +670,9 @@ the system if the user is logged in locally." (compose list elogind-package)) (service-extension udev-service-type (compose list elogind-package)) - ;; TODO: Extend polkit(?) and PAM. + (service-extension polkit-service-type + (compose list elogind-package)) + ;; TODO: Extend PAM with pam_elogind.so. )))) (define* (elogind-service #:key (config (elogind-configuration))) @@ -643,9 +692,14 @@ when they log out." ;; List of services typically useful for a "desktop" use case. (cons* (slim-service) + ;; Screen lockers are a pretty useful thing and these are small. + (screen-locker-service slock) + (screen-locker-service xlockmore "xlock") + ;; The D-Bus clique. (avahi-service) (wicd-service) + (udisks-service) (upower-service) (colord-service) (geoclue-service) diff --git a/gnu/services/dmd.scm b/gnu/services/dmd.scm index e87b9e4415..545087acc9 100644 --- a/gnu/services/dmd.scm +++ b/gnu/services/dmd.scm @@ -45,6 +45,11 @@ dmd-service-start dmd-service-stop dmd-service-auto-start? + dmd-service-modules + dmd-service-imported-modules + + %default-imported-modules + %default-modules dmd-service-back-edges)) @@ -99,6 +104,18 @@ service that extends DMD-ROOT-SERVICE-TYPE and nothing else." (list (service-extension dmd-root-service-type (compose list proc)))))) +(define %default-imported-modules + ;; Default set of modules imported for a service's consumption. + '((guix build utils) + (guix build syscalls))) + +(define %default-modules + ;; Default set of modules visible in a service's file. + `((dmd service) + (oop goops) + (guix build utils) + (guix build syscalls))) + (define-record-type* <dmd-service> dmd-service make-dmd-service dmd-service? @@ -113,64 +130,106 @@ service that extends DMD-ROOT-SERVICE-TYPE and nothing else." (stop dmd-service-stop ;g-expression (procedure) (default #~(const #f))) (auto-start? dmd-service-auto-start? ;Boolean - (default #t))) + (default #t)) + (modules dmd-service-modules ;list of module names + (default %default-modules)) + (imported-modules dmd-service-imported-modules ;list of module names + (default %default-imported-modules))) -(define (assert-no-duplicates services) - "Raise an error if SERVICES provide the same dmd service more than once. +(define (assert-valid-graph services) + "Raise an error if SERVICES does not define a valid dmd service graph, for +instance if a service requires a nonexistent service, or if more than one +service uses a given name. -This is a constraint that dmd's 'register-service' verifies but we'd better -verify it here statically than wait until PID 1 halts with an assertion +These are constraints that dmd's 'register-service' verifies but we'd better +verify them here statically than wait until PID 1 halts with an assertion failure." - (fold (lambda (service set) - (define (assert-unique symbol) - (when (set-contains? set symbol) - (raise (condition - (&message - (message - (format #f (_ "service '~a' provided more than once") - symbol))))))) - - (for-each assert-unique (dmd-service-provision service)) - (fold set-insert set (dmd-service-provision service))) - (setq) - services)) + (define provisions + ;; The set of provisions (symbols). Bail out if a symbol is given more + ;; than once. + (fold (lambda (service set) + (define (assert-unique symbol) + (when (set-contains? set symbol) + (raise (condition + (&message + (message + (format #f (_ "service '~a' provided more than once") + symbol))))))) + + (for-each assert-unique (dmd-service-provision service)) + (fold set-insert set (dmd-service-provision service))) + (setq 'dmd) + services)) + + (define (assert-satisfied-requirements service) + ;; Bail out if the requirements of SERVICE aren't satisfied. + (for-each (lambda (requirement) + (unless (set-contains? provisions requirement) + (raise (condition + (&message + (message + (format #f (_ "service '~a' requires '~a', \ +which is undefined") + (match (dmd-service-provision service) + ((head . _) head) + (_ service)) + requirement))))))) + (dmd-service-requirement service))) + + (for-each assert-satisfied-requirements services)) + +(define (dmd-service-file-name service) + "Return the file name where the initialization code for SERVICE is to be +stored." + (let ((provisions (string-join (map symbol->string + (dmd-service-provision service))))) + (string-append "dmd-" + (string-map (match-lambda + (#\/ #\-) + (chr chr)) + provisions) + ".scm"))) + +(define (dmd-service-file service) + "Return a file defining SERVICE." + (gexp->file (dmd-service-file-name service) + #~(begin + (use-modules #$@(dmd-service-modules service)) + + (make <service> + #:docstring '#$(dmd-service-documentation service) + #:provides '#$(dmd-service-provision service) + #:requires '#$(dmd-service-requirement service) + #:respawn? '#$(dmd-service-respawn? service) + #:start #$(dmd-service-start service) + #:stop #$(dmd-service-stop service))))) (define (dmd-configuration-file services) "Return the dmd configuration file for SERVICES." (define modules - ;; Extra modules visible to dmd.conf. - '((guix build syscalls) - (gnu build file-systems) - (guix build utils))) + (delete-duplicates + (append-map dmd-service-imported-modules services))) - (assert-no-duplicates services) + (assert-valid-graph services) (mlet %store-monad ((modules (imported-modules modules)) - (compiled (compiled-modules modules))) + (compiled (compiled-modules modules)) + (files (mapm %store-monad dmd-service-file services))) (define config #~(begin (eval-when (expand load eval) (set! %load-path (cons #$modules %load-path)) (set! %load-compiled-path - (cons #$compiled %load-compiled-path))) - - (use-modules (ice-9 ftw) - (guix build syscalls) - (guix build utils) - ((gnu build file-systems) - #:select (check-file-system canonicalize-device-spec))) - - (register-services - #$@(map (lambda (service) - #~(make <service> - #:docstring '#$(dmd-service-documentation service) - #:provides '#$(dmd-service-provision service) - #:requires '#$(dmd-service-requirement service) - #:respawn? '#$(dmd-service-respawn? service) - #:start #$(dmd-service-start service) - #:stop #$(dmd-service-stop service))) - services)) + (cons #$compiled %load-compiled-path))) + + (use-modules (system repl error-handling)) + + ;; Arrange to spawn a REPL if loading one of FILES fails. This is + ;; better than a kernel panic. + (call-with-error-handling + (lambda () + (apply register-services (map primitive-load '#$files)))) ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around it. (setenv "PATH" "/run/current-system/profile/bin") diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm index 003d5a5010..ce21b1d9ff 100644 --- a/gnu/services/networking.scm +++ b/gnu/services/networking.scm @@ -22,15 +22,18 @@ #:use-module (gnu services dmd) #:use-module (gnu services dbus) #:use-module (gnu system shadow) - #:use-module (gnu system linux) ;PAM + #:use-module (gnu system pam) #:use-module (gnu packages admin) #:use-module (gnu packages linux) #:use-module (gnu packages tor) #:use-module (gnu packages messaging) #:use-module (gnu packages ntp) #:use-module (gnu packages wicd) + #:use-module (gnu packages gnome) #:use-module (guix gexp) #:use-module (guix records) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:export (%facebook-host-aliases @@ -38,9 +41,11 @@ dhcp-client-service %ntp-servers ntp-service + tor-hidden-service tor-service bitlbee-service - wicd-service)) + wicd-service + network-manager-service)) ;;; Commentary: ;;; @@ -305,6 +310,15 @@ keep the system clock synchronized with that of @var{servers}." ;;; Tor. ;;; +(define-record-type* <tor-configuration> + tor-configuration make-tor-configuration + tor-configuration? + (tor tor-configuration-tor + (default tor)) + (config-file tor-configuration-config-file) + (hidden-services tor-configuration-hidden-services + (default '()))) + (define %tor-accounts ;; User account and groups for Tor. (list (user-group (name "tor") (system? #t)) @@ -316,20 +330,93 @@ keep the system clock synchronized with that of @var{servers}." (home-directory "/var/empty") (shell #~(string-append #$shadow "/sbin/nologin"))))) -(define (tor-dmd-service tor) +(define-record-type <hidden-service> + (hidden-service name mapping) + hidden-service? + (name hidden-service-name) ;string + (mapping hidden-service-mapping)) ;list of port/address tuples + +(define (tor-configuration->torrc config) + "Return a 'torrc' file for CONFIG." + (match config + (($ <tor-configuration> tor config-file services) + (computed-file + "torrc" + #~(begin + (use-modules (guix build utils) + (ice-9 match)) + + (call-with-output-file #$output + (lambda (port) + (display "\ +# The beginning was automatically added. +User tor +DataDirectory /var/lib/tor +Log notice syslog\n" port) + + (for-each (match-lambda + ((service (ports hosts) ...) + (format port "\ +HiddenServiceDir /var/lib/tor/hidden-services/~a~%" + service) + (for-each (lambda (tcp-port host) + (format port "\ +HiddenServicePort ~a ~a~%" + tcp-port host)) + ports hosts))) + '#$(map (match-lambda + (($ <hidden-service> name mapping) + (cons name mapping))) + services)) + + ;; Append the user's config file. + (call-with-input-file #$config-file + (lambda (input) + (dump-port input port))) + #t))) + #:modules '((guix build utils)))))) + +(define (tor-dmd-service config) "Return a <dmd-service> running TOR." - (let ((torrc (plain-file "torrc" "User tor\n"))) - (list (dmd-service - (provision '(tor)) + (match config + (($ <tor-configuration> tor) + (let ((torrc (tor-configuration->torrc config))) + (list (dmd-service + (provision '(tor)) + + ;; Tor needs at least one network interface to be up, hence the + ;; dependency on 'loopback'. + (requirement '(user-processes loopback syslogd)) + + (start #~(make-forkexec-constructor + (list (string-append #$tor "/bin/tor") "-f" #$torrc))) + (stop #~(make-kill-destructor)) + (documentation "Run the Tor anonymous network overlay."))))))) + +(define (tor-hidden-service-activation config) + "Return the activation gexp for SERVICES, a list of hidden services." + #~(begin + (use-modules (guix build utils)) + + (define %user + (getpw "tor")) - ;; Tor needs at least one network interface to be up, hence the - ;; dependency on 'loopback'. - (requirement '(user-processes loopback)) + (define (initialize service) + (let ((directory (string-append "/var/lib/tor/hidden-services/" + service))) + (mkdir-p directory) + (chown directory (passwd:uid %user) (passwd:gid %user)) - (start #~(make-forkexec-constructor - (list (string-append #$tor "/bin/tor") "-f" #$torrc))) - (stop #~(make-kill-destructor)) - (documentation "Run the Tor anonymous network overlay."))))) + ;; The daemon bails out if we give wider permissions. + (chmod directory #o700))) + + (mkdir-p "/var/lib/tor") + (chown "/var/lib/tor" (passwd:uid %user) (passwd:gid %user)) + (chmod "/var/lib/tor" #o700) + + (for-each initialize + '#$(map hidden-service-name + (tor-configuration-hidden-services config))))) (define tor-service-type (service-type (name 'tor) @@ -337,14 +424,59 @@ keep the system clock synchronized with that of @var{servers}." (list (service-extension dmd-root-service-type tor-dmd-service) (service-extension account-service-type - (const %tor-accounts)))))) + (const %tor-accounts)) + (service-extension activation-service-type + tor-hidden-service-activation))) + + ;; This can be extended with hidden services. + (compose concatenate) + (extend (lambda (config services) + (tor-configuration + (inherit config) + (hidden-services + (append (tor-configuration-hidden-services config) + services))))))) + +(define* (tor-service #:optional + (config-file (plain-file "empty" "")) + #:key (tor tor)) + "Return a service to run the @uref{https://torproject.org, Tor} anonymous +networking daemon. + +The daemon runs as the @code{tor} unprivileged user. It is passed +@var{config-file}, a file-like object, with an additional @code{User tor} line +and lines for hidden services added via @code{tor-hidden-service}. Run +@command{man tor} for information about the configuration file." + (service tor-service-type + (tor-configuration (tor tor) + (config-file config-file)))) + +(define tor-hidden-service-type + ;; A type that extends Tor with hidden services. + (service-type (name 'tor-hidden-service) + (extensions + (list (service-extension tor-service-type list))))) + +(define (tor-hidden-service name mapping) + "Define a new Tor @dfn{hidden service} called @var{name} and implementing +@var{mapping}. @var{mapping} is a list of port/host tuples, such as: -(define* (tor-service #:key (tor tor)) - "Return a service to run the @uref{https://torproject.org,Tor} daemon. +@example + '((22 \"127.0.0.1:22\") + (80 \"127.0.0.1:8080\")) +@end example -The daemon runs with the default settings (in particular the default exit -policy) as the @code{tor} unprivileged user." - (service tor-service-type tor)) +In this example, port 22 of the hidden service is mapped to local port 22, and +port 80 is mapped to local port 8080. + +This creates a @file{/var/lib/tor/hidden-services/@var{name}} directory, where +the @file{hostname} file contains the @code{.onion} host name for the hidden +service. + +See @uref{https://www.torproject.org/docs/tor-hidden-service.html.en, the Tor +project's documentation} for more information." + (service tor-hidden-service-type + (hidden-service name mapping))) ;;; @@ -466,11 +598,58 @@ configuration file." (service-extension dbus-root-service-type list) (service-extension activation-service-type - (const %wicd-activation)))))) + (const %wicd-activation)) + + ;; Add Wicd to the global profile. + (service-extension profile-service-type list))))) (define* (wicd-service #:key (wicd wicd)) "Return a service that runs @url{https://launchpad.net/wicd,Wicd}, a network -manager that aims to simplify wired and wireless networking." +management daemon that aims to simplify wired and wireless networking. + +This service adds the @var{wicd} package to the global profile, providing +several commands to interact with the daemon and configure networking: +@command{wicd-client}, a graphical user interface, and the @command{wicd-cli} +and @command{wicd-curses} user interfaces." (service wicd-service-type wicd)) + +;;; +;;; NetworkManager +;;; + +(define %network-manager-activation + ;; Activation gexp for NetworkManager. + #~(begin + (use-modules (guix build utils)) + (mkdir-p "/etc/NetworkManager/system-connections"))) + +(define (network-manager-dmd-service network-manager) + "Return a dmd service for NETWORK-MANAGER." + (list (dmd-service + (documentation "Run the NetworkManager.") + (provision '(networking)) + (requirement '(user-processes dbus-system loopback)) + (start #~(make-forkexec-constructor + (list (string-append #$network-manager + "/sbin/NetworkManager") + "--no-daemon"))) + (stop #~(make-kill-destructor))))) + +(define network-manager-service-type + (service-type (name 'network-manager) + (extensions + (list (service-extension dmd-root-service-type + network-manager-dmd-service) + (service-extension dbus-root-service-type list) + (service-extension activation-service-type + (const %network-manager-activation)) + ;; Add network-manager to the system profile. + (service-extension profile-service-type list))))) + +(define* (network-manager-service #:key (network-manager network-manager)) + "Return a service that runs NetworkManager, a network connection manager +that attempting to keep active network connectivity when available." + (service network-manager-service-type network-manager)) + ;;; networking.scm ends here diff --git a/gnu/services/ssh.scm b/gnu/services/ssh.scm index d3a6cfb33a..4b0380e8fd 100644 --- a/gnu/services/ssh.scm +++ b/gnu/services/ssh.scm @@ -21,8 +21,9 @@ #:use-module (guix records) #:use-module (gnu services) #:use-module (gnu services dmd) - #:use-module (gnu system linux) ; 'pam-service' + #:use-module (gnu system pam) #:use-module (gnu packages lsh) + #:use-module (srfi srfi-26) #:export (lsh-service)) ;;; Commentary: @@ -142,8 +143,8 @@ "--tcpip-forward" "--no-tcpip-forward") (if (null? interfaces) '() - (list (string-append "--interfaces=" - (string-join interfaces ","))))))) + (map (cut string-append "--interface=" <>) + interfaces))))) (define requires (if (and daemonic? (lsh-configuration-syslog-output? config)) diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm index 3a57891a96..7fea6829d5 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.scm @@ -21,7 +21,7 @@ #:use-module (gnu artwork) #:use-module (gnu services) #:use-module (gnu services dmd) - #:use-module (gnu system linux) ; 'pam-service' + #:use-module (gnu system pam) #:use-module ((gnu packages base) #:select (canonical-package)) #:use-module (gnu packages guile) #:use-module (gnu packages xorg) @@ -32,16 +32,23 @@ #:use-module (gnu packages bash) #:use-module (guix gexp) #:use-module (guix store) + #:use-module (guix packages) #:use-module (guix derivations) #:use-module (guix records) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:export (xorg-configuration-file xorg-start-command %default-slim-theme %default-slim-theme-name - slim-service)) + slim-configuration + slim-service-type + slim-service + + screen-locker-service-type + screen-locker-service)) ;;; Commentary: ;;; @@ -304,7 +311,12 @@ reboot_cmd " dmd "/sbin/reboot\n" (list (service-extension dmd-root-service-type slim-dmd-service) (service-extension pam-root-service-type - slim-pam-service))))) + slim-pam-service) + + ;; Unconditionally add xterm to the system profile, to + ;; avoid bad surprises. + (service-extension profile-service-type + (const (list xterm))))))) (define* (slim-service #:key (slim slim) (allow-empty-passwords? #t) auto-login? @@ -350,4 +362,52 @@ theme." (auto-login-session auto-login-session) (startx startx)))) + +;;; +;;; Screen lockers & co. +;;; + +(define-record-type <screen-locker> + (screen-locker name program empty?) + screen-locker? + (name screen-locker-name) ;string + (program screen-locker-program) ;gexp + (empty? screen-locker-allows-empty-passwords?)) ;Boolean + +(define screen-locker-pam-services + (match-lambda + (($ <screen-locker> name _ empty?) + (list (unix-pam-service name + #:allow-empty-passwords? empty?))))) + +(define screen-locker-setuid-programs + (compose list screen-locker-program)) + +(define screen-locker-service-type + (service-type (name 'screen-locker) + (extensions + (list (service-extension pam-root-service-type + screen-locker-pam-services) + (service-extension setuid-program-service-type + screen-locker-setuid-programs))))) + +(define* (screen-locker-service package + #:optional + (program (package-name package)) + #:key allow-empty-passwords?) + "Add @var{package}, a package for a screen-locker or screen-saver whose +command is @var{program}, to the set of setuid programs and add a PAM entry +for it. For example: + +@lisp +(screen-locker-service xlockmore \"xlock\") +@end lisp + +makes the good ol' XlockMore usable." + (service screen-locker-service-type + (screen-locker program + #~(string-append #$package + #$(string-append "/bin/" program)) + allow-empty-passwords?))) + ;;; xorg.scm ends here |