diff options
Diffstat (limited to 'gnu/services')
| -rw-r--r-- | gnu/services/avahi.scm | 108 | ||||
| -rw-r--r-- | gnu/services/base.scm | 219 | ||||
| -rw-r--r-- | gnu/services/dbus.scm | 120 | ||||
| -rw-r--r-- | gnu/services/dmd.scm | 76 | ||||
| -rw-r--r-- | gnu/services/networking.scm | 58 | ||||
| -rw-r--r-- | gnu/services/xorg.scm | 118 |
6 files changed, 513 insertions, 186 deletions
diff --git a/gnu/services/avahi.scm b/gnu/services/avahi.scm new file mode 100644 index 0000000000..4b52fd7840 --- /dev/null +++ b/gnu/services/avahi.scm @@ -0,0 +1,108 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 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 avahi) + #:use-module (gnu services) + #:use-module (gnu system shadow) + #:use-module (gnu packages avahi) + #:use-module (guix monads) + #:use-module (guix gexp) + #:export (avahi-service)) + +;;; Commentary: +;;; +;;; This module provides service definitions for the Avahi +;;; "zero-configuration" tool set. +;;; +;;; Code: + +(define* (configuration-file #:key host-name publish? + ipv4? ipv6? wide-area? domains-to-browse) + "Return an avahi-daemon configuration file." + (define (bool value) + (if value "yes\n" "no\n")) + + (text-file "avahi-daemon.conf" + (string-append + "[server]\n" + (if host-name + (string-append "host-name=" host-name "\n") + "") + + "browse-domains=" (string-join domains-to-browse) + "\n" + "use-ipv4=" (bool ipv4?) + "use-ipv6=" (bool ipv6?) + "[wide-area]\n" + "enable-wide-area=" (bool wide-area?) + "[publish]\n" + "disable-publishing=" (bool (not publish?))))) + +(define* (avahi-service #:key (avahi avahi) + host-name + (publish? #t) + (ipv4? #t) (ipv6? #t) + wide-area? + (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. + +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. + +When @var{publish?} is true, publishing of host names and services is allowed; +in particular, avahi-daemon will publish the machine's host name and IP +address via mDNS on the local network. + +When @var{wide-area?} is true, DNS-SD over unicast DNS is enabled. + +Boolean values @var{ipv4?} and @var{ipv6?} determine whether to use IPv4/IPv6 +sockets." + (mlet %store-monad ((config (configuration-file #:host-name host-name + #:publish? publish? + #:ipv4? ipv4? + #:ipv6? ipv6? + #:wide-area? wide-area? + #:domains-to-browse + domains-to-browse))) + (return + (service + (documentation "Run the Avahi mDNS/DNS-SD responder.") + (provision '(avahi-daemon)) + (requirement '(dbus-system networking)) + + (start #~(make-forkexec-constructor + (string-append #$avahi "/sbin/avahi-daemon") + "--syslog" "-f" #$config)) + (stop #~(make-kill-destructor)) + (activate #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/run/avahi-daemon"))) + + (user-groups (list (user-group + (name "avahi")))) + (user-accounts (list (user-account + (name "avahi") + (group "avahi") + (comment "Avahi daemon user") + (home-directory "/var/empty") + (shell + "/run/current-system/profile/sbin/nologin")))))))) + +;;; avahi.scm ends here diff --git a/gnu/services/base.scm b/gnu/services/base.scm index d6c1707c6a..dc0161408b 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -24,11 +24,15 @@ #:use-module ((gnu packages base) #:select (glibc-final)) #:use-module (gnu packages package-management) + #:use-module (guix gexp) #:use-module (guix monads) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (ice-9 format) - #:export (host-name-service + #:export (root-file-system-service + file-system-service + user-processes-service + host-name-service mingetty-service nscd-service syslog-service @@ -42,14 +46,148 @@ ;;; ;;; Code: +(define (root-file-system-service) + "Return a service whose sole purpose is to re-mount read-only the root file +system upon shutdown (aka. cleanly \"umounting\" root.) + +This service must be the root of the service dependency graph so that its +'stop' action is invoked when dmd is the only process left." + (with-monad %store-monad + (return + (service + (documentation "Take care of the root file system.") + (provision '(root-file-system)) + (start #~(const #t)) + (stop #~(lambda _ + ;; Return #f if successfully stopped. + (sync) + + (call-with-blocked-asyncs + (lambda () + (let ((null (%make-void-port "w"))) + ;; Close 'dmd.log'. + (display "closing log\n") + ;; XXX: Ideally we'd use 'stop-logging', but that one + ;; doesn't actually close the port as of dmd 0.1. + (close-port (@@ (dmd comm) log-output-port)) + (set! (@@ (dmd comm) log-output-port) null) + + ;; Redirect the default output ports.. + (set-current-output-port null) + (set-current-error-port null) + + ;; Close /dev/console. + (for-each close-fdes '(0 1 2)) + + ;; At this point, there are no open files left, so the + ;; root file system can be re-mounted read-only. + (mount #f "/" #f + (logior MS_REMOUNT MS_RDONLY) + #:update-mtab? #f) + + #f))))) + (respawn? #f))))) + +(define* (file-system-service device target type + #:key (check? #t) options) + "Return a service that mounts DEVICE on TARGET as a file system TYPE with +OPTIONS. When CHECK? is true, check the file system before mounting it." + (with-monad %store-monad + (return + (service + (provision (list (symbol-append 'file-system- (string->symbol target)))) + (requirement '(root-file-system)) + (documentation "Check, mount, and unmount the given file system.") + (start #~(lambda args + #$(if check? + #~(check-file-system #$device #$type) + #~#t) + (mount #$device #$target #$type 0 #$options) + #t)) + (stop #~(lambda args + ;; Normally there are no processes left at this point, so + ;; TARGET can be safely unmounted. + (umount #$target) + #f)))))) + +(define %do-not-kill-file + ;; Name of the file listing PIDs of processes that must survive when halting + ;; the system. Typical example is user-space file systems. + "/etc/dmd/do-not-kill") + +(define* (user-processes-service requirements #:key (grace-delay 2)) + "Return the service that is responsible for terminating all the processes so +that the root file system can be re-mounted read-only, just before +rebooting/halting. Processes still running GRACE-DELAY seconds after SIGTERM +has been sent are terminated with SIGKILL. + +The returned service will depend on 'root-file-system' and on all the services +listed in REQUIREMENTS. + +All the services that spawn processes must depend on this one so that they are +stopped before 'kill' is called." + (with-monad %store-monad + (return (service + (documentation "When stopped, terminate all user processes.") + (provision '(user-processes)) + (requirement (cons 'root-file-system requirements)) + (start #~(const #t)) + (stop #~(lambda _ + (define (kill-except omit signal) + ;; Kill all the processes with SIGNAL except those + ;; listed in OMIT and the current process. + (let ((omit (cons (getpid) omit))) + (for-each (lambda (pid) + (unless (memv pid omit) + (false-if-exception + (kill pid signal)))) + (processes)))) + + (define omitted-pids + ;; List of PIDs that must not be killed. + (if (file-exists? #$%do-not-kill-file) + (map string->number + (call-with-input-file #$%do-not-kill-file + (compose string-tokenize + (@ (ice-9 rdelim) read-string)))) + '())) + + ;; When this happens, all the processes have been + ;; killed, including 'deco', so DMD-OUTPUT-PORT and + ;; thus CURRENT-OUTPUT-PORT are dangling. + (call-with-output-file "/dev/console" + (lambda (port) + (display "sending all processes the TERM signal\n" + port))) + + (if (null? omitted-pids) + (begin + ;; Easy: terminate all of them. + (kill -1 SIGTERM) + (sleep #$grace-delay) + (kill -1 SIGKILL)) + (begin + ;; Kill them all except OMITTED-PIDS. XXX: We + ;; would like to (kill -1 SIGSTOP) to get a fixed + ;; list of processes, like 'killall5' does, but + ;; that seems unreliable. + (kill-except omitted-pids SIGTERM) + (sleep #$grace-delay) + (kill-except omitted-pids SIGKILL) + (delete-file #$%do-not-kill-file))) + + (display "all processes have been terminated\n") + #f)) + (respawn? #f))))) + (define (host-name-service name) "Return a service that sets the host name to NAME." (with-monad %store-monad (return (service (documentation "Initialize the machine's host name.") (provision '(host-name)) - (start `(lambda _ - (sethostname ,name))) + (start #~(lambda _ + (sethostname #$name))) (respawn? #f))))) (define* (mingetty-service tty @@ -57,8 +195,7 @@ (motd (text-file "motd" "Welcome.\n")) (allow-empty-passwords? #t)) "Return a service to run mingetty on TTY." - (mlet %store-monad ((mingetty-bin (package-file mingetty "sbin/mingetty")) - (motd motd)) + (mlet %store-monad ((motd motd)) (return (service (documentation (string-append "Run mingetty on " tty ".")) @@ -66,12 +203,12 @@ ;; Since the login prompt shows the host name, wait for the 'host-name' ;; service to be done. - (requirement '(host-name)) + (requirement '(user-processes host-name)) - (start `(make-forkexec-constructor ,mingetty-bin "--noclear" ,tty)) - (stop `(make-kill-destructor)) - (inputs `(("mingetty" ,mingetty) - ("motd" ,motd))) + (start #~(make-forkexec-constructor + (string-append #$mingetty "/sbin/mingetty") + "--noclear" #$tty)) + (stop #~(make-kill-destructor)) (pam-services ;; Let 'login' be known to PAM. All the mingetty services will have @@ -83,16 +220,23 @@ (define* (nscd-service #:key (glibc glibc-final)) "Return a service that runs libc's name service cache daemon (nscd)." - (mlet %store-monad ((nscd (package-file glibc "sbin/nscd"))) + (with-monad %store-monad (return (service (documentation "Run libc's name service cache daemon (nscd).") (provision '(nscd)) - (start `(make-forkexec-constructor ,nscd "-f" "/dev/null" - "--foreground")) - (stop `(make-kill-destructor)) + (requirement '(user-processes)) - (respawn? #f) - (inputs `(("glibc" ,glibc))))))) + (activate #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/run/nscd"))) + + (start + #~(make-forkexec-constructor (string-append #$glibc "/sbin/nscd") + "-f" "/dev/null" + "--foreground")) + (stop #~(make-kill-destructor)) + + (respawn? #f))))) (define (syslog-service) "Return a service that runs 'syslogd' with reasonable default settings." @@ -120,21 +264,22 @@ ") (mlet %store-monad - ((syslog.conf (text-file "syslog.conf" contents)) - (syslogd (package-file inetutils "libexec/syslogd"))) + ((syslog.conf (text-file "syslog.conf" contents))) (return (service (documentation "Run the syslog daemon (syslogd).") (provision '(syslogd)) - (start `(make-forkexec-constructor ,syslogd "--no-detach" - "--rcfile" ,syslog.conf)) - (stop `(make-kill-destructor)) - (inputs `(("inetutils" ,inetutils) - ("syslog.conf" ,syslog.conf))))))) + (requirement '(user-processes)) + (start + #~(make-forkexec-constructor (string-append #$inetutils + "/libexec/syslogd") + "--no-detach" + "--rcfile" #$syslog.conf)) + (stop #~(make-kill-destructor)))))) (define* (guix-build-accounts count #:key + (group "guixbuild") (first-uid 30001) - (gid 30000) (shadow shadow)) "Return a list of COUNT user accounts for Guix build users, with UIDs starting at FIRST-UID, and under GID." @@ -143,34 +288,32 @@ starting at FIRST-UID, and under GID." (lambda (n) (user-account (name (format #f "guixbuilder~2,'0d" n)) - (password "!") (uid (+ first-uid n -1)) - (gid gid) + (group group) (comment (format #f "Guix Build User ~2d" n)) (home-directory "/var/empty") - (shell (package-file shadow "sbin/nologin")) - (inputs `(("shadow" ,shadow))))) + (shell #~(string-append #$shadow "/sbin/nologin")))) 1+ 1)))) (define* (guix-service #:key (guix guix) (builder-group "guixbuild") - (build-user-gid 30000) (build-accounts 10)) + (build-accounts 10)) "Return a service that runs the build daemon from GUIX, and has BUILD-ACCOUNTS user accounts available under BUILD-USER-GID." - (mlet %store-monad ((daemon (package-file guix "bin/guix-daemon")) - (accounts (guix-build-accounts build-accounts - #:gid build-user-gid))) + (mlet %store-monad ((accounts (guix-build-accounts build-accounts + #:group builder-group))) (return (service (provision '(guix-daemon)) - (start `(make-forkexec-constructor ,daemon - "--build-users-group" - ,builder-group)) - (stop `(make-kill-destructor)) - (inputs `(("guix" ,guix))) + (requirement '(user-processes)) + (start + #~(make-forkexec-constructor (string-append #$guix + "/bin/guix-daemon") + "--build-users-group" + #$builder-group)) + (stop #~(make-kill-destructor)) (user-accounts accounts) (user-groups (list (user-group (name builder-group) - (id build-user-gid) (members (map user-account-name user-accounts))))))))) diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm new file mode 100644 index 0000000000..3fbbfde09b --- /dev/null +++ b/gnu/services/dbus.scm @@ -0,0 +1,120 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 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 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)) + + (define (services->sxml services) + ;; Return the SXML 'includedir' clauses for DIRS. + `(busconfig + ,@(map (lambda (dir) + `(includedir ,(string-append dir + "/etc/dbus-1/system.d"))) + 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 + (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")))) + (user-accounts (list (user-account + (name "messagebus") + (group "messagebus") + (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/dmd.scm b/gnu/services/dmd.scm index 54fb5cbfd6..982c196fe4 100644 --- a/gnu/services/dmd.scm +++ b/gnu/services/dmd.scm @@ -17,6 +17,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (gnu services dmd) + #:use-module (guix gexp) #:use-module (guix monads) #:use-module (gnu services) #:use-module (ice-9 match) @@ -29,52 +30,45 @@ ;;; ;;; Code: -(define (dmd-configuration-file services etc) - "Return the dmd configuration file for SERVICES, that initializes /etc from -ETC (the name of a directory in the store) on startup." - (define config - `(begin - (use-modules (ice-9 ftw)) +(define (dmd-configuration-file services) + "Return the dmd configuration file for SERVICES." + (define modules + ;; Extra modules visible to dmd.conf. + '((guix build syscalls) + (guix build linux-initrd) + (guix build utils))) - (register-services - ,@(map (lambda (service) - `(make <service> - #:docstring ',(service-documentation service) - #:provides ',(service-provision service) - #:requires ',(service-requirement service) - #:respawn? ',(service-respawn? service) - #:start ,(service-start service) - #:stop ,(service-stop service))) - services)) + (mlet %store-monad ((modules (imported-modules modules)) + (compiled (compiled-modules modules))) + (define config + #~(begin + (eval-when (expand load eval) + (set! %load-path (cons #$modules %load-path)) + (set! %load-compiled-path + (cons #$compiled %load-compiled-path))) - ;; /etc is a mixture of static and dynamic settings. Here is where we - ;; initialize it from the static part. - (format #t "populating /etc from ~a...~%" ,etc) - (let ((rm-f (lambda (f) - (false-if-exception (delete-file f))))) - (rm-f "/etc/static") - (symlink ,etc "/etc/static") - (for-each (lambda (file) - ;; TODO: Handle 'shadow' specially so that changed - ;; password aren't lost. - (let ((target (string-append "/etc/" file)) - (source (string-append "/etc/static/" file))) - (rm-f target) - (symlink source target))) - (scandir ,etc - (lambda (file) - (not (member file '("." "..")))))) + (use-modules (ice-9 ftw) + (guix build syscalls) + ((guix build linux-initrd) + #:select (check-file-system))) - ;; Prevent ETC from being GC'd. - (rm-f "/var/guix/gcroots/etc-directory") - (symlink ,etc "/var/guix/gcroots/etc-directory")) + (register-services + #$@(map (lambda (service) + #~(make <service> + #:docstring '#$(service-documentation service) + #:provides '#$(service-provision service) + #:requires '#$(service-requirement service) + #:respawn? '#$(service-respawn? service) + #:start #$(service-start service) + #:stop #$(service-stop service))) + services)) - ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around it. - (setenv "PATH" "/run/current-system/bin") + ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around it. + (setenv "PATH" "/run/current-system/profile/bin") - (format #t "starting services...~%") - (for-each start ',(append-map service-provision services)))) + (format #t "starting services...~%") + (for-each start '#$(append-map service-provision services)))) - (text-file "dmd.conf" (object->string config))) + (gexp->file "dmd.conf" config))) ;;; dmd.scm ends here diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm index 317800db50..8bb05850e3 100644 --- a/gnu/services/networking.scm +++ b/gnu/services/networking.scm @@ -20,6 +20,7 @@ #:use-module (gnu services) #:use-module (gnu packages admin) #:use-module (gnu packages linux) + #:use-module (guix gexp) #:use-module (guix monads) #:export (static-networking-service)) @@ -41,40 +42,41 @@ true, it must be a string specifying the default network gateway." ;; TODO: Eventually we should do this using Guile's networking procedures, ;; like 'configure-qemu-networking' does, but the patch that does this is ;; not yet in stock Guile. - (mlet %store-monad ((ifconfig (package-file inetutils "bin/ifconfig")) - (route (package-file net-tools "sbin/route"))) + (with-monad %store-monad (return (service (documentation (string-append "Set up networking on the '" interface "' interface using a static IP address.")) (provision '(networking)) - (start `(lambda _ - ;; Return #t if successfully started. - (and (zero? (system* ,ifconfig ,interface ,ip "up")) - ,(if gateway - `(zero? (system* ,route "add" "-net" "default" - "gw" ,gateway)) - #t) - ,(if (pair? name-servers) - `(call-with-output-file "/etc/resolv.conf" - (lambda (port) - (display - "# Generated by 'static-networking-service'.\n" - port) - (for-each (lambda (server) - (format port "nameserver ~a~%" - server)) - ',name-servers))) - #t)))) - (stop `(lambda _ + (start #~(lambda _ + ;; Return #t if successfully started. + (and (zero? (system* (string-append #$inetutils + "/bin/ifconfig") + #$interface #$ip "up")) + #$(if gateway + #~(zero? (system* (string-append #$net-tools + "/sbin/route") + "add" "-net" "default" + "gw" #$gateway)) + #t) + #$(if (pair? name-servers) + #~(call-with-output-file "/etc/resolv.conf" + (lambda (port) + (display + "# Generated by 'static-networking-service'.\n" + port) + (for-each (lambda (server) + (format port "nameserver ~a~%" + server)) + '#$name-servers))) + #t)))) + (stop #~(lambda _ ;; Return #f is successfully stopped. - (not (and (system* ,ifconfig ,interface "down") - (system* ,route "del" "-net" "default"))))) - (respawn? #f) - (inputs `(("inetutils" ,inetutils) - ,@(if gateway - `(("net-tools" ,net-tools)) - '()))))))) + (not (and (system* (string-append #$inetutils "/bin/ifconfig") + #$interface "down") + (system* (string-append #$net-tools "/sbin/route") + "del" "-net" "default"))))) + (respawn? #f))))) ;;; networking.scm ends here diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm index 086150a658..7215297f69 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.scm @@ -27,6 +27,7 @@ #:use-module (gnu packages gnustep) #:use-module (gnu packages admin) #:use-module (gnu packages bash) + #:use-module (guix gexp) #:use-module (guix monads) #:use-module (guix derivations) #:export (xorg-start-command @@ -86,77 +87,42 @@ Section \"Screen\" Device \"Device-vesa\" EndSection")) - (mlet %store-monad ((guile-bin (package-file guile "bin/guile")) - (xorg-bin (package-file xorg-server "bin/X")) - (dri (package-file mesa "lib/dri")) - (xkbcomp-bin (package-file xkbcomp "bin")) - (xkb-dir (package-file xkeyboard-config - "share/X11/xkb")) - (config (xserver.conf))) - (define builder + (mlet %store-monad ((config (xserver.conf))) + (define script ;; Write a small wrapper around the X server. - `(let ((out (assoc-ref %outputs "out"))) - (call-with-output-file out - (lambda (port) - (format port "#!~a --no-auto-compile~%!#~%" ,guile-bin) - (write '(begin - (setenv "XORG_DRI_DRIVER_PATH" ,dri) - (setenv "XKB_BINDIR" ,xkbcomp-bin) - - (apply execl - - ,xorg-bin "-ac" "-logverbose" "-verbose" - "-xkbdir" ,xkb-dir - "-config" ,(derivation->output-path config) - "-nolisten" "tcp" "-terminate" - - ;; Note: SLiM and other display managers add the - ;; '-auth' flag by themselves. - (cdr (command-line)))) - port))) - (chmod out #o555) - #t)) - - (mlet %store-monad ((inputs (lower-inputs - `(("xorg" ,xorg-server) - ("xkbcomp" ,xkbcomp) - ("xkeyboard-config" ,xkeyboard-config) - ("mesa" ,mesa) - ("guile" ,guile) - ("xorg.conf" ,config))))) - (derivation-expression "start-xorg" builder - #:inputs inputs)))) + #~(begin + (setenv "XORG_DRI_DRIVER_PATH" (string-append #$mesa "/lib/dri")) + (setenv "XKB_BINDIR" (string-append #$xkbcomp "/bin")) + + (apply execl (string-append #$xorg-server "/bin/X") + "-ac" "-logverbose" "-verbose" + "-xkbdir" (string-append #$xkeyboard-config "/share/X11/xkb") + "-config" #$config + "-nolisten" "tcp" "-terminate" + + ;; Note: SLiM and other display managers add the + ;; '-auth' flag by themselves. + (cdr (command-line))))) + + (gexp->script "start-xorg" script))) (define* (xinitrc #:key (guile guile-final) (ratpoison ratpoison) (windowmaker windowmaker)) "Return a system-wide xinitrc script that starts the specified X session." - (mlet %store-monad ((guile-bin (package-file guile "bin/guile")) - (ratpoison-bin (package-file ratpoison "bin/ratpoison")) - (wmaker-bin (package-file windowmaker "bin/wmaker")) - (inputs (lower-inputs - `(("raptoison" ,ratpoison) - ("wmaker" ,windowmaker))))) - (define builder - `(let ((out (assoc-ref %outputs "out"))) - (call-with-output-file out - (lambda (port) - (format port "#!~a --no-auto-compile~%!#~%" ,guile-bin) - (write '(begin - (use-modules (ice-9 match)) - - ;; TODO: Check for ~/.xsession. - (match (command-line) - ((_ "ratpoison") - (execl ,ratpoison-bin)) - (_ - (execl ,wmaker-bin)))) - port))) - (chmod out #o555) - #t)) - - (derivation-expression "xinitrc" builder #:inputs inputs))) + (define builder + #~(begin + (use-modules (ice-9 match)) + + ;; TODO: Check for ~/.xsession. + (match (command-line) + ((_ "ratpoison") + (execl (string-append #$ratpoison "/bin/ratpoison"))) + (_ + (execl (string-append #$windowmaker "/bin/wmaker")))))) + + (gexp->script "xinitrc" builder)) (define* (slim-service #:key (slim slim) (allow-empty-passwords? #t) auto-login? @@ -173,7 +139,7 @@ When AUTO-LOGIN? is true, log in automatically as DEFAULT-USER." (mlet %store-monad ((startx (or startx (xorg-start-command))) (xinitrc (xinitrc))) (text-file* "slim.cfg" " -default_path /run/current-system/bin +default_path /run/current-system/profile/bin default_xserver " startx " xserver_arguments :0 vt7 xauth_path " xauth "/bin/xauth @@ -181,7 +147,7 @@ authfile /var/run/slim.auth # The login command. '%session' is replaced by the chosen session name, one # of the names specified in the 'sessions' setting: 'wmaker', 'xfce', etc. -login_cmd exec " xinitrc "%session +login_cmd exec " xinitrc " %session sessions wmaker,ratpoison halt_cmd " dmd "/sbin/halt @@ -190,25 +156,19 @@ reboot_cmd " dmd "/sbin/reboot (string-append "auto_login yes\ndefault_user " default-user) "")))) - (mlet %store-monad ((slim-bin (package-file slim "bin/slim")) - (bash-bin (package-file bash "bin/bash")) - (slim.cfg (slim.cfg))) + (mlet %store-monad ((slim.cfg (slim.cfg))) (return (service (documentation "Xorg display server") (provision '(xorg-server)) - (requirement '(host-name)) + (requirement '(user-processes host-name)) (start ;; XXX: Work around the inability to specify env. vars. directly. - `(make-forkexec-constructor - ,bash-bin "-c" - ,(string-append "SLIM_CFGFILE=" (derivation->output-path slim.cfg) - " " slim-bin - " -nodaemon"))) - (stop `(make-kill-destructor)) - (inputs `(("slim" ,slim) - ("slim.cfg" ,slim.cfg) - ("bash" ,bash))) + #~(make-forkexec-constructor + (string-append #$bash "/bin/sh") "-c" + (string-append "SLIM_CFGFILE=" #$slim.cfg + " " #$slim "/bin/slim" " -nodaemon"))) + (stop #~(make-kill-destructor)) (respawn? #t) (pam-services ;; Tell PAM about 'slim'. |