aboutsummaryrefslogtreecommitdiff
path: root/HACKING
blob: 28948b3e23deda5428486d0eb3c1a5d07141af79 (about) (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
-*- mode: org; coding: utf-8; -*-

#+TITLE: Hacking GNU Guix and Its Incredible Distro

Copyright © 2012, 2013, 2014, 2016 Ludovic Courtès <ludo@gnu.org>
Copyright © 2015 Mathieu Lirzin <mthl@openmailbox.org>

  Copying and distribution of this file, with or without modification,
  are permitted in any medium without royalty provided the copyright
  notice and this notice are preserved.

* Contributing

See the manual for useful hacking informations, either by running

  info -f doc/guix.info "(guix) Contributing"

or by checking the [[http://www.gnu.org/software/guix/manual/guix.html#Contributing][web copy of the manual]].

* Commit Access

For frequent contributors, having write access to the repository is
convenient.  When you deem it necessary, feel free to ask for it on the
mailing list.  When you get commit access, please make sure to follow the
policy below (discussions of the policy can take place on guix-devel@gnu.org.)

Non-trivial patches should always be posted to guix-devel@gnu.org (trivial
patches include fixing typos, etc.)

For patches that just add a new package, and a simple one, it’s OK to commit,
if you’re confident (which means you successfully built it in a chroot setup,
and have done a reasonable copyright and license auditing.)  Likewise for
package upgrades, except upgrades that trigger a lot of rebuilds (for example,
upgrading GnuTLS or GLib.)  We have a mailing list for commit notifications
(guix-commits@gnu.org), so people can notice.  Before pushing your changes,
make sure to run ‘git pull --rebase’.

All commits that are pushed to the central repository on Savannah must be
signed with an OpenPGP key, and the public key should be uploaded to your user
account on Savannah and to public key servers, such as ‘pgp.mit.edu’.  To
configure Git to automatically sign commits, run:

  git config commit.gpgsign true
  git config user.signingkey CABBA6EA1DC0FF33

For anything else, please post to guix-devel@gnu.org and leave time for a
review, without committing anything.  If you didn’t receive any reply
after two weeks, and if you’re confident, it’s OK to commit.

That last part is subject to being adjusted, allowing individuals to commit
directly on non-controversial changes on parts they’re familiar with.
-locker-configuration? screen-locker-configuration-name screen-locker-configuration-program screen-locker-configuration-allow-empty-password? screen-locker-configuration-using-pam? screen-locker-configuration-using-setuid? screen-locker-service-type screen-locker-service ; deprecated localed-configuration localed-configuration? localed-service-type dconf-keyfile dconf-profile dconf-profile-name dconf-profile-content dconf-profile-keyfile dconf-service-type gdm-configuration gdm-service-type handle-xorg-configuration set-xorg-configuration)) ;;; Commentary: ;;; ;;; Services that relate to the X Window System. ;;; ;;; Code: (define %default-xorg-modules ;; Default list of modules loaded by the server. When multiple drivers ;; match, the first one in the list is loaded. (list xf86-video-vesa xf86-video-fbdev xf86-video-amdgpu xf86-video-ati xf86-video-cirrus xf86-video-intel xf86-video-mach64 xf86-video-nouveau xf86-video-nv xf86-video-sis ;; Libinput is the new thing and is recommended over evdev/synaptics: ;; <http://who-t.blogspot.fr/2015/01/xf86-input-libinput-compatibility-with.html>. xf86-input-libinput xf86-input-evdev xf86-input-keyboard xf86-input-mouse)) (define %default-xorg-fonts ;; Default list of fonts available to the X server. (list (file-append font-alias "/share/fonts/X11/75dpi") (file-append font-alias "/share/fonts/X11/100dpi") (file-append font-alias "/share/fonts/X11/misc") (file-append font-alias "/share/fonts/X11/cyrillic") (file-append font-misc-misc ;default fonts for xterm "/share/fonts/X11/misc") (file-append font-adobe75dpi "/share/fonts/X11/75dpi"))) (define %default-xorg-server-arguments ;; Default command-line arguments for X. '("-nolisten" "tcp")) ;; Configuration of an Xorg server. (define-record-type* <xorg-configuration> xorg-configuration make-xorg-configuration xorg-configuration? (modules xorg-configuration-modules ;list of file-like (thunked) ; 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 (default '())) (resolutions xorg-configuration-resolutions ;list of tuples (default '())) (keyboard-layout xorg-configuration-keyboard-layout ;#f | <keyboard-layout> (default #f)) (extra-config xorg-configuration-extra-config ;list of strings (default '())) (server xorg-configuration-server ;file-like (default xorg-server)) (server-arguments xorg-configuration-server-arguments ;list of strings (default %default-xorg-server-arguments))) (define (xorg-configuration->file config) "Compute an Xorg configuration file corresponding to CONFIG, an <xorg-configuration> record." (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 " Section \"Device\" Identifier \"device-" driver "\" Driver \"" driver "\" EndSection")) (define (screen-section driver resolutions) (string-append " Section \"Screen\" Identifier \"screen-" driver "\" Device \"device-" driver "\" SubSection \"Display\" Modes " (string-join (map (match-lambda ((x y) (string-append "\"" (number->string x) "x" (number->string y) "\""))) resolutions)) " EndSubSection EndSection")) (define (input-class-section layout variant model options) (string-append " Section \"InputClass\" Identifier \"evdev keyboard catchall\" MatchIsKeyboard \"on\" Option \"XkbLayout\" " (object->string layout) (if variant (string-append " Option \"XkbVariant\" \"" variant "\"") "") (if model (string-append " Option \"XkbModel\" \"" model "\"") "") (match options (() "") (_ (string-append " Option \"XkbOptions\" \"" (string-join options ",") "\""))) " MatchDevicePath \"/dev/input/event*\" 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 " 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))) (define (xorg-configuration-directory modules) "Return a directory that contains the @code{.conf} files for X.org that includes the @code{share/X11/xorg.conf.d} directories of each package listed in @var{modules}." (with-imported-modules '((guix build utils)) (computed-file "xorg.conf.d" #~(begin (use-modules (guix build utils) (srfi srfi-1)) (define files (append-map (lambda (module) (find-files (string-append module "/share/X11/xorg.conf.d") "\\.conf$")) (list #$@modules))) (mkdir #$output) (for-each (lambda (file) (symlink file (string-append #$output "/" (basename file)))) files) #t)))) (define (xorg-configuration-server-package-path config input path) "Lookup the direct @var{input} in the xorg server package of @var{config} and append @var{path} to it." (let* ((server (xorg-configuration-server config)) (package (lookup-package-direct-input server input))) (when package (file-append package path)))) (define (xorg-configuration-dri-driver-path config) (xorg-configuration-server-package-path config "mesa" "/lib/dri")) (define (xorg-configuration-xkb-bin-dir config) (xorg-configuration-server-package-path config "xkbcomp" "/bin")) (define (xorg-configuration-xkb-dir config) (xorg-configuration-server-package-path config "xkeyboard-config" "/share/X11/xkb")) (define* (xorg-wrapper #:optional (config (xorg-configuration))) "Return a derivation that builds a script to start the X server with the given @var{config}. The resulting script should be used in place of @code{/usr/bin/X}." (define exp ;; Write a small wrapper around the X server. #~(begin (setenv "XORG_DRI_DRIVER_PATH" #$(xorg-configuration-dri-driver-path config)) (setenv "XKB_BINDIR" #$(xorg-configuration-xkb-bin-dir config)) (let ((X (string-append #$(xorg-configuration-server config) "/bin/X"))) (apply execl X X "-xkbdir" #$(xorg-configuration-xkb-dir config) "-config" #$(xorg-configuration->file config) "-configdir" #$(xorg-configuration-directory (xorg-configuration-modules config)) (cdr (command-line)))))) (program-file "X-wrapper" exp)) (define* (xorg-start-command #:optional (config (xorg-configuration))) "Return a @code{startx} script in which the modules, fonts, etc. specified in @var{config}, are available. The result should be used in place of @code{startx}." (define X (xorg-wrapper config)) (define exp ;; Write a small wrapper around the X server. #~(apply execl #$X #$X ;; Second #$X is for argv[0]. "-logverbose" "-verbose" "-terminate" #$@(xorg-configuration-server-arguments config) (cdr (command-line)))) (program-file "startx" exp)) (define* (xorg-start-command-xinit #:optional (config (xorg-configuration))) "Return a @code{startx} script in which the modules, fonts, etc. specified in @var{config}, are available. The result should be used in place of @code{startx}. Compared to the @code{xorg-start-command} it calls xinit, therefore it works well when executed from tty." (define X (xorg-wrapper config)) (define exp ;; Small wrapper providing subset of functionality of typical startx ;; script from distributions like alpine. (with-imported-modules (source-module-closure '((guix build utils))) #~(begin (use-modules (guix build utils) (ice-9 popen) (ice-9 textual-ports)) (define (capture-stdout . prog+args) (let* ((port (apply open-pipe* OPEN_READ prog+args)) (data (get-string-all port))) (if (zero? (status:exit-val (close-pipe port))) (string-trim-right data #\newline) (error "Command failed: " prog+args)))) (define (determine-unused-display n) (let ((lock-file (format #f "/tmp/.X~a-lock" n)) (sock-file (format #f "/tmp/.X11-unix/X~a" n))) (if (or (file-exists? lock-file) (false-if-exception (eq? 'socket (stat:type (stat sock-file))))) (determine-unused-display (+ n 1)) (format #f ":~a" n)))) (define (determine-vty) (let ((fd0 (readlink "/proc/self/fd/0")) (pref "/dev/tty")) (if (string-prefix? pref fd0) (string-append "vt" (substring fd0 (string-length pref))) (error (format #f "Cannot determine VT from: ~a" fd0))))) (define (enable-xauth server-auth-file display) ;; Configure and enable X authority (or (getenv "XAUTHORITY") (setenv "XAUTHORITY" (string-append (getenv "HOME") "/.Xauthority"))) (let* ((bin/xauth #$(file-append xauth "/bin/xauth")) (bin/mcookie #$(file-append util-linux "/bin/mcookie")) (mcookie (capture-stdout bin/mcookie))) (invoke bin/xauth "-qf" server-auth-file "add" display "." mcookie) (invoke bin/xauth "-q" "add" display "." mcookie))) (let* ((xinit #$(file-append xinit "/bin/xinit")) (display (determine-unused-display 0)) (vty (determine-vty)) (server-auth-port (mkstemp "/tmp/serverauth.XXXXXX")) (server-auth-file (port-filename server-auth-port))) (close-port server-auth-port) (enable-xauth server-auth-file display) (apply execl xinit xinit "--" #$X display vty "-keeptty" "-auth" server-auth-file ;; These are set by xorg-start-command, so do the same to keep ;; it consistent. "-logverbose" "-verbose" "-terminate" #$@(xorg-configuration-server-arguments config) (cdr (command-line))))))) (program-file "startx" exp)) (define (startx-command-profile-service config) ;; XXX: profile-service-type only accepts <package> objects. (package (name "startx-profile-package") (version "0") (source (xorg-start-command-xinit config)) (build-system trivial-build-system) (arguments (list #:modules '((guix build utils)) #:builder #~(begin (use-modules (guix build utils)) (let ((bin (string-append #$output "/bin"))) (mkdir-p bin) (symlink #$source (string-append bin "/startx")))))) (home-page #f) (synopsis #f) (description #f) (license #f))) (define startx-command-service-type (service-type (name 'startx-command) (extensions (list (service-extension profile-service-type (compose list startx-command-profile-service)))) (default-value (xorg-configuration)) (description "Add @command{startx} to the system profile."))) (define* (xinitrc #:key fallback-session) "Return a system-wide xinitrc script that starts the specified X session, which should be passed to this script as the first argument. If not, the @var{fallback-session} will be used or, if @var{fallback-session} is false, a desktop session from the system or user profile will be used." (define builder #~(begin (use-modules (ice-9 match) (ice-9 regex) (ice-9 ftw) (ice-9 rdelim) (srfi srfi-1) (srfi srfi-26)) (define (close-all-fdes) ;; Close all the open file descriptors except 0 to 2. (let loop ((fd 3)) (when (< fd 4096) ;FIXME: use sysconf + _SC_OPEN_MAX (false-if-exception (close-fdes fd)) (loop (+ 1 fd))))) (define (exec-from-login-shell command . args) ;; Run COMMAND from a login shell so that it gets to see the same ;; environment variables that one gets when logging in on a tty, for ;; instance. (let* ((pw (getpw (getuid))) (shell (passwd:shell pw))) ;; Close any open file descriptors. This is all the more ;; important that SLiM itself exec's us directly without closing ;; its own file descriptors! (close-all-fdes) ;; The '--login' option is supported at least by Bash and zsh. (execl shell shell "--login" "-c" (string-join (cons command args))))) (define system-profile "/run/current-system/profile") (define user-profile (and=> (getpw (getuid)) (lambda (pw) (string-append (passwd:dir pw) "/.guix-profile")))) (define (xsession-command desktop-file) ;; Read from DESKTOP-FILE its X session command and return it as a ;; list. (define exec-regexp (make-regexp "^[[:blank:]]*Exec=(.*)$")) (call-with-input-file desktop-file (lambda (port) (let loop () (match (read-line port) ((? eof-object?) #f) ((= (cut regexp-exec exec-regexp <>) result) (if result (string-tokenize (match:substring result 1)) (loop)))))))) (define (find-session profile) ;; Return an X session command from PROFILE or #f if none was found. (let ((directory (string-append profile "/share/xsessions"))) (match (scandir directory (cut string-suffix? ".desktop" <>)) ((or () #f) #f) ((sessions ...) (any xsession-command (map (cut string-append directory "/" <>) sessions)))))) (let* ((home (getenv "HOME")) (xsession-file (string-append home "/.xsession")) (session (match (command-line) ((_) #$(if fallback-session #~(list #$fallback-session) #f)) ((_ x ..1) x)))) (if (file-exists? xsession-file) ;; Run ~/.xsession when it exists. (apply exec-from-login-shell xsession-file (or session '())) ;; Otherwise, start the specified session or a fallback. (apply exec-from-login-shell (or session (find-session user-profile) (find-session system-profile))))))) (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))))))) (define (xorg-server-profile-service config) ;; XXX: profile-service-type only accepts <package> objects. (list (package (name "xorg-wrapper") (version (package-version xorg-server)) (source (xorg-wrapper config)) (build-system trivial-build-system) (arguments '(#:modules ((guix build utils)) #:builder (begin (use-modules (guix build utils)) (let* ((source (assoc-ref %build-inputs "source")) (out (assoc-ref %outputs "out")) (bin (string-append out "/bin"))) (mkdir-p bin) (symlink source (string-append bin "/X")) (symlink source (string-append bin "/Xorg")) #t)))) (home-page (package-home-page xorg-server)) (synopsis (package-synopsis xorg-server)) (description (package-description xorg-server)) (license (package-license xorg-server))))) (define xorg-server-service-type (service-type (name 'xorg-server) (extensions (list (service-extension profile-service-type xorg-server-profile-service))) (default-value (xorg-configuration)) (description "Add @command{X} to the system profile, to be used with @command{sx} or @command{xinit}."))) ;;; ;;; SLiM log-in manager. ;;; (define %default-slim-theme ;; Theme based on work by Felipe López. (file-append %artwork-repository "/slim")) (define %default-slim-theme-name ;; This must be the name of the sub-directory in %DEFAULT-SLIM-THEME that ;; contains the actual theme files. "1.x") (define-record-type* <slim-configuration> slim-configuration make-slim-configuration slim-configuration? (slim slim-configuration-slim (default slim)) (allow-empty-passwords? slim-configuration-allow-empty-passwords? (default #t)) (gnupg? slim-configuration-gnupg? (default #f)) (auto-login? slim-configuration-auto-login? (default #f)) (default-user slim-configuration-default-user (default "")) (theme slim-configuration-theme (default %default-slim-theme)) (theme-name slim-configuration-theme-name (default %default-slim-theme-name)) (xauth slim-configuration-xauth (default xauth)) (shepherd slim-configuration-shepherd (default shepherd)) (auto-login-session slim-configuration-auto-login-session (default #f)) (xorg-configuration slim-configuration-xorg (default (xorg-configuration))) (display slim-configuration-display (default ":0")) (vt slim-configuration-vt (default "vt7")) (sessreg slim-configuration-sessreg (default sessreg))) (define (slim-pam-service config) "Return a PAM service for @command{slim}." (list (unix-pam-service "slim" #:login-uid? #t #:allow-empty-passwords? (slim-configuration-allow-empty-passwords? config) #:gnupg? (slim-configuration-gnupg? config)))) (define (slim-shepherd-service config) (let* ((xinitrc (xinitrc #:fallback-session (slim-configuration-auto-login-session config))) (xauth (slim-configuration-xauth config)) (startx (xorg-start-command (slim-configuration-xorg config))) (display (slim-configuration-display config)) (vt (slim-configuration-vt config)) (shepherd (slim-configuration-shepherd config)) (theme-name (slim-configuration-theme-name config)) (sessreg (slim-configuration-sessreg config)) (lockfile (string-append "/var/run/slim-" vt ".lock"))) (define slim.cfg (mixed-text-file "slim.cfg" " default_path /run/current-system/profile/bin default_xserver " startx " display_name " display " xserver_arguments " vt " xauth_path " xauth "/bin/xauth authfile /var/run/slim-" vt ".auth lockfile " lockfile " logfile /var/log/slim-" vt ".log # 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 sessiondir /run/current-system/profile/share/xsessions session_msg session (F1 to change): sessionstart_cmd " sessreg "/bin/sessreg -a -l $DISPLAY %user sessionstop_cmd " sessreg "/bin/sessreg -d -l $DISPLAY %user halt_cmd " shepherd "/sbin/halt reboot_cmd " shepherd "/sbin/reboot\n" (if (slim-configuration-auto-login? config) (string-append "auto_login yes\ndefault_user " (slim-configuration-default-user config) "\n") "") (if theme-name (string-append "current_theme " theme-name "\n") ""))) (define theme (slim-configuration-theme config)) (list (shepherd-service (documentation "Xorg display server") (provision (append ;; For compatibility, also provide 'xorg-server'. (if (string=? vt "vt7") '(xorg-server) '()) (list (symbol-append 'xorg-server- (string->symbol vt))))) (requirement '(pam user-processes host-name udev)) (start #~(lambda () ;; A stale lock file can prevent SLiM from starting, so remove it to ;; be on the safe side. (false-if-exception (delete-file lockfile)) (fork+exec-command (list (string-append #$(slim-configuration-slim config) "/bin/slim") "-nodaemon") #:environment-variables (list (string-append "SLIM_CFGFILE=" #$slim.cfg) #$@(if theme (list #~(string-append "SLIM_THEMESDIR=" #$theme)) #~()))))) (stop #~(make-kill-destructor)) (respawn? #t))))) (define slim-service-type (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))) (default-value (slim-configuration)) (description "Run the SLiM graphical login manager for X11.")))) ;;; ;;; Screen lockers & co. ;;; (define-configuration/no-serialization screen-locker-configuration (name string "Name of the screen locker.") (program file-like "Path to the executable for the screen locker as a G-Expression.") (allow-empty-password? (boolean #f) "Whether to allow empty passwords.") (using-pam? (boolean #t) "Whether to setup PAM entry.") (using-setuid? (boolean #t) "Whether to setup program as setuid binary.")) (define (screen-locker-pam-services config) (match-record config <screen-locker-configuration> (name allow-empty-password? using-pam?) (if using-pam? (list (unix-pam-service name #:allow-empty-passwords? allow-empty-password?)) '()))) (define (screen-locker-privileged-programs config) (match-record config <screen-locker-configuration> (name program using-setuid?) (if using-setuid? (list (privileged-program (program program) (setuid? #t))) '()))) (define screen-locker-service-type (service-type (name 'screen-locker) (extensions (list (service-extension pam-root-service-type screen-locker-pam-services) (service-extension privileged-program-service-type screen-locker-privileged-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-generate-doc) (configuration->documentation 'screen-locker-configuration)) (define-deprecated (screen-locker-service package #:optional (program (package-name package)) #:key allow-empty-passwords?) screen-locker-service-type "Add @var{package}, a package for a screen locker or screen saver whose command is @var{program}, to the set of setuid programs and add a PAM entry for it. For example: @lisp (screen-locker-service xlockmore \"xlock\") @end lisp makes the good ol' XlockMore usable." (service screen-locker-service-type (screen-locker-configuration (name program) (program (file-append package "/bin/" program)) (allow-empty-password? allow-empty-passwords?)))) ;;; ;;; Locale service. ;;; (define-record-type* <localed-configuration> localed-configuration make-localed-configuration localed-configuration? (localed localed-configuration-localed (default localed)) (keyboard-layout localed-configuration-keyboard-layout (default #f))) (define (localed-dbus-service config) "Return the 'localed' D-Bus service for @var{config}, a @code{<localed-configuration>} record." (define keyboard-layout (localed-configuration-keyboard-layout config)) ;; The primary purpose of 'localed' is to tell GDM what the "current" Xorg ;; keyboard layout is. If 'localed' is missing, or if it's unable to ;; determine the current XKB layout, then GDM forcefully installs its ;; default XKB config (US English). Here we communicate the configured ;; layout through environment variables. (if keyboard-layout (let* ((layout (keyboard-layout-name keyboard-layout)) (variant (keyboard-layout-variant keyboard-layout)) (model (keyboard-layout-model keyboard-layout)) (options (keyboard-layout-options keyboard-layout))) (list (wrapped-dbus-service (localed-configuration-localed config) "libexec/localed/localed" `(("GUIX_XKB_LAYOUT" ,layout) ,@(if variant `(("GUIX_XKB_VARIANT" ,variant)) '()) ,@(if model `(("GUIX_XKB_MODEL" ,model)) '()) ,@(if (null? options) '() `(("GUIX_XKB_OPTIONS" ,(string-join options ",")))))))) '())) (define localed-service-type (let ((package (lambda (config) ;; Don't bother if the user didn't specify any keyboard ;; layout. (if (localed-configuration-keyboard-layout config) (list (localed-configuration-localed config)) '())))) (service-type (name 'localed) (extensions (list (service-extension dbus-root-service-type localed-dbus-service) (service-extension udev-service-type package) (service-extension polkit-service-type package) ;; Add 'localectl' to the profile. (service-extension profile-service-type package))) ;; This service can be extended, typically by the X login ;; manager, to communicate the chosen Xorg keyboard layout. (compose (lambda (extensions) (find keyboard-layout? extensions))) (extend (lambda (config keyboard-layout) (localed-configuration (inherit config) (keyboard-layout keyboard-layout)))) (description "Run the locale daemon, @command{localed}, which can be used to control the system locale and keyboard mapping from user programs such as the GNOME desktop environment.") (default-value (localed-configuration))))) ;;; ;;; Dconf. ;;; (define-maybe text-config) (define-configuration/no-serialization dconf-keyfile (name string "The file name of the associated keyfile, e.g. \"00-login-screen\".") (content text-config "The content of the associated keyfile.")) (define-configuration/no-serialization dconf-profile (name string "The file name of the dconf system profile, which should match the name of a user for which the profile is to be used with. To have the profile used, the environment variable \"DCONF_PROFILE\" should be set to the profile file, e.g.: @example export DCONF_PROFILE=/etc/dconf/profile/gdm @end example") (content maybe-text-config "The content of the Dconf profile. Unless provided, it defaults to include the user database (\"user-db:NAME\") as well as the system database (\"system-db:NAME\"), which corresponds to the generated database, @file{/etc/dconf/db/NAME}.") (keyfile dconf-keyfile "The keyfile associated with the profile")) (define dconf-profiles? (list-of dconf-profile?)) (define-configuration/no-serialization dconf-configuration (profiles dconf-profiles "The list of <dconf-profile> objects to populate.")) (define (dconf-profile->profile-file profile) "Given PROFILE, a <dconf-profile> object, return a dconf profile file." (let ((name (dconf-profile-name profile)) (content (dconf-profile-content profile))) (apply mixed-text-file name (if (maybe-value-set? content) (interpose content "\n" 'suffix) (interpose (list (string-append "user-db:" name) (string-append "system-db:" name)) "\n" 'suffix))))) (define (dconf-profile->db-keyfile profile) "Given PROFILE, a <dconf-profile> object, return a dconf profile file." (let ((keyfile (dconf-profile-keyfile profile))) (apply mixed-text-file (dconf-keyfile-name keyfile) (interpose (dconf-keyfile-content keyfile) "\n" 'suffix)))) (define (dconf-profile->db-keyfile-dir profile) "Wrap the keyfile in a directory, to satisfy 'dconf compile'." (let ((name (dconf-profile-name profile)) (keyfile-name (dconf-keyfile-name (dconf-profile-keyfile profile)))) (computed-file name #~(begin (mkdir #$output) (symlink #$(dconf-profile->db-keyfile profile) (string-append #$output "/" #$keyfile-name)))))) (define (dconf-profile->db profile) "Compile the a <dconf-profile> object into a GVariant Database file." (let ((name (dconf-profile-name profile))) (computed-file name (with-imported-modules '((guix build utils)) #~(begin (use-modules (guix build utils)) (setenv "DCONF_PROFILE" #$(dconf-profile->profile-file profile)) (invoke #$(file-append dconf "/bin/dconf") "compile" #$output #$(dconf-profile->db-keyfile-dir profile))))))) (define (dconf-profile->files profile) "Given PROFILE, a <dconf-profile> object, return a dconf directory containing the associated profile, keyfile and database files to be assembled under /etc." (let ((name (dconf-profile-name profile)) (keyfile-name (dconf-keyfile-name (dconf-profile-keyfile profile)))) (list (list (string-append "dconf/profile/" name) (dconf-profile->profile-file profile)) (list (string-append "dconf/db/" name ".d/" keyfile-name) (dconf-profile->db-keyfile profile)) (list (string-append "dconf/db/" name) (dconf-profile->db profile))))) (define dconf-service-type (service-type (name 'dconf-profile) (extensions (list (service-extension etc-service-type (lambda (dconf-profiles) (append-map dconf-profile->files dconf-profiles))))) (compose concatenate) (extend append) (default-value '()) (description "Extend the @code{etc-service-type} to populate the file hierarchy under @file{/etc/dconf} with the <dconf-profile> objects provided as argument."))) ;;; ;;; GNOME Desktop Manager. ;;; (define %gdm-accounts (list (user-group (name "gdm") (system? #t)) (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 dbus-daemon-wrapper (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")))) (define home-profile (and=> (getpw (getuid)) (lambda (pw) (string-append (passwd:dir pw) "/.guix-home/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 (append (if home-profile (list home-profile) '()) (if user-profile (list user-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))))) ;; Wrapper script for Wayland sessions, similar to Xsession. ;; ;; See `xinitrc`. By default, it launches the specified session through a ;; login shell. With the default Guix configuration, this should source ;; /etc/profile, setting up the Guix profile environment variables. However, ;; gdm launches its own graphical session through the same method, so we need ;; to ignore this case, since `gdm` doesn't have a login shell. (define gdm-wayland-session-wrapper (program-file "gdm-wayland-session-wrapper" #~((let* ((user (getpw (getuid))) (name (passwd:name user)) (shell (passwd:shell user)) (args (cdr (command-line)))) (if (string=? name "gdm") (apply execl (cons (car args) args)) (execl shell shell "--login" "-c" (string-join args))))))) (define-record-type* <gdm-configuration> gdm-configuration make-gdm-configuration gdm-configuration? (gdm gdm-configuration-gdm (default gdm)) (allow-empty-passwords? gdm-configuration-allow-empty-passwords? (default #t)) (auto-login? gdm-configuration-auto-login? (default #f)) (auto-suspend? gdm-configuration-auto-suspend? (default #t)) (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-abattis-cantarell))) (xorg-configuration gdm-configuration-xorg (default (xorg-configuration))) (x-session gdm-configuration-x-session (default (xinitrc))) (xdmcp? gdm-configuration-xdmcp? (default #f)) (wayland? gdm-configuration-wayland? (default #t)) (wayland-session gdm-configuration-wayland-session (default gdm-wayland-session-wrapper))) (define (gdm-dconf-profiles config) (if (gdm-configuration-auto-suspend? config) '() ;; This custom gconf profile works around a lack of configuration option ;; to disable auto-suspend when no users are physically logged in (see: ;; https://gitlab.gnome.org/GNOME/gnome-control-center/-/issues/22). (list (dconf-profile (name "gdm") (content (list #~(begin (use-modules (ice-9 textual-ports)) (string-trim (call-with-input-file #$(file-append gdm "/share/dconf/profile/gdm") get-string-all))) "system-db:gdm")) (keyfile (dconf-keyfile (name "00-disable-suspend") (content (list "[org/gnome/settings-daemon/plugins/power]" "sleep-inactive-ac-type='nothing'" "sleep-inactive-battery-type='nothing'" "sleep-inactive-ac-timeout=0" "sleep-inactive-battery-timeout=0")))))))) (define (gdm-configuration-file config) (mixed-text-file "gdm-custom.conf" "[daemon]\n" "#User=gdm\n" "#Group=gdm\n" (if (gdm-configuration-auto-login? config) (string-append "AutomaticLoginEnable=true\n" "AutomaticLogin=" (or (gdm-configuration-default-user config) (error "missing default user for auto-login")) "\n") (string-append "AutomaticLoginEnable=false\n" "#AutomaticLogin=\n")) "#TimedLoginEnable=false\n" "#TimedLogin=\n" "#TimedLoginDelay=0\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" (format #f "WaylandEnable=~:[false~;true~]~%" (gdm-configuration-wayland? config)) "\n" "[debug]\n" (format #f "Enable=~:[false~;true~]~%" (gdm-configuration-debug? config)) "\n" "[security]\n" "#DisallowTCP=true\n" "#AllowRemoteAutoLogin=false\n" "\n" "[xdmcp]\n" (format #f "Enable=~:[false~;true~]~%" (gdm-configuration-xdmcp? config)))) (define (gdm-pam-service config) "Return a PAM service for @command{gdm}." (list (pam-service (inherit (unix-pam-service "gdm-autologin" #:login-uid? #t)) (auth (list (pam-entry (control "optional") (module (file-append (gdm-configuration-gdm config) "/lib/security/pam_gdm.so"))) (pam-entry (control "sufficient") (module "pam_permit.so"))))) (pam-service (inherit (unix-pam-service "gdm-launch-environment")) (auth (list (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)))) (define (gdm-shepherd-service config) (define config-file (gdm-configuration-file config)) (list (shepherd-service (documentation "Xorg display server (GDM)") (provision '(xorg-server)) (requirement '(dbus-system pam user-processes host-name udev elogind)) (start #~(make-forkexec-constructor '(#$(file-append (gdm-configuration-gdm config) "/bin/gdm")) #:environment-variables (list #$@(if (gdm-configuration-auto-suspend? config) #~() #~("DCONF_PROFILE=/etc/dconf/profile/gdm")) (string-append "GDM_CUSTOM_CONF=" #$config-file) (string-append "GDM_DBUS_DAEMON=" #$(gdm-configuration-dbus-daemon config)) (string-append "GDM_X_SERVER=" #$(xorg-wrapper (gdm-configuration-xorg config))) (string-append "GDM_X_SESSION=" #$(gdm-configuration-x-session config)) (string-append "XDG_DATA_DIRS=" ((lambda (ls) (string-join ls ":")) (map (lambda (path) (string-append path "/share")) ;; XXX: Remove gnome-shell below when GDM ;; can depend on GNOME Shell directly. (cons #$gnome-shell '#$(gdm-configuration-gnome-shell-assets config))))) ;; Add XCURSOR_PATH so that mutter can find its ;; cursors. gdm doesn't login so doesn't source ;; the corresponding line in /etc/profile. "XCURSOR_PATH=/run/current-system/profile/share/icons" (string-append "GDK_PIXBUF_MODULE_FILE=" #$gnome-shell "/" #$%gdk-pixbuf-loaders-cache-file) (string-append "GDM_WAYLAND_SESSION=" #$(gdm-configuration-wayland-session config))))) (stop #~(make-kill-destructor)) (actions (list (shepherd-configuration-action config-file))) (respawn? #t)))) (define gdm-polkit-rules (lambda (config) (if (gdm-configuration-xdmcp? config) ;; Allow remote (XDMCP) users to use colord; otherwise an ;; authentication dialog would appear on the GDM screen (see the ;; upstream bug: ;; https://gitlab.gnome.org/GNOME/gnome-settings-daemon/-/issues/273). (list (computed-file "02-allow-colord.rules" (with-imported-modules '((guix build utils)) #~(begin (use-modules (guix build utils)) (let* ((rules.d (string-append #$output "/share/polkit-1" "/rules.d")) (allow-colord.rules (string-append rules.d "/02-allow-colord.rules"))) (mkdir-p rules.d) (call-with-output-file allow-colord.rules (lambda (port) ;; This workaround enables any local or remote in ;; the "users" group to use colord (see: ;; https://c-nergy.be/blog/?p=12073). (format port "\ polkit.addRule(function(action, subject) { if (action.id.match(\"org.freedesktop.color-manager\")) { polkit.log(\"POLKIT DEBUG returning YES for action: \" + action); return polkit.Result.YES; } });~%")))))))) '()))) (define gdm-service-type (handle-xorg-configuration gdm-configuration (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 dconf-service-type gdm-dconf-profiles) (service-extension pam-root-service-type gdm-pam-service) (service-extension polkit-service-type gdm-polkit-rules) (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.")))) ;; Since GDM depends on Rust and Rust is not available on all platforms, ;; use SDDM as the fall-back display manager. ;; TODO: Switch the condition to take into account if Rust is supported and ;; match the configuration in desktop-services-for-system. (define* (set-xorg-configuration config #:optional (login-manager-service-type (if (target-x86-64?) gdm-service-type sddm-service-type))) "Tell the log-in manager (of type @var{login-manager-service-type}) to use @var{config}, an <xorg-configuration> record." (simple-service 'set-xorg-configuration login-manager-service-type config)) ;;; xorg.scm ends here