aboutsummaryrefslogtreecommitdiff
path: root/gnu/services
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/services')
-rw-r--r--gnu/services/admin.scm7
-rw-r--r--gnu/services/avahi.scm2
-rw-r--r--gnu/services/base.scm100
-rw-r--r--gnu/services/configuration.scm2
-rw-r--r--gnu/services/cuirass.scm141
-rw-r--r--gnu/services/cups.scm2
-rw-r--r--gnu/services/databases.scm35
-rw-r--r--gnu/services/desktop.scm5
-rw-r--r--gnu/services/kerberos.scm378
-rw-r--r--gnu/services/networking.scm3
-rw-r--r--gnu/services/sddm.scm2
-rw-r--r--gnu/services/shepherd.scm2
-rw-r--r--gnu/services/web.scm100
13 files changed, 669 insertions, 110 deletions
diff --git a/gnu/services/admin.scm b/gnu/services/admin.scm
index d8086b78d4..deaf677bd9 100644
--- a/gnu/services/admin.scm
+++ b/gnu/services/admin.scm
@@ -58,8 +58,8 @@
}
"))
-(define (simple-rotation-config file)
- (string-append file " {
+(define (simple-rotation-config files)
+ #~(string-append #$(string-join files ",") " {
sharedscripts
}
"))
@@ -72,7 +72,8 @@
(display #$(syslog-rotation-config %rotated-files)
port)
(display #$(simple-rotation-config
- "/var/log/shepherd.log")
+ '("/var/log/shepherd.log"
+ "/var/log/guix-daemon.log"))
port)))))))
(define (default-jobs rottlog)
diff --git a/gnu/services/avahi.scm b/gnu/services/avahi.scm
index 60e9e61f94..29720415fc 100644
--- a/gnu/services/avahi.scm
+++ b/gnu/services/avahi.scm
@@ -107,7 +107,7 @@
(requirement '(dbus-system networking))
(start #~(make-forkexec-constructor
- (list (string-append #$avahi "/sbin/avahi-daemon")
+ (list #$(file-append avahi "/sbin/avahi-daemon")
"--daemonize"
#$@(if debug? #~("--debug") #~())
"-f" #$config)
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index afbecdb47e..1b1ce0d5e8 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -37,7 +37,6 @@
#:use-module ((gnu packages base)
#:select (canonical-package glibc))
#:use-module (gnu packages package-management)
- #:use-module (gnu packages ssh)
#:use-module (gnu packages lsof)
#:use-module (gnu packages terminals)
#:use-module ((gnu build file-systems)
@@ -252,6 +251,8 @@ FILE-SYSTEM."
(device (file-system-device file-system))
(type (file-system-type file-system))
(title (file-system-title file-system))
+ (flags (file-system-flags file-system))
+ (options (file-system-options file-system))
(check? (file-system-check? file-system))
(create? (file-system-create-mount-point? file-system))
(dependencies (file-system-dependencies file-system)))
@@ -264,35 +265,27 @@ FILE-SYSTEM."
,@(map dependency->shepherd-service-name dependencies)))
(documentation "Check, mount, and unmount the given file system.")
(start #~(lambda args
- ;; FIXME: Use or factorize with 'mount-file-system'.
- (let ((device (canonicalize-device-spec #$device '#$title))
- (flags #$(mount-flags->bit-mask
- (file-system-flags file-system))))
- #$(if create?
- #~(mkdir-p #$target)
- #~#t)
- #$(if check?
- #~(begin
- ;; Make sure fsck.ext2 & co. can be found.
- (setenv "PATH"
- (string-append
- #$e2fsprogs "/sbin:"
- "/run/current-system/profile/sbin:"
- (getenv "PATH")))
- (check-file-system device #$type))
- #~#t)
-
- (mount device #$target #$type flags
- #$(file-system-options file-system))
-
- ;; For read-only bind mounts, an extra remount is
- ;; needed, as per <http://lwn.net/Articles/281157/>,
- ;; which still applies to Linux 4.0.
- (when (and (= MS_BIND (logand flags MS_BIND))
- (= MS_RDONLY (logand flags MS_RDONLY)))
- (mount device #$target #$type
- (logior MS_BIND MS_REMOUNT MS_RDONLY))))
- #t))
+ #$(if create?
+ #~(mkdir-p #$target)
+ #t)
+
+ (let (($PATH (getenv "PATH")))
+ ;; Make sure fsck.ext2 & co. can be found.
+ (dynamic-wind
+ (lambda ()
+ (setenv "PATH"
+ (string-append
+ #$e2fsprogs "/sbin:"
+ "/run/current-system/profile/sbin:"
+ $PATH)))
+ (lambda ()
+ (mount-file-system
+ `(#$device #$title #$target #$type #$flags
+ #$options #$check?)
+ #:root "/"))
+ (lambda ()
+ (setenv "PATH" $PATH)))
+ #t)))
(stop #~(lambda args
;; Normally there are no processes left at this point, so
;; TARGET can be safely unmounted.
@@ -305,7 +298,7 @@ FILE-SYSTEM."
;; We need an additional module.
(modules `(((gnu build file-systems)
- #:select (check-file-system canonicalize-device-spec))
+ #:select (mount-file-system))
,@%default-modules)))))))
(define file-system-service-type
@@ -616,7 +609,7 @@ strings or string-valued gexps."
(dup2 (open-fdes #$tty O_RDONLY) 0)
(close-fdes 1)
(dup2 (open-fdes #$tty O_WRONLY) 1)
- (execl (string-append #$kbd "/bin/unicode_start")
+ (execl #$(file-append kbd "/bin/unicode_start")
"unicode_start"))
(else
(zero? (cdr (waitpid pid))))))))
@@ -629,7 +622,7 @@ strings or string-valued gexps."
(documentation (string-append "Load console keymap (loadkeys)."))
(provision '(console-keymap))
(start #~(lambda _
- (zero? (system* (string-append #$kbd "/bin/loadkeys")
+ (zero? (system* #$(file-append kbd "/bin/loadkeys")
#$@files))))
(respawn? #f)))))
@@ -661,7 +654,7 @@ strings or string-valued gexps."
(start #~(lambda _
(and #$(unicode-start device)
(zero?
- (system* (string-append #$kbd "/bin/setfont")
+ (system* #$(file-append kbd "/bin/setfont")
"-C" #$device #$font)))))
(stop #~(const #t))
(respawn? #f)))))
@@ -743,7 +736,7 @@ the message of the day, among other things."
(requirement '(user-processes host-name udev))
(start #~(make-forkexec-constructor
- (list (string-append #$mingetty "/sbin/mingetty")
+ (list #$(file-append mingetty "/sbin/mingetty")
"--noclear" #$tty
#$@(if auto-login
#~("--autologin" #$auto-login)
@@ -878,7 +871,7 @@ the tty to run, among other things."
(provision '(nscd))
(requirement '(user-processes))
(start #~(make-forkexec-constructor
- (list (string-append #$(nscd-configuration-glibc config)
+ (list #$(file-append (nscd-configuration-glibc config)
"/sbin/nscd")
"-f" #$nscd.conf "--foreground")
@@ -1064,7 +1057,7 @@ public key, with GUIX."
(format #t "registering public key '~a'...~%" key)
(close-port (current-input-port))
(dup port 0)
- (execl (string-append #$guix "/bin/guix")
+ (execl #$(file-append guix "/bin/guix")
"guix" "archive" "--authorize")
(exit 1)))
(else
@@ -1096,10 +1089,10 @@ failed to register hydra.gnu.org public key: ~a~%" status))))))))
(default %default-substitute-urls))
(extra-options guix-configuration-extra-options ;list of strings
(default '()))
+ (log-file guix-configuration-log-file ;string
+ (default "/var/log/guix-daemon.log"))
(lsof guix-configuration-lsof ;<package>
- (default lsof))
- (lsh guix-configuration-lsh ;<package>
- (default lsh)))
+ (default lsof)))
(define %default-guix-configuration
(guix-configuration))
@@ -1110,14 +1103,14 @@ failed to register hydra.gnu.org public key: ~a~%" status))))))))
(($ <guix-configuration> guix build-group build-accounts
authorize-key? keys
use-substitutes? substitute-urls extra-options
- lsof lsh)
+ log-file lsof)
(list (shepherd-service
(documentation "Run the Guix daemon.")
(provision '(guix-daemon))
(requirement '(user-processes))
(start
#~(make-forkexec-constructor
- (list (string-append #$guix "/bin/guix-daemon")
+ (list #$(file-append guix "/bin/guix-daemon")
"--build-users-group" #$build-group
#$@(if use-substitutes?
'()
@@ -1125,10 +1118,11 @@ failed to register hydra.gnu.org public key: ~a~%" status))))))))
"--substitute-urls" #$(string-join substitute-urls)
#$@extra-options)
- ;; Add 'lsof' (for the GC) and 'lsh' (for offloading) to the
- ;; daemon's $PATH.
+ ;; Add 'lsof' (for the GC) to the daemon's $PATH.
#:environment-variables
- (list (string-append "PATH=" #$lsof "/bin:" #$lsh "/bin"))))
+ (list (string-append "PATH=" #$lsof "/bin"))
+
+ #:log-file #$log-file))
(stop #~(make-kill-destructor)))))))
(define (guix-accounts config)
@@ -1192,7 +1186,7 @@ failed to register hydra.gnu.org public key: ~a~%" status))))))))
(provision '(guix-publish))
(requirement '(guix-daemon))
(start #~(make-forkexec-constructor
- (list (string-append #$guix "/bin/guix")
+ (list #$(file-append guix "/bin/guix")
"publish" "-u" "guix-publish"
"-p" #$(number->string port)
(string-append "--listen=" #$host))))
@@ -1346,7 +1340,7 @@ item of @var{packages}."
;; The first one is for udev, the second one for eudev.
(setenv "UDEV_CONFIG_FILE" #$udev.conf)
(setenv "EUDEV_RULES_DIRECTORY"
- (string-append #$rules "/lib/udev/rules.d"))
+ #$(file-append rules "/lib/udev/rules.d"))
(let ((pid (primitive-fork)))
(case pid
@@ -1359,11 +1353,11 @@ item of @var{packages}."
(wait-for-udevd)
;; Trigger device node creation.
- (system* (string-append #$udev "/bin/udevadm")
+ (system* #$(file-append udev "/bin/udevadm")
"trigger" "--action=add")
;; Wait for things to settle down.
- (system* (string-append #$udev "/bin/udevadm")
+ (system* #$(file-append udev "/bin/udevadm")
"settle")
pid)))))
(stop #~(make-kill-destructor))
@@ -1434,7 +1428,7 @@ extra rules from the packages listed in @var{rules}."
;; 'gpm' runs in the background and sets a PID file.
;; Note that it requires running as "root".
(false-if-exception (delete-file "/var/run/gpm.pid"))
- (fork+exec-command (list (string-append #$gpm "/sbin/gpm")
+ (fork+exec-command (list #$(file-append gpm "/sbin/gpm")
#$@options))
;; Wait for the PID file to appear; declare failure if
@@ -1449,7 +1443,7 @@ extra rules from the packages listed in @var{rules}."
(stop #~(lambda (_)
;; Return #f if successfully stopped.
- (not (zero? (system* (string-append #$gpm "/sbin/gpm")
+ (not (zero? (system* #$(file-append gpm "/sbin/gpm")
"-k"))))))))))
(define gpm-service-type
@@ -1478,7 +1472,7 @@ This service is not part of @var{%base-services}."
(default kmscon))
(virtual-terminal kmscon-configuration-virtual-terminal)
(login-program kmscon-configuration-login-program
- (default #~(string-append #$shadow "/bin/login")))
+ (default (file-append shadow "/bin/login")))
(login-arguments kmscon-configuration-login-arguments
(default '("-p")))
(hardware-acceleration? kmscon-configuration-hardware-acceleration?
@@ -1496,7 +1490,7 @@ This service is not part of @var{%base-services}."
(define kmscon-command
#~(list
- (string-append #$kmscon "/bin/kmscon") "--login"
+ #$(file-append kmscon "/bin/kmscon") "--login"
"--vt" #$virtual-terminal
#$@(if hardware-acceleration? '("--hwaccel") '())
"--" #$login-program #$@login-arguments))
diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm
index 9f28aabc96..94c5f21557 100644
--- a/gnu/services/configuration.scm
+++ b/gnu/services/configuration.scm
@@ -30,6 +30,8 @@
configuration-field-name
configuration-missing-field
configuration-field-error
+ configuration-field-serializer
+ configuration-field-getter
serialize-configuration
define-configuration
validate-configuration
diff --git a/gnu/services/cuirass.scm b/gnu/services/cuirass.scm
new file mode 100644
index 0000000000..c15a846bad
--- /dev/null
+++ b/gnu/services/cuirass.scm
@@ -0,0 +1,141 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.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 cuirass)
+ #:use-module (guix gexp)
+ #:use-module (guix records)
+ #:use-module (gnu packages admin)
+ #:autoload (gnu packages ci) (cuirass)
+ #:use-module (gnu services)
+ #:use-module (gnu services base)
+ #:use-module (gnu services shepherd)
+ #:use-module (gnu system shadow)
+ #:export (<cuirass-configuration>
+ cuirass-configuration
+ cuirass-configuration?
+
+ cuirass-service-type))
+
+;;;; Commentary:
+;;;
+;;; This module implements a service that to run instances of Cuirass, a
+;;; continuous integration tool.
+;;;
+;;;; Code:
+
+(define-record-type* <cuirass-configuration>
+ cuirass-configuration make-cuirass-configuration
+ cuirass-configuration?
+ (cuirass cuirass-configuration-cuirass ;package
+ (default cuirass))
+ (log-file cuirass-configuration-log-file ;string
+ (default "/var/log/cuirass.log"))
+ (cache-directory cuirass-configuration-cache-directory ;string (dir-name)
+ (default "/var/cache/cuirass"))
+ (user cuirass-configuration-user ;string
+ (default "cuirass"))
+ (group cuirass-configuration-group ;string
+ (default "cuirass"))
+ (interval cuirass-configuration-interval ;integer (seconds)
+ (default 60))
+ (database cuirass-configuration-database ;string (file-name)
+ (default "/var/run/cuirass/cuirass.db"))
+ (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)))
+
+(define (cuirass-shepherd-service config)
+ "Return a <shepherd-service> for the Cuirass service with CONFIG."
+ (and
+ (cuirass-configuration? config)
+ (let ((cuirass (cuirass-configuration-cuirass config))
+ (cache-directory (cuirass-configuration-cache-directory config))
+ (log-file (cuirass-configuration-log-file config))
+ (user (cuirass-configuration-user config))
+ (group (cuirass-configuration-group config))
+ (interval (cuirass-configuration-interval config))
+ (database (cuirass-configuration-database config))
+ (specs (cuirass-configuration-specifications config))
+ (use-substitutes? (cuirass-configuration-use-substitutes? config))
+ (one-shot? (cuirass-configuration-one-shot? config)))
+ (list (shepherd-service
+ (documentation "Run Cuirass.")
+ (provision '(cuirass))
+ (requirement '(guix-daemon))
+ (start #~(make-forkexec-constructor
+ (list (string-append #$cuirass "/bin/cuirass")
+ "--cache-directory" #$cache-directory
+ "--specifications"
+ #$(scheme-file "cuirass-specs.scm" specs)
+ "--database" #$database
+ "--interval" #$(number->string interval)
+ #$@(if use-substitutes? '("--use-substitutes") '())
+ #$@(if one-shot? '("--one-shot") '()))
+ #:user #$user
+ #:group #$group
+ #:log-file #$log-file))
+ (stop #~(make-kill-destructor)))))))
+
+(define (cuirass-account config)
+ "Return the user accounts and user groups for CONFIG."
+ (let ((cuirass-user (cuirass-configuration-user config))
+ (cuirass-group (cuirass-configuration-group config)))
+ (list (user-group
+ (name cuirass-group)
+ (system? #t))
+ (user-account
+ (name cuirass-user)
+ (group cuirass-group)
+ (system? #t)
+ (comment "Cuirass privilege separation user")
+ (home-directory (string-append "/var/run/" cuirass-user))
+ (shell #~(string-append #$shadow "/sbin/nologin"))))))
+
+(define (cuirass-activation config)
+ "Return the activation code for CONFIG."
+ (let ((cache (cuirass-configuration-cache-directory config))
+ (db (dirname (cuirass-configuration-database config)))
+ (user (cuirass-configuration-user config))
+ (group (cuirass-configuration-group config)))
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils))
+
+ (mkdir-p #$cache)
+ (mkdir-p #$db)
+
+ (let ((uid (passwd:uid (getpw #$user)))
+ (gid (group:gid (getgr #$group))))
+ (chown #$cache uid gid)
+ (chown #$db uid gid))))))
+
+(define cuirass-service-type
+ (service-type
+ (name 'cuirass)
+ (extensions
+ (list
+ (service-extension profile-service-type ;for 'info cuirass'
+ (compose list cuirass-configuration-cuirass))
+ (service-extension activation-service-type cuirass-activation)
+ (service-extension shepherd-root-service-type cuirass-shepherd-service)
+ (service-extension account-service-type cuirass-account)))))
+
diff --git a/gnu/services/cups.scm b/gnu/services/cups.scm
index 391046a75f..df1843e438 100644
--- a/gnu/services/cups.scm
+++ b/gnu/services/cups.scm
@@ -894,7 +894,7 @@ IPP specifications.")
(if (file-exists? dst)
(format (current-error-port) "warning: ~a exists\n" dst)
(symlink src dst))))
- (find-files (string-append package path))))
+ (find-files (string-append package path) #:stat stat)))
(list #$@paths)))
(list #$@packages))
#t))))
diff --git a/gnu/services/databases.scm b/gnu/services/databases.scm
index 1eed85542b..d88c839f7d 100644
--- a/gnu/services/databases.scm
+++ b/gnu/services/databases.scm
@@ -48,6 +48,10 @@
postgresql-configuration?
(postgresql postgresql-configuration-postgresql ;<package>
(default postgresql))
+ (port postgresql-configuration-port
+ (default 5432))
+ (locale postgresql-configuration-locale
+ (default "en_US.utf8"))
(config-file postgresql-configuration-file)
(data-directory postgresql-configuration-data-directory))
@@ -80,13 +84,18 @@ host all all ::1/128 trust"))
(define postgresql-activation
(match-lambda
- (($ <postgresql-configuration> postgresql config-file data-directory)
+ (($ <postgresql-configuration> postgresql port locale config-file data-directory)
#~(begin
(use-modules (guix build utils)
(ice-9 match))
(let ((user (getpwnam "postgres"))
- (initdb (string-append #$postgresql "/bin/initdb")))
+ (initdb (string-append #$postgresql "/bin/initdb"))
+ (initdb-args
+ (append
+ (if #$locale
+ (list (string-append "--locale=" #$locale))
+ '()))))
;; Create db state directory.
(mkdir-p #$data-directory)
(chown #$data-directory (passwd:uid user) (passwd:gid user))
@@ -101,14 +110,19 @@ host all all ::1/128 trust"))
(lambda ()
(setgid (passwd:gid user))
(setuid (passwd:uid user))
- (primitive-exit (system* initdb "-D" #$data-directory)))
+ (primitive-exit
+ (apply system*
+ initdb
+ "-D"
+ #$data-directory
+ initdb-args)))
(lambda ()
(primitive-exit 1))))
(pid (waitpid pid))))))))
(define postgresql-shepherd-service
(match-lambda
- (($ <postgresql-configuration> postgresql config-file data-directory)
+ (($ <postgresql-configuration> postgresql port locale config-file data-directory)
(let ((start-script
;; Wrapper script that switches to the 'postgres' user before
;; launching daemon.
@@ -121,6 +135,7 @@ host all all ::1/128 trust"))
(system* postgres
(string-append "--config-file="
#$config-file)
+ "-p" (number->string #$port)
"-D" #$data-directory)))))
(list (shepherd-service
(provision '(postgres))
@@ -140,6 +155,8 @@ host all all ::1/128 trust"))
(const %postgresql-accounts))))))
(define* (postgresql-service #:key (postgresql postgresql)
+ (port 5432)
+ (locale "en_US.utf8")
(config-file %default-postgres-config)
(data-directory "/var/lib/postgresql/data"))
"Return a service that runs @var{postgresql}, the PostgreSQL database server.
@@ -149,6 +166,8 @@ and stores the database cluster in @var{data-directory}."
(service postgresql-service-type
(postgresql-configuration
(postgresql postgresql)
+ (port port)
+ (locale locale)
(config-file config-file)
(data-directory data-directory))))
@@ -160,7 +179,8 @@ and stores the database cluster in @var{data-directory}."
(define-record-type* <mysql-configuration>
mysql-configuration make-mysql-configuration
mysql-configuration?
- (mysql mysql-configuration-mysql (default mariadb)))
+ (mysql mysql-configuration-mysql (default mariadb))
+ (port mysql-configuration-port (default 3306)))
(define %mysql-accounts
(list (user-group
@@ -175,10 +195,11 @@ and stores the database cluster in @var{data-directory}."
(define mysql-configuration-file
(match-lambda
- (($ <mysql-configuration> mysql)
- (plain-file "my.cnf" "[mysqld]
+ (($ <mysql-configuration> mysql port)
+ (mixed-text-file "my.cnf" "[mysqld]
datadir=/var/lib/mysql
socket=/run/mysqld/mysqld.sock
+port=" (number->string port) "
"))))
(define (%mysql-activation config)
diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm
index 7555780ade..36049587d3 100644
--- a/gnu/services/desktop.scm
+++ b/gnu/services/desktop.scm
@@ -40,6 +40,7 @@
#:use-module (gnu packages xdisorg)
#:use-module (gnu packages suckless)
#:use-module (gnu packages linux)
+ #:use-module (gnu packages libusb)
#:use-module (guix records)
#:use-module (guix packages)
#:use-module (guix store)
@@ -753,6 +754,10 @@ with the administrator's password."
(screen-locker-service slock)
(screen-locker-service xlockmore "xlock")
+ ;; Add udev rules for MTP devices so that non-root users can access
+ ;; them.
+ (simple-service 'mtp udev-service-type (list libmtp))
+
;; The D-Bus clique.
(avahi-service)
(wicd-service)
diff --git a/gnu/services/kerberos.scm b/gnu/services/kerberos.scm
index a56f63082c..cb33a7c53d 100644
--- a/gnu/services/kerberos.scm
+++ b/gnu/services/kerberos.scm
@@ -17,14 +17,388 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu services kerberos)
- #:use-module (gnu packages admin)
#:use-module (gnu services)
+ #:use-module (gnu services configuration)
#:use-module (gnu system pam)
#:use-module (guix gexp)
#:use-module (guix records)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (ice-9 match)
#:export (pam-krb5-configuration
pam-krb5-configuration?
- pam-krb5-service-type))
+ pam-krb5-service-type
+
+ krb5-realm
+ krb5-realm?
+
+ krb5-configuration
+ krb5-configuration?
+ krb5-service-type))
+
+
+
+(define unset-field (list 'unset-field))
+
+(define (predicate/unset pred)
+ (lambda (x) (or (eq? x unset-field) (pred x))))
+
+(define string/unset? (predicate/unset string?))
+(define boolean/unset? (predicate/unset boolean?))
+(define integer/unset? (predicate/unset integer?))
+
+(define (uglify-field-name field-name)
+ "Return FIELD-NAME with all instances of '-' replaced by '_' and any
+trailing '?' removed."
+ (let ((str (symbol->string field-name)))
+ (string-join (string-split (if (string-suffix? "?" str)
+ (substring str 0 (1- (string-length str)))
+ str)
+ #\-)
+ "_")))
+
+(define (serialize-field* field-name val)
+ (format #t "~a = ~a\n" (uglify-field-name field-name) val))
+
+(define (serialize-string/unset field-name val)
+ (unless (eq? val unset-field)
+ (serialize-field* field-name val)))
+
+(define (serialize-integer/unset field-name val)
+ (unless (eq? val unset-field)
+ (serialize-field* field-name val)))
+
+(define (serialize-boolean/unset field-name val)
+ (unless (eq? val unset-field)
+ (serialize-field* field-name
+ (if val "true" "false"))))
+
+
+;; An end-point is an address such as "192.168.0.1"
+;; or an address port pair ("foobar.example.com" . 109)
+(define (end-point? val)
+ (match val
+ ((? string?) #t)
+ (((? string?) . (? integer?)) #t)
+ (_ #f)))
+
+(define (serialize-end-point field-name val)
+ (serialize-field* field-name
+ (match val
+ ((host . port)
+ ;; The [] are needed in the case of IPv6 addresses
+ (format #f "[~a]:~a" host port))
+ (host
+ (format #f "~a" host)))))
+
+(define (serialize-space-separated-string-list/unset field-name val)
+ (unless (eq? val unset-field)
+ (serialize-field* field-name (string-join val " "))))
+
+(define space-separated-string-list/unset?
+ (predicate/unset space-separated-string-list?))
+
+(define comma-separated-integer-list/unset?
+ (predicate/unset (lambda (val)
+ (and (list? val)
+ (and-map (lambda (x) (integer? x))
+ val)))))
+
+(define (serialize-comma-separated-integer-list/unset field-name val)
+ (unless (eq? val unset-field)
+ (serialize-field* field-name
+ (string-drop ; Drop the leading comma
+ (fold
+ (lambda (i prev)
+ (string-append prev "," (number->string i)))
+ "" val) 1))))
+
+(define file-name? (predicate/unset
+ (lambda (val)
+ (string-prefix? "/" val))))
+
+(define (serialize-file-name field-name val)
+ (unless (eq? val unset-field)
+ (serialize-string field-name val)))
+
+(define (non-negative-integer? val)
+ (and (exact-integer? val) (not (negative? val))))
+
+(define (serialize-non-negative-integer/unset field-name val)
+ (unless (eq? val unset-field)
+ (serialize-field* field-name val)))
+
+(define (free-form-fields? val)
+ (match val
+ (() #t)
+ ((((? symbol?) . (? string)) . val) (free-form-fields? val))
+ (_ #f)))
+
+(define (serialize-free-form-fields field-name val)
+ (for-each (match-lambda ((k . v) (serialize-field* k v))) val))
+
+(define non-negative-integer/unset? (predicate/unset non-negative-integer?))
+
+(define (realm-list? val)
+ (and (list? val)
+ (and-map (lambda (x) (krb5-realm? x)) val)))
+
+(define (serialize-realm-list field-name val)
+ (format #t "\n[~a]\n" field-name)
+ (for-each (lambda (realm)
+ (format #t "\n~a = {\n" (krb5-realm-name realm))
+ (for-each (lambda (field)
+ (unless (eq? 'name (configuration-field-name field))
+ ((configuration-field-serializer field)
+ (configuration-field-name field)
+ ((configuration-field-getter field)
+ realm)))) krb5-realm-fields)
+
+ (format #t "}\n")) val))
+
+
+
+;; For a more detailed explanation of these fields see man 5 krb5.conf
+(define-configuration krb5-realm
+ (name
+ (string/unset unset-field)
+ "The name of the realm.")
+
+ (kdc
+ (end-point unset-field)
+ "The host and port on which the realm's Key Distribution Server listens.")
+
+ (admin-server
+ (string/unset unset-field)
+ "The Host running the administration server for the realm.")
+
+ (master-kdc
+ (string/unset unset-field)
+ "If an attempt to get credentials fails because of an invalid password,
+the client software will attempt to contact the master KDC.")
+
+ (kpasswd-server
+ (string/unset unset-field)
+ "The server where password changes are performed.")
+
+ (auth-to-local
+ (free-form-fields '())
+ "Rules to map between principals and local users.")
+
+ (auth-to-local-names
+ (free-form-fields '())
+ "Explicit mappings between principal names and local user names.")
+
+ (http-anchors
+ (free-form-fields '())
+ "Useful only when http proxy is used to access KDC or KPASSWD.")
+
+ ;; The following are useful only for working with V4 services
+ (default-domain
+ (string/unset unset-field)
+ "The domain used to expand host names when translating Kerberos 4 service
+principals to Kerberos 5 principals")
+
+ (v4-instance-convert
+ (free-form-fields '())
+ "Exceptions to the default-domain mapping rule.")
+
+ (v4-realm
+ (string/unset unset-field)
+ "Used when the V4 realm name and the V5 realm name are not the same, but
+still share the same principal names and passwords"))
+
+
+
+;; For a more detailed explanation of these fields see man 5 krb5.conf
+(define-configuration krb5-configuration
+ (allow-weak-crypto?
+ (boolean/unset unset-field)
+ "If true, permits access to services which only offer weak encryption.")
+
+ (ap-req-checksum-type
+ (non-negative-integer/unset unset-field)
+ "The type of the AP-REQ checksum.")
+
+ (canonicalize?
+ (boolean/unset unset-field)
+ "Should principals in initial ticket requests be canonicalized?")
+
+ (ccache-type
+ (non-negative-integer/unset unset-field)
+ "The format of the credential cache type.")
+
+ (clockskew
+ (non-negative-integer/unset unset-field)
+ "Maximum allowable clock skew in seconds (default 300).")
+
+ (default-ccache-name
+ (file-name unset-field)
+ "The name of the default credential cache.")
+
+ (default-client-keytab-name
+ (file-name unset-field)
+ "The name of the default keytab for client credentials.")
+
+ (default-keytab-name
+ (file-name unset-field)
+ "The name of the default keytab file.")
+
+ (default-realm
+ (string/unset unset-field)
+ "The realm to be accessed if not explicitly specified by clients.")
+
+ (default-tgs-enctypes
+ (free-form-fields '())
+ "Session key encryption types when making TGS-REQ requests.")
+
+ (default-tkt-enctypes
+ (free-form-fields '())
+ "Session key encryption types when making AS-REQ requests.")
+
+ (dns-canonicalize-hostname?
+ (boolean/unset unset-field)
+ "Whether name lookups will be used to canonicalize host names for use in
+service principal names.")
+
+ (dns-lookup-kdc?
+ (boolean/unset unset-field)
+ "Should DNS SRV records should be used to locate the KDCs and other servers
+not appearing in the realm specification")
+
+ (err-fmt
+ (string/unset unset-field)
+ "Custom error message formatting. If not #f error messages will be formatted
+by substituting a normal error message for %M and an error code for %C in the
+value.")
+
+ (forwardable?
+ (boolean/unset unset-field)
+ "Should initial tickets be forwardable by default?")
+
+ (ignore-acceptor-hostname?
+ (boolean/unset unset-field)
+ "When accepting GSSAPI or krb5 security contexts for host-based service
+principals, ignore any hostname passed by the calling application, and allow
+clients to authenticate to any service principal in the keytab matching the
+service name and realm name.")
+
+ (k5login-authoritative?
+ (boolean/unset unset-field)
+ "If this flag is true, principals must be listed in a local user's k5login
+file to be granted login access, if a ~/.k5login file exists.")
+
+ (k5login-directory
+ (string/unset unset-field)
+ "If not #f, the library will look for a local user's @file{k5login} file
+within the named directory (instead of the user's home directory), with a
+file name corresponding to the local user name.")
+
+ (kcm-mach-service
+ (string/unset unset-field)
+ "The name of the bootstrap service used to contact the KCM daemon for the
+KCM credential cache type.")
+
+ (kcm-socket
+ (file-name unset-field)
+ "Path to the Unix domain socket used to access the KCM daemon for the KCM
+credential cache type.")
+
+ (kdc-default-options
+ (non-negative-integer/unset unset-field)
+ "Default KDC options (logored for multiple values) when requesting initial
+tickets.")
+
+ (kdc-timesync
+ (non-negative-integer/unset unset-field)
+ "Attempt to compensate for clock skew between the KDC and client.")
+
+ (kdc-req-checksum-type
+ (non-negative-integer/unset unset-field)
+ "The type of checksum to use for the KDC requests. Relevant only for DES
+keys")
+
+ (noaddresses?
+ (boolean/unset unset-field)
+ "If true, initial ticket requests will not be made with address restrictions.
+This enables their use across NATs.")
+
+ (permitted-enctypes
+ (space-separated-string-list/unset unset-field)
+ "All encryption types that are permitted for use in session key encryption.")
+
+ (plugin-base-dir
+ (file-name unset-field)
+ "The directory where krb5 plugins are located.")
+
+ (preferred-preauth-types
+ (comma-separated-integer-list/unset unset-field)
+ "The preferred pre-authentication types which the client will attempt before
+others.")
+
+ (proxiable?
+ (boolean/unset unset-field)
+ "Should initial tickets be proxiable by default?")
+
+ (rdns?
+ (boolean/unset unset-field)
+ "Should reverse DNS lookup be used in addition to forward name lookup to
+canonicalize host names for use in service principal names.")
+
+ (realm-try-domains
+ (integer/unset unset-field)
+ "Should a host's domain components should be used to determine the Kerberos
+realm of the host.")
+
+ (renew-lifetime
+ (non-negative-integer/unset unset-field)
+ "The default renewable lifetime for initial ticket requests.")
+
+ (safe-checksum-type
+ (non-negative-integer/unset unset-field)
+ "The type of checksum to use for the KRB-SAFE requests.")
+
+ (ticket-lifetime
+ (non-negative-integer/unset unset-field)
+ "The default lifetime for initial ticket requests.")
+
+ (udp-preference-limit
+ (non-negative-integer/unset unset-field)
+ "When sending messages to the KDC, the library will try using TCP
+before UDP if the size of the message greater than this limit.")
+
+ (verify-ap-rereq-nofail?
+ (boolean/unset unset-field)
+ "If true, then attempts to verify initial credentials will fail if the client
+machine does not have a keytab.")
+
+ (realms
+ (realm-list '())
+ "The list of realms which clients may access."))
+
+
+(define (krb5-configuration-file config)
+ "Create a Kerberos 5 configuration file based on CONFIG"
+ (mixed-text-file "krb5.conf"
+ "[libdefaults]\n\n"
+ (with-output-to-string
+ (lambda ()
+ (serialize-configuration config
+ krb5-configuration-fields)))))
+
+(define (krb5-etc-service config)
+ (list `("krb5.conf" ,(krb5-configuration-file config))))
+
+
+(define krb5-service-type
+ (service-type (name 'krb5)
+ (extensions
+ (list (service-extension etc-service-type
+ krb5-etc-service)))))
+
+
+
(define-record-type* <pam-krb5-configuration>
pam-krb5-configuration make-pam-krb5-configuration
diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm
index bbb9053008..d672ecf687 100644
--- a/gnu/services/networking.scm
+++ b/gnu/services/networking.scm
@@ -467,6 +467,9 @@ HiddenServicePort ~a ~a~%"
(chown "/var/lib/tor" (passwd:uid %user) (passwd:gid %user))
(chmod "/var/lib/tor" #o700)
+ ;; Make sure /var/lib is accessible to the 'tor' user.
+ (chmod "/var/lib" #o755)
+
(for-each initialize
'#$(map hidden-service-name
(tor-configuration-hidden-services config)))))
diff --git a/gnu/services/sddm.scm b/gnu/services/sddm.scm
index 5bb58bd6f0..2ebfe22016 100644
--- a/gnu/services/sddm.scm
+++ b/gnu/services/sddm.scm
@@ -220,7 +220,7 @@ Relogin=" (if (sddm-configuration-relogin? config)
(name "sddm-greeter")
(auth
(list
- ;; Load environment form /etc/environment and ~/.pam_environment
+ ;; Load environment from /etc/environment and ~/.pam_environment
(pam-entry
(control "required")
(module "pam_env.so"))
diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm
index 3273184b9a..d8d5006abf 100644
--- a/gnu/services/shepherd.scm
+++ b/gnu/services/shepherd.scm
@@ -82,7 +82,7 @@
(loop (+ 1 fd))))
;; Start shepherd.
- (execl (string-append #$shepherd "/bin/shepherd")
+ (execl #$(file-append shepherd "/bin/shepherd")
"shepherd" "--config" #$shepherd-conf)))))
(define shepherd-root-service-type
diff --git a/gnu/services/web.scm b/gnu/services/web.scm
index 59e1e54e04..db895405a2 100644
--- a/gnu/services/web.scm
+++ b/gnu/services/web.scm
@@ -27,11 +27,12 @@
#:use-module (gnu packages web)
#:use-module (guix records)
#:use-module (guix gexp)
+ #:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:export (nginx-configuration
nginx-configuration?
- nginx-vhost-configuration
- nginx-vhost-configuration?
+ nginx-server-configuration
+ nginx-server-configuration?
nginx-service
nginx-service-type))
@@ -41,24 +42,24 @@
;;;
;;; Code:
-(define-record-type* <nginx-vhost-configuration>
- nginx-vhost-configuration make-nginx-vhost-configuration
- nginx-vhost-configuration?
- (http-port nginx-vhost-configuration-http-port
+(define-record-type* <nginx-server-configuration>
+ nginx-server-configuration make-nginx-server-configuration
+ nginx-server-configuration?
+ (http-port nginx-server-configuration-http-port
(default 80))
- (https-port nginx-vhost-configuration-https-port
+ (https-port nginx-server-configuration-https-port
(default 443))
- (server-name nginx-vhost-configuration-server-name
+ (server-name nginx-server-configuration-server-name
(default (list 'default)))
- (root nginx-vhost-configuration-root
+ (root nginx-server-configuration-root
(default "/srv/http"))
- (index nginx-vhost-configuration-index
+ (index nginx-server-configuration-index
(default (list "index.html")))
- (ssl-certificate nginx-vhost-configuration-ssl-certificate
+ (ssl-certificate nginx-server-configuration-ssl-certificate
(default "/etc/nginx/cert.pem"))
- (ssl-certificate-key nginx-vhost-configuration-ssl-certificate-key
+ (ssl-certificate-key nginx-server-configuration-ssl-certificate-key
(default "/etc/nginx/key.pem"))
- (server-tokens? nginx-vhost-configuration-server-tokens?
+ (server-tokens? nginx-server-configuration-server-tokens?
(default #f)))
(define-record-type* <nginx-configuration>
@@ -67,56 +68,57 @@
(nginx nginx-configuration-nginx) ;<package>
(log-directory nginx-configuration-log-directory) ;string
(run-directory nginx-configuration-run-directory) ;string
+ (server-blocks nginx-configuration-server-blocks) ;list
(file nginx-configuration-file)) ;string | file-like
(define (config-domain-strings names)
"Return a string denoting the nginx config representation of NAMES, a list
of domain names."
- (string-concatenate
+ (string-join
(map (match-lambda
- ('default "_")
- ((? string? str) str))
+ ('default "_ ")
+ ((? string? str) (string-append str " ")))
names)))
(define (config-index-strings names)
"Return a string denoting the nginx config representation of NAMES, a list
of index files."
- (string-concatenate
+ (string-join
(map (match-lambda
- ((? string? str) str))
+ ((? string? str) (string-append str " ")))
names)))
-(define (default-nginx-vhost-config vhost)
+(define (default-nginx-server-config server)
(string-append
" server {\n"
- (if (nginx-vhost-configuration-http-port vhost)
+ (if (nginx-server-configuration-http-port server)
(string-append " listen "
- (number->string (nginx-vhost-configuration-http-port vhost))
+ (number->string (nginx-server-configuration-http-port server))
";\n")
"")
- (if (nginx-vhost-configuration-https-port vhost)
+ (if (nginx-server-configuration-https-port server)
(string-append " listen "
- (number->string (nginx-vhost-configuration-https-port vhost))
+ (number->string (nginx-server-configuration-https-port server))
" ssl;\n")
"")
" server_name " (config-domain-strings
- (nginx-vhost-configuration-server-name vhost))
+ (nginx-server-configuration-server-name server))
";\n"
- (if (nginx-vhost-configuration-ssl-certificate vhost)
+ (if (nginx-server-configuration-ssl-certificate server)
(string-append " ssl_certificate "
- (nginx-vhost-configuration-ssl-certificate vhost) ";\n")
+ (nginx-server-configuration-ssl-certificate server) ";\n")
"")
- (if (nginx-vhost-configuration-ssl-certificate-key vhost)
+ (if (nginx-server-configuration-ssl-certificate-key server)
(string-append " ssl_certificate_key "
- (nginx-vhost-configuration-ssl-certificate-key vhost) ";\n")
+ (nginx-server-configuration-ssl-certificate-key server) ";\n")
"")
- " root " (nginx-vhost-configuration-root vhost) ";\n"
- " index " (config-index-strings (nginx-vhost-configuration-index vhost)) ";\n"
- " server_tokens " (if (nginx-vhost-configuration-server-tokens? vhost)
+ " root " (nginx-server-configuration-root server) ";\n"
+ " index " (config-index-strings (nginx-server-configuration-index server)) ";\n"
+ " server_tokens " (if (nginx-server-configuration-server-tokens? server)
"on" "off") ";\n"
" }\n"))
-(define (default-nginx-config log-directory run-directory vhost-list)
+(define (default-nginx-config log-directory run-directory server-list)
(plain-file "nginx.conf"
(string-append
"user nginx nginx;\n"
@@ -129,7 +131,7 @@ of index files."
" uwsgi_temp_path " run-directory "/uwsgi_temp;\n"
" scgi_temp_path " run-directory "/scgi_temp;\n"
" access_log " log-directory "/access.log;\n"
- (let ((http (map default-nginx-vhost-config vhost-list)))
+ (let ((http (map default-nginx-server-config server-list)))
(do ((http http (cdr http))
(block "" (string-append (car http) "\n" block )))
((null? http) block)))
@@ -148,7 +150,8 @@ of index files."
(define nginx-activation
(match-lambda
- (($ <nginx-configuration> nginx log-directory run-directory config-file)
+ (($ <nginx-configuration> nginx log-directory run-directory server-blocks
+ config-file)
#~(begin
(use-modules (guix build utils))
@@ -164,17 +167,25 @@ of index files."
(mkdir-p (string-append #$run-directory "/scgi_temp"))
;; Check configuration file syntax.
(system* (string-append #$nginx "/sbin/nginx")
- "-c" #$config-file "-t")))))
+ "-c" #$(or config-file
+ (default-nginx-config log-directory
+ run-directory server-blocks))
+ "-t")))))
(define nginx-shepherd-service
(match-lambda
- (($ <nginx-configuration> nginx log-directory run-directory config-file)
+ (($ <nginx-configuration> nginx log-directory run-directory server-blocks
+ config-file)
(let* ((nginx-binary (file-append nginx "/sbin/nginx"))
(nginx-action
(lambda args
#~(lambda _
(zero?
- (system* #$nginx-binary "-c" #$config-file #$@args))))))
+ (system* #$nginx-binary "-c"
+ #$(or config-file
+ (default-nginx-config log-directory
+ run-directory server-blocks))
+ #$@args))))))
;; TODO: Add 'reload' action.
(list (shepherd-service
@@ -192,14 +203,20 @@ of index files."
(service-extension activation-service-type
nginx-activation)
(service-extension account-service-type
- (const %nginx-accounts))))))
+ (const %nginx-accounts))))
+ (compose concatenate)
+ (extend (lambda (config servers)
+ (nginx-configuration
+ (inherit config)
+ (server-blocks
+ (append (nginx-configuration-server-blocks config)
+ servers)))))))
(define* (nginx-service #:key (nginx nginx)
(log-directory "/var/log/nginx")
(run-directory "/var/run/nginx")
- (vhost-list (list (nginx-vhost-configuration)))
- (config-file
- (default-nginx-config log-directory run-directory vhost-list)))
+ (server-list '())
+ (config-file #f))
"Return a service that runs NGINX, the nginx web server.
The nginx daemon loads its runtime configuration from CONFIG-FILE, stores log
@@ -209,4 +226,5 @@ files in LOG-DIRECTORY, and stores temporary runtime files in RUN-DIRECTORY."
(nginx nginx)
(log-directory log-directory)
(run-directory run-directory)
+ (server-blocks server-list)
(file config-file))))
generated by cgit v1.2.3 (git 2.45.0) at 2024-11-15 09:51:22 +0000