summaryrefslogtreecommitdiff
path: root/gnu/services
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/services')
-rw-r--r--gnu/services/base.scm109
-rw-r--r--gnu/services/certbot.scm2
-rw-r--r--gnu/services/guix.scm9
-rw-r--r--gnu/services/networking.scm123
-rw-r--r--gnu/services/shepherd.scm13
-rw-r--r--gnu/services/vnc.scm247
-rw-r--r--gnu/services/web.scm60
-rw-r--r--gnu/services/xorg.scm205
8 files changed, 676 insertions, 92 deletions
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 3f662f1a6c..d3e3335030 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -19,6 +19,7 @@
;;; Copyright © 2021 muradm <[email protected]>
;;; Copyright © 2022 Guillaume Le Vaillant <[email protected]>
;;; Copyright © 2022 Justin Veilleux <[email protected]>
+;;; Copyright © 2022 ( <[email protected]>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -71,6 +72,7 @@
#:use-module ((gnu packages file-systems)
#:select (bcachefs-tools exfat-utils jfsutils zfs))
#:use-module (gnu packages terminals)
+ #:use-module ((gnu packages wm) #:select (sway))
#:use-module ((gnu build file-systems)
#:select (mount-flags->bit-mask
swap-space->flags-bit-mask))
@@ -237,6 +239,8 @@
greetd-configuration
greetd-terminal-configuration
greetd-agreety-session
+ greetd-wlgreet-session
+ greetd-wlgreet-sway-session
%base-services))
@@ -2902,6 +2906,109 @@ to handle."
"agreety-command"
#~(execl #$agreety #$agreety "-c" #$command))))
+(define-record-type* <greetd-wlgreet-session>
+ greetd-wlgreet-session make-greetd-wlgreet-session
+ greetd-wlgreet-session?
+ (wlgreet greetd-wlgreet (default wlgreet))
+ (command greetd-wlgreet-command
+ (default (file-append sway "/bin/sway")))
+ (command-args greetd-wlgreet-command-args (default '()))
+ (output-mode greetd-wlgreet-output-mode (default "all"))
+ (scale greetd-wlgreet-scale (default 1))
+ (background greetd-wlgreet-background (default '(0 0 0 0.9)))
+ (headline greetd-wlgreet-headline (default '(1 1 1 1)))
+ (prompt greetd-wlgreet-prompt (default '(1 1 1 1)))
+ (prompt-error greetd-wlgreet-prompt-error (default '(1 1 1 1)))
+ (border greetd-wlgreet-border (default '(1 1 1 1)))
+ (extra-env greetd-wlgreet-extra-env (default '())))
+
+(define (greetd-wlgreet-wayland-session-command session)
+ (program-file "wlgreet-session-command"
+ #~(let* ((username (getenv "USER"))
+ (useruid (number->string
+ (passwd:uid (getpwuid username))))
+ (command #$(greetd-wlgreet-command session)))
+ (use-modules (ice-9 match))
+ (setenv "XDG_SESSION_TYPE" "wayland")
+ (setenv "XDG_RUNTIME_DIR" (string-append "/run/user/" useruid))
+ (for-each (lambda (env) (setenv (car env) (cdr env)))
+ '(#$@(greetd-wlgreet-extra-env session)))
+ (apply execl command command
+ (list #$@(greetd-wlgreet-command-args session))))))
+
+(define (make-wlgreet-config-color section-name color)
+ (match color
+ ((red green blue opacity)
+ (string-append
+ "[" section-name "]\n"
+ "red = " (number->string red) "\n"
+ "green = " (number->string green) "\n"
+ "blue = " (number->string blue) "\n"
+ "opacity = " (number->string opacity) "\n"))))
+
+(define (make-wlgreet-configuration-file session)
+ (let ((command (greetd-wlgreet-wayland-session-command session))
+ (output-mode (greetd-wlgreet-output-mode session))
+ (scale (greetd-wlgreet-scale session))
+ (background (greetd-wlgreet-background session))
+ (headline (greetd-wlgreet-headline session))
+ (prompt (greetd-wlgreet-prompt session))
+ (prompt-error (greetd-wlgreet-prompt-error session))
+ (border (greetd-wlgreet-border session)))
+ (mixed-text-file "wlgreet.toml"
+ "command = \"" command "\"\n"
+ "outputMode = \"" output-mode "\"\n"
+ "scale = " (number->string scale) "\n"
+ (apply string-append
+ (map (match-lambda
+ ((section-name . color)
+ (make-wlgreet-config-color section-name color)))
+ `(("background" . ,background)
+ ("headline" . ,headline)
+ ("prompt" . ,prompt)
+ ("prompt-error" . ,prompt-error)
+ ("border" . ,border)))))))
+
+(define-record-type* <greetd-wlgreet-sway-session>
+ greetd-wlgreet-sway-session make-greetd-wlgreet-sway-session
+ greetd-wlgreet-sway-session?
+ (wlgreet-session greetd-wlgreet-sway-session-wlgreet-session ;<greetd-wlgreet-session>
+ (default (greetd-wlgreet-session)))
+ (sway greetd-wlgreet-sway-session-sway (default sway)) ;<package>
+ (sway-configuration greetd-wlgreet-sway-session-sway-configuration ;file-like
+ (default (plain-file "wlgreet-sway-config" ""))))
+
+(define (make-wlgreet-sway-configuration-file session)
+ (let* ((wlgreet-session (greetd-wlgreet-sway-session-wlgreet-session session))
+ (wlgreet-config (make-wlgreet-configuration-file wlgreet-session))
+ (wlgreet (file-append (greetd-wlgreet wlgreet-session) "/bin/wlgreet"))
+ (sway-config (greetd-wlgreet-sway-session-sway-configuration session))
+ (swaymsg (file-append (greetd-wlgreet-sway-session-sway session)
+ "/bin/swaymsg")))
+ (mixed-text-file "wlgreet-sway.conf"
+ "include " sway-config "\n"
+ "xwayland disable\n"
+ "exec \"" wlgreet " --config " wlgreet-config "; "
+ swaymsg " exit\"\n")))
+
+(define (greetd-wlgreet-sway-session-command session)
+ (let ((sway (file-append (greetd-wlgreet-sway-session-sway session)
+ "/bin/sway"))
+ (config (make-wlgreet-sway-configuration-file session)))
+ (program-file "wlgreet-sway-session-command"
+ #~(let* ((log-file (open-output-file
+ (string-append "/tmp/sway-greeter."
+ (number->string (getpid))
+ ".log")))
+ (username (getenv "USER"))
+ (useruid (number->string (passwd:uid (getpwuid username)))))
+ ;; redirect stdout/err to log-file
+ (dup2 (fileno log-file) 1)
+ (dup2 1 2)
+ (sleep 1) ;give seatd/logind some time to start up
+ (setenv "XDG_RUNTIME_DIR" (string-append "/run/user/" useruid))
+ (execl #$sway #$sway "-d" "-c" #$config)))))
+
(define (make-greetd-default-session-command config-or-command)
(cond ((greetd-agreety-session? config-or-command)
(cond ((greetd-agreety-xdg-env? config-or-command)
@@ -2912,6 +3019,8 @@ to handle."
(make-greetd-agreety-session-command
config-or-command
(greetd-agreety-tty-session-command config-or-command)))))
+ ((greetd-wlgreet-sway-session? config-or-command)
+ (greetd-wlgreet-sway-session-command config-or-command))
(#t config-or-command)))
(define-record-type* <greetd-terminal-configuration>
diff --git a/gnu/services/certbot.scm b/gnu/services/certbot.scm
index 1c819bef48..7dfdad9874 100644
--- a/gnu/services/certbot.scm
+++ b/gnu/services/certbot.scm
@@ -154,6 +154,7 @@
(define (certbot-activation config)
(let* ((certbot-directory "/var/lib/certbot")
+ (certbot-cert-directory "/etc/letsencrypt/live")
(script (in-vicinity certbot-directory "renew-certificates"))
(message (format #f (G_ "~a may need to be run~%") script)))
(match config
@@ -164,6 +165,7 @@
(use-modules (guix build utils))
(mkdir-p #$webroot)
(mkdir-p #$certbot-directory)
+ (mkdir-p #$certbot-cert-directory)
(copy-file #$(certbot-command config) #$script)
(display #$message)))))))
diff --git a/gnu/services/guix.scm b/gnu/services/guix.scm
index dac1e5841a..907824ac61 100644
--- a/gnu/services/guix.scm
+++ b/gnu/services/guix.scm
@@ -59,6 +59,7 @@
guix-build-coordinator-agent-configuration-authentication
guix-build-coordinator-agent-configuration-systems
guix-build-coordinator-agent-configuration-max-parallel-builds
+ guix-build-coordinator-agent-configuration-max-allocated-builds
guix-build-coordinator-agent-configuration-max-1min-load-average
guix-build-coordinator-agent-configuration-derivation-substitute-urls
guix-build-coordinator-agent-configuration-non-derivation-substitute-urls
@@ -177,6 +178,9 @@
(max-parallel-builds
guix-build-coordinator-agent-configuration-max-parallel-builds
(default 1))
+ (max-allocated-builds
+ guix-build-coordinator-agent-configuration-max-allocated-builds
+ (default #f))
(max-1min-load-average
guix-build-coordinator-agent-configuration-max-1min-load-average
(default #f))
@@ -406,6 +410,7 @@
(define (guix-build-coordinator-agent-shepherd-services config)
(match-record config <guix-build-coordinator-agent-configuration>
(package user coordinator authentication max-parallel-builds
+ max-allocated-builds
max-1min-load-average
derivation-substitute-urls non-derivation-substitute-urls
systems)
@@ -439,6 +444,10 @@
token-file))))
#$(simple-format #f "--max-parallel-builds=~A"
max-parallel-builds)
+ #$@(if max-allocated-builds
+ #~(#$(simple-format #f "--max-allocated-builds=~A"
+ max-allocated-builds))
+ #~())
#$@(if max-1min-load-average
#~(#$(simple-format #f "--max-1min-load-average=~A"
max-1min-load-average))
diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm
index 9d85728371..19aba8c266 100644
--- a/gnu/services/networking.scm
+++ b/gnu/services/networking.scm
@@ -66,6 +66,9 @@
#:use-module (guix modules)
#:use-module (guix packages)
#:use-module (guix deprecation)
+ #:use-module (guix diagnostics)
+ #:autoload (guix ui) (display-hint)
+ #:use-module (guix i18n)
#:use-module (rnrs enums)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
@@ -77,6 +80,10 @@
static-networking-service-type)
#:export (%facebook-host-aliases
dhcp-client-service-type
+ dhcp-client-configuration
+ dhcp-client-configuration?
+ dhcp-client-configuration-package
+ dhcp-client-configuration-interfaces
dhcpd-service-type
dhcpd-configuration
@@ -259,52 +266,78 @@ fe80::1%lo0 connect.facebook.net
fe80::1%lo0 www.connect.facebook.net
fe80::1%lo0 apps.facebook.com\n")
+
+(define-record-type* <dhcp-client-configuration>
+ dhcp-client-configuration make-dhcp-client-configuration
+ dhcp-client-configuration?
+ (package dhcp-client-configuration-package ;file-like
+ (default isc-dhcp))
+ (interfaces dhcp-client-configuration-interfaces
+ (default 'all))) ;'all | list of strings
+
+(define dhcp-client-shepherd-service
+ (match-lambda
+ (($ <dhcp-client-configuration> package interfaces)
+ (let ((pid-file "/var/run/dhclient.pid"))
+ (list (shepherd-service
+ (documentation "Set up networking via DHCP.")
+ (requirement '(user-processes udev))
+
+ ;; XXX: Running with '-nw' ("no wait") avoids blocking for a minute when
+ ;; networking is unavailable, but also means that the interface is not up
+ ;; yet when 'start' completes. To wait for the interface to be ready, one
+ ;; should instead monitor udev events.
+ (provision '(networking))
+
+ (start #~(lambda _
+ (define dhclient
+ (string-append #$package "/sbin/dhclient"))
+
+ ;; When invoked without any arguments, 'dhclient' discovers all
+ ;; non-loopback interfaces *that are up*. However, the relevant
+ ;; interfaces are typically down at this point. Thus we perform
+ ;; our own interface discovery here.
+ (define valid?
+ (lambda (interface)
+ (and (arp-network-interface? interface)
+ (not (loopback-network-interface? interface))
+ ;; XXX: Make sure the interfaces are up so that
+ ;; 'dhclient' can actually send/receive over them.
+ ;; Ignore those that cannot be activated.
+ (false-if-exception
+ (set-network-interface-up interface)))))
+ (define ifaces
+ (filter valid?
+ #$(match interfaces
+ ('all
+ #~(all-network-interface-names))
+ (_
+ #~'#$interfaces))))
+
+ (false-if-exception (delete-file #$pid-file))
+ (let ((pid (fork+exec-command
+ (cons* dhclient "-nw"
+ "-pf" #$pid-file ifaces))))
+ (and (zero? (cdr (waitpid pid)))
+ (read-pid-file #$pid-file)))))
+ (stop #~(make-kill-destructor))))))
+ (package
+ (warning (G_ "'dhcp-client' service now expects a \
+'dhcp-client-configuration' record~%"))
+ (display-hint (G_ "The value associated with instances of
+@code{dhcp-client-service-type} must now be a @code{dhcp-client-configuration}
+record instead of a package. Please adjust your configuration accordingly."))
+ (dhcp-client-shepherd-service
+ (dhcp-client-configuration
+ (package package))))))
+
(define dhcp-client-service-type
- (shepherd-service-type
- 'dhcp-client
- (lambda (dhcp)
- (define dhclient
- (file-append dhcp "/sbin/dhclient"))
-
- (define pid-file
- "/var/run/dhclient.pid")
-
- (shepherd-service
- (documentation "Set up networking via DHCP.")
- (requirement '(user-processes udev))
-
- ;; XXX: Running with '-nw' ("no wait") avoids blocking for a minute when
- ;; networking is unavailable, but also means that the interface is not up
- ;; yet when 'start' completes. To wait for the interface to be ready, one
- ;; should instead monitor udev events.
- (provision '(networking))
-
- (start #~(lambda _
- ;; When invoked without any arguments, 'dhclient' discovers all
- ;; non-loopback interfaces *that are up*. However, the relevant
- ;; interfaces are typically down at this point. Thus we perform
- ;; our own interface discovery here.
- (define valid?
- (lambda (interface)
- (and (arp-network-interface? interface)
- (not (loopback-network-interface? interface))
- ;; XXX: Make sure the interfaces are up so that
- ;; 'dhclient' can actually send/receive over them.
- ;; Ignore those that cannot be activated.
- (false-if-exception
- (set-network-interface-up interface)))))
- (define ifaces
- (filter valid? (all-network-interface-names)))
-
- (false-if-exception (delete-file #$pid-file))
- (let ((pid (fork+exec-command
- (cons* #$dhclient "-nw"
- "-pf" #$pid-file ifaces))))
- (and (zero? (cdr (waitpid pid)))
- (read-pid-file #$pid-file)))))
- (stop #~(make-kill-destructor))))
- isc-dhcp
- (description "Run @command{dhcp}, a Dynamic Host Configuration
+ (service-type (name 'dhcp-client)
+ (extensions
+ (list (service-extension shepherd-root-service-type
+ dhcp-client-shepherd-service)))
+ (default-value (dhcp-client-configuration))
+ (description "Run @command{dhcp}, a Dynamic Host Configuration
Protocol (DHCP) client, on all the non-loopback network interfaces.")))
(define-record-type* <dhcpd-configuration>
diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm
index 61f759a19d..7110e5aa89 100644
--- a/gnu/services/shepherd.scm
+++ b/gnu/services/shepherd.scm
@@ -107,14 +107,15 @@
(symlink (canonicalize-path "/run/current-system")
"/run/booted-system")
- ;; Close any remaining open file descriptors to be on the safe
- ;; side. This must be the very last thing we do, because
- ;; Guile has internal FDs such as 'sleep_pipe' that need to be
- ;; alive.
+ ;; Ensure open file descriptors are close-on-exec so shepherd doesn't
+ ;; inherit them.
(let loop ((fd 3))
(when (< fd 1024)
- (false-if-exception (close-fdes fd))
- (loop (+ 1 fd))))
+ (false-if-exception
+ (let ((flags (fcntl fd F_GETFD)))
+ (when (zero? (logand flags FD_CLOEXEC))
+ (fcntl fd F_SETFD (logior FD_CLOEXEC flags)))))
+ (loop (+ fd 1))))
;; Start shepherd.
(execl #$(file-append shepherd "/bin/shepherd")
diff --git a/gnu/services/vnc.scm b/gnu/services/vnc.scm
new file mode 100644
index 0000000000..15c3c14fee
--- /dev/null
+++ b/gnu/services/vnc.scm
@@ -0,0 +1,247 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2022 Maxim Cournoyer <[email protected]>
+;;;
+;;; 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 vnc)
+ #:use-module (gnu packages vnc)
+ #:use-module ((gnu services) #:hide (delete))
+ #:use-module (gnu system shadow)
+ #:use-module (gnu services configuration)
+ #:use-module (gnu services shepherd)
+ #:use-module (guix gexp)
+ #:use-module (guix records)
+
+ #:export (xvnc-configuration
+ xvnc-configuration-xvnc
+ xvnc-configuration-display-number
+ xvnc-configuration-geometry
+ xvnc-configuration-depth
+ xvnc-configuration-port
+ xvnc-configuration-ipv4?
+ xvnc-configuration-ipv6?
+ xvnc-configuration-password-file
+ xvnc-configuration-xdmcp?
+ xvnc-configuration-inetd?
+ xvnc-configuration-frame-rate
+ xvnc-configuration-security-types
+ xvnc-configuration-localhost?
+ xvnc-configuration-log-level
+ xvnc-configuration-extra-options
+
+ xvnc-service-type))
+
+;;;
+;;; Xvnc.
+;;;
+
+(define (color-depth? x)
+ (member x '(16 24 32)))
+
+(define (port? x)
+ (and (number? x)
+ (and (>= x 0) (<= x 65535))))
+
+(define-maybe/no-serialization port)
+
+(define-maybe/no-serialization string)
+
+(define %security-types '("None" "VncAuth" "Plain" "TLSNone" "TLSVnc" "TLSPlain"
+ "X509None" "X509Vnc"))
+
+(define (security-type? x)
+ (member x %security-types))
+
+(define (security-types? x)
+ (and (list? x)
+ (and-map security-type? x)))
+
+(define (log-level? x)
+ (and (number? x)
+ (and (>= x 0) (<= x 100))))
+
+(define (strings? x)
+ (and (list? x)
+ (and-map string? x)))
+
+(define-configuration/no-serialization xvnc-configuration
+ (xvnc
+ (file-like tigervnc-server)
+ "The package that provides the Xvnc binary.")
+ (display-number
+ (number 0)
+ "The display number used by Xvnc. You should set this to a number not
+already used by a Xorg server. When remoting a complete desktop session via
+XDMCP and using a compatible VNC viewer as provided by the
+@code{tigervnc-client} or @code{turbovnc} packages, the geometry is
+automatically adjusted.")
+ (geometry
+ (string "1024x768")
+ "The size of the desktop to be created.")
+ (depth
+ (color-depth 24)
+ "The pixel depth in bits of the desktop to be created. Accepted values are
+16, 24 or 32.")
+ (port
+ maybe-port
+ "The port on which to listen for connections from viewers. When left
+unspecified, it defaults to 5900 plus the display number.")
+ (ipv4?
+ (boolean #t)
+ "Use IPv4 for incoming and outgoing connections.")
+ (ipv6?
+ (boolean #t)
+ "Use IPv6 for incoming and outgoing connections.")
+ (password-file
+ maybe-string
+ "The password file to use, if any. Refer to vncpasswd(1) to learn how to
+generate such a file.")
+ (xdmcp?
+ (boolean #f)
+ "Query the XDMCP server for a session. This enables users to log in a
+desktop session from the login manager screen. For a multiple users scenario,
+you'll want to enable the @code{inetd?} option as well, so that each
+connection to the VNC server is handled separately rather than shared.")
+ (inetd?
+ (boolean #f)
+ "Use an Inetd-style service, which runs the Xvnc server on demand.")
+ (frame-rate
+ (number 60)
+ "The maximum number of updates per second sent to each client.")
+ (security-types
+ (security-types (list "None"))
+ (format #f "The allowed security schemes to use for incoming connections.
+The default is \"None\", which is safe given that Xvnc is configured to
+authenticate the user via the display manager, and only for local connections.
+Accepted values are any of the following: ~s" %security-types))
+ (localhost?
+ (boolean #t)
+ "Only allow connections from the same machine. It is set to @code{#true}
+by default for security, which means SSH or another secure means should be
+used to expose the remote port.")
+ (log-level
+ (log-level 30)
+ "The log level, a number between 0 and 100, 100 meaning most verbose
+output. The log messages are output to syslog.")
+ (extra-options
+ (strings '())
+ "This can be used to provide extra Xvnc options not exposed via this
+<xvnc-configuration> record."))
+
+(define (xvnc-configuration->command-line-arguments config)
+ "Derive the command line arguments to used to launch the Xvnc daemon from
+CONFIG, a <xvnc-configuration> object."
+ (match-record config <xvnc-configuration>
+ (xvnc display-number geometry depth port ipv4? ipv6? password-file xdmcp?
+ inetd? frame-rate security-types localhost? log-level extra-options)
+ #~(list #$(file-append xvnc "/bin/Xvnc")
+ #$(format #f ":~a" display-number)
+ "-geometry" #$geometry
+ "-depth" #$(number->string depth)
+ #$@(if inetd?
+ (list "-inetd")
+ '())
+ #$@(if (not inetd?)
+ (if (maybe-value-set? port)
+ (list "-rfbport" (number->string port))
+ '())
+ '())
+ #$@(if (not inetd?)
+ (if ipv4?
+ (list "-UseIPv4")
+ '())
+ '())
+ #$@(if (not inetd?)
+ (if ipv6?
+ (list "-UseIPv6")
+ '())
+ '())
+ #$@(if (maybe-value-set? password-file)
+ (list "-PasswordFile" password-file)
+ '())
+ "-FrameRate" #$(number->string frame-rate)
+ "-SecurityTypes" #$(string-join security-types ",")
+ #$@(if localhost?
+ (list "-localhost")
+ '())
+ "-Log" #$(format #f "*:syslog:~a" log-level)
+ #$@(if xdmcp?
+ (list "-query" "localhost" "-once")
+ '())
+ #$@extra-options)))
+
+(define %xvnc-accounts
+ (list (user-group
+ (name "xvnc")
+ (system? #t))
+ (user-account
+ (name "xvnc")
+ (group "xvnc")
+ (system? #t)
+ (comment "User for Xvnc server"))))
+
+(define (xvnc-shepherd-service config)
+ "Return a <shepherd-service> for Xvnc with CONFIG."
+ (let* ((display-number (xvnc-configuration-display-number config))
+ (port (if (maybe-value-set? (xvnc-configuration-port config))
+ (xvnc-configuration-port config)
+ #f))
+ (port* (or port (+ 5900 display-number))))
+ (shepherd-service
+ (provision '(xvnc vncserver))
+ (documentation "Run the Xvnc server.")
+ (requirement '(networking syslogd))
+ (start (if (xvnc-configuration-inetd? config)
+ #~(let* ((inaddr (if #$(xvnc-configuration-localhost? config)
+ INADDR_LOOPBACK
+ INADDR_ANY))
+ (in6addr (if #$(xvnc-configuration-localhost? config)
+ IN6ADDR_LOOPBACK
+ IN6ADDR_ANY))
+ (ipv4-socket (and #$(xvnc-configuration-ipv4? config)
+ (make-socket-address AF_INET inaddr
+ #$port*)))
+ (ipv6-socket (and #$(xvnc-configuration-ipv6? config)
+ (make-socket-address AF_INET6 in6addr
+ #$port*))))
+ (make-inetd-constructor
+ #$(xvnc-configuration->command-line-arguments config)
+ `(,@(if ipv4-socket
+ (list (endpoint ipv4-socket))
+ '())
+ ,@(if ipv6-socket
+ (list (endpoint ipv6-socket))
+ '()))
+ #:user "xvnc"
+ #:group "xvnc"))
+ #~(make-forkexec-constructor
+ #$(xvnc-configuration->command-line-arguments config)
+ #:user "xvnc"
+ #:group "xvnc")))
+ (stop #~(make-inetd-destructor)))))
+
+(define xvnc-service-type
+ (service-type
+ (name 'xvnc)
+ (default-value (xvnc-configuration))
+ (description "Run the Xvnc server, which creates a virtual X11 session and
+allow remote clients connecting to it via the remote framebuffer (RFB)
+protocol.")
+ (extensions (list (service-extension
+ shepherd-root-service-type
+ (compose list xvnc-shepherd-service))
+ (service-extension account-service-type
+ (const %xvnc-accounts))))))
diff --git a/gnu/services/web.scm b/gnu/services/web.scm
index e347f5dbcc..e5ab1a1180 100644
--- a/gnu/services/web.scm
+++ b/gnu/services/web.scm
@@ -1438,32 +1438,40 @@ files.")
(documentation
"Anonimyze the given log file location with anonip.")
(start
- #~(lambda _
- (unless (file-exists? #$input)
- (mknod #$input 'fifo #o600 0))
- (let ((pid
- (fork+exec-command
- (append
- (list #$(file-append (anonip-configuration-anonip config)
- "/bin/anonip")
- (string-append "--input=" #$input)
- (string-append "--output=" #$output))
- (if #$(anonip-configuration-skip-private? config)
- '("--skip-private") (list))
- '#$(optional anonip-configuration-column "--column")
- '#$(optional anonip-configuration-ipv4mask "--ipv4mask")
- '#$(optional anonip-configuration-ipv6mask "--ipv6mask")
- '#$(optional anonip-configuration-increment "--increment")
- '#$(optional anonip-configuration-replacement
- "--replacement")
- '#$(optional anonip-configuration-delimiter "--delimiter")
- '#$(optional anonip-configuration-regex "--regex"))
- ;; Run in a UTF-8 locale
- #:environment-variables
- (list (string-append "GUIX_LOCPATH=" #$glibc-utf8-locales
- "/lib/locale")
- "LC_ALL=en_US.utf8"))))
- pid)))
+ #~(lambda ()
+ (define (spawn)
+ (fork+exec-command
+ (append
+ (list #$(file-append (anonip-configuration-anonip config)
+ "/bin/anonip")
+ (string-append "--input=" #$input)
+ (string-append "--output=" #$output))
+ (if #$(anonip-configuration-skip-private? config)
+ '("--skip-private") (list))
+ '#$(optional anonip-configuration-column "--column")
+ '#$(optional anonip-configuration-ipv4mask "--ipv4mask")
+ '#$(optional anonip-configuration-ipv6mask "--ipv6mask")
+ '#$(optional anonip-configuration-increment "--increment")
+ '#$(optional anonip-configuration-replacement
+ "--replacement")
+ '#$(optional anonip-configuration-delimiter "--delimiter")
+ '#$(optional anonip-configuration-regex "--regex"))
+ ;; Run in a UTF-8 locale
+ #:environment-variables
+ (list (string-append "GUIX_LOCPATH=" #$glibc-utf8-locales
+ "/lib/locale")
+ "LC_ALL=en_US.utf8")))
+
+ (let ((stat (stat #$input #f)))
+ (cond ((not stat)
+ (mknod #$input 'fifo #o600 0)
+ (spawn))
+ ((eq? 'fifo (stat:type stat))
+ (spawn))
+ (else
+ (format #t "'~a' is not a FIFO; bailing out~%"
+ #$input)
+ #f)))))
(stop #~(make-kill-destructor))))))
(define anonip-service-type
diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm
index 3ff290c197..7f1f0bb581 100644
--- a/gnu/services/xorg.scm
+++ b/gnu/services/xorg.scm
@@ -12,6 +12,7 @@
;;; Copyright © 2021 Oleg Pykhalov <[email protected]>
;;; Copyright © 2021 Josselin Poiret <[email protected]>
;;; Copyright © 2022 Chris Marusich <[email protected]>
+;;; Copyright © 2022 Maxim Cournoyer <[email protected]>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -32,6 +33,7 @@
#:autoload (gnu services sddm) (sddm-service-type)
#:use-module (gnu artwork)
#:use-module (gnu services)
+ #:use-module (gnu services configuration)
#:use-module (gnu services shepherd)
#:use-module (gnu system pam)
#:use-module (gnu system setuid)
@@ -63,6 +65,7 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
+ #:use-module (ice-9 format)
#:use-module (ice-9 match)
#:export (xorg-configuration
xorg-configuration?
@@ -113,6 +116,13 @@
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
@@ -663,13 +673,7 @@ reboot_cmd " shepherd "/sbin/reboot\n"
(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)))))
-
+ slim-pam-service)))
(default-value (slim-configuration))
(description
"Run the SLiM graphical login manager for X11."))))
@@ -804,6 +808,106 @@ the GNOME desktop environment.")
;;;
+;;; 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.
;;;
@@ -876,6 +980,7 @@ the GNOME desktop environment.")
(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))
@@ -885,10 +990,36 @@ the GNOME desktop environment.")
(default (xorg-configuration)))
(x-session gdm-configuration-x-session
(default (xinitrc)))
+ (xdmcp? gdm-configuration-xdmcp?
+ (default #f))
(wayland? gdm-configuration-wayland? (default #f))
(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"
@@ -913,18 +1044,20 @@ the GNOME desktop environment.")
;; See also
;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=39281>.
"InitialSetupEnable=false\n"
- "WaylandEnable=" (if (gdm-configuration-wayland? config)
- "true"
- "false") "\n"
+ (format #f "WaylandEnable=~:[false~;true~]~%"
+ (gdm-configuration-wayland? config))
"\n"
"[debug]\n"
- "Enable=" (if (gdm-configuration-debug? config)
- "true"
- "false") "\n"
+ (format #f "Enable=~:[false~;true~]~%"
+ (gdm-configuration-debug? config))
"\n"
"[security]\n"
"#DisallowTCP=true\n"
- "#AllowRemoteAutoLogin=false\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}."
@@ -959,7 +1092,10 @@ the GNOME desktop environment.")
(list #$(file-append (gdm-configuration-gdm config)
"/bin/gdm"))
#:environment-variables
- (list (string-append
+ (list #$@(if (gdm-configuration-auto-suspend? config)
+ #~()
+ #~("DCONF_PROFILE=/etc/dconf/profile/gdm"))
+ (string-append
"GDM_CUSTOM_CONF="
#$(gdm-configuration-file config))
(string-append
@@ -995,6 +1131,41 @@ the GNOME desktop environment.")
(stop #~(make-kill-destructor))
(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)
@@ -1003,8 +1174,12 @@ the GNOME desktop environment.")
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
generated by cgit v1.2.3 (git 2.45.2) at 2025-05-29 17:16:26 +0000