diff options
Diffstat (limited to 'gnu/services')
| -rw-r--r-- | gnu/services/base.scm | 116 | ||||
| -rw-r--r-- | gnu/services/dbus.scm | 37 |
2 files changed, 117 insertions, 36 deletions
diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 82c6940780..154e3079d3 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -82,6 +82,7 @@ #:select (mount-flags->bit-mask swap-space->flags-bit-mask)) #:use-module (guix gexp) + #:use-module ((guix packages) #:select (package-version)) #:use-module (guix records) #:use-module (guix modules) #:use-module (guix pki) @@ -152,11 +153,15 @@ udev-configuration udev-configuration? udev-configuration-rules + udev-configuration-hardware udev-service-type udev-service ; deprecated udev-rule + udev-hardware file->udev-rule + file->udev-hardware udev-rules-service + udev-hardware-service login-configuration login-configuration? @@ -2232,11 +2237,13 @@ command that allows you to share pre-built binaries with others over HTTP."))) (udev udev-configuration-udev ;file-like (default eudev)) (rules udev-configuration-rules ;list of file-like - (default '()))) + (default '())) + (hardware udev-configuration-hardware ;list of file-like + (default '()))) -(define (udev-rules-union packages) - "Return the union of the @code{lib/udev/rules.d} directories found in each -item of @var{packages}." +(define (udev-configurations-union subdirectory packages) + "Return the union of the lib/udev/SUBDIRECTORY directories found in each +item of PACKAGES." (define build (with-imported-modules '((guix build union) (guix build utils)) @@ -2247,51 +2254,64 @@ item of @var{packages}." (srfi srfi-26)) (define %standard-locations - '("/lib/udev/rules.d" "/libexec/udev/rules.d")) + '(#$(string-append "/lib/udev/" subdirectory) + #$(string-append "/libexec/udev/" subdirectory))) - (define (rules-sub-directory directory) - ;; Return the sub-directory of DIRECTORY containing udev rules, or - ;; #f if none was found. + (define (configuration-sub-directory directory) + ;; Return the sub-directory of DIRECTORY containing udev + ;; configurations, or #f if none was found. (find directory-exists? (map (cut string-append directory <>) %standard-locations))) (union-build #$output - (filter-map rules-sub-directory '#$packages))))) + (filter-map configuration-sub-directory '#$packages))))) + + (computed-file (string-append "udev-" subdirectory) build)) + +(define (udev-rules-union packages) + "Return the union of the lib/udev/rules.d directories found in each +item of PACKAGES." + (udev-configurations-union "rules.d" packages)) - (computed-file "udev-rules" build)) +(define (udev-configuration-file subdirectory file-name contents) + "Return a directory with a udev configuration file FILE-NAME containing CONTENTS." + (file->udev-configuration-file subdirectory file-name (plain-file file-name contents))) (define (udev-rule file-name contents) "Return a directory with a udev rule file FILE-NAME containing CONTENTS." - (computed-file file-name - (with-imported-modules '((guix build utils)) - #~(begin - (use-modules (guix build utils)) - - (define rules.d - (string-append #$output "/lib/udev/rules.d")) + (udev-configuration-file "rules.d" file-name contents)) - (mkdir-p rules.d) - (call-with-output-file - (string-append rules.d "/" #$file-name) - (lambda (port) - (display #$contents port))))))) +(define (udev-hardware file-name contents) + "Return a directory with a udev hardware file FILE-NAME containing CONTENTS." + (udev-configuration-file "hwdb.d" file-name contents)) -(define (file->udev-rule file-name file) - "Return a directory with a udev rule file FILE-NAME which is a copy of FILE." +(define (file->udev-configuration-file subdirectory file-name file) + "Return a directory with a udev configuration file FILE-NAME which is a copy + of FILE." (computed-file file-name (with-imported-modules '((guix build utils)) #~(begin (use-modules (guix build utils)) - (define rules.d - (string-append #$output "/lib/udev/rules.d")) + (define configuration-directory + (string-append #$output + "/lib/udev/" + #$subdirectory)) (define file-copy-dest - (string-append rules.d "/" #$file-name)) + (string-append configuration-directory "/" #$file-name)) - (mkdir-p rules.d) + (mkdir-p configuration-directory) (copy-file #$file file-copy-dest))))) +(define (file->udev-rule file-name file) + "Return a directory with a udev rule file FILE-NAME which is a copy of FILE." + (file->udev-configuration-file "rules.d" file-name file)) + +(define (file->udev-hardware file-name file) + "Return a directory with a udev hardware file FILE-NAME which is a copy of FILE." + (file->udev-configuration-file "hwdb.d" file-name file)) + (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, @@ -2399,13 +2419,27 @@ item of @var{packages}." (define (udev-etc config) (match-record config <udev-configuration> - (udev rules) + (udev rules hardware) + (let* ((hardware + (udev-configurations-union "hwdb.d" (cons* udev hardware))) + (hwdb.bin + (computed-file + "hwdb.bin" + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (setenv "UDEV_HWDB_PATH" #$hardware) + (invoke #+(file-append udev "/bin/udevadm") + "hwdb" + "--update" + "-o" #$output)))))) `(("udev" ,(file-union "udev" `(("udev.conf" ,udev.conf) ("rules.d" ,(udev-rules-union (cons* udev kvm-udev-rule - rules))))))))) + rules))) + ("hwdb.bin" ,hwdb.bin)))))))) (define udev-service-type (service-type (name 'udev) @@ -2414,12 +2448,15 @@ item of @var{packages}." udev-shepherd-service) (service-extension etc-service-type udev-etc))) (compose concatenate) ;concatenate the list of rules - (extend (lambda (config rules) + (extend (lambda (config extensions) (let ((initial-rules - (udev-configuration-rules config))) + (udev-configuration-rules config)) + (initial-hardware + (udev-configuration-hardware config))) (udev-configuration (inherit config) - (rules (append initial-rules rules)))))) + (rules (append initial-rules extensions)) + (hardware (append initial-hardware extensions)))))) (default-value (udev-configuration)) (description "Run @command{udev}, which populates the @file{/dev} @@ -2454,6 +2491,19 @@ instance." (description "This service adds udev rules.")))) (service type #f))) +(define (udev-hardware-service name hardware-files) + "Return a service that extends udev-service-type with HARDWARE-FILES, named +NAME-udev-hardware." + (let* ((name (symbol-append name '-udev-hardware)) + (udev-extension (const (list hardware-files))) + (type (service-type + (name name) + (extensions (list + (service-extension + udev-service-type udev-extension))) + (description "This service adds udev hardware files.")))) + (service type #f))) + (define (swap-space->shepherd-service-name space) (let ((target (swap-space-target space))) (symbol-append 'swap- diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm index 5a0c634393..1edcc6eb9e 100644 --- a/gnu/services/dbus.scm +++ b/gnu/services/dbus.scm @@ -163,7 +163,7 @@ includes the @code{etc/dbus-1/system.d} directories of each package listed in (group "messagebus") (system? #t) (comment "D-Bus system bus user") - (home-directory "/var/run/dbus") + (home-directory "/run/dbus") (shell (file-append shadow "/sbin/nologin"))))) (define dbus-setuid-programs @@ -186,7 +186,38 @@ includes the @code{etc/dbus-1/system.d} directories of each package listed in (let ((user (getpwnam "messagebus"))) ;; This directory contains the daemon's socket so it must be ;; world-readable. - (mkdir-p/perms "/var/run/dbus" user #o755)) + (mkdir-p/perms "/run/dbus" user #o755)) + + (catch 'system-error + (lambda () + (symlink "/run/dbus" "/var/run/dbus")) + (lambda args + (let ((errno (system-error-errno args))) + (cond + ((= errno EEXIST) + (let ((existing-name + (false-if-exception + (readlink "/var/run/dbus")))) + (unless (equal? existing-name "/run/dbus") + ;; Move the content of /var/run/dbus to /run/dbus, and + ;; retry. + (let ((dir (opendir "/var/run/dbus"))) + (let loop ((next (readdir dir))) + (cond + ((eof-object? next) (closedir dir)) + ((member next '("." "..")) (loop (readdir dir))) + (else + (begin + (rename-file (string-append "/var/run/dbus/" next) + (string-append "/run/dbus/" next)) + (loop (readdir dir)))))))) + (rmdir "/var/run/dbus") + (symlink "/run/dbus" "/var/run/dbus"))) + (else + (format (current-error-port) + "Failed to symlink /run/dbus to /var/run/dbus: ~s~%" + (strerror errno)) + (error "cannot create /var/run/dbus")))))) (unless (file-exists? "/etc/machine-id") (format #t "creating /etc/machine-id...~%") @@ -210,7 +241,7 @@ includes the @code{etc/dbus-1/system.d} directories of each package listed in '(#:environment-variables '("DBUS_VERBOSE=1") #:log-file "/var/log/dbus-daemon.log") '()) - #:pid-file "/var/run/dbus/pid")) + #:pid-file "/run/dbus/pid")) (stop #~(make-kill-destructor))))))) (define dbus-root-service-type |