Merge branch 'gnome-team'

4 files changed, 230 insertions, 54 deletions

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index cd61df718e..5104b3d104 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -85,6 +85,7 @@
                           swap-space->flags-bit-mask))
   #:autoload   (guix channels) (%default-channels channel->code)
   #:use-module (guix gexp)
+  #:use-module ((guix packages) #:select (package-version))
   #:use-module (guix records)
   #:use-module (guix modules)
   #:use-module (guix pki)
@@ -155,11 +156,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?
@@ -2268,11 +2273,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))
@@ -2283,51 +2290,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,
@@ -2435,13 +2455,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)
@@ -2450,12 +2484,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}
@@ -2490,6 +2527,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..8dee91a3f7 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
diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm
index 5b79fbcda1..02a7802d58 100644
--- a/gnu/services/desktop.scm
+++ b/gnu/services/desktop.scm
@@ -37,6 +37,7 @@
   #:use-module (gnu services)
   #:use-module (gnu services shepherd)
   #:use-module (gnu services base)
+  #:use-module (gnu services configuration)
   #:use-module (gnu services dbus)
   #:use-module (gnu services avahi)
   #:use-module (gnu services xorg)
@@ -60,6 +61,7 @@
   #:use-module (gnu packages kde)
   #:use-module (gnu packages kde-frameworks)
   #:use-module (gnu packages kde-plasma)
+  #:use-module (gnu packages pulseaudio)
   #:use-module (gnu packages xfce)
   #:use-module (gnu packages avahi)
   #:use-module (gnu packages xdisorg)
@@ -79,6 +81,7 @@
   #:use-module (guix ui)
   #:use-module (guix utils)
   #:use-module (guix gexp)
+  #:use-module (guix modules)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 format)
@@ -139,6 +142,11 @@
 
             gnome-desktop-configuration
             gnome-desktop-configuration?
+            gnome-desktop-configuration-core-services
+            gnome-desktop-configuration-shell
+            gnome-desktop-configuration-utilities
+            gnome-desktop-configuration-extra-packages
+            gnome-desktop-configuration-udev-ignorelist
             gnome-desktop-service
             gnome-desktop-service-type
 
@@ -1382,11 +1390,45 @@ rules.")
 ;;; GNOME desktop service.
 ;;;
 
-(define-record-type* <gnome-desktop-configuration> gnome-desktop-configuration
-  make-gnome-desktop-configuration
-  gnome-desktop-configuration?
-  (gnome gnome-desktop-configuration-gnome
-         (default gnome)))
+(define-maybe/no-serialization package)
+
+(define (extract-propagated-inputs package)
+  ;; Drop input labels.  Attempt to support outputs.
+  (map
+   (match-lambda
+     ((_ (? package? pkg)) pkg)
+     ((_ (? package? pkg) output) (list pkg output)))
+   (package-propagated-inputs package)))
+
+(define-configuration/no-serialization gnome-desktop-configuration
+  (core-services
+   (list-of-packages (extract-propagated-inputs gnome-meta-core-services))
+   "A list of packages that the GNOME Shell and applications may rely on.")
+  (shell
+   (list-of-packages (extract-propagated-inputs gnome-meta-core-shell))
+   "A list of packages that constitute the GNOME Shell, without applications.")
+  (utilities
+   (list-of-packages (extract-propagated-inputs gnome-meta-core-utilities))
+   "A list of packages that serve as applications to use on top of the \
+GNOME Shell.")
+  (gnome (maybe-package) "Deprecated.  Do not use.")
+  (extra-packages
+   (list-of-packages (extract-propagated-inputs gnome-essential-extras))
+   "A list of GNOME-adjacent packages to also include.  This field is intended
+for users to add their own packages to their GNOME experience.  Note, that it
+already includes some packages that are considered essential by some (most?)
+GNOME users.")
+  (udev-ignorelist
+   (list-of-strings '())
+   "A list of regular expressions denoting udev rules or hardware file names
+provided by any package that should not be installed.  By default, every udev
+rule and hardware file specified by any package referenced in the other fields
+are installed.")
+  (polkit-ignorelist
+   (list-of-strings '())
+   "A list of regular expressions denoting polkit rules provided by any package
+that should not be installed.  By default, every polkit rule added by any package
+referenced in the other fields are installed."))
 
 (define (gnome-package gnome name)
   "Return the package NAME among the GNOME package inputs.  NAME can be a
@@ -1398,31 +1440,84 @@ denote the spice-gtk input of the gnome-boxes input of the GNOME meta-package."
   "Return the package NAMES among the GNOME package inputs."
   (map (cut gnome-package gnome <>) names))
 
-(define (gnome-udev-rules config)
-  "Return the list of GNOME dependencies that provide udev rules."
-  (let ((gnome (gnome-desktop-configuration-gnome config)))
-    (gnome-packages gnome '("gnome-settings-daemon"))))
+(define (gnome-udev-configuration-files config)
+  "Return the GNOME udev rules and hardware files as computed from its
+dependencies by filtering out the ignorelist."
+  (list
+   (computed-file
+    "gnome-udev-configurations"
+    (with-imported-modules
+        (source-module-closure '((guix build utils)
+                                 (guix build union)))
+      #~(begin
+          (use-modules (guix build utils)
+                       (guix build union))
+          ;; If rules.d or hwdb.d is not a proper directory but a symlink,
+          ;; then it will not be possible to delete individual files in this
+          ;; directory.
+          (union-build #$output
+                       (search-path-as-list
+                        (list "lib/udev" "libexec/udev")
+                        (list #$@(gnome-profile config)))
+                       #:create-all-directories? #t)
+          (for-each
+           (lambda (pattern)
+             (for-each
+              delete-file-recursively
+              (find-files #$output pattern)))
+           (list #$@(gnome-desktop-configuration-udev-ignorelist config))))))))
 
 (define (gnome-polkit-settings config)
   "Return the list of GNOME dependencies that provide polkit actions and
 rules."
-  (let ((gnome (gnome-desktop-configuration-gnome config)))
-    (gnome-packages gnome
-                    '("gnome-settings-daemon"
-                      "gnome-control-center"
-                      "gnome-system-monitor"
-                      "gvfs"))))
+  (list
+   (computed-file
+    "gnome-polkit-settings"
+    (with-imported-modules
+        (source-module-closure '((guix build utils)
+                                 (guix build union)))
+      #~(let ((output (string-append #$output "/share/polkit-1")))
+          (use-modules (guix build utils)
+                       (guix build union))
+          (mkdir-p (dirname output))
+          (union-build output
+                       (search-path-as-list
+                        (list "share/polkit-1")
+                        (list #$@(gnome-profile config)))
+                       #:create-all-directories? #t)
+          (for-each
+           (lambda (pattern)
+             (for-each
+              delete-file-recursively
+              (find-files output pattern)))
+           (list #$@(gnome-desktop-configuration-polkit-ignorelist config))))))))
+
+(define (gnome-profile config)
+  "Return a list of packages propagated through CONFIG."
+  (append
+   (gnome-desktop-configuration-core-services config)
+   (gnome-desktop-configuration-shell config)
+   (gnome-desktop-configuration-utilities config)
+   (let ((gnome-meta (gnome-desktop-configuration-gnome config)))
+     (if (maybe-value-set? gnome-meta)
+         (begin
+           (warning
+            (gnome-desktop-configuration-source-location config)
+            (G_ "Using a meta-package for gnome-desktop is discouraged.~%"))
+           (list gnome-meta))
+         (list)))
+   (gnome-desktop-configuration-extra-packages config)))
 
 (define gnome-desktop-service-type
   (service-type
    (name 'gnome-desktop)
    (extensions
     (list (service-extension udev-service-type
-                             gnome-udev-rules)
+                             gnome-udev-configuration-files)
           (service-extension polkit-service-type
                              gnome-polkit-settings)
           (service-extension profile-service-type
-                             (compose list gnome-desktop-configuration-gnome))))
+                             gnome-profile)))
    (default-value (gnome-desktop-configuration))
    (description "Run the GNOME desktop environment.")))
 
diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm
index b86e2d3c5b..26902c0568 100644
--- a/gnu/services/xorg.scm
+++ b/gnu/services/xorg.scm
@@ -1048,7 +1048,7 @@ argument.")))
              (default (xinitrc)))
   (xdmcp? gdm-configuration-xdmcp?
           (default #f))
-  (wayland? gdm-configuration-wayland? (default #f))
+  (wayland? gdm-configuration-wayland? (default #t))
   (wayland-session gdm-configuration-wayland-session
                    (default gdm-wayland-session-wrapper)))