diff options
Diffstat (limited to 'gnu/services')
| -rw-r--r-- | gnu/services/avahi.scm | 5 | ||||
| -rw-r--r-- | gnu/services/base.scm | 47 | ||||
| -rw-r--r-- | gnu/services/databases.scm | 121 | ||||
| -rw-r--r-- | gnu/services/dbus.scm | 126 | ||||
| -rw-r--r-- | gnu/services/desktop.scm | 300 | ||||
| -rw-r--r-- | gnu/services/lirc.scm | 68 | ||||
| -rw-r--r-- | gnu/services/networking.scm | 38 | ||||
| -rw-r--r-- | gnu/services/ssh.scm | 2 | ||||
| -rw-r--r-- | gnu/services/xorg.scm | 73 |
9 files changed, 613 insertions, 167 deletions
diff --git a/gnu/services/avahi.scm b/gnu/services/avahi.scm index 89478cb997..a3ca5ab6fb 100644 --- a/gnu/services/avahi.scm +++ b/gnu/services/avahi.scm @@ -20,6 +20,7 @@ #:use-module (gnu services) #:use-module (gnu system shadow) #:use-module (gnu packages avahi) + #:use-module (gnu packages admin) #:use-module (guix monads) #:use-module (guix store) #:use-module (guix gexp) @@ -62,7 +63,7 @@ (domains-to-browse '())) "Return a service that runs @command{avahi-daemon}, a system-wide mDNS/DNS-SD responder that allows for service discovery and -\"zero-configuration\" host name lookups. +\"zero-configuration\" host name lookups (see @uref{http://avahi.org/}). 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. @@ -106,6 +107,6 @@ sockets." (comment "Avahi daemon user") (home-directory "/var/empty") (shell - "/run/current-system/profile/sbin/nologin")))))))) + #~(string-append #$shadow "/sbin/nologin"))))))))) ;;; avahi.scm ends here diff --git a/gnu/services/base.scm b/gnu/services/base.scm index a9126032bb..d5744204d9 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015 Alex Kost <alezost@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -46,6 +47,7 @@ swap-service user-processes-service host-name-service + console-keymap-service console-font-service udev-service mingetty-service @@ -131,7 +133,9 @@ names such as device-mapping services." (requirement `(root-file-system ,@requirements)) (documentation "Check, mount, and unmount the given file system.") (start #~(lambda args - (let ((device (canonicalize-device-spec #$device '#$title))) + ;; FIXME: Use or factorize with 'mount-file-system'. + (let ((device (canonicalize-device-spec #$device '#$title)) + (flags #$(mount-flags->bit-mask flags))) #$(if create-mount-point? #~(mkdir-p #$target) #~#t) @@ -145,9 +149,16 @@ names such as device-mapping services." (getenv "PATH"))) (check-file-system device #$type)) #~#t) - (mount device #$target #$type - #$(mount-flags->bit-mask flags) - #$options)) + + (mount device #$target #$type flags #$options) + + ;; For read-only bind mounts, an extra remount is needed, + ;; as per <http://lwn.net/Articles/281157/>, which still + ;; applies to Linux 4.0. + (when (and (= MS_BIND (logand flags MS_BIND)) + (= MS_RDONLY (logand flags MS_RDONLY))) + (mount device #$target #$type + (logior MS_BIND MS_REMOUNT MS_RDONLY)))) #t)) (stop #~(lambda args ;; Normally there are no processes left at this point, so @@ -304,6 +315,19 @@ stopped before 'kill' is called." (else (zero? (cdr (waitpid pid)))))))) +(define (console-keymap-service file) + "Return a service to load console keymap from @var{file}." + (with-monad %store-monad + (return + (service + (documentation + (string-append "Load console keymap (loadkeys).")) + (provision '(console-keymap)) + (start #~(lambda _ + (zero? (system* (string-append #$kbd "/bin/loadkeys") + #$file)))) + (respawn? #f))))) + (define* (console-font-service tty #:optional (font "LatGrkCyr-8x16")) "Return a service that sets up Unicode support in @var{tty} and loads @var{font} for that tty (fonts are per virtual console in Linux.)" @@ -499,7 +523,7 @@ the ``message of the day''." "Return a service that runs libc's name service cache daemon (nscd) with the given @var{config}---an @code{<nscd-configuration>} object. Optionally, @code{#:name-services} is a list of packages that provide name service switch - (NSS) modules needed by nscd." + (NSS) modules needed by nscd. @xref{Name Service Switch}, for an example." (mlet %store-monad ((nscd.conf (nscd.conf-file config))) (return (service (documentation "Run libc's name service cache daemon (nscd).") @@ -526,8 +550,10 @@ given @var{config}---an @code{<nscd-configuration>} object. Optionally, (respawn? #f))))) -(define (syslog-service) - "Return a service that runs @code{syslogd} with reasonable default settings." +(define* (syslog-service #:key config-file) + "Return a service that runs @code{syslogd}. +If configuration file name @var{config-file} is not specified, use some +reasonable default settings." ;; Snippet adapted from the GNU inetutils manual. (define contents " @@ -561,7 +587,7 @@ given @var{config}---an @code{<nscd-configuration>} object. Optionally, (start #~(make-forkexec-constructor (list (string-append #$inetutils "/libexec/syslogd") - "--no-detach" "--rcfile" #$syslog.conf))) + "--no-detach" "--rcfile" #$(or config-file syslog.conf)))) (stop #~(make-kill-destructor)))))) (define* (guix-build-accounts count #:key @@ -640,6 +666,7 @@ passed to @command{guix-daemon}." (with-monad %store-monad (return (service + (documentation "Run the Guix daemon.") (provision '(guix-daemon)) (requirement '(user-processes)) (start @@ -824,10 +851,10 @@ gexp, to open it, and evaluate @var{close} to close it." (requirement `(udev ,@requirement)) (documentation "Enable the given swap device.") (start #~(lambda () - (swapon #$device) + (restart-on-EINTR (swapon #$device)) #t)) (stop #~(lambda _ - (swapoff #$device) + (restart-on-EINTR (swapoff #$device)) #f)) (respawn? #f))))) diff --git a/gnu/services/databases.scm b/gnu/services/databases.scm new file mode 100644 index 0000000000..18f41e74da --- /dev/null +++ b/gnu/services/databases.scm @@ -0,0 +1,121 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 David Thompson <davet@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gnu services databases) + #:use-module (gnu services) + #:use-module (gnu system shadow) + #:use-module (gnu packages admin) + #:use-module (gnu packages databases) + #:use-module (guix records) + #:use-module (guix monads) + #:use-module (guix store) + #:use-module (guix gexp) + #:export (postgresql-service)) + +;;; Commentary: +;;; +;;; Database services. +;;; +;;; Code: + +(define %default-postgres-hba + (text-file "pg_hba.conf" + " +local all all trust +host all all 127.0.0.1/32 trust +host all all ::1/128 trust")) + +(define %default-postgres-ident + (text-file "pg_ident.conf" + "# MAPNAME SYSTEM-USERNAME PG-USERNAME")) + +(define %default-postgres-config + (mlet %store-monad ((hba %default-postgres-hba) + (ident %default-postgres-ident)) + (text-file* "postgresql.conf" + ;; The daemon will not start without these. + "hba_file = '" hba "'\n" + "ident_file = '" ident "'\n"))) + +(define* (postgresql-service #:key (postgresql postgresql) + (config-file %default-postgres-config) + (data-directory "/var/lib/postgresql/data")) + "Return a service that runs @var{postgresql}, the PostgreSQL database server. + +The PostgreSQL daemon loads its runtime configuration from @var{config-file} +and stores the database cluster in @var{data-directory}." + ;; Wrapper script that switches to the 'postgres' user before launching + ;; daemon. + (define start-script + (mlet %store-monad ((config-file config-file)) + (gexp->script "start-postgres" + #~(let ((user (getpwnam "postgres")) + (postgres (string-append #$postgresql + "/bin/postgres"))) + (setgid (passwd:gid user)) + (setuid (passwd:uid user)) + (system* postgres + (string-append "--config-file=" #$config-file) + "-D" #$data-directory))))) + + (define activate + #~(begin + (use-modules (guix build utils) + (ice-9 match)) + + (let ((user (getpwnam "postgres")) + (initdb (string-append #$postgresql "/bin/initdb"))) + ;; Create db state directory. + (mkdir-p #$data-directory) + (chown #$data-directory (passwd:uid user) (passwd:gid user)) + + ;; Drop privileges and init state directory in a new + ;; process. Wait for it to finish before proceeding. + (match (primitive-fork) + (0 + ;; Exit with a non-zero status code if an exception is thrown. + (dynamic-wind + (const #t) + (lambda () + (setgid (passwd:gid user)) + (setuid (passwd:uid user)) + (primitive-exit (system* initdb "-D" #$data-directory))) + (lambda () + (primitive-exit 1)))) + (pid (waitpid pid)))))) + + (mlet %store-monad ((start-script start-script)) + (return + (service + (provision '(postgres)) + (documentation "Run the PostgreSQL daemon.") + (requirement '(user-processes loopback)) + (start #~(make-forkexec-constructor #$start-script)) + (stop #~(make-kill-destructor)) + (activate activate) + (user-groups (list (user-group + (name "postgres") + (system? #t)))) + (user-accounts (list (user-account + (name "postgres") + (group "postgres") + (system? #t) + (comment "PostgreSQL server user") + (home-directory "/var/empty") + (shell + #~(string-append #$shadow "/sbin/nologin"))))))))) diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm deleted file mode 100644 index 671dafa194..0000000000 --- a/gnu/services/dbus.scm +++ /dev/null @@ -1,126 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. - -(define-module (gnu services dbus) - #:use-module (gnu services) - #:use-module (gnu system shadow) - #:use-module (gnu packages glib) - #:use-module (guix monads) - #:use-module (guix store) - #:use-module (guix gexp) - #:export (dbus-service)) - -;;; Commentary: -;;; -;;; This module supports the configuration of the D-Bus message bus -;;; (http://dbus.freedesktop.org/). D-Bus is an inter-process communication -;;; facility. Its "system bus" is used to allow system services to -;;; communicate and be notified of system-wide events. -;;; -;;; Code: - -(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 -@var{services}." - (define build - #~(begin - (use-modules (sxml simple) - (srfi srfi-1)) - - (define (services->sxml services) - ;; Return the SXML 'includedir' clauses for DIRS. - `(busconfig - ,@(append-map (lambda (dir) - `((includedir - ,(string-append dir "/etc/dbus-1/system.d")) - (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")) - - ;; 'system-local.conf' is automatically included by the default - ;; 'system.conf', so this is where we stuff our own things. - (call-with-output-file (string-append #$output "/system-local.conf") - (lambda (port) - (sxml->xml (services->sxml (list #$@services)) - port))))) - - (gexp->derivation "dbus-configuration" build)) - -(define* (dbus-service services #:key (dbus dbus)) - "Return a service that runs the system bus, using @var{dbus}, with support -for @var{services}. - -@var{services} must be a list of packages that provide an -@file{etc/dbus-1/system.d} directory containing additional D-Bus configuration -and policy files. For example, to allow avahi-daemon to use the system bus, -@var{services} must be equal to @code{(list avahi)}." - (mlet %store-monad ((conf (dbus-configuration-directory dbus services))) - (return - (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)) - (user-groups (list (user-group - (name "messagebus") - (system? #t)))) - (user-accounts (list (user-account - (name "messagebus") - (group "messagebus") - (system? #t) - (comment "D-Bus system bus user") - (home-directory "/var/run/dbus") - (shell - "/run/current-system/profile/sbin/nologin")))) - (activate #~(begin - (use-modules (guix build utils)) - - (mkdir-p "/var/run/dbus") - - (let ((user (getpwnam "messagebus"))) - (chown "/var/run/dbus" - (passwd:uid user) (passwd:gid user))) - - (unless (file-exists? "/etc/machine-id") - (format #t "creating /etc/machine-id...~%") - (let ((prog (string-append #$dbus "/bin/dbus-uuidgen"))) - ;; XXX: We can't use 'system' because the initrd's - ;; guile system(3) only works when 'sh' is in $PATH. - (let ((pid (primitive-fork))) - (if (zero? pid) - (call-with-output-file "/etc/machine-id" - (lambda (port) - (close-fdes 1) - (dup2 (port->fdes port) 1) - (execl prog))) - (waitpid pid))))))))))) - -;;; dbus.scm ends here diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm new file mode 100644 index 0000000000..910dc1f9e0 --- /dev/null +++ b/gnu/services/desktop.scm @@ -0,0 +1,300 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015 Andy Wingo <wingo@igalia.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gnu services desktop) + #:use-module (gnu services) + #:use-module (gnu services base) + #:use-module (gnu services avahi) + #:use-module (gnu services xorg) + #:use-module (gnu services networking) + #:use-module (gnu services ssh) + #:use-module (gnu system shadow) + #:use-module (gnu packages glib) + #:use-module (gnu packages admin) + #:use-module (gnu packages gnome) + #:use-module (gnu packages avahi) + #:use-module (gnu packages wicd) + #:use-module (guix monads) + #:use-module (guix store) + #:use-module (guix gexp) + #:use-module (ice-9 match) + #:export (dbus-service + upower-service + colord-service + %desktop-services)) + +;;; Commentary: +;;; +;;; This module contains service definitions for a "desktop" environment. +;;; +;;; Code: + + +;;; +;;; D-Bus. +;;; + +(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 +@var{services}." + (define build + #~(begin + (use-modules (sxml simple) + (srfi srfi-1)) + + (define (services->sxml services) + ;; Return the SXML 'includedir' clauses for DIRS. + `(busconfig + ,@(append-map (lambda (dir) + `((includedir + ,(string-append dir "/etc/dbus-1/system.d")) + (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")) + + ;; 'system-local.conf' is automatically included by the default + ;; 'system.conf', so this is where we stuff our own things. + (call-with-output-file (string-append #$output "/system-local.conf") + (lambda (port) + (sxml->xml (services->sxml (list #$@services)) + port))))) + + (gexp->derivation "dbus-configuration" build)) + +(define* (dbus-service services #:key (dbus dbus)) + "Return a service that runs the \"system bus\", using @var{dbus}, with +support for @var{services}. + +@uref{http://dbus.freedesktop.org/, D-Bus} is an inter-process communication +facility. Its system bus is used to allow system services to communicate and +be notified of system-wide events. + +@var{services} must be a list of packages that provide an +@file{etc/dbus-1/system.d} directory containing additional D-Bus configuration +and policy files. For example, to allow avahi-daemon to use the system bus, +@var{services} must be equal to @code{(list avahi)}." + (mlet %store-monad ((conf (dbus-configuration-directory dbus services))) + (return + (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)) + (user-groups (list (user-group + (name "messagebus") + (system? #t)))) + (user-accounts (list (user-account + (name "messagebus") + (group "messagebus") + (system? #t) + (comment "D-Bus system bus user") + (home-directory "/var/run/dbus") + (shell + #~(string-append #$shadow "/sbin/nologin"))))) + (activate #~(begin + (use-modules (guix build utils)) + + (mkdir-p "/var/run/dbus") + + (let ((user (getpwnam "messagebus"))) + (chown "/var/run/dbus" + (passwd:uid user) (passwd:gid user))) + + (unless (file-exists? "/etc/machine-id") + (format #t "creating /etc/machine-id...~%") + (let ((prog (string-append #$dbus "/bin/dbus-uuidgen"))) + ;; XXX: We can't use 'system' because the initrd's + ;; guile system(3) only works when 'sh' is in $PATH. + (let ((pid (primitive-fork))) + (if (zero? pid) + (call-with-output-file "/etc/machine-id" + (lambda (port) + (close-fdes 1) + (dup2 (port->fdes port) 1) + (execl prog))) + (waitpid pid))))))))))) + + +;;; +;;; Upower D-Bus service. +;;; + +(define* (upower-configuration-file #:key watts-up-pro? poll-batteries? + ignore-lid? use-percentage-for-policy? + percentage-low percentage-critical + percentage-action time-low + time-critical time-action + critical-power-action) + "Return an upower-daemon configuration file." + (define (bool value) + (if value "true\n" "false\n")) + + (text-file "UPower.conf" + (string-append + "[UPower]\n" + "EnableWattsUpPro=" (bool watts-up-pro?) + "NoPollBatteries=" (bool (not poll-batteries?)) + "IgnoreLid=" (bool ignore-lid?) + "UsePercentageForPolicy=" (bool use-percentage-for-policy?) + "PercentageLow=" (number->string percentage-low) "\n" + "PercentageCritical=" (number->string percentage-critical) "\n" + "PercentageAction=" (number->string percentage-action) "\n" + "TimeLow=" (number->string time-low) "\n" + "TimeCritical=" (number->string time-critical) "\n" + "TimeAction=" (number->string time-action) "\n" + "CriticalPowerAction=" (match critical-power-action + ('hybrid-sleep "HybridSleep") + ('hibernate "Hibernate") + ('power-off "PowerOff")) + "\n"))) + +(define* (upower-service #:key (upower upower) + (watts-up-pro? #f) + (poll-batteries? #t) + (ignore-lid? #f) + (use-percentage-for-policy? #f) + (percentage-low 10) + (percentage-critical 3) + (percentage-action 2) + (time-low 1200) + (time-critical 300) + (time-action 120) + (critical-power-action 'hybrid-sleep)) + "Return a service that runs @uref{http://upower.freedesktop.org/, +@command{upowerd}}, a system-wide monitor for power consumption and battery +levels, with the given configuration settings. It implements the +@code{org.freedesktop.UPower} D-Bus interface, and is notably used by GNOME." + (mlet %store-monad ((config (upower-configuration-file + #:watts-up-pro? watts-up-pro? + #:poll-batteries? poll-batteries? + #:ignore-lid? ignore-lid? + #:use-percentage-for-policy? use-percentage-for-policy? + #:percentage-low percentage-low + #:percentage-critical percentage-critical + #:percentage-action percentage-action + #:time-low time-low + #:time-critical time-critical + #:time-action time-action + #:critical-power-action critical-power-action))) + (return + (service + (documentation "Run the UPower power and battery monitor.") + (provision '(upower-daemon)) + (requirement '(dbus-system udev)) + + (start #~(make-forkexec-constructor + (list (string-append #$upower "/libexec/upowerd")) + #:environment-variables + (list (string-append "UPOWER_CONF_FILE_NAME=" #$config)))) + (stop #~(make-kill-destructor)) + (activate #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/lib/upower") + (let ((user (getpwnam "upower"))) + (chown "/var/lib/upower" + (passwd:uid user) (passwd:gid user))))) + + (user-groups (list (user-group + (name "upower") + (system? #t)))) + (user-accounts (list (user-account + (name "upower") + (group "upower") + (system? #t) + (comment "UPower daemon user") + (home-directory "/var/empty") + (shell + #~(string-append #$shadow "/sbin/nologin"))))))))) + + +;;; +;;; Colord D-Bus service. +;;; + +(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." + (with-monad %store-monad + (return + (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)) + (activate #~(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))))) + + (user-groups (list (user-group + (name "colord") + (system? #t)))) + (user-accounts (list (user-account + (name "colord") + (group "colord") + (system? #t) + (comment "colord daemon user") + (home-directory "/var/empty") + (shell + #~(string-append #$shadow "/sbin/nologin"))))))))) + +(define %desktop-services + ;; List of services typically useful for a "desktop" use case. + (cons* (slim-service) + + (avahi-service) + (wicd-service) + (upower-service) + (colord-service) + (dbus-service (list avahi wicd upower colord)) + + (ntp-service) + (lsh-service) + + (map (lambda (mservice) + ;; Provide an nscd ready to use nss-mdns. + (mlet %store-monad ((service mservice)) + (if (memq 'nscd (service-provision service)) + (nscd-service (nscd-configuration) + #:name-services (list nss-mdns)) + mservice))) + %base-services))) + +;;; desktop.scm ends here diff --git a/gnu/services/lirc.scm b/gnu/services/lirc.scm new file mode 100644 index 0000000000..857f362db7 --- /dev/null +++ b/gnu/services/lirc.scm @@ -0,0 +1,68 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Alex Kost <alezost@gmail.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gnu services lirc) + #:use-module (gnu services) + #:use-module (gnu packages lirc) + #:use-module (guix monads) + #:use-module (guix store) + #:use-module (guix gexp) + #:export (lirc-service)) + +;;; Commentary: +;;; +;;; LIRC services. +;;; +;;; Code: + +(define* (lirc-service #:key (lirc lirc) + device driver config-file + (extra-options '())) + "Return a service that runs @url{http://www.lirc.org,LIRC}, a daemon that +decodes infrared signals from remote controls. + +The daemon will use specified @var{device}, @var{driver} and +@var{config-file} (configuration file name). + +Finally, @var{extra-options} is a list of additional command-line options +passed to @command{lircd}." + (with-monad %store-monad + (return + (service + (provision '(lircd)) + (documentation "Run the LIRC daemon.") + (requirement '(user-processes)) + (start #~(make-forkexec-constructor + (list (string-append #$lirc "/sbin/lircd") + "--nodaemon" + #$@(if device + #~("--device" #$device) + #~()) + #$@(if driver + #~("--driver" #$driver) + #~()) + #$@(if config-file + #~(#$config-file) + #~()) + #$@extra-options))) + (stop #~(make-kill-destructor)) + (activate #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/run/lirc"))))))) + +;;; lirc.scm ends here diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm index af8dd43bd6..102202c853 100644 --- a/gnu/services/networking.scm +++ b/gnu/services/networking.scm @@ -170,15 +170,33 @@ Protocol (DHCP) client, on all the non-loopback network interfaces." ;; up*. However, the relevant interfaces are ;; typically down at this point. Thus we perform our ;; own interface discovery here. - (let* ((valid? (negate loopback-network-interface?)) - (ifaces (filter valid? - (all-network-interfaces))) - (pid (fork+exec-command - (cons* #$dhclient "-nw" - "-pf" #$pid-file - ifaces)))) + (define valid? + (negate loopback-network-interface?)) + (define ifaces + (filter valid? (all-network-interfaces))) + + ;; XXX: Make sure the interfaces are up so that + ;; 'dhclient' can actually send/receive over them. + (for-each set-network-interface-up ifaces) + + (false-if-exception (delete-file #$pid-file)) + (let ((pid (fork+exec-command + (cons* #$dhclient "-nw" + "-pf" #$pid-file ifaces)))) (and (zero? (cdr (waitpid pid))) - (call-with-input-file #$pid-file read))))) + (let loop () + (catch 'system-error + (lambda () + (call-with-input-file #$pid-file read)) + (lambda args + ;; 'dhclient' returned before PID-FILE + ;; was created, so try again. + (let ((errno (system-error-errno args))) + (if (= ENOENT errno) + (begin + (sleep 1) + (loop)) + (apply throw args)))))))))) (stop #~(make-kill-destructor)))))) (define %ntp-servers @@ -227,7 +245,7 @@ restrict -6 ::1\n")) (comment "NTP daemon user") (home-directory "/var/empty") (shell - "/run/current-system/profile/sbin/nologin")))))))) + #~(string-append #$shadow "/sbin/nologin"))))))))) (define* (tor-service #:key (tor tor)) "Return a service to run the @uref{https://torproject.org,Tor} daemon. @@ -257,7 +275,7 @@ policy) as the @code{tor} unprivileged user." (comment "Tor daemon user") (home-directory "/var/empty") (shell - "/run/current-system/profile/sbin/nologin")))) + #~(string-append #$shadow "/sbin/nologin"))))) (documentation "Run the Tor anonymous network overlay."))))) diff --git a/gnu/services/ssh.scm b/gnu/services/ssh.scm index 9537958df7..e2f85421e9 100644 --- a/gnu/services/ssh.scm +++ b/gnu/services/ssh.scm @@ -86,7 +86,7 @@ (tcp/ip-forwarding? #t) (password-authentication? #t) (public-key-authentication? #t) - initialize?) + (initialize? #t)) "Run the @command{lshd} program from @var{lsh} to listen on port @var{port-number}. @var{host-key} must designate a file containing the host key, and readable only by root. diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm index c687b46bc2..9ee88170e4 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.scm @@ -37,7 +37,8 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (ice-9 match) - #:export (xorg-start-command + #:export (xorg-configuration-file + xorg-start-command %default-slim-theme %default-slim-theme-name slim-service)) @@ -48,12 +49,10 @@ ;;; ;;; Code: -(define* (xorg-start-command #:key - (guile (canonical-package guile-2.0)) - (xorg-server xorg-server) - (drivers '()) (resolutions '())) - "Return a derivation that builds a @var{guile} script to start the X server -from @var{xorg-server}. Usually the X server is started by a login manager. +(define* (xorg-configuration-file #:key (drivers '()) (resolutions '()) + (extra-config '())) + "Return a configuration file for the Xorg server containing search paths for +all the common drivers. @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 @@ -61,8 +60,11 @@ 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))}." +resolutions---e.g., @code{((1024 768) (640 480))}. +Last, @var{extra-config} is a list of strings or objects appended to the +@code{text-file*} argument list. It is used to pass extra text to be added +verbatim to the configuration file." (define (device-section driver) (string-append " Section \"Device\" @@ -78,15 +80,14 @@ Section \"Screen\" SubSection \"Display\" Modes " (string-join (map (match-lambda - ((x y) - (string-append "\"" (number->string x) - "x" (number->string y) "\""))) + ((x y) + (string-append "\"" (number->string x) + "x" (number->string y) "\""))) resolutions)) " EndSubSection EndSection")) - (define (xserver.conf) - (text-file* "xserver.conf" " + (apply text-file* "xserver.conf" " Section \"Files\" FontPath \"" font-adobe75dpi "/share/fonts/X11/75dpi\" ModulePath \"" xf86-video-vesa "/lib/xorg/modules/drivers\" @@ -98,6 +99,12 @@ Section \"Files\" ModulePath \"" xf86-video-nouveau "/lib/xorg/modules/drivers\" ModulePath \"" xf86-video-nv "/lib/xorg/modules/drivers\" ModulePath \"" xf86-video-sis "/lib/xorg/modules/drivers\" + + # Libinput is the new thing and is recommended over evdev/synaptics + # by those who know: + # <http://who-t.blogspot.fr/2015/01/xf86-input-libinput-compatibility-with.html>. + ModulePath \"" xf86-input-libinput "/lib/xorg/modules/input\" + ModulePath \"" xf86-input-evdev "/lib/xorg/modules/input\" ModulePath \"" xf86-input-keyboard "/lib/xorg/modules/input\" ModulePath \"" xf86-input-mouse "/lib/xorg/modules/input\" @@ -111,12 +118,27 @@ Section \"ServerFlags\" Option \"AllowMouseOpenFail\" \"on\" EndSection " - (string-join (map device-section drivers) "\n") + (string-join (map device-section drivers) "\n") "\n" (string-join (map (cut screen-section <> resolutions) drivers) - "\n"))) + "\n") + + "\n" + extra-config)) - (mlet %store-monad ((config (xserver.conf))) +(define* (xorg-start-command #:key + (guile (canonical-package guile-2.0)) + configuration-file + (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. + +Usually the X server is started by a login manager." + (mlet %store-monad ((config (if configuration-file + (return configuration-file) + (xorg-configuration-file)))) (define script ;; Write a small wrapper around the X server. #~(begin @@ -192,7 +214,7 @@ which should be passed to this script as the first argument. If not, the (define %default-slim-theme-name ;; This must be the name of the sub-directory in %DEFAULT-SLIM-THEME that ;; contains the actual theme files. - "0.8") + "0.x") (define* (slim-service #:key (slim slim) (allow-empty-passwords? #t) auto-login? @@ -207,6 +229,19 @@ which should be passed to this script as the first argument. If not, the turn starts the X display server with @var{startx}, a command as returned by @code{xorg-start-command}. +@cindex X session + +SLiM automatically looks for session types described by the @file{.desktop} +files in @file{/run/current-system/profile/share/xsessions} and allows users +to choose a session from the log-in screen using @kbd{F1}. Packages such as +@var{xfce}, @var{sawfish}, and @var{ratpoison} provide @file{.desktop} files; +adding them to the system-wide set of packages automatically makes them +available at the log-in screen. + +In addition, @file{~/.xsession} files are honored. When available, +@file{~/.xsession} must be an executable that starts a window manager +and/or other X clients. + When @var{allow-empty-passwords?} is true, allow logins with an empty password. When @var{auto-login?} is true, log in automatically as @var{default-user} with @var{auto-login-session}. @@ -217,7 +252,9 @@ theme to use. In that case, @var{theme-name} specifies the name of the theme." (define (slim.cfg) - (mlet %store-monad ((startx (or startx (xorg-start-command))) + (mlet %store-monad ((startx (if startx + (return startx) + (xorg-start-command))) (xinitrc (xinitrc #:fallback-session auto-login-session))) (text-file* "slim.cfg" " |