;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Andy Wingo <wingo@igalia.com>
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
;;; Copyright © 2018, 2019 Timothy Sample <samplet@ngyro.com>
;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2019 Tim Gesthuizen <tim.gesthuizen@yahoo.de>
+;;; Copyright © 2020 shtwzrd <shtwzrd@protonmail.com>
+;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
+;;; Copyright © 2020 Alex Griffin <a@ajgrf.com>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (gnu system keyboard)
#:use-module (gnu services base)
#:use-module (gnu services dbus)
- #:use-module ((gnu packages base) #:select (canonical-package))
+ #:use-module (gnu packages base)
#:use-module (gnu packages guile)
#:use-module (gnu packages xorg)
#:use-module (gnu packages fonts)
gdm-configuration
gdm-service-type
gdm-service
+
+ handle-xorg-configuration
set-xorg-configuration))
;;; Commentary:
xorg-configuration make-xorg-configuration
xorg-configuration?
(modules xorg-configuration-modules ;list of packages
- (default %default-xorg-modules))
+ ; filter out modules not supported on current system
+ (default (filter
+ (lambda (p)
+ (member (%current-system)
+ (package-supported-systems p)))
+ %default-xorg-modules)))
(fonts xorg-configuration-fonts ;list of packges
(default %default-xorg-fonts))
(drivers xorg-configuration-drivers ;list of strings
(define (xorg-configuration->file config)
"Compute an Xorg configuration file corresponding to CONFIG, an
<xorg-configuration> record."
- (define all-modules
- ;; 'xorg-server' provides 'fbdevhw.so' etc.
- (append (xorg-configuration-modules config)
- (list xorg-server)))
-
- (define build
- #~(begin
- (use-modules (ice-9 match)
- (srfi srfi-1)
- (srfi srfi-26))
-
- (call-with-output-file #$output
- (lambda (port)
- (define drivers
- '#$(xorg-configuration-drivers config))
+ (let ((xorg-server (xorg-configuration-server config)))
+ (define all-modules
+ ;; 'xorg-server' provides 'fbdevhw.so' etc.
+ (append (xorg-configuration-modules config)
+ (list xorg-server)))
+
+ (define build
+ #~(begin
+ (use-modules (ice-9 match)
+ (srfi srfi-1)
+ (srfi srfi-26))
+
+ (call-with-output-file #$output
+ (lambda (port)
+ (define drivers
+ '#$(xorg-configuration-drivers config))
- (define (device-section driver)
- (string-append "
+ (define (device-section driver)
+ (string-append "
Section \"Device\"
Identifier \"device-" driver "\"
Driver \"" driver "\"
EndSection"))
- (define (screen-section driver resolutions)
- (string-append "
+ (define (screen-section driver resolutions)
+ (string-append "
Section \"Screen\"
Identifier \"screen-" driver "\"
Device \"device-" driver "\"
EndSubSection
EndSection"))
- (define (input-class-section layout variant model options)
- (string-append "
+ (define (input-class-section layout variant model options)
+ (string-append "
Section \"InputClass\"
Identifier \"evdev keyboard catchall\"
MatchIsKeyboard \"on\"
Driver \"evdev\"
EndSection\n"))
- (define (expand modules)
- ;; Append to MODULES the relevant /lib/xorg/modules
- ;; sub-directories.
- (append-map (lambda (module)
- (filter-map (lambda (directory)
- (let ((full (string-append module
- directory)))
- (and (file-exists? full)
- full)))
- '("/lib/xorg/modules/drivers"
- "/lib/xorg/modules/input"
- "/lib/xorg/modules/multimedia"
- "/lib/xorg/modules/extensions")))
- modules))
-
- (display "Section \"Files\"\n" port)
- (for-each (lambda (font)
- (format port " FontPath \"~a\"~%" font))
- '#$(xorg-configuration-fonts config))
- (for-each (lambda (module)
- (format port
- " ModulePath \"~a\"~%"
- module))
- (append (expand '#$all-modules)
-
- ;; For fbdevhw.so and so on.
- (list #$(file-append xorg-server
- "/lib/xorg/modules"))))
- (display "EndSection\n" port)
- (display "
+ (define (expand modules)
+ ;; Append to MODULES the relevant /lib/xorg/modules
+ ;; sub-directories.
+ (append-map (lambda (module)
+ (filter-map (lambda (directory)
+ (let ((full (string-append module
+ directory)))
+ (and (file-exists? full)
+ full)))
+ '("/lib/xorg/modules/drivers"
+ "/lib/xorg/modules/input"
+ "/lib/xorg/modules/multimedia"
+ "/lib/xorg/modules/extensions")))
+ modules))
+
+ (display "Section \"Files\"\n" port)
+ (for-each (lambda (font)
+ (format port " FontPath \"~a\"~%" font))
+ '#$(xorg-configuration-fonts config))
+ (for-each (lambda (module)
+ (format port
+ " ModulePath \"~a\"~%"
+ module))
+ (append (expand '#$all-modules)
+
+ ;; For fbdevhw.so and so on.
+ (list #$(file-append xorg-server
+ "/lib/xorg/modules"))))
+ (display "EndSection\n" port)
+ (display "
Section \"ServerFlags\"
Option \"AllowMouseOpenFail\" \"on\"
EndSection\n" port)
- (display (string-join (map device-section drivers) "\n")
- port)
- (newline port)
- (display (string-join
- (map (cut screen-section <>
- '#$(xorg-configuration-resolutions config))
- drivers)
- "\n")
- port)
- (newline port)
-
- (let ((layout #$(and=> (xorg-configuration-keyboard-layout config)
- keyboard-layout-name))
- (variant #$(and=> (xorg-configuration-keyboard-layout config)
- keyboard-layout-variant))
- (model #$(and=> (xorg-configuration-keyboard-layout config)
- keyboard-layout-model))
- (options '#$(and=> (xorg-configuration-keyboard-layout config)
- keyboard-layout-options)))
- (when layout
- (display (input-class-section layout variant model options)
- port)
- (newline port)))
-
- (for-each (lambda (config)
- (display config port))
- '#$(xorg-configuration-extra-config config))))))
-
- (computed-file "xserver.conf" build))
+ (display (string-join (map device-section drivers) "\n")
+ port)
+ (newline port)
+ (display (string-join
+ (map (cut screen-section <>
+ '#$(xorg-configuration-resolutions config))
+ drivers)
+ "\n")
+ port)
+ (newline port)
+
+ (let ((layout #$(and=> (xorg-configuration-keyboard-layout config)
+ keyboard-layout-name))
+ (variant #$(and=> (xorg-configuration-keyboard-layout config)
+ keyboard-layout-variant))
+ (model #$(and=> (xorg-configuration-keyboard-layout config)
+ keyboard-layout-model))
+ (options '#$(and=> (xorg-configuration-keyboard-layout config)
+ keyboard-layout-options)))
+ (when layout
+ (display (input-class-section layout variant model options)
+ port)
+ (newline port)))
+
+ (for-each (lambda (config)
+ (display config port))
+ '#$(xorg-configuration-extra-config config))))))
+
+ (computed-file "xserver.conf" build)))
(define (xorg-configuration-directory modules)
"Return a directory that contains the @code{.conf} files for X.org that
(program-file "xinitrc" builder))
+(define-syntax handle-xorg-configuration
+ (syntax-rules ()
+ "Generate the `compose' and `extend' entries of a login manager
+`service-type' to handle specifying the `xorg-configuration' through
+a `service-extension', as used by `set-xorg-configuration'."
+ ((_ configuration-record service-type-definition)
+ (service-type
+ (inherit service-type-definition)
+ (compose (lambda (extensions)
+ (match extensions
+ (() #f)
+ ((config . _) config))))
+ (extend (lambda (config xorg-configuration)
+ (if xorg-configuration
+ (configuration-record
+ (inherit config)
+ (xorg-configuration xorg-configuration))
+ config)))))))
+
\f
;;;
;;; SLiM log-in manager.
(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.x")
+ "1.x")
(define-record-type* <slim-configuration>
slim-configuration make-slim-configuration
"Return a PAM service for @command{slim}."
(list (unix-pam-service
"slim"
+ #:login-uid? #t
#:allow-empty-passwords?
(slim-configuration-allow-empty-passwords? config))))
(respawn? #t)))))
(define slim-service-type
- (service-type (name 'slim)
- (extensions
- (list (service-extension shepherd-root-service-type
- slim-shepherd-service)
- (service-extension pam-root-service-type
- slim-pam-service)
+ (handle-xorg-configuration slim-configuration
+ (service-type (name 'slim)
+ (extensions
+ (list (service-extension shepherd-root-service-type
+ slim-shepherd-service)
+ (service-extension pam-root-service-type
+ slim-pam-service)
+
+ ;; Unconditionally add xterm to the system profile, to
+ ;; avoid bad surprises.
+ (service-extension profile-service-type
+ (const (list xterm)))))
- ;; Unconditionally add xterm to the system profile, to
- ;; avoid bad surprises.
- (service-extension profile-service-type
- (const (list xterm)))))
- (default-value (slim-configuration))))
+ (default-value (slim-configuration))
+ (description
+ "Run the SLiM graphical login manager for X11."))))
(define-deprecated (slim-service #:key (slim slim)
(allow-empty-passwords? #t) auto-login?
(list (service-extension pam-root-service-type
screen-locker-pam-services)
(service-extension setuid-program-service-type
- screen-locker-setuid-programs)))))
+ screen-locker-setuid-programs)))
+ (description
+ "Allow the given program to be used as a screen locker for
+the graphical server by making it setuid-root, so it can authenticate users,
+and by creating a PAM service for it.")))
(define* (screen-locker-service package
#:optional
(user-account
(name "gdm")
(group "gdm")
+ (supplementary-groups '("video"))
(system? #t)
(comment "GNOME Display Manager user")
(home-directory "/var/lib/gdm")
(shell (file-append shadow "/sbin/nologin")))))
+(define %gdm-activation
+ ;; Ensure /var/lib/gdm is owned by the "gdm" user. This is normally the
+ ;; case but could be wrong if the "gdm" user was created, then removed, and
+ ;; then recreated under a different UID/GID: <https://bugs.gnu.org/37423>.
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils))
+
+ (let* ((gdm (getpwnam "gdm"))
+ (uid (passwd:uid gdm))
+ (gid (passwd:gid gdm))
+ (st (stat "/var/lib/gdm" #f)))
+ ;; Recurse into /var/lib/gdm only if it has wrong ownership.
+ (when (and st
+ (or (not (= uid (stat:uid st)))
+ (not (= gid (stat:gid st)))))
+ (for-each (lambda (file)
+ (chown file uid gid))
+ (find-files "/var/lib/gdm"
+ #:directories? #t)))))))
+
(define dbus-daemon-wrapper
- (program-file "gdm-dbus-wrapper"
- #~(begin
- (setenv "XDG_CONFIG_DIRS"
- "/run/current-system/profile/etc/xdg")
- (setenv "XDG_DATA_DIRS"
- "/run/current-system/profile/share")
- (apply execl (string-append #$dbus "/bin/dbus-daemon")
- (program-arguments)))))
+ (program-file
+ "gdm-dbus-wrapper"
+ #~(begin
+ (use-modules (srfi srfi-26))
+
+ (define system-profile
+ "/run/current-system/profile")
+
+ (define user-profile
+ (and=> (getpw (getuid))
+ (lambda (pw)
+ (string-append (passwd:dir pw) "/.guix-profile"))))
+
+ ;; If we are able to find the user's profile, we can add it to
+ ;; the search paths set below. We need to do this so that D-Bus
+ ;; can start services installed by the user. This allows
+ ;; applications that require session D-Bus services (e.g,
+ ;; 'evolution') to work even if those services are only available
+ ;; in the user's profile. See <https://bugs.gnu.org/35267>.
+ (define profiles
+ (if user-profile
+ (list user-profile system-profile)
+ (list system-profile)))
+
+ (setenv "XDG_CONFIG_DIRS"
+ (string-join (map (cut string-append <> "/etc/xdg") profiles)
+ ":"))
+ (setenv "XDG_DATA_DIRS"
+ (string-join (map (cut string-append <> "/share") profiles)
+ ":"))
+ (apply execl (string-append #$dbus "/bin/dbus-daemon")
+ (program-arguments)))))
(define-record-type* <gdm-configuration>
gdm-configuration make-gdm-configuration
(allow-empty-passwords? gdm-configuration-allow-empty-passwords? (default #t))
(auto-login? gdm-configuration-auto-login? (default #f))
(dbus-daemon gdm-configuration-dbus-daemon (default dbus-daemon-wrapper))
+ (debug? gdm-configuration-debug? (default #f))
(default-user gdm-configuration-default-user (default #f))
(gnome-shell-assets gdm-configuration-gnome-shell-assets
(default (list adwaita-icon-theme font-cantarell)))
"#TimedLoginEnable=false\n"
"#TimedLogin=\n"
"#TimedLoginDelay=0\n"
- "#InitialSetupEnable=true\n"
+ ;; Disable initial system setup inside GDM.
+ ;; Whatever settings are set there should already be
+ ;; taken care of through `guix system'.
+ ;; See also
+ ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=39281>.
+ "InitialSetupEnable=false\n"
;; Enable me once X is working.
"WaylandEnable=false\n"
"\n"
"[debug]\n"
- "#Enable=true\n"
+ "Enable=" (if (gdm-configuration-debug? config)
+ "true"
+ "false") "\n"
"\n"
"[security]\n"
"#DisallowTCP=true\n"
"Return a PAM service for @command{gdm}."
(list
(pam-service
- (inherit (unix-pam-service "gdm-autologin"))
+ (inherit (unix-pam-service "gdm-autologin"
+ #:login-uid? #t))
(auth (list (pam-entry
- (control "[success=ok default=1]")
+ (control "optional")
(module (file-append (gdm-configuration-gdm config)
"/lib/security/pam_gdm.so")))
(pam-entry
(control "required")
(module "pam_permit.so")))))
(unix-pam-service "gdm-password"
+ #:login-uid? #t
#:allow-empty-passwords?
(gdm-configuration-allow-empty-passwords? config))))
(respawn? #t))))
(define gdm-service-type
- (service-type (name 'gdm)
- (extensions
- (list (service-extension shepherd-root-service-type
- gdm-shepherd-service)
- (service-extension account-service-type
- (const %gdm-accounts))
- (service-extension pam-root-service-type
- gdm-pam-service)
- (service-extension profile-service-type
- gdm-configuration-gnome-shell-assets)
- (service-extension dbus-root-service-type
- (compose list
- gdm-configuration-gdm))
- (service-extension localed-service-type
- (compose
- xorg-configuration-keyboard-layout
- gdm-configuration-xorg))))
-
- ;; For convenience, this service can be extended with an
- ;; <xorg-configuration> record. Take the first one that
- ;; comes.
- (compose (lambda (extensions)
- (match extensions
- (() #f)
- ((config . _) config))))
- (extend (lambda (config xorg-configuration)
- (if xorg-configuration
- (gdm-configuration
- (inherit config)
- (xorg-configuration xorg-configuration))
- config)))
-
- (default-value (gdm-configuration))
- (description
- "Run the GNOME Desktop Manager (GDM), a program that allows
-you to log in in a graphical session, whether or not you use GNOME.")))
+ (handle-xorg-configuration gdm-configuration
+ (service-type (name 'gdm)
+ (extensions
+ (list (service-extension shepherd-root-service-type
+ gdm-shepherd-service)
+ (service-extension activation-service-type
+ (const %gdm-activation))
+ (service-extension account-service-type
+ (const %gdm-accounts))
+ (service-extension pam-root-service-type
+ gdm-pam-service)
+ (service-extension profile-service-type
+ gdm-configuration-gnome-shell-assets)
+ (service-extension dbus-root-service-type
+ (compose list
+ gdm-configuration-gdm))
+ (service-extension localed-service-type
+ (compose
+ xorg-configuration-keyboard-layout
+ gdm-configuration-xorg))))
+ (default-value (gdm-configuration))
+ (description
+ "Run the GNOME Desktop Manager (GDM), a program that allows
+you to log in in a graphical session, whether or not you use GNOME."))))
(define-deprecated (gdm-service #:key (gdm gdm)
(allow-empty-passwords? #t)
HCoop / jackhill / guix / guix.git / blobdiff