aboutsummaryrefslogtreecommitdiff
path: root/gnu/services
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/services')
-rw-r--r--gnu/services/audio.scm18
-rw-r--r--gnu/services/avahi.scm14
-rw-r--r--gnu/services/backup.scm236
-rw-r--r--gnu/services/base.scm62
-rw-r--r--gnu/services/certbot.scm4
-rw-r--r--gnu/services/cuirass.scm28
-rw-r--r--gnu/services/dbus.scm10
-rw-r--r--gnu/services/desktop.scm53
-rw-r--r--gnu/services/dns.scm24
-rw-r--r--gnu/services/docker.scm441
-rw-r--r--gnu/services/ganeti.scm2
-rw-r--r--gnu/services/guix.scm4
-rw-r--r--gnu/services/mail.scm423
-rw-r--r--gnu/services/mcron.scm63
-rw-r--r--gnu/services/monitoring.scm4
-rw-r--r--gnu/services/networking.scm20
-rw-r--r--gnu/services/nix.scm33
-rw-r--r--gnu/services/pm.scm60
-rw-r--r--gnu/services/sddm.scm17
-rw-r--r--gnu/services/shepherd.scm60
-rw-r--r--gnu/services/syncthing.scm10
-rw-r--r--gnu/services/web.scm249
-rw-r--r--gnu/services/xorg.scm113
23 files changed, 1684 insertions, 264 deletions
diff --git a/gnu/services/audio.scm b/gnu/services/audio.scm
index ae991ced4d..5d2cd56a17 100644
--- a/gnu/services/audio.scm
+++ b/gnu/services/audio.scm
@@ -251,16 +251,14 @@ user-group instead~%"))
(configuration-field-error #f 'group value))))
(define (mpd-log-file-sanitizer value)
- (match value
- (%unset-value
- ;; XXX: While leaving the 'sys_log' option out of the mpd.conf file is
- ;; supposed to cause logging to happen via systemd (elogind provides a
- ;; compatible interface), this doesn't work (nothing gets logged); use
- ;; syslog instead.
- "syslog")
- ((? string?)
- value)
- (_ (configuration-field-error #f 'log-file value))))
+ ;; XXX: While leaving the 'sys_log' option out of the mpd.conf file is
+ ;; supposed to cause logging to happen via systemd (elogind provides a
+ ;; compatible interface), this doesn't work (nothing gets logged); use
+ ;; syslog instead.
+ (let ((value (maybe-value value "syslog")))
+ (if (string? value)
+ value
+ (configuration-field-error #f 'log-file value))))
;;;
diff --git a/gnu/services/avahi.scm b/gnu/services/avahi.scm
index 1c4220e490..9352492bbd 100644
--- a/gnu/services/avahi.scm
+++ b/gnu/services/avahi.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014-2020, 2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014-2020, 2022, 2024 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -131,13 +131,17 @@
(provision '(avahi-daemon))
(requirement '(user-processes dbus-system networking))
- (start #~(make-forkexec-constructor
+ (start #~(make-systemd-constructor
(list #$(file-append avahi "/sbin/avahi-daemon")
- "--daemonize"
#$@(if debug? #~("--debug") #~())
"-f" #$config)
- #:pid-file "/run/avahi-daemon/pid"))
- (stop #~(make-kill-destructor))
+ (list (endpoint
+ (make-socket-address
+ AF_UNIX
+ "/run/avahi-daemon/socket")))
+ #:lazy-start? #f
+ #:log-file "/var/log/avahi-daemon.log"))
+ (stop #~(make-systemd-destructor))
(actions (list (shepherd-configuration-action config)))))))
(define avahi-service-type
diff --git a/gnu/services/backup.scm b/gnu/services/backup.scm
new file mode 100644
index 0000000000..555e9fc959
--- /dev/null
+++ b/gnu/services/backup.scm
@@ -0,0 +1,236 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2024 Giacomo Leidi <goodoldpaul@autistici.org>
+;;;
+;;; 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 backup)
+ #:use-module (gnu packages backup)
+ #:use-module (gnu services)
+ #:use-module (gnu services configuration)
+ #:use-module (gnu services mcron)
+ #:use-module (guix build-system copy)
+ #:use-module (guix gexp)
+ #:use-module ((guix licenses)
+ #:prefix license:)
+ #:use-module (guix modules)
+ #:use-module (guix packages)
+ #:use-module (srfi srfi-1)
+ #:export (restic-backup-job
+ restic-backup-job?
+ restic-backup-job-fields
+ restic-backup-job-restic
+ restic-backup-job-user
+ restic-backup-job-name
+ restic-backup-job-repository
+ restic-backup-job-password-file
+ restic-backup-job-schedule
+ restic-backup-job-files
+ restic-backup-job-verbose?
+ restic-backup-job-extra-flags
+
+ restic-backup-configuration
+ restic-backup-configuration?
+ restic-backup-configuration-fields
+ restic-backup-configuration-jobs
+
+ restic-backup-job-program
+ restic-backup-job->mcron-job
+ restic-guix
+ restic-guix-wrapper-package
+ restic-backup-service-profile
+ restic-backup-service-type))
+
+(define (gexp-or-string? value)
+ (or (gexp? value)
+ (string? value)))
+
+(define (lowerable? value)
+ (or (file-like? value)
+ (gexp-or-string? value)))
+
+(define list-of-lowerables?
+ (list-of lowerable?))
+
+(define-configuration/no-serialization restic-backup-job
+ (restic
+ (package restic)
+ "The restic package to be used for the current job.")
+ (user
+ (string "root")
+ "The user used for running the current job.")
+ (name
+ (string)
+ "A string denoting a name for this job.")
+ (repository
+ (string)
+ "The restic repository target of this job.")
+ (password-file
+ (string)
+ "Name of the password file, readable by the configured @code{user}, that
+will be used to set the @code{RESTIC_PASSWORD} environment variable for the
+current job.")
+ (schedule
+ (gexp-or-string)
+ "A string or a gexp that will be passed as time specification in the mcron
+job specification (@pxref{Syntax, mcron job specifications,, mcron,
+GNU@tie{}mcron}).")
+ (files
+ (list-of-lowerables '())
+ "The list of files or directories to be backed up. It must be a list of
+values that can be lowered to strings.")
+ (verbose?
+ (boolean #f)
+ "Whether to enable verbose output for the current backup job.")
+ (extra-flags
+ (list-of-lowerables '())
+ "A list of values that are lowered to strings. These will be passed as
+command-line arguments to the current job @command{restic backup} invokation."))
+
+(define list-of-restic-backup-jobs?
+ (list-of restic-backup-job?))
+
+(define-configuration/no-serialization restic-backup-configuration
+ (jobs
+ (list-of-restic-backup-jobs '())
+ "The list of backup jobs for the current system."))
+
+(define (restic-backup-job-program config)
+ (let ((restic
+ (file-append (restic-backup-job-restic config) "/bin/restic"))
+ (repository
+ (restic-backup-job-repository config))
+ (password-file
+ (restic-backup-job-password-file config))
+ (files
+ (restic-backup-job-files config))
+ (extra-flags
+ (restic-backup-job-extra-flags config))
+ (verbose
+ (if (restic-backup-job-verbose? config)
+ '("--verbose")
+ '())))
+ (program-file
+ "restic-backup-job.scm"
+ #~(begin
+ (use-modules (ice-9 popen)
+ (ice-9 rdelim))
+ (setenv "RESTIC_PASSWORD"
+ (with-input-from-file #$password-file read-line))
+
+ (execlp #$restic #$restic #$@verbose
+ "-r" #$repository
+ #$@extra-flags
+ "backup" #$@files)))))
+
+(define (restic-guix jobs)
+ (program-file
+ "restic-guix"
+ #~(begin
+ (use-modules (ice-9 match)
+ (srfi srfi-1))
+
+ (define names '#$(map restic-backup-job-name jobs))
+ (define programs '#$(map restic-backup-job-program jobs))
+
+ (define (get-program name)
+ (define idx
+ (list-index (lambda (n) (string=? n name)) names))
+ (unless idx
+ (error (string-append "Unknown job name " name "\n\n"
+ "Possible job names are: "
+ (string-join names " "))))
+ (list-ref programs idx))
+
+ (define (backup args)
+ (define name (third args))
+ (define program (get-program name))
+ (execlp program program))
+
+ (define (validate-args args)
+ (when (not (>= (length args) 3))
+ (error (string-append "Usage: " (basename (car args))
+ " backup NAME"))))
+
+ (define (main args)
+ (validate-args args)
+ (define action (second args))
+ (match action
+ ("backup"
+ (backup args))
+ (_
+ (error (string-append "Unknown action: " action)))))
+
+ (main (command-line)))))
+
+(define (restic-backup-job->mcron-job config)
+ (let ((user
+ (restic-backup-job-user config))
+ (schedule
+ (restic-backup-job-schedule config))
+ (name
+ (restic-backup-job-name config)))
+ #~(job #$schedule
+ #$(string-append "restic-guix backup " name)
+ #:user #$user)))
+
+(define (restic-guix-wrapper-package jobs)
+ (package
+ (name "restic-backup-service-wrapper")
+ (version "0.0.0")
+ (source (restic-guix jobs))
+ (build-system copy-build-system)
+ (arguments
+ (list #:install-plan #~'(("./" "/bin"))))
+ (home-page "https://restic.net")
+ (synopsis
+ "Easily interact from the CLI with Guix configured backups")
+ (description
+ "This package provides a simple wrapper around @code{restic}, handled
+by the @code{restic-backup-service-type}. It allows for easily interacting
+with Guix configured backup jobs, for example for manually triggering a backup
+without waiting for the scheduled job to run.")
+ (license license:gpl3+)))
+
+(define restic-backup-service-profile
+ (lambda (config)
+ (define jobs (restic-backup-configuration-jobs config))
+ (if (> (length jobs) 0)
+ (list
+ (restic-guix-wrapper-package jobs))
+ '())))
+
+(define restic-backup-service-type
+ (service-type (name 'restic-backup)
+ (extensions
+ (list
+ (service-extension profile-service-type
+ restic-backup-service-profile)
+ (service-extension mcron-service-type
+ (lambda (config)
+ (map restic-backup-job->mcron-job
+ (restic-backup-configuration-jobs
+ config))))))
+ (compose concatenate)
+ (extend
+ (lambda (config jobs)
+ (restic-backup-configuration
+ (inherit config)
+ (jobs (append (restic-backup-configuration-jobs config)
+ jobs)))))
+ (default-value (restic-backup-configuration))
+ (description
+ "This service configures @code{mcron} jobs for running backups
+with @code{restic}.")))
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 3f912225a0..4b5b103cc3 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -212,6 +212,7 @@
guix-configuration-guix
guix-configuration-build-group
guix-configuration-build-accounts
+ guix-configuration-build-machines
guix-configuration-authorize-key?
guix-configuration-authorized-keys
guix-configuration-use-substitutes?
@@ -403,6 +404,7 @@ upon boot."
(create? (file-system-create-mount-point? file-system))
(mount? (file-system-mount? file-system))
(dependencies (file-system-dependencies file-system))
+ (requirements (file-system-shepherd-requirements file-system))
(packages (file-system-packages (list file-system))))
(and (or mount? create?)
(with-imported-modules (source-module-closure
@@ -411,7 +413,8 @@ upon boot."
(provision (list (file-system->shepherd-service-name file-system)))
(requirement `(root-file-system
udev
- ,@(map dependency->shepherd-service-name dependencies)))
+ ,@(map dependency->shepherd-service-name dependencies)
+ ,@requirements))
(documentation "Check, mount, and unmount the given file system.")
(start #~(lambda args
#$(if create?
@@ -445,7 +448,11 @@ upon boot."
;; Make sure PID 1 doesn't keep TARGET busy.
(chdir "/")
- (umount #$target)
+ #$(if (file-system-mount-may-fail? file-system)
+ #~(catch 'system-error
+ (lambda () (umount #$target))
+ (const #f))
+ #~(umount #$target))
#f))
;; We need additional modules.
@@ -460,12 +467,20 @@ upon boot."
(or (file-system-mount? x)
(file-system-create-mount-point? x)))
file-systems)))
+
(define sink
(shepherd-service
(provision '(file-systems))
(requirement (cons* 'root-file-system 'user-file-systems
(map file-system->shepherd-service-name
- file-systems)))
+ ;; Do not require file systems with Shepherd
+ ;; requirements to provision
+ ;; 'file-systems. Many Shepherd services
+ ;; require 'file-systems, so we would likely
+ ;; deadlock.
+ (filter (lambda (file-system)
+ (null? (file-system-shepherd-requirements file-system)))
+ file-systems))))
(documentation "Target for all the initially-mounted file systems")
(start #~(const #t))
(stop #~(const #f))))
@@ -1284,7 +1299,7 @@ the tty to run, among other things."
make-nscd-configuration
nscd-configuration?
(log-file nscd-configuration-log-file ;string
- (default "/var/log/nscd.log"))
+ (default #f))
(debug-level nscd-debug-level ;integer
(default 0))
;; TODO: See nscd.conf in glibc for other options to add.
@@ -1339,7 +1354,22 @@ the tty to run, among other things."
(positive-time-to-live (* 3600 24))
(negative-time-to-live 3600)
(check-files? #t) ;check /etc/services changes
- (persistent? #t))))
+ (persistent? #t))
+
+ ;; Enable minimal caching of the user databases, not so much for
+ ;; caching but rather to allow that uses of NSS plugins like LDAP
+ ;; don't lead user processes to dlopen them (which is likely to fail
+ ;; due to them not being found in $LD_LIBRARY_PATH).
+ (nscd-cache (database 'passwd)
+ (positive-time-to-live 600)
+ (negative-time-to-live 20)
+ (check-files? #t) ;check /etc/passwd changes
+ (persistent? #f))
+ (nscd-cache (database 'group)
+ (positive-time-to-live 600)
+ (negative-time-to-live 20)
+ (check-files? #t) ;check /etc/group changes
+ (persistent? #f))))
(define-deprecated %nscd-default-configuration
#f
@@ -1829,7 +1859,7 @@ archive' public keys, with GUIX."
(generate-substitute-key? guix-configuration-generate-substitute-key?
(default #t)) ;Boolean
(channels guix-configuration-channels ;file-like
- (default %default-channels))
+ (default #f))
(chroot-directories guix-configuration-chroot-directories ;list of file-like/strings
(default '()))
(max-silent-time guix-configuration-max-silent-time ;integer
@@ -1848,8 +1878,8 @@ archive' public keys, with GUIX."
(default #f))
(tmpdir guix-tmpdir ;string | #f
(default #f))
- (build-machines guix-build-machines ;list of gexps | #f
- (default #f))
+ (build-machines guix-configuration-build-machines ;list of gexps | '()
+ (default '()))
(environment guix-configuration-environment ;list of strings
(default '())))
@@ -1876,7 +1906,8 @@ proxy of 'guix-daemon' to ~s...~%"
(format #t "clearing HTTP/HTTPS \
proxy of 'guix-daemon'...~%")
(unsetenv "http_proxy")))
- (action 'guix-daemon 'restart)
+ (perform-service-action (lookup-service 'guix-daemon)
+ 'restart)
(environ environment)
#t)))))
@@ -1897,7 +1928,8 @@ proxy of 'guix-daemon'...~%")
(begin
(format #t "disable substitute servers discovery~%")
(unsetenv "discover")))
- (action 'guix-daemon 'restart)
+ (perform-service-action (lookup-service 'guix-daemon)
+ 'restart)
(environ environment)
#t)))))
@@ -2044,10 +2076,10 @@ proxy of 'guix-daemon'...~%")
#$(and channels (install-channels-file channels))
;; ... and /etc/guix/machines.scm.
- #$(if (guix-build-machines config)
+ #$(if (null? (guix-configuration-build-machines config))
+ #~#f
(guix-machines-files-installation
- #~(list #$@(guix-build-machines config)))
- #~#f))))
+ #~(list #$@(guix-configuration-build-machines config)))))))
(define-record-type* <guix-extension>
guix-extension make-guix-extension
@@ -2093,9 +2125,9 @@ proxy of 'guix-daemon'...~%")
(substitute-urls (append (guix-extension-substitute-urls extension)
(guix-configuration-substitute-urls config)))
(build-machines
- (and (or (guix-build-machines config)
+ (and (or (guix-configuration-build-machines config)
(pair? (guix-extension-build-machines extension)))
- (append (or (guix-build-machines config) '())
+ (append (guix-configuration-build-machines config)
(guix-extension-build-machines extension))))
(chroot-directories
(append (guix-extension-chroot-directories extension)
diff --git a/gnu/services/certbot.scm b/gnu/services/certbot.scm
index 27f40033d3..7bee0de0a3 100644
--- a/gnu/services/certbot.scm
+++ b/gnu/services/certbot.scm
@@ -383,7 +383,9 @@ deploy."
(define certbot-sans-nginx-service-type
(service-type (name 'certbot)
(extensions
- (list (service-extension activation-service-type
+ (list (service-extension profile-service-type
+ (compose list certbot-configuration-package))
+ (service-extension activation-service-type
certbot-activation)
(service-extension mcron-service-type
certbot-renewal-jobs)
diff --git a/gnu/services/cuirass.scm b/gnu/services/cuirass.scm
index bcdbffa2f3..f68b4dc5a2 100644
--- a/gnu/services/cuirass.scm
+++ b/gnu/services/cuirass.scm
@@ -101,6 +101,10 @@
(default "cuirass"))
(interval cuirass-configuration-interval ;integer (seconds)
(default 60))
+ (ttl cuirass-configuration-ttl ;integer
+ (default 2592000))
+ (threads cuirass-configuration-threads ;integer
+ (default #f))
(parameters cuirass-configuration-parameters ;string
(default #f))
(remote-server cuirass-configuration-remote-server
@@ -113,13 +117,13 @@
(default "localhost"))
(specifications cuirass-configuration-specifications)
;gexp that evaluates to specification-alist
- (use-substitutes? cuirass-configuration-use-substitutes? ;boolean
- (default #f))
(one-shot? cuirass-configuration-one-shot? ;boolean
(default #f))
(fallback? cuirass-configuration-fallback? ;boolean
(default #f))
(extra-options cuirass-configuration-extra-options
+ (default '()))
+ (web-extra-options cuirass-configuration-web-extra-options
(default '())))
(define (cuirass-shepherd-service config)
@@ -131,6 +135,8 @@
(user (cuirass-configuration-user config))
(group (cuirass-configuration-group config))
(interval (cuirass-configuration-interval config))
+ (ttl (cuirass-configuration-ttl config))
+ (threads (cuirass-configuration-threads config))
(parameters (cuirass-configuration-parameters config))
(remote-server (cuirass-configuration-remote-server config))
(database (cuirass-configuration-database config))
@@ -139,10 +145,10 @@
(config-file (scheme-file
"cuirass-specs.scm"
(cuirass-configuration-specifications config)))
- (use-substitutes? (cuirass-configuration-use-substitutes? config))
(one-shot? (cuirass-configuration-one-shot? config))
(fallback? (cuirass-configuration-fallback? config))
- (extra-options (cuirass-configuration-extra-options config)))
+ (extra-options (cuirass-configuration-extra-options config))
+ (web-extra-options (cuirass-configuration-web-extra-options config)))
`(,(shepherd-service
(documentation "Run Cuirass.")
(provision '(cuirass))
@@ -156,13 +162,23 @@
"--specifications" #$config-file
"--database" #$database
"--interval" #$(number->string interval)
+ #$@(if ttl
+ (list (string-append
+ "--ttl="
+ (number->string ttl)
+ "s"))
+ '())
+ #$@(if threads
+ (list (string-append
+ "--threads="
+ (number->string threads)))
+ '())
#$@(if parameters
(list (string-append
"--parameters="
parameters))
'())
#$@(if remote-server '("--build-remote") '())
- #$@(if use-substitutes? '("--use-substitutes") '())
#$@(if one-shot? '("--one-shot") '())
#$@(if fallback? '("--fallback") '())
#$@extra-options)
@@ -192,7 +208,7 @@
"--parameters="
parameters))
'())
- #$@extra-options)
+ #$@web-extra-options)
#:user #$user
#:group #$group
diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm
index 8dee91a3f7..2004c48452 100644
--- a/gnu/services/dbus.scm
+++ b/gnu/services/dbus.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2017, 2019-2021, 2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
@@ -115,7 +115,7 @@ includes the @code{etc/dbus-1/system.d} directories of each package listed in
;; failures such as <https://issues.guix.gnu.org/52051> on slow
;; computers with slow I/O.
(limit (@ (name "auth_timeout")) "300000")
- (servicehelper "/run/setuid-programs/dbus-daemon-launch-helper")
+ (servicehelper "/run/privileged/bin/dbus-daemon-launch-helper")
;; First, the '.service' files of services subject to activation.
;; We use a fixed location under /etc because the setuid helper
@@ -234,12 +234,12 @@ includes the @code{etc/dbus-1/system.d} directories of each package listed in
(requirement '(user-processes syslogd))
(start #~(make-forkexec-constructor
(list (string-append #$dbus "/bin/dbus-daemon")
- "--nofork" "--system" "--syslog-only")
+ "--nofork" "--system")
+ #:log-file "/var/log/dbus-daemon.log"
#$@(if verbose?
;; Since the verbose output goes to the console,
;; not syslog, add a log file to capture it.
- '(#:environment-variables '("DBUS_VERBOSE=1")
- #:log-file "/var/log/dbus-daemon.log")
+ '(#:environment-variables '("DBUS_VERBOSE=1"))
'())
#:pid-file "/run/dbus/pid"))
(stop #~(make-kill-destructor)))))))
diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm
index d0b9728d4a..b8dc4a4912 100644
--- a/gnu/services/desktop.scm
+++ b/gnu/services/desktop.scm
@@ -11,7 +11,7 @@
;;; Copyright © 2017, 2019 Christopher Baines <mail@cbaines.net>
;;; Copyright © 2019 Tim Gesthuizen <tim.gesthuizen@yahoo.de>
;;; Copyright © 2019 David Wilson <david@daviwil.com>
-;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2020, 2024 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2020 Reza Alizadeh Majd <r.majd@pantherx.org>
;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
;;; Copyright © 2021, 2022 muradm <mail@muradm.net>
@@ -49,7 +49,7 @@
file-system))
#:autoload (gnu services sddm) (sddm-service-type)
#:use-module (gnu system)
- #:use-module (gnu system setuid)
+ #:use-module (gnu system privilege)
#:use-module (gnu system shadow)
#:use-module (gnu system uuid)
#:use-module (gnu system pam)
@@ -1080,7 +1080,11 @@ and many other) available for GIO applications.")
(default '("disk")))
(hybrid-sleep-mode elogind-hybrid-sleep-mode
(default
- '("suspend" "platform" "shutdown"))))
+ '("suspend" "platform" "shutdown")))
+ (hibernate-delay-seconds elogind-hibernate-delay-seconds
+ (default *unspecified*))
+ (suspend-estimation-seconds elogind-suspend-estimation-seconds
+ (default *unspecified*)))
(define (elogind-configuration-file config)
(define (yesno x)
@@ -1104,8 +1108,11 @@ and many other) available for GIO applications.")
(unless (exact-integer? x) (error "not an integer" x))
(when (negative? x) (error "negative number not allowed" x))
(number->string x))
+ (define (maybe-non-negative-integer x)
+ (or (and (unspecified? x) x)
+ (non-negative-integer x)))
(define handle-actions
- '(ignore poweroff reboot halt kexec suspend hibernate hybrid-sleep lock))
+ '(ignore poweroff reboot halt kexec suspend hibernate hybrid-sleep suspend-then-hibernate lock))
(define (handle-action x)
(if (unspecified? x)
x ;let the unspecified value go through
@@ -1163,7 +1170,9 @@ and many other) available for GIO applications.")
("HibernateState" (sleep-list elogind-hibernate-state))
("HibernateMode" (sleep-list elogind-hibernate-mode))
("HybridSleepState" (sleep-list elogind-hybrid-sleep-state))
- ("HybridSleepMode" (sleep-list elogind-hybrid-sleep-mode))))
+ ("HybridSleepMode" (sleep-list elogind-hybrid-sleep-mode))
+ ("HibernateDelaySec" (maybe-non-negative-integer elogind-hibernate-delay-seconds))
+ ("SuspendEstimationSec" (maybe-non-negative-integer elogind-suspend-estimation-seconds))))
(define (elogind-dbus-service config)
"Return a @file{org.freedesktop.login1.service} file that tells D-Bus how to
@@ -1723,11 +1732,12 @@ need to create it beforehand."))))
(enlightenment enlightenment-package
(default enlightenment)))
-(define (enlightenment-setuid-programs enlightenment-desktop-configuration)
+(define (enlightenment-privileged-programs enlightenment-desktop-configuration)
(match-record enlightenment-desktop-configuration
<enlightenment-desktop-configuration>
(enlightenment)
- (map file-like->setuid-program
+ (map (lambda (program) (privileged-program (program program)
+ (setuid? #t)))
(list (file-append enlightenment
"/lib/enlightenment/utils/enlightenment_sys")
(file-append enlightenment
@@ -1749,8 +1759,8 @@ need to create it beforehand."))))
(package-direct-input-selector
"ddcutil")
enlightenment-package))
- (service-extension setuid-program-service-type
- enlightenment-setuid-programs)
+ (service-extension privileged-program-service-type
+ enlightenment-privileged-programs)
(service-extension profile-service-type
(compose list
enlightenment-package))))
@@ -1758,7 +1768,7 @@ need to create it beforehand."))))
(description
"Return a service that adds the @code{enlightenment} package to the system
profile, and extends dbus with the ability for @code{efl} to generate
-thumbnails and makes setuid the programs which enlightenment needs to function
+thumbnails and privileges the programs which enlightenment needs to function
as expected.")))
;;;
@@ -1785,6 +1795,22 @@ rules."
"powerdevil"
"plasma-firewall"))))
+(define (plasma-dbus-service config)
+ "Return the list of KDE Plasma dependencies that provide D-Bus services."
+ (let ((plasma-plasma (plasma-package config)))
+ (map (lambda (name)
+ ((package-direct-input-selector name) plasma-plasma))
+ '("plasma-desktop"
+ "plasma-workspace"
+ "kactivitymanagerd"
+ "plasma-disks"
+ "kinfocenter"
+ "libksysguard"
+ "ktexteditor"
+ "powerdevil"
+ "kwallet"
+ "plasma-firewall"))))
+
;; see https://bugs.kde.org/show_bug.cgi?id=456210
;; if `kde' no exits, fallback to `other', and then unlock lockscreen not work,
;; so add it.
@@ -1799,6 +1825,8 @@ rules."
(extensions
(list (service-extension polkit-service-type
plasma-polkit-settings)
+ (service-extension dbus-root-service-type
+ plasma-dbus-service)
(service-extension pam-root-service-type
plasma-pam-services)
(service-extension profile-service-type
@@ -2026,8 +2054,9 @@ applications needing access to be root.")
;; without root.
(simple-service 'mount-setuid-helpers setuid-program-service-type
(map (lambda (program)
- (setuid-program
- (program program)))
+ (privileged-program
+ (program program)
+ (setuid? #t)))
(list (file-append nfs-utils "/sbin/mount.nfs")
(file-append ntfs-3g "/sbin/mount.ntfs-3g"))))
diff --git a/gnu/services/dns.scm b/gnu/services/dns.scm
index 6608046909..34ad95eb65 100644
--- a/gnu/services/dns.scm
+++ b/gnu/services/dns.scm
@@ -651,7 +651,11 @@ name server for the @acronym{DNS, Domain Name System}.")))
(kresd-config-file knot-resolver-kresd-config-file
(default %kresd.conf))
(garbage-collection-interval knot-resolver-garbage-collection-interval
- (default 1000)))
+ (default 1000))
+ (user knot-resolver-configuration-user
+ (default "knot-resolver"))
+ (group knot-resolver-configuration-group
+ (default "knot-resolver")))
(define %kresd.conf
(plain-file "kresd.conf" "-- -*- mode: lua -*-
@@ -685,7 +689,8 @@ cache.size = 100 * MB
(match-lambda
(($ <knot-resolver-configuration> package
kresd-config-file
- garbage-collection-interval)
+ garbage-collection-interval
+ user group)
(list
(shepherd-service
(provision '(kresd))
@@ -694,7 +699,9 @@ cache.size = 100 * MB
(start #~(make-forkexec-constructor
'(#$(file-append package "/sbin/kresd")
"-c" #$kresd-config-file "-n"
- "/var/cache/knot-resolver")))
+ "/var/cache/knot-resolver")
+ #:user #$user
+ #:group #$group))
(stop #~(make-kill-destructor)))
(shepherd-service
(provision '(kres-cache-gc))
@@ -704,8 +711,8 @@ cache.size = 100 * MB
'(#$(file-append package "/sbin/kres-cache-gc")
"-d" #$(number->string garbage-collection-interval)
"-c" "/var/cache/knot-resolver")
- #:user "knot-resolver"
- #:group "knot-resolver"))
+ #:user #$user
+ #:group #$group))
(stop #~(make-kill-destructor)))))))
(define knot-resolver-service-type
@@ -739,6 +746,8 @@ cache.size = 100 * MB
(default #t)) ;boolean
(listen-addresses dnsmasq-configuration-listen-address
(default '())) ;list of string
+ (extra-options dnsmasq-configuration-extra-options
+ (default '())) ;list of string
(resolv-file dnsmasq-configuration-resolv-file
(default "/etc/resolv.conf")) ;string
(no-resolv? dnsmasq-configuration-no-resolv?
@@ -798,7 +807,7 @@ cache.size = 100 * MB
tftp-single-port? tftp-secure?
tftp-max tftp-mtu tftp-no-blocksize?
tftp-lowercase? tftp-port-range
- tftp-root tftp-unique-root)
+ tftp-root tftp-unique-root extra-options)
(shepherd-service
(provision '(dnsmasq))
(requirement '(networking))
@@ -877,7 +886,8 @@ cache.size = 100 * MB
(if (> (length tftp-unique-root) 0)
(format #f "--tftp-unique-root=~a" tftp-unique-root)
(format #f "--tftp-unique-root")))
- '()))
+ '())
+ #$@extra-options)
#:pid-file "/run/dnsmasq.pid"))
(stop #~(make-kill-destructor)))))
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index 4d32b96847..1963f3c4bd 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -5,7 +5,7 @@
;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2020 Jesse Dowell <jessedowell@gmail.com>
;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
-;;; Copyright © 2023 Giacomo Leidi <goodoldpaul@autistici.org>
+;;; Copyright © 2023, 2024 Giacomo Leidi <goodoldpaul@autistici.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -23,11 +23,14 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu services docker)
+ #:use-module (gnu image)
#:use-module (gnu services)
#:use-module (gnu services configuration)
#:use-module (gnu services base)
#:use-module (gnu services dbus)
#:use-module (gnu services shepherd)
+ #:use-module (gnu system)
+ #:use-module (gnu system image)
#:use-module (gnu system setuid)
#:use-module (gnu system shadow)
#:use-module (gnu packages admin) ;shadow
@@ -37,14 +40,30 @@
#:use-module (guix diagnostics)
#:use-module (guix gexp)
#:use-module (guix i18n)
+ #:use-module (guix monads)
#:use-module (guix packages)
+ #:use-module (guix profiles)
+ #:use-module ((guix scripts pack) #:prefix pack:)
+ #:use-module (guix store)
#:use-module (srfi srfi-1)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
- #:export (docker-configuration
+ #:export (containerd-configuration
+ containerd-service-type
+ docker-configuration
docker-service-type
singularity-service-type
+ oci-image
+ oci-image?
+ oci-image-fields
+ oci-image-repository
+ oci-image-tag
+ oci-image-value
+ oci-image-pack-options
+ oci-image-target
+ oci-image-system
+ oci-image-grafts?
oci-container-configuration
oci-container-configuration?
oci-container-configuration-fields
@@ -52,14 +71,24 @@
oci-container-configuration-group
oci-container-configuration-command
oci-container-configuration-entrypoint
+ oci-container-configuration-host-environment
oci-container-configuration-environment
oci-container-configuration-image
oci-container-configuration-provision
+ oci-container-configuration-requirement
+ oci-container-configuration-log-file
+ oci-container-configuration-auto-start?
+ oci-container-configuration-respawn?
+ oci-container-configuration-shepherd-actions
oci-container-configuration-network
oci-container-configuration-ports
oci-container-configuration-volumes
+ oci-container-configuration-container-user
+ oci-container-configuration-workdir
+ oci-container-configuration-extra-arguments
oci-container-service-type
- oci-container-shepherd-service))
+ oci-container-shepherd-service
+ %oci-container-accounts))
(define-maybe file-like)
@@ -72,7 +101,7 @@
"Docker client package.")
(containerd
(file-like containerd)
- "containerd package.")
+ "Deprecated. Do not use.")
(proxy
(file-like docker-libnetwork-cmd-proxy)
"The proxy package to support inter-container and outside-container
@@ -94,6 +123,18 @@ loop-back communications.")
"JSON configuration file to pass to dockerd")
(no-serialization))
+(define-configuration containerd-configuration
+ (containerd
+ (file-like containerd)
+ "containerd package.")
+ (debug?
+ (boolean #f)
+ "Enable or disable debug output.")
+ (environment-variables
+ (list '())
+ "Environment variables to set for containerd.")
+ (no-serialization))
+
(define %docker-accounts
(list (user-group (name "docker") (system? #t))))
@@ -111,24 +152,37 @@ loop-back communications.")
(mkdir-p #$state-dir))))
(define (containerd-shepherd-service config)
- (let* ((package (docker-configuration-containerd config))
- (debug? (docker-configuration-debug? config))
- (containerd (docker-configuration-containerd config)))
+ (match-record config <containerd-configuration>
+ (containerd debug? environment-variables)
(shepherd-service
- (documentation "containerd daemon.")
- (provision '(containerd))
- (start #~(make-forkexec-constructor
- (list (string-append #$package "/bin/containerd")
- #$@(if debug?
- '("--log-level=debug")
- '()))
- ;; For finding containerd-shim binary.
- #:environment-variables
- (list (string-append "PATH=" #$containerd "/bin"))
- #:pid-file "/run/containerd/containerd.pid"
- #:pid-file-timeout 300
- #:log-file "/var/log/containerd.log"))
- (stop #~(make-kill-destructor)))))
+ (documentation "containerd daemon.")
+ (provision '(containerd))
+ (start #~(make-forkexec-constructor
+ (list (string-append #$containerd "/bin/containerd")
+ #$@(if debug?
+ '("--log-level=debug")
+ '()))
+ ;; For finding containerd-shim binary.
+ #:environment-variables
+ (list #$@environment-variables
+ (string-append "PATH=" #$containerd "/bin"))
+ #:pid-file "/run/containerd/containerd.pid"
+ #:pid-file-timeout 300
+ #:log-file "/var/log/containerd.log"))
+ (stop #~(make-kill-destructor)))))
+
+(define containerd-service-type
+ (service-type (name 'containerd)
+ (description "Run containerd container runtime.")
+ (extensions
+ (list
+ ;; Make sure the 'ctr' command is available.
+ (service-extension profile-service-type
+ (compose list containerd-configuration-containerd))
+ (service-extension shepherd-root-service-type
+ (lambda (config)
+ (list (containerd-shepherd-service config))))))
+ (default-value (containerd-configuration))))
(define (docker-shepherd-service config)
(let* ((docker (docker-configuration-docker config))
@@ -185,8 +239,7 @@ bundles in Docker containers.")
%docker-activation)
(service-extension shepherd-root-service-type
(lambda (config)
- (list (containerd-shepherd-service config)
- (docker-shepherd-service config))))
+ (list (docker-shepherd-service config))))
(service-extension account-service-type
(const %docker-accounts))))
(default-value (docker-configuration))))
@@ -282,6 +335,11 @@ found!")
name el)))))
value))
+(define (oci-sanitize-host-environment value)
+ ;; Expected spec format:
+ ;; '(("HOME" . "/home/nobody") "JAVA_HOME=/java")
+ (oci-sanitize-mixed-list "host-environment" value "="))
+
(define (oci-sanitize-environment value)
;; Expected spec format:
;; '(("HOME" . "/home/nobody") "JAVA_HOME=/java")
@@ -297,8 +355,94 @@ found!")
;; '(("/mnt/dir" . "/dir") "/run/current-system/profile:/java")
(oci-sanitize-mixed-list "volumes" value ":"))
+(define (oci-sanitize-shepherd-actions value)
+ (map
+ (lambda (el)
+ (if (shepherd-action? el)
+ el
+ (raise
+ (formatted-message
+ (G_ "shepherd-actions may only be shepherd-action records
+but ~a was found") el))))
+ value))
+
+(define (oci-sanitize-extra-arguments value)
+ (define (valid? member)
+ (or (string? member)
+ (gexp? member)
+ (file-like? member)))
+ (map
+ (lambda (el)
+ (if (valid? el)
+ el
+ (raise
+ (formatted-message
+ (G_ "extra arguments may only be strings, gexps or file-like objects
+but ~a was found") el))))
+ value))
+
+(define (oci-image-reference image)
+ (if (string? image)
+ image
+ (string-append (oci-image-repository image)
+ ":" (oci-image-tag image))))
+
+(define (oci-lowerable-image? image)
+ (or (manifest? image)
+ (operating-system? image)
+ (gexp? image)
+ (file-like? image)))
+
+(define (string-or-oci-image? image)
+ (or (string? image)
+ (oci-image? image)))
+
+(define list-of-symbols?
+ (list-of symbol?))
+
(define-maybe/no-serialization string)
+(define-configuration/no-serialization oci-image
+ (repository
+ (string)
+ "A string like @code{myregistry.local:5000/testing/test-image} that names
+the OCI image.")
+ (tag
+ (string "latest")
+ "A string representing the OCI image tag. Defaults to @code{latest}.")
+ (value
+ (oci-lowerable-image)
+ "A @code{manifest} or @code{operating-system} record that will be lowered
+into an OCI compatible tarball. Otherwise this field's value can be a gexp
+or a file-like object that evaluates to an OCI compatible tarball.")
+ (pack-options
+ (list '())
+ "An optional set of keyword arguments that will be passed to the
+@code{docker-image} procedure from @code{guix scripts pack}. They can be used
+to replicate @command{guix pack} behavior:
+
+@lisp
+(oci-image
+ (repository \"guile\")
+ (tag \"3\")
+ (manifest (specifications->manifest '(\"guile\")))
+ (pack-options
+ '(#:symlinks ((\"/bin/guile\" -> \"bin/guile\"))
+ #:max-layers 2)))
+@end lisp
+
+If the @code{value} field is an @code{operating-system} record, this field's
+value will be ignored.")
+ (system
+ (maybe-string)
+ "Attempt to build for a given system, e.g. \"i686-linux\"")
+ (target
+ (maybe-string)
+ "Attempt to cross-build for a given triple, e.g. \"aarch64-linux-gnu\"")
+ (grafts?
+ (boolean #f)
+ "Whether to allow grafting or not in the pack build."))
+
(define-configuration/no-serialization oci-container-configuration
(user
(string "oci-container")
@@ -312,28 +456,70 @@ found!")
(entrypoint
(maybe-string)
"Overwrite the default entrypoint (@code{ENTRYPOINT}) of the image.")
+ (host-environment
+ (list '())
+ "Set environment variables in the host environment where @command{docker run}
+is invoked. This is especially useful to pass secrets from the host to the
+container without having them on the @command{docker run}'s command line: by
+setting the @code{MYSQL_PASSWORD} on the host and by passing
+@code{--env MYSQL_PASSWORD} through the @code{extra-arguments} field, it is
+possible to securely set values in the container environment. This field's
+value can be a list of pairs or strings, even mixed:
+
+@lisp
+(list '(\"LANGUAGE\" . \"eo:ca:eu\")
+ \"JAVA_HOME=/opt/java\")
+@end lisp
+
+Pair members can be strings, gexps or file-like objects. Strings are passed
+directly to @code{make-forkexec-constructor}."
+ (sanitizer oci-sanitize-host-environment))
(environment
(list '())
- "Set environment variables. This can be a list of pairs or strings, even
-mixed:
+ "Set environment variables inside the container. This can be a list of pairs
+or strings, even mixed:
@lisp
(list '(\"LANGUAGE\" . \"eo:ca:eu\")
\"JAVA_HOME=/opt/java\")
@end lisp
-String are passed directly to the Docker CLI. You can refer to the
+Pair members can be strings, gexps or file-like objects. Strings are passed
+directly to the Docker CLI. You can refer to the
@url{https://docs.docker.com/engine/reference/commandline/run/#env,upstream}
documentation for semantics."
(sanitizer oci-sanitize-environment))
(image
- (string)
- "The image used to build the container. Images are resolved by the Docker
+ (string-or-oci-image)
+ "The image used to build the container. It can be a string or an
+@code{oci-image} record. Strings are resolved by the Docker
Engine, and follow the usual format
@code{myregistry.local:5000/testing/test-image:tag}.")
(provision
(maybe-string)
"Set the name of the provisioned Shepherd service.")
+ (requirement
+ (list-of-symbols '())
+ "Set additional Shepherd services dependencies to the provisioned Shepherd
+service.")
+ (log-file
+ (maybe-string)
+ "When @code{log-file} is set, it names the file to which the service’s
+standard output and standard error are redirected. @code{log-file} is created
+if it does not exist, otherwise it is appended to.")
+ (auto-start?
+ (boolean #t)
+ "Whether this service should be started automatically by the Shepherd. If it
+is @code{#f} the service has to be started manually with @command{herd start}.")
+ (respawn?
+ (boolean #f)
+ "Whether to restart the service when it stops, for instance when the
+underlying process dies.")
+ (shepherd-actions
+ (list '())
+ "This is a list of @code{shepherd-action} records defining actions supported
+by the service."
+ (sanitizer oci-sanitize-shepherd-actions))
(network
(maybe-string)
"Set a Docker network for the spawned container.")
@@ -347,7 +533,8 @@ be a list of pairs or strings, even mixed:
\"10443:443\")
@end lisp
-String are passed directly to the Docker CLI. You can refer to the
+Pair members can be strings, gexps or file-like objects. Strings are passed
+directly to the Docker CLI. You can refer to the
@url{https://docs.docker.com/engine/reference/commandline/run/#publish,upstream}
documentation for semantics."
(sanitizer oci-sanitize-ports))
@@ -361,7 +548,8 @@ list of pairs or strings, even mixed:
\"/gnu/store:/gnu/store\")
@end lisp
-String are passed directly to the Docker CLI. You can refer to the
+Pair members can be strings, gexps or file-like objects. Strings are passed
+directly to the Docker CLI. You can refer to the
@url{https://docs.docker.com/engine/reference/commandline/run/#volume,upstream}
documentation for semantics."
(sanitizer oci-sanitize-volumes))
@@ -375,7 +563,12 @@ documentation for semantics.")
"Set the current working for the spawned Shepherd service.
You can refer to the
@url{https://docs.docker.com/engine/reference/run/#workdir,upstream}
-documentation for semantics."))
+documentation for semantics.")
+ (extra-arguments
+ (list '())
+ "A list of strings, gexps or file-like objects that will be directly passed
+to the @command{docker run} invokation."
+ (sanitizer oci-sanitize-extra-arguments)))
(define oci-container-configuration->options
(lambda (config)
@@ -414,49 +607,185 @@ documentation for semantics."))
(list "-v" spec))
(oci-container-configuration-volumes config))))))))
+(define* (get-keyword-value args keyword #:key (default #f))
+ (let ((kv (memq keyword args)))
+ (if (and kv (>= (length kv) 2))
+ (cadr kv)
+ default)))
+
+(define (lower-operating-system os target system)
+ (mlet* %store-monad
+ ((tarball
+ (lower-object
+ (system-image (os->image os #:type docker-image-type))
+ system
+ #:target target)))
+ (return tarball)))
+
+(define (lower-manifest name image target system)
+ (define value (oci-image-value image))
+ (define options (oci-image-pack-options image))
+ (define image-reference
+ (oci-image-reference image))
+ (define image-tag
+ (let* ((extra-options
+ (get-keyword-value options #:extra-options))
+ (image-tag-option
+ (and extra-options
+ (get-keyword-value extra-options #:image-tag))))
+ (if image-tag-option
+ '()
+ `(#:extra-options (#:image-tag ,image-reference)))))
+
+ (mlet* %store-monad
+ ((_ (set-grafting
+ (oci-image-grafts? image)))
+ (guile (set-guile-for-build (default-guile)))
+ (profile
+ (profile-derivation value
+ #:target target
+ #:system system
+ #:hooks '()
+ #:locales? #f))
+ (tarball (apply pack:docker-image
+ `(,name ,profile
+ ,@options
+ ,@image-tag
+ #:localstatedir? #t))))
+ (return tarball)))
+
+(define (lower-oci-image name image)
+ (define value (oci-image-value image))
+ (define image-target (oci-image-target image))
+ (define image-system (oci-image-system image))
+ (define target
+ (if (maybe-value-set? image-target)
+ image-target
+ (%current-target-system)))
+ (define system
+ (if (maybe-value-set? image-system)
+ image-system
+ (%current-system)))
+ (with-store store
+ (run-with-store store
+ (match value
+ ((? manifest? value)
+ (lower-manifest name image target system))
+ ((? operating-system? value)
+ (lower-operating-system value target system))
+ ((or (? gexp? value)
+ (? file-like? value))
+ value)
+ (_
+ (raise
+ (formatted-message
+ (G_ "oci-image value must contain only manifest,
+operating-system, gexp or file-like records but ~a was found")
+ value))))
+ #:target target
+ #:system system)))
+
+(define (%oci-image-loader name image tag)
+ (let ((docker (file-append docker-cli "/bin/docker"))
+ (tarball (lower-oci-image name image)))
+ (with-imported-modules '((guix build utils))
+ (program-file (format #f "~a-image-loader" name)
+ #~(begin
+ (use-modules (guix build utils)
+ (ice-9 popen)
+ (ice-9 rdelim))
+
+ (format #t "Loading image for ~a from ~a...~%" #$name #$tarball)
+ (define line
+ (read-line
+ (open-input-pipe
+ (string-append #$docker " load -i " #$tarball))))
+
+ (unless (or (eof-object? line)
+ (string-null? line))
+ (format #t "~a~%" line)
+ (let ((repository&tag
+ (string-drop line
+ (string-length
+ "Loaded image: "))))
+
+ (invoke #$docker "tag" repository&tag #$tag)
+ (format #t "Tagged ~a with ~a...~%" #$tarball #$tag))))))))
+
(define (oci-container-shepherd-service config)
(define (guess-name name image)
(if (maybe-value-set? name)
name
(string-append "docker-"
- (basename (car (string-split image #\:))))))
-
- (let* ((docker-command (file-append docker-cli "/bin/docker"))
+ (basename
+ (if (string? image)
+ (first (string-split image #\:))
+ (oci-image-repository image))))))
+
+ (let* ((docker (file-append docker-cli "/bin/docker"))
+ (actions (oci-container-configuration-shepherd-actions config))
+ (auto-start?
+ (oci-container-configuration-auto-start? config))
(user (oci-container-configuration-user config))
(group (oci-container-configuration-group config))
+ (host-environment
+ (oci-container-configuration-host-environment config))
(command (oci-container-configuration-command config))
+ (log-file (oci-container-configuration-log-file config))
(provision (oci-container-configuration-provision config))
+ (requirement (oci-container-configuration-requirement config))
+ (respawn?
+ (oci-container-configuration-respawn? config))
(image (oci-container-configuration-image config))
+ (image-reference (oci-image-reference image))
(options (oci-container-configuration->options config))
- (name (guess-name provision image)))
+ (name (guess-name provision image))
+ (extra-arguments
+ (oci-container-configuration-extra-arguments config)))
(shepherd-service (provision `(,(string->symbol name)))
- (requirement '(dockerd user-processes))
- (respawn? #f)
+ (requirement `(dockerd user-processes ,@requirement))
+ (respawn? respawn?)
+ (auto-start? auto-start?)
(documentation
(string-append
- "Docker backed Shepherd service for image: " image))
+ "Docker backed Shepherd service for "
+ (if (oci-image? image) name image) "."))
(start
- #~(make-forkexec-constructor
- ;; docker run [OPTIONS] IMAGE [COMMAND] [ARG...]
- (list #$docker-command "run" "--rm"
- "--name" #$name
- #$@options #$image #$@command)
- #:user #$user
- #:group #$group))
+ #~(lambda ()
+ #$@(if (oci-image? image)
+ #~((invoke #$(%oci-image-loader
+ name image image-reference)))
+ #~())
+ (fork+exec-command
+ ;; docker run [OPTIONS] IMAGE [COMMAND] [ARG...]
+ (list #$docker "run" "--rm" "--name" #$name
+ #$@options #$@extra-arguments
+ #$image-reference #$@command)
+ #:user #$user
+ #:group #$group
+ #$@(if (maybe-value-set? log-file)
+ (list #:log-file log-file)
+ '())
+ #:environment-variables
+ (list #$@host-environment))))
(stop
#~(lambda _
- (invoke #$docker-command "rm" "-f" #$name)))
+ (invoke #$docker "rm" "-f" #$name)))
(actions
- (list
- (shepherd-action
- (name 'pull)
- (documentation
- (format #f "Pull ~a's image (~a)."
- name image))
- (procedure
- #~(lambda _
- (invoke #$docker-command "pull" #$image)))))))))
+ (if (oci-image? image)
+ '()
+ (append
+ (list
+ (shepherd-action
+ (name 'pull)
+ (documentation
+ (format #f "Pull ~a's image (~a)."
+ name image))
+ (procedure
+ #~(lambda _
+ (invoke #$docker "pull" #$image)))))
+ actions))))))
(define %oci-container-accounts
(list (user-account
@@ -482,5 +811,5 @@ documentation for semantics."))
(extend append)
(compose concatenate)
(description
- "This service allows the management of Docker and OCI
+ "This service allows the management of OCI
containers as Shepherd services.")))
diff --git a/gnu/services/ganeti.scm b/gnu/services/ganeti.scm
index f4fec3833e..ee72946c88 100644
--- a/gnu/services/ganeti.scm
+++ b/gnu/services/ganeti.scm
@@ -182,7 +182,7 @@
;; Ceph, Gluster, etc, without having to add absolute references to everything.
(define %default-ganeti-environment-variables
(list (string-append "PATH="
- (string-join '("/run/setuid-programs"
+ (string-join '("/run/privileged/bin"
"/run/current-system/profile/sbin"
"/run/current-system/profile/bin")
":"))))
diff --git a/gnu/services/guix.scm b/gnu/services/guix.scm
index 96f5ecaac0..0182c21ea7 100644
--- a/gnu/services/guix.scm
+++ b/gnu/services/guix.scm
@@ -291,7 +291,8 @@
(build-coordinator (make-build-coordinator
#:database-uri-string #$database-uri-string
#:hooks hooks-with-defaults
- #:allocation-strategy #$allocation-strategy)))
+ #:allocation-strategy #$allocation-strategy
+ #:timestamp-log-output? #f)))
(run-coordinator-service
build-coordinator
@@ -421,6 +422,7 @@
(fork+exec-command
(list #$(file-append package "/bin/guix-build-coordinator-agent")
#$(string-append "--coordinator=" coordinator)
+ "--timestamp-log-output=false"
#$@(match authentication
(($ <guix-build-coordinator-agent-password-auth>
uuid password)
diff --git a/gnu/services/mail.scm b/gnu/services/mail.scm
index d5c5e5d35e..392c5f6c44 100644
--- a/gnu/services/mail.scm
+++ b/gnu/services/mail.scm
@@ -2,7 +2,7 @@
;;; Copyright © 2015 Andy Wingo <wingo@igalia.com>
;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2017 Carlo Zancanaro <carlo@zancanaro.id.au>
-;;; Copyright © 2017, 2020 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2017, 2020, 2024 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2019 Kristofer Buffington <kristoferbuffington@gmail.com>
;;; Copyright © 2020 Jonathan Brielmaier <jonathan.brielmaier@web.de>
;;; Copyright © 2023 Thomas Ieong <th.ieong@free.fr>
@@ -10,6 +10,7 @@
;;; Copyright © 2023, 2024 Wojtek Kosior <koszko@koszko.org>
;;; Additions and modifications by Wojtek Kosior are additionally
;;; dual-licensed under the Creative Commons Zero v1.0.
+;;; Copyright © 2024 Juliana Sims <juli@incana.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -34,17 +35,19 @@
#:use-module (gnu services configuration)
#:use-module (gnu services shepherd)
#:use-module (gnu system pam)
+ #:use-module (gnu system privilege)
#:use-module (gnu system shadow)
- #:use-module (gnu system setuid)
#:use-module (gnu packages mail)
#:use-module (gnu packages admin)
#:use-module (gnu packages dav)
#:use-module (gnu packages tls)
#:use-module (guix deprecation)
+ #:use-module ((guix diagnostics) #:select (source-properties->location))
#:use-module (guix modules)
#:use-module (guix records)
#:use-module (guix packages)
#:use-module (guix gexp)
+ #:use-module (ice-9 curried-definitions)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:use-module (srfi srfi-1)
@@ -82,10 +85,21 @@
imap4d-service-type
%default-imap4d-config-file
+ radicale-auth-configuration
+ radicale-auth-configuration?
+ radicale-encoding-configuration
+ radicale-encoding-configuration?
+ radicale-logging-configuration
+ radicale-logging-configuration?
+ radicale-rights-configuration
+ radicale-rights-configuration?
+ radicale-server-configuration
+ radicale-server-configuration?
+ radicale-storage-configuration
+ radicale-storage-configuration?
radicale-configuration
radicale-configuration?
radicale-service-type
- %default-radicale-config-file
rspamd-configuration
rspamd-service-type
@@ -1732,37 +1746,20 @@ match from local for any action outbound
(define (opensmtpd-set-gids config)
(match-record config <opensmtpd-configuration> (package config-file setgid-commands?)
(if setgid-commands?
- (list
- (setuid-program
- (program (file-append package "/sbin/smtpctl"))
- (setuid? #false)
- (setgid? #true)
- (group "smtpq"))
- (setuid-program
- (program (file-append package "/sbin/sendmail"))
- (setuid? #false)
- (setgid? #true)
- (group "smtpq"))
- (setuid-program
- (program (file-append package "/sbin/send-mail"))
- (setuid? #false)
- (setgid? #true)
- (group "smtpq"))
- (setuid-program
- (program (file-append package "/sbin/makemap"))
- (setuid? #false)
- (setgid? #true)
- (group "smtpq"))
- (setuid-program
- (program (file-append package "/sbin/mailq"))
- (setuid? #false)
- (setgid? #true)
- (group "smtpq"))
- (setuid-program
- (program (file-append package "/sbin/newaliases"))
- (setuid? #false)
- (setgid? #true)
- (group "smtpq")))
+ (map (lambda (command)
+ (privileged-program
+ (program (file-append package "/" command))
+ (setgid? #t)
+ (group "smtpq")))
+ (list "sbin/smtpctl"
+
+ ;; Also privilege the compatibility symlinks created by
+ ;; the Guix opensmtpd package; all synonyms for smtpctl.
+ "sbin/mailq"
+ "sbin/makemap"
+ "sbin/newaliases"
+ "sbin/sendmail"
+ "sbin/send-mail"))
'())))
(define opensmtpd-service-type
@@ -1779,7 +1776,7 @@ match from local for any action outbound
(compose list opensmtpd-configuration-package))
(service-extension shepherd-root-service-type
opensmtpd-shepherd-service)
- (service-extension setuid-program-service-type
+ (service-extension privileged-program-service-type
opensmtpd-set-gids)))
(description "Run the OpenSMTPD, a lightweight @acronym{SMTP, Simple Mail
Transfer Protocol} server.")))
@@ -1887,7 +1884,7 @@ database---computed from the given alias list.")))
(match-lambda
(($ <exim-configuration> package config-file setuid-user setgid-group)
(if (or setuid-user setgid-group)
- (list (setuid-program
+ (list (privileged-program
(program (file-append package "/bin/exim"))
(setuid? #t)
(user (or setuid-user "exim"))
@@ -1904,7 +1901,7 @@ database---computed from the given alias list.")))
(service-extension activation-service-type exim-activation)
(service-extension profile-service-type exim-profile)
(service-extension mail-aliases-service-type (const '()))
- (service-extension setuid-program-service-type exim-setuids)))
+ (service-extension privileged-program-service-type exim-setuids)))
(description "Run the Exim mail transfer agent (MTA).")))
@@ -1950,23 +1947,258 @@ database---computed from the given alias list.")))
;;; Radicale.
;;;
-(define-record-type* <radicale-configuration>
- radicale-configuration make-radicale-configuration
- radicale-configuration?
- (package radicale-configuration-package
- (default radicale))
- (config-file radicale-configuration-config-file
- (default %default-radicale-config-file)))
+;; Maybe types
-(define %default-radicale-config-file
- (plain-file "radicale.conf" "
-[auth]
-type = htpasswd
-htpasswd_filename = /var/lib/radicale/users
-htpasswd_encryption = plain
+(define (comma-separated-ip-list? lst)
+ (every (lambda (s)
+ (or (string-prefix? "localhost" s)
+ ((@@ (gnu services vpn) ipv4-address?) s)
+ ((@@ (gnu services vpn) ipv6-address?) s)))
+ lst))
-[server]
-hosts = localhost:5232"))
+(define-maybe boolean (prefix radicale-))
+(define-maybe comma-separated-ip-list (prefix radicale-))
+(define-maybe file-name (prefix radicale-))
+(define-maybe non-negative-integer (prefix radicale-))
+(define-maybe string (prefix radicale-))
+(define-maybe symbol (prefix radicale-))
+
+;; Serializers and sanitizers
+
+(define (radicale-serialize-field field-name value)
+ ;; XXX We quote the un-gexp form here because otherwise symbol-literals are
+ ;; treated as variables. We can get away with this because all of our other
+ ;; field value types are primitives by the time they get here so are printed
+ ;; the same whether or not they are quoted.
+ #~(format #f "~a = ~a\n" #$(uglify-field-name field-name) '#$value))
+
+(define (radicale-serialize-boolean field-name value?)
+ (radicale-serialize-field field-name (if value? "True" "False")))
+
+(define (radicale-serialize-comma-separated-ip-list field-name value)
+ (radicale-serialize-field field-name (string-join value ", ")))
+
+(define radicale-serialize-file-name radicale-serialize-field)
+
+(define radicale-serialize-non-negative-integer radicale-serialize-field)
+
+(define radicale-serialize-string radicale-serialize-field)
+
+(define radicale-serialize-symbol radicale-serialize-field)
+
+(define ((sanitize-delimited-symbols syms location field) value)
+ (cond
+ ((not (maybe-value-set? value))
+ value)
+ ((member value syms)
+ (string->symbol (uglify-field-name value)))
+ (else
+ (configuration-field-error (source-properties->location location)
+ field
+ value))))
+
+;; Section configuration types
+
+(define-configuration radicale-auth-configuration
+ (type
+ maybe-symbol
+ "The method to verify usernames and passwords. Options are @code{none},
+@code{htpasswd}, @code{remote-user}, and @code{http-x-remote-user}.
+
+This value is tied to @code{htpasswd-filename} and @code{htpasswd-encryption}."
+ (sanitizer
+ (sanitize-delimited-symbols '(none htpasswd remote-user http-x-remote-user)
+ (current-source-location)
+ 'type)))
+ (htpasswd-filename
+ maybe-file-name
+ "Path to the htpasswd file. Use htpasswd or similar to generate this file.")
+ (htpasswd-encryption
+ maybe-symbol
+ "Encryption method used in the htpasswd file. Options are @code{plain},
+@code{bcrypt}, and @code{md5}."
+ (sanitizer
+ (sanitize-delimited-symbols '(plain bcrypt md5)
+ (current-source-location)
+ 'htpasswd-encryption)))
+ (delay
+ maybe-non-negative-integer
+ "Average delay after failed login attempts in seconds.")
+ (realm
+ maybe-string
+ "Message displayed in the client when a password is needed.")
+ (prefix radicale-))
+
+(define-configuration radicale-encoding-configuration
+ (request
+ maybe-symbol
+ "Encoding for responding requests.")
+ (stock
+ maybe-symbol
+ "Encoding for storing local collections.")
+ (prefix radicale-))
+
+(define-configuration radicale-logging-configuration
+ (level
+ maybe-symbol
+ "Set the logging level. One of @code{debug}, @code{info}, @code{warning},
+@code{error}, or @code{critical}."
+ (sanitizer (sanitize-delimited-symbols '(debug info warning error critical)
+ (current-source-location)
+ 'level)))
+ (mask-passwords?
+ maybe-boolean
+ "Whether to include passwords in logs.")
+ (prefix radicale-))
+
+(define-configuration radicale-rights-configuration
+ (type
+ maybe-symbol
+ "Backend used to check collection access rights. The recommended backend is
+@code{owner-only}. If access to calendars and address books outside the home
+directory of users is granted, clients won't detect these collections and will
+not show them to the user. Choosing any other method is only useful if you
+access calendars and address books directly via URL. Options are
+@code{authenticate}, @code{owner-only}, @code{owner-write}, and
+@code{from-file}."
+ (sanitizer
+ (sanitize-delimited-symbols '(authenticate owner-only owner-write from-file)
+ (current-source-location)
+ 'type)))
+ (file
+ maybe-file-name
+ "File for the rights backend @code{from-file}.")
+ (prefix radicale-))
+
+(define-configuration radicale-server-configuration
+ (hosts
+ maybe-comma-separated-ip-list
+ "List of IP addresses that the server will bind to.")
+ (max-connections
+ maybe-non-negative-integer
+ "Maximum number of parallel connections. Set to 0 to disable the limit.")
+ (max-content-length
+ maybe-non-negative-integer
+ "Maximum size of the request body in byetes.")
+ (timeout
+ maybe-non-negative-integer
+ "Socket timeout in seconds.")
+ (ssl?
+ maybe-boolean
+ "Whether to enable transport layer encryption.")
+ (certificate
+ maybe-file-name
+ "Path of the SSL certificate.")
+ (key
+ maybe-file-name
+ "Path to the private key for SSL. Only effective if @code{ssl?} is
+@code{#t}.")
+ (certificate-authority
+ maybe-file-name
+ "Path to CA certificate for validating client certificates. This can be used
+to secure TCP traffic between Radicale and a reverse proxy. If you want to
+authenticate users with client-side certificates, you also have to write an
+authentication plugin that extracts the username from the certificate.")
+ (prefix radicale-))
+
+(define-configuration radicale-storage-configuration
+ (type
+ maybe-symbol
+ "Backend used to store data. Options are @code{multifilesystem} and
+@code{multifilesystem-nolock}."
+ (sanitizer
+ (sanitize-delimited-symbols '(multifilesystem multifilesystem-nolock)
+ (current-source-location)
+ 'type)))
+ (filesystem-folder
+ maybe-file-name
+ "Folder for storing local collections. Created if not present.")
+ (max-sync-token-age
+ maybe-non-negative-integer
+ "Delete sync-tokens that are older than the specified time in seconds.")
+ (hook
+ maybe-string
+ "Command run after changes to storage.")
+ (prefix radicale-))
+
+;; Helpers for using section configurations in the main configuration
+
+;; XXX These indirections are necessary to avoid creating semantic ambiguity
+(define auth-config? radicale-auth-configuration?)
+(define encoding-config? radicale-encoding-configuration?)
+(define headers-file? file-like?)
+(define logging-config? radicale-logging-configuration?)
+(define rights-config? radicale-rights-configuration?)
+(define server-config? radicale-server-configuration?)
+(define storage-config? radicale-storage-configuration?)
+
+(define-maybe auth-config)
+(define-maybe encoding-config)
+(define-maybe headers-file)
+(define-maybe logging-config)
+(define-maybe rights-config)
+(define-maybe server-config)
+(define-maybe storage-config)
+
+(define ((serialize-radicale-section fields) name cfg)
+ #~(format #f "[~a]\n~a\n" '#$name #$(serialize-configuration cfg fields)))
+
+(define serialize-auth-config
+ (serialize-radicale-section radicale-auth-configuration-fields))
+(define serialize-encoding-config
+ (serialize-radicale-section radicale-encoding-configuration-fields))
+(define serialize-logging-config
+ (serialize-radicale-section radicale-logging-configuration-fields))
+(define serialize-rights-config
+ (serialize-radicale-section radicale-rights-configuration-fields))
+(define serialize-server-config
+ (serialize-radicale-section radicale-server-configuration-fields))
+(define serialize-storage-config
+ (serialize-radicale-section radicale-storage-configuration-fields))
+
+(define (serialize-radicale-configuration cfg)
+ (mixed-text-file
+ "radicale.conf"
+ (serialize-configuration cfg radicale-configuration-fields)))
+
+(define-configuration radicale-configuration
+ ;; Only fields whose default value does not match upstream are not maybe-types
+ (package
+ (file-like radicale)
+ "Package that provides @command{radicale}.")
+ (auth
+ maybe-auth-config
+ "Configuration for auth-related variables.")
+ (encoding
+ maybe-encoding-config
+ "Configuration for encoding-related variables.")
+ (headers-file
+ maybe-headers-file
+ "Custom HTTP headers."
+ (serializer
+ (lambda (field-name value)
+ #~(begin
+ (use-modules (ice-9 rdelim))
+ (format #f "[headers]\n~a\n\n"
+ (with-input-from-file #$value read-string))))))
+ (logging
+ maybe-logging-config
+ "Configuration for logging-related variables.")
+ (rights
+ maybe-rights-config
+ "Configuration for rights-related variables.")
+ (server
+ maybe-server-config
+ "Configuration for server-related variables. Ignored if WSGI is used.")
+ (storage
+ maybe-storage-config
+ "Configuration for storage-related variables.")
+ (web-interface?
+ maybe-boolean
+ "Whether to use Radicale's built-in web interface."
+ (serializer
+ (lambda (_ use?)
+ #~(format #f "[web]\ntype = ~a\n\n" #$(if use? "internal" "none"))))))
(define %radicale-accounts
(list (user-group
@@ -1980,43 +2212,88 @@ hosts = localhost:5232"))
(home-directory "/var/empty")
(shell (file-append shadow "/sbin/nologin")))))
-(define radicale-shepherd-service
- (match-lambda
- (($ <radicale-configuration> package config-file)
- (list (shepherd-service
- (provision '(radicale))
- (documentation "Run the radicale daemon.")
- (requirement '(networking))
- (start #~(make-forkexec-constructor
- (list #$(file-append package "/bin/radicale")
- "-C" #$config-file)
- #:user "radicale"
- #:group "radicale"))
- (stop #~(make-kill-destructor)))))))
+(define (radicale-shepherd-service cfg)
+ (list (shepherd-service
+ (provision '(radicale))
+ (documentation "Run the radicale daemon.")
+ (requirement '(networking))
+ (start #~(make-forkexec-constructor
+ (list #$(file-append (radicale-configuration-package cfg)
+ "/bin/radicale")
+ "-C" #$(serialize-radicale-configuration cfg))
+ #:user "radicale"
+ #:group "radicale"))
+ (stop #~(make-kill-destructor)))))
(define radicale-activation
(match-lambda
- (($ <radicale-configuration> package config-file)
+ (($ <radicale-configuration> _ auth-config _ _ _ _ _ storage-config _)
+ ;; Get values for the collections directory
+ ;; See https://radicale.org/v3.html#running-as-a-service
+ (define filesystem-folder-val
+ (if (maybe-value-set? storage-config)
+ (radicale-storage-configuration-filesystem-folder storage-config)
+ storage-config))
+ (define collections-dir
+ (if (maybe-value-set? filesystem-folder-val)
+ filesystem-folder-val
+ "/var/lib/radicale/collections"))
+ (define collections-parent-dir (dirname collections-dir))
+ ;; Get values for the password file directory
+ (define auth-value-set? (maybe-value-set? auth-config))
+ ;; If auth's type is 'none or unset, that means there is no authentication
+ ;; and we don't need to setup files for it
+ (define auth?
+ (and auth-value-set?
+ (not (eq? (radicale-auth-configuration-type auth-config) 'none))))
+ (define password-file-val
+ (if auth-value-set?
+ (radicale-auth-configuration-htpasswd-filename auth-config)
+ auth-config))
+ (define password-file-dir
+ (if (maybe-value-set? password-file-val)
+ (dirname password-file-val)
+ "/etc/radicale"))
(with-imported-modules '((guix build utils))
#~(begin
(use-modules (guix build utils))
- (let ((uid (passwd:uid (getpw "radicale")))
- (gid (group:gid (getgr "radicale"))))
- (mkdir-p "/var/lib/radicale/collections")
- (chown "/var/lib/radicale" uid gid)
- (chown "/var/lib/radicale/collections" uid gid)
- (chmod "/var/lib/radicale" #o700)))))))
+ (let ((user (getpwnam "radicale")))
+ ;; Collections directory perms
+ (mkdir-p/perms #$collections-dir user #o700)
+ ;; Password file perms
+ (when #$auth?
+ ;; In theory, the password file and thus this directory should already
+ ;; exist because the user has to make them by hand
+ (mkdir-p/perms #$password-file-dir user #o700))))))))
(define radicale-service-type
(service-type
(name 'radicale)
- (description "Run radicale, a small CalDAV and CardDAV server.")
+ (description "Run Radicale, a small CalDAV and CardDAV server.")
(extensions
(list (service-extension shepherd-root-service-type radicale-shepherd-service)
(service-extension account-service-type (const %radicale-accounts))
(service-extension activation-service-type radicale-activation)))
(default-value (radicale-configuration))))
+(define (generate-radicale-documentation)
+ (generate-documentation
+ `((radicale-configuration
+ ,radicale-configuration-fields
+ (auth radicale-auth-configuration)
+ (encoding radicale-encoding-configuration)
+ (logging radicale-logging-configuration)
+ (rights radicale-rights-configuration)
+ (server radicale-server-configuration)
+ (storage radicale-storage-configuration))
+ (radicale-auth-configuration ,radicale-auth-configuration-fields)
+ (radicale-encoding-configuration ,radicale-encoding-configuration-fields)
+ (radicale-logging-configuration ,radicale-logging-configuration-fields)
+ (radicale-rights-configuration ,radicale-rights-configuration-fields)
+ (radicale-server-configuration ,radicale-server-configuration-fields)
+ (radicale-storage-configuration ,radicale-storage-configuration-fields))
+ 'radicale-configuration))
+
;;;
;;; Rspamd.
;;;
diff --git a/gnu/services/mcron.scm b/gnu/services/mcron.scm
index e907d364da..b56e1e18c2 100644
--- a/gnu/services/mcron.scm
+++ b/gnu/services/mcron.scm
@@ -20,8 +20,12 @@
(define-module (gnu services mcron)
#:use-module (gnu services)
+ #:use-module ((gnu services configuration) #:select
+ (define-configuration/no-serialization))
#:use-module (gnu services shepherd)
+ #:use-module (gnu system privilege)
#:use-module (gnu packages guile-xyz)
+ #:use-module ((guix packages) #:select (package?))
#:use-module (guix records)
#:use-module (guix gexp)
#:use-module (srfi srfi-1)
@@ -37,7 +41,12 @@
mcron-configuration-date-format
mcron-configuration-home-service?
- mcron-service-type))
+ mcron-service-type
+
+ cron-daemon-configuration
+ cron-daemon-configuration-cron
+ cron-daemon-configuration-
+ cron-daemon-service-type))
;;; Commentary:
;;;
@@ -182,9 +191,12 @@ files."
;; set a sane value for 'PATH'.
#:environment-variables
(cons* "GUILE_AUTO_COMPILE=0"
- "PATH=/run/current-system/profile/bin"
- (remove (cut string-prefix? "PATH=" <>)
- (environ)))
+ #$(if home-service?
+ '(environ)
+ '(cons*
+ "PATH=/run/current-system/profile/bin"
+ (remove (cut string-prefix? "PATH=" <>)
+ (environ)))))
#:log-file #$log-file))
(stop #~(make-kill-destructor))
@@ -211,4 +223,47 @@ files."
jobs)))))
(default-value (mcron-configuration)))) ;empty job list
+
+
+(define-configuration/no-serialization cron-daemon-configuration
+ (cron
+ (package mcron)
+ "The cron package to use.")
+ (monitor-etc?
+ (boolean #f)
+ "Whether to check /etc/crontab for updates."))
+
+(define (cron-daemon-shepherd-services config)
+ (list (shepherd-service
+ (provision '(cron-daemon))
+ (start #~(make-forkexec-constructor
+ '(#$(file-append (cron-daemon-configuration-cron config)
+ "/sbin/cron")
+ #$@(if (cron-daemon-configuration-monitor-etc? config)
+ '()
+ '("--noetc")))
+ #:pid-file "/var/run/cron.pid"))
+ (stop #~(make-kill-destructor)))))
+
+(define cron-daemon-activation
+ (const #~(mkdir-p "/var/cron/tabs")))
+
+(define (cron-daemon-setuid-programs config)
+ (list (privileged-program
+ (program (file-append (cron-daemon-configuration-cron config)
+ "/sbin/crontab-access")))))
+
+(define cron-daemon-service-type
+ (service-type (name 'cron-daemon)
+ (description
+ "Run the traditional cron daemon.")
+ (extensions
+ (list (service-extension shepherd-root-service-type
+ cron-daemon-shepherd-services)
+ (service-extension activation-service-type
+ cron-daemon-activation)
+ (service-extension privileged-program-service-type
+ cron-daemon-setuid-programs)))
+ (default-value (cron-daemon-configuration))))
+
;;; mcron.scm ends here
diff --git a/gnu/services/monitoring.scm b/gnu/services/monitoring.scm
index e698040078..59cf4710ea 100644
--- a/gnu/services/monitoring.scm
+++ b/gnu/services/monitoring.scm
@@ -132,7 +132,7 @@
(shepherd-service
(documentation "Network statistics gatherer.")
(provision '(darkstat))
- (requirement '(networking))
+ (requirement '(user-processes networking))
(start #~(make-forkexec-constructor
(list #$(file-append package "/sbin/darkstat")
"-i" #$interface
@@ -1016,7 +1016,7 @@ configuration file."))
/etc/ssl/certs"
"SSL_CERT_FILE=/run/current-system/profile\
/etc/ssl/certs/ca-certificates.crt"
- "PATH=/run/setuid-programs:\
+ "PATH=/run/privileged/bin:\
/run/current-system/profile/bin:/run/current-system/profile/sbin")))
(stop #~(make-kill-destructor)))))
diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm
index 8e64e529ab..12d8934e43 100644
--- a/gnu/services/networking.scm
+++ b/gnu/services/networking.scm
@@ -91,6 +91,7 @@
dhcp-client-configuration?
dhcp-client-configuration-package
dhcp-client-configuration-interfaces
+ dhcp-client-configuration-config-file
dhcp-client-configuration-shepherd-provision
dhcp-client-configuration-shepherd-requirement
@@ -319,6 +320,8 @@
(default '()))
(shepherd-provision dhcp-client-configuration-shepherd-provision
(default '(networking)))
+ (config-file dhcp-client-configuration-config-file
+ (default #f))
(interfaces dhcp-client-configuration-interfaces
(default 'all))) ;'all | list of strings
@@ -329,6 +332,7 @@
(requirement (dhcp-client-configuration-shepherd-requirement config))
(provision (dhcp-client-configuration-shepherd-provision config))
(interfaces (dhcp-client-configuration-interfaces config))
+ (config-file (dhcp-client-configuration-config-file config))
(pid-file "/var/run/dhclient.pid"))
(list (shepherd-service
(documentation "Set up networking via DHCP.")
@@ -364,6 +368,11 @@
(_
#~'#$interfaces))))
+ (define config-file-args
+ (if #$config-file
+ (list "-cf" #$config-file)
+ '()))
+
(false-if-exception (delete-file #$pid-file))
(let ((pid (fork+exec-command
;; By default dhclient uses a
@@ -371,8 +380,10 @@
;; DDNS, which is incompatable with
;; non-ISC DHCP servers; thus, pass '-I'.
;; <https://kb.isc.org/docs/aa-01091>.
- (cons* dhclient "-nw" "-I"
- "-pf" #$pid-file ifaces))))
+ `(,dhclient "-nw" "-I"
+ "-pf" ,#$pid-file
+ ,@config-file-args
+ ,@ifaces))))
(and (zero? (cdr (waitpid pid)))
(read-pid-file #$pid-file)))))
(stop #~(make-kill-destructor))))))
@@ -1001,7 +1012,7 @@ maps ports 22 and 80 of the Onion Service to the local ports 22 and 8080."))
(display "\
### These lines were generated from your system configuration:
DataDirectory /var/lib/tor
-Log notice syslog\n" port)
+Log notice stderr\n" port)
(when (eq? 'unix '#$socks-socket-type)
(display "\
SocksPort unix:/var/run/tor/socks-sock
@@ -1047,9 +1058,6 @@ HiddenServicePort ~a ~a~%"
(target source)
(writable? #t))
(file-system-mapping
- (source "/dev/log") ;for syslog
- (target source))
- (file-system-mapping
(source "/var/run/tor")
(target source)
(writable? #t))
diff --git a/gnu/services/nix.scm b/gnu/services/nix.scm
index 82853253f6..9749fc9e0f 100644
--- a/gnu/services/nix.scm
+++ b/gnu/services/nix.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2019, 2020, 2021 Oleg Pykhalov <go.wigust@gmail.com>
+;;; Copyright © 2019, 2020, 2021, 2024 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2020 Peng Mei Yu <i@pengmeiyu.com>
;;;
;;; This file is part of GNU Guix.
@@ -26,6 +26,7 @@
#:use-module (gnu services shepherd)
#:use-module (gnu services web)
#:use-module (gnu services)
+ #:use-module (gnu system file-systems)
#:use-module (gnu system shadow)
#:use-module (guix gexp)
#:use-module (guix packages)
@@ -97,12 +98,14 @@ GID."
#~(begin
(use-modules (guix build utils)
(srfi srfi-26))
- (for-each (cut mkdir-p <>) '("/nix/store" "/nix/var/log"
+ (for-each (cut mkdir-p <>) '("/nix/var/log"
"/nix/var/nix/gcroots/per-user"
"/nix/var/nix/profiles/per-user"))
- (chown "/nix/store"
- (passwd:uid (getpw "root")) (group:gid (getpw "nixbld01")))
- (chmod "/nix/store" #o775)
+ (unless (file-exists? #$%nix-store-directory)
+ (mkdir-p #$%nix-store-directory)
+ (chown #$%nix-store-directory
+ (passwd:uid (getpw "root")) (group:gid (getpw "nixbld01")))
+ (chmod #$%nix-store-directory #o775))
(for-each (cut chmod <> #o777) '("/nix/var/nix/profiles"
"/nix/var/nix/profiles/per-user"))))
@@ -129,6 +132,20 @@ GID."
'#$build-sandbox-items))
(for-each (cut display <>) '#$extra-config)))))))))))
+(define %nix-store-directory
+ "/nix/store")
+
+(define %immutable-nix-store
+ ;; Read-only store to avoid users or daemons accidentally modifying it.
+ ;; 'nix-daemon' has provisions to remount it read-write in its own name
+ ;; space.
+ (list (file-system
+ (device %nix-store-directory)
+ (mount-point %nix-store-directory)
+ (type "none")
+ (check? #f)
+ (flags '(read-only bind-mount)))))
+
(define nix-shepherd-service
;; Return a <shepherd-service> for Nix.
(match-lambda
@@ -137,7 +154,7 @@ GID."
(shepherd-service
(provision '(nix-daemon))
(documentation "Run nix-daemon.")
- (requirement '())
+ (requirement '(user-processes file-system-/nix/store))
(start #~(make-forkexec-constructor
(list (string-append #$package "/bin/nix-daemon")
#$@extra-options)
@@ -156,7 +173,9 @@ GID."
(service-extension activation-service-type nix-activation)
(service-extension etc-service-type nix-service-etc)
(service-extension profile-service-type
- (compose list nix-configuration-package))))
+ (compose list nix-configuration-package))
+ (service-extension file-system-service-type
+ (const %immutable-nix-store))))
(description "Run the Nix daemon.")
(default-value (nix-configuration))))
diff --git a/gnu/services/pm.scm b/gnu/services/pm.scm
index 3daf484cc1..47f0bf7812 100644
--- a/gnu/services/pm.scm
+++ b/gnu/services/pm.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2024 Dariqq <dariqq@posteo.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -21,18 +22,75 @@
#:use-module (guix packages)
#:use-module (guix records)
#:use-module (gnu packages admin)
+ #:use-module (gnu packages freedesktop)
#:use-module (gnu packages linux)
#:use-module (gnu services)
#:use-module (gnu services base)
#:use-module (gnu services configuration)
+ #:use-module (gnu services dbus)
#:use-module (gnu services shepherd)
#:use-module (gnu system shadow)
- #:export (tlp-service-type
+ #:export (power-profiles-daemon-service-type
+ power-profiles-daemon-configuration
+
+ tlp-service-type
tlp-configuration
thermald-configuration
thermald-service-type))
+;;;
+;;; power-profiles-daemon
+;;;
+
+(define-configuration/no-serialization power-profiles-daemon-configuration
+ (power-profiles-daemon
+ (file-like power-profiles-daemon)
+ "The power-profiles-daemon package."))
+
+(define (power-profiles-daemon-shepherd-service config)
+ (match-record
+ config <power-profiles-daemon-configuration>
+ (power-profiles-daemon)
+ (list (shepherd-service
+ (provision '(power-profiles-daemon))
+ (requirement '(dbus-system))
+ (documentation "Run the power-profiles-daemon.")
+ (start #~(make-forkexec-constructor
+ (list #$(file-append power-profiles-daemon
+ "/libexec/power-profiles-daemon"))))
+ (stop #~(make-kill-destructor))))))
+
+(define %power-profiles-daemon-activation
+ #~(begin
+ (use-modules (guix build utils))
+ (mkdir-p "/var/lib/power-profiles-daemon")))
+
+(define power-profiles-daemon-service-type
+ (let ((config->package
+ (compose list power-profiles-daemon-configuration-power-profiles-daemon)))
+ (service-type
+ (name 'power-profiles-daemon)
+ (extensions (list
+ (service-extension shepherd-root-service-type
+ power-profiles-daemon-shepherd-service)
+ (service-extension dbus-root-service-type
+ config->package)
+ (service-extension polkit-service-type
+ config->package)
+ (service-extension profile-service-type
+ config->package)
+ (service-extension activation-service-type
+ (const %power-profiles-daemon-activation))))
+ (default-value (power-profiles-daemon-configuration))
+ (description "Run the power-profiles-daemon"))))
+
+
+
+;;;
+;;; tlp
+;;;
+
(define (uglify-field-name field-name)
(let ((str (symbol->string field-name)))
(string-join (string-split
diff --git a/gnu/services/sddm.scm b/gnu/services/sddm.scm
index 48695e2806..92d64cc599 100644
--- a/gnu/services/sddm.scm
+++ b/gnu/services/sddm.scm
@@ -33,6 +33,8 @@
#:use-module (guix gexp)
#:use-module (guix records)
#:use-module (guix deprecation)
+ #:use-module (guix utils)
+ #:use-module (guix packages)
#:export (sddm-configuration
sddm-configuration?
sddm-service-type
@@ -165,8 +167,13 @@ Relogin=" (if (sddm-configuration-relogin? config)
(define (sddm-shepherd-service config)
"Return a <shepherd-service> for sddm with CONFIG."
+ (define sddm (sddm-configuration-sddm config))
+ (define qt6? (version-prefix?
+ "6"
+ (package-version (lookup-package-input sddm "qtbase"))))
+
(define sddm-command
- #~(list (string-append #$(sddm-configuration-sddm config) "/bin/sddm")))
+ #~(list (string-append #$sddm "/bin/sddm")))
(list (shepherd-service
(documentation "SDDM display manager.")
@@ -179,8 +186,12 @@ Relogin=" (if (sddm-configuration-relogin? config)
(cons*
"XDG_DATA_DIRS=/run/current-system/profile/share"
"XDG_CONFIG_DIRS=/run/current-system/profile/etc/xdg"
- "QT_PLUGIN_PATH=/run/current-system/profile/lib/qt5/plugins"
- "QML2_IMPORT_PATH=/run/current-system/profile/lib/qt5/qml"
+ #$(string-append "QT_PLUGIN_PATH=/run/current-system/profile/lib/qt"
+ (if qt6? "6" "5")
+ "/plugins")
+ #$(string-append "QML" (if qt6? "" "2")
+ "_IMPORT_PATH=/run/current-system/profile/lib/qt"
+ (if qt6? "6" "5") "/qml")
(default-environment-variables))))
(stop #~(make-kill-destructor)))))
diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm
index 455e972535..05534ab317 100644
--- a/gnu/services/shepherd.scm
+++ b/gnu/services/shepherd.scm
@@ -60,6 +60,7 @@
shepherd-service-respawn?
shepherd-service-start
shepherd-service-stop
+ shepherd-service-free-form
shepherd-service-auto-start?
shepherd-service-modules
@@ -217,7 +218,10 @@ DEFAULT is given, use it as the service's default value."
(default #f))
(respawn-delay shepherd-service-respawn-delay
(default #f))
- (start shepherd-service-start) ;g-expression (procedure)
+ (free-form shepherd-service-free-form ;#f | g-expression (service)
+ (default #f))
+ (start shepherd-service-start ;g-expression (procedure)
+ (default #~(const #t)))
(stop shepherd-service-stop ;g-expression (procedure)
(default #~(const #f)))
(actions shepherd-service-actions ;list of <shepherd-action>
@@ -298,8 +302,8 @@ stored."
provisions)
".scm")))
-(define (shepherd-service-file service)
- "Return a file defining SERVICE."
+(define (shepherd-service-file/regular service)
+ "Return a file defining SERVICE, a service whose 'free-form' field is #f."
(scheme-file (shepherd-service-file-name service)
(with-imported-modules %default-imported-modules
#~(begin
@@ -332,6 +336,21 @@ stored."
#~(#$name #$doc #$proc)))
(shepherd-service-actions service))))))))
+(define (shepherd-service-file/free-form service)
+ "Return a file defining SERVICE, a service whose 'free-form' field is set."
+ (scheme-file (shepherd-service-file-name service)
+ (with-imported-modules %default-imported-modules
+ #~(begin
+ (use-modules #$@(shepherd-service-modules service))
+
+ #$(shepherd-service-free-form service)))))
+
+(define (shepherd-service-file service)
+ "Return a file defining SERVICE."
+ (if (shepherd-service-free-form service)
+ (shepherd-service-file/free-form service)
+ (shepherd-service-file/regular service)))
+
(define (scm->go file shepherd)
"Compile FILE, which contains code to be loaded by shepherd's config file,
and return the resulting '.go' file. SHEPHERD is used as shepherd package."
@@ -380,8 +399,7 @@ as shepherd package."
(scm->go (cute scm->go <> shepherd)))
(define config
#~(begin
- (use-modules (srfi srfi-34)
- (system repl error-handling))
+ (use-modules (srfi srfi-1))
(define (make-user-module)
;; Copied from (shepherd support), where it's private.
@@ -415,19 +433,25 @@ as shepherd package."
;; <https://bugs.gnu.org/40572>.
(default-pid-file-timeout 30)
- ;; Arrange to spawn a REPL if something goes wrong. This is better
- ;; than a kernel panic.
- (call-with-error-handling
- (lambda ()
- (register-services
- (parameterize ((current-warning-port
- (%make-void-port "w")))
- (map (lambda (file)
- (save-module-excursion
- (lambda ()
- (set-current-module (make-user-module))
- (load-compiled file))))
- '#$(map scm->go files))))))
+ ;; Load service files one by one; filter out those that could not be
+ ;; loaded--e.g., due to an unbound variable--such that an error in
+ ;; one service definition does not prevent the system from booting.
+ (register-services
+ (parameterize ((current-warning-port (%make-void-port "w")))
+ (filter-map (lambda (file)
+ (with-exception-handler
+ (lambda (exception)
+ (format #t "Exception caught \
+while loading '~a': ~s~%"
+ file exception)
+ #f)
+ (lambda ()
+ (save-module-excursion
+ (lambda ()
+ (set-current-module (make-user-module))
+ (load-compiled file))))
+ #:unwind? #t))
+ '#$(map scm->go files))))
(format #t "starting services...~%")
(let ((services-to-start
diff --git a/gnu/services/syncthing.scm b/gnu/services/syncthing.scm
index 9bb623186b..a7a9c6aadd 100644
--- a/gnu/services/syncthing.scm
+++ b/gnu/services/syncthing.scm
@@ -73,7 +73,15 @@
#:user #$(and (not home-service?) user)
#:group #$(and (not home-service?) group)
#:environment-variables
- (append (list (string-append "HOME=" (or #$home (passwd:dir (getpw #$user))))
+ (append
+ (list
+ (string-append "HOME="
+ (or #$home
+ (passwd:dir
+ (getpw (if (and #$home-service?
+ (not #$user))
+ (getuid)
+ #$user)))))
"SSL_CERT_DIR=/etc/ssl/certs"
"SSL_CERT_FILE=/etc/ssl/certs/ca-certificates.crt")
(filter (negate ;XXX: 'remove' is not in (guile)
diff --git a/gnu/services/web.scm b/gnu/services/web.scm
index 406117c457..ab7d40e53c 100644
--- a/gnu/services/web.scm
+++ b/gnu/services/web.scm
@@ -17,6 +17,9 @@
;;; Copyright © 2022 Simen Endsjø <simendsjo@gmail.com>
;;; Copyright © 2023 Bruno Victal <mirai@makinata.eu>
;;; Copyright © 2023 Miguel Ángel Moreno <mail@migalmoreno.com>
+;;; Copyright © 2024 Wojtek Kosior <koszko@koszko.org>
+;;; Additions and modifications by Wojtek Kosior are additionally
+;;; dual-licensed under the Creative Commons Zero v1.0.
;;;
;;; This file is part of GNU Guix.
;;;
@@ -45,6 +48,7 @@
#:use-module (gnu packages admin)
#:use-module (gnu packages base)
#:use-module (gnu packages databases)
+ #:use-module ((gnu packages linux) #:select (util-linux))
#:use-module (gnu packages web)
#:use-module (gnu packages patchutils)
#:use-module (gnu packages php)
@@ -250,6 +254,16 @@
whoogle-configuration-port
whoogle-configuration-environment-variables
+ epicyon-service-type
+ epicyon-configuration
+ epicyon-configuration?
+ epicyon-configuration-package
+ epicyon-configuration-port
+ epicyon-configuration-real-port
+ epicyon-configuration-domain
+ epicyon-configuration-registration-open?
+ epicyon-configuration-log-login-failures?
+
patchwork-database-configuration
patchwork-database-configuration?
patchwork-database-configuration-engine
@@ -302,13 +316,15 @@
agate-configuration?
agate-configuration-package
agate-configuration-content
- agate-configuration-cert
- agate-configuration-key
+ agate-configuration-certs
agate-configuration-addr
agate-configuration-hostname
agate-configuration-lang
- agate-configuration-silent
+ agate-configuration-only-tls13
agate-configuration-serve-secret
+ agate-configuration-central-conf
+ agate-configuration-ed25519
+ agate-configuration-skip-port-check
agate-configuration-log-ip
agate-configuration-user
agate-configuration-group
@@ -771,7 +787,14 @@ of index files."
"\n"
(map emit-nginx-upstream-config upstream-blocks)
(map emit-nginx-server-config server-blocks)
- extra-content
+ (match extra-content
+ ((? list? extra-content)
+ (map (lambda (line)
+ `(" " ,line "\n"))
+ extra-content))
+ ;; XXX: For compatibility strings and gexp's are inserted
+ ;; directly.
+ (_ extra-content))
"\n}\n"))))
(define %nginx-accounts
@@ -823,7 +846,7 @@ of index files."
#~(lambda _
(invoke #$nginx-binary "-c" #$config-file #$@args)
(match '#$args
- (("-s" . _) #f)
+ (("-s" . _) #t)
(_
;; When FILE is true, we cannot be sure that PID-FILE will
;; be created, so assume it won't show up. When FILE is
@@ -850,11 +873,11 @@ This has the effect of killing old worker processes and starting new ones, using
the same configuration file. It is useful for situations where the same nginx
configuration file can point to different things after a reload, such as
renewed TLS certificates, or @code{include}d files.")
- (procedure (nginx-action "-s" "reload")))
+ (procedure (nginx-action "-p" run-directory "-s" "reload")))
(shepherd-action
(name 'reopen)
(documentation "Re-open log files.")
- (procedure (nginx-action "-s" "reopen"))))))))))
+ (procedure (nginx-action "-p" run-directory "-s" "reopen"))))))))))
(define nginx-service-type
(service-type (name 'nginx)
@@ -1661,6 +1684,162 @@ Whoogle."))
;;;
+;;; Epicyon
+;;;
+
+(define-configuration/no-serialization epicyon-configuration
+ (package
+ (package epicyon)
+ "The Epicyon package to use.")
+ (port
+ (integer 7156)
+ "The port Epicyon will listen on.")
+ (real-port
+ (integer 443)
+ "The port under which Epicyon is accessed when proxied.")
+ (domain
+ (string "localhost")
+ "Domain under which Epicyon is accessed.")
+ (registration-open?
+ (boolean #t)
+ "Whether Epicyon will allow new users to register.")
+ (log-login-failures?
+ (boolean #t)
+ "Whether Epicyon will log failed login attempts."))
+
+(define (epicyon-activation _)
+ #~(for-each mkdir-p
+ '("/var/lib/epicyon/upper"
+ "/var/lib/epicyon/work"
+ "/var/lib/epicyon/mount")))
+
+(define %epicyon-passwd
+ (list (user-account
+ (name "epicyon")
+ (group "epicyon")
+ (system? #t)
+ (home-directory "/var/lib/epicyon/mount")
+ (shell (file-append shadow "/sbin/nologin"))
+ (comment "Epicyon server system user."))
+ (user-group
+ (name "epicyon")
+ (system? #t))))
+
+(define %ensure-epicyon-overlay-unmounted
+ (with-used-modules '(((srfi srfi-26) #:select (cut))
+ ((ice-9 match) #:select (match-lambda))
+ ((ice-9 textual-ports) #:select (get-string-all)))
+ #~(lambda ()
+ (define (overlay-mounted?)
+ (call-with-input-file "/proc/mounts"
+ (compose (cut or-map (match-lambda
+ ((_ "/var/lib/epicyon/mount" "overlay" . _)
+ #t)
+ (_
+ #f))
+ <>)
+ (cut map (cut string-split <> #\space) <>)
+ (cut string-split <> #\newline)
+ get-string-all)))
+
+ (define unmount (cut system*
+ #$(file-append util-linux "/bin/umount")
+ "/var/lib/epicyon/mount"))
+
+ (letrec ((loop (lambda ()
+ (when (overlay-mounted?)
+ (unmount)
+ (loop)))))
+ (loop)))))
+
+(define (epicyon-shepherd-services config)
+ (match-record config <epicyon-configuration>
+ (package port real-port domain registration-open? log-login-failures?)
+ (list
+ (shepherd-service
+ (provision '(epicyon))
+
+ (requirement '(networking))
+
+ (start (with-used-modules '(((srfi srfi-26) #:select (cut))
+ ((ice-9 ftw) #:select (ftw scandir)))
+ #~(let ((constructor
+ (make-forkexec-constructor
+ `(#$(file-append package "/bin/epicyon")
+ "--port" #$(number->string real-port)
+ "--proxy" #$(number->string port)
+ "--domain" #$domain
+ "--registration" #$(if registration-open?
+ "open"
+ "closed")
+ #$@(if log-login-failures?
+ '("--log_login_failures")
+ '()))
+ #:user "epicyon"
+ #:group "epicyon"
+ #:directory "/var/lib/epicyon/mount")))
+
+ (lambda args
+ (#$%ensure-epicyon-overlay-unmounted)
+
+ (define site-packages-dir
+ (let* ((libdir #$(file-append package "/lib"))
+ (subdir (car (scandir libdir
+ (cut string-prefix?
+ "python" <>)))))
+ ;; e.g. /gnu/store/.../lib/python3.10/site-packages
+ (format #f "~a/~a/site-packages" libdir subdir)))
+
+ (define mount-opts
+ `(("rw")
+ ("upperdir" "/var/lib/epicyon/upper")
+ ("lowerdir" ,site-packages-dir)
+ ("workdir" "/var/lib/epicyon/work")))
+
+ (system* #$(file-append util-linux "/bin/mount")
+ "-t" "overlay" "dummy" "-o"
+ (string-join
+ (map (cut string-join <> "=") mount-opts)
+ ",")
+ "/var/lib/epicyon/mount")
+
+ (let ((gid (group:gid (getgrnam "epicyon"))))
+ (ftw "/var/lib/epicyon/mount"
+ (lambda (filename statinfo flag)
+ (when (eq? flag 'directory)
+ (chown filename -1 gid)
+ (chmod filename #o770))
+ #t)))
+
+ (apply constructor args)))))
+
+ (stop (with-used-modules '(((srfi srfi-26) #:select (cut)))
+ #~(let ((destructor (make-kill-destructor)))
+ (lambda args
+ (define results
+ ((compose list (cut apply destructor args))))
+
+ (#$%ensure-epicyon-overlay-unmounted)
+
+ (apply values results)))))
+
+ (documentation "Run Epicyon daemon.")))))
+
+(define epicyon-service-type
+ (service-type
+ (name 'epicyon)
+ (extensions
+ (list (service-extension account-service-type
+ (const %epicyon-passwd))
+ (service-extension activation-service-type
+ epicyon-activation)
+ (service-extension shepherd-root-service-type
+ epicyon-shepherd-services)))
+ (description
+ "Host an instance of the Epicyon social media platform.")))
+
+
+;;;
;;; Patchwork
;;;
@@ -2177,20 +2356,24 @@ root=/srv/gemini
(default agate))
(content agate-configuration-content
(default "/srv/gemini"))
- (cert agate-configuration-cert
- (default #f))
- (key agate-configuration-key
- (default #f))
- (addr agate-configuration-addr
- (default '("0.0.0.0:1965" "[::]:1965")))
- (hostname agate-configuration-hostname
- (default #f))
- (lang agate-configuration-lang
- (default #f))
- (silent? agate-configuration-silent
- (default #f))
+ (certificates agate-configuration-certificates
+ (default "/srv/gemini-certs"))
+ (addresses agate-configuration-addresses
+ (default '("[::]:1965" "0.0.0.0:1965")))
+ (hostnames agate-configuration-hostnames
+ (default '()))
+ (languages agate-configuration-languages
+ (default #f))
+ (only-tls13? agate-configuration-only-tls13
+ (default #f))
(serve-secret? agate-configuration-serve-secret
(default #f))
+ (central-configuration? agate-configuration-central-configuration
+ (default #f))
+ (ed25519? agate-configuration-ed25519
+ (default #f))
+ (skip-port-check? agate-configuration-skip-port-check
+ (default #f))
(log-ip? agate-configuration-log-ip
(default #t))
(user agate-configuration-user
@@ -2202,8 +2385,10 @@ root=/srv/gemini
(define agate-shepherd-service
(match-lambda
- (($ <agate-configuration> package content cert key addr
- hostname lang silent? serve-secret?
+ (($ <agate-configuration> package content certificates addresses
+ hostnames languages only-tls13?
+ serve-secret? central-configuration?
+ ed25519? skip-port-check?
log-ip? user group log-file)
(list (shepherd-service
(provision '(agate))
@@ -2213,17 +2398,21 @@ root=/srv/gemini
#~(make-forkexec-constructor
(list #$agate
"--content" #$content
- "--cert" #$cert
- "--key" #$key
- "--addr" #$@addr
- #$@(if lang
- (list "--lang" lang)
- '())
- #$@(if hostname
- (list "--hostname" hostname)
+ "--certs" #$certificates
+ #$@(append-map
+ (lambda x (append '("--addr") x))
+ addresses)
+ #$@(append-map
+ (lambda x (append '("--hostname") x))
+ hostnames)
+ #$@(if languages
+ (list "--lang" languages)
'())
- #$@(if silent? '("--silent") '())
#$@(if serve-secret? '("--serve-secret") '())
+ #$@(if only-tls13? '("--only-tls13") '())
+ #$@(if central-configuration? '("--central-conf") '())
+ #$@(if ed25519? '("--ed25519") '())
+ #$@(if skip-port-check? '("--skip-port-check") '())
#$@(if log-ip? '("--log-ip") '()))
#:user #$user #:group #$group
#:log-file #$log-file)))
diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm
index 51d704439e..e7d8922d76 100644
--- a/gnu/services/xorg.scm
+++ b/gnu/services/xorg.scm
@@ -15,6 +15,7 @@
;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2023 muradm <mail@muradm.net>
;;; Copyright © 2024 Zheng Junjie <873216071@qq.com>
+;;; Copyright © 2024 Tomas Volf <~@wolfsden.cz>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -54,11 +55,13 @@
#:use-module (gnu packages gnome)
#:use-module (gnu packages admin)
#:use-module (gnu packages bash)
+ #:use-module (gnu packages linux)
#:use-module (gnu system shadow)
#:use-module (guix build-system glib-or-gtk)
#:use-module (guix build-system trivial)
#:use-module (guix gexp)
#:use-module (guix store)
+ #:use-module ((guix modules) #:select (source-module-closure))
#:use-module (guix packages)
#:use-module (guix derivations)
#:use-module (guix records)
@@ -86,8 +89,10 @@
xorg-wrapper
xorg-start-command
+ xorg-start-command-xinit
xinitrc
xorg-server-service-type
+ startx-command-service-type
%default-slim-theme
%default-slim-theme-name
@@ -416,6 +421,114 @@ in @var{config}, are available. The result should be used in place of
(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
generated by cgit