diff options
Diffstat (limited to 'gnu/services')
| -rw-r--r-- | gnu/services/authentication.scm | 22 | ||||
| -rw-r--r-- | gnu/services/base.scm | 3 | ||||
| -rw-r--r-- | gnu/services/cuirass.scm | 50 | ||||
| -rw-r--r-- | gnu/services/cups.scm | 12 | ||||
| -rw-r--r-- | gnu/services/databases.scm | 113 | ||||
| -rw-r--r-- | gnu/services/dbus.scm | 37 | ||||
| -rw-r--r-- | gnu/services/dns.scm | 35 | ||||
| -rw-r--r-- | gnu/services/file-sharing.scm | 804 | ||||
| -rw-r--r-- | gnu/services/guix.scm | 88 | ||||
| -rw-r--r-- | gnu/services/networking.scm | 13 | ||||
| -rw-r--r-- | gnu/services/shepherd.scm | 10 | ||||
| -rw-r--r-- | gnu/services/sysctl.scm | 10 | ||||
| -rw-r--r-- | gnu/services/virtualization.scm | 227 | ||||
| -rw-r--r-- | gnu/services/vpn.scm | 138 | ||||
| -rw-r--r-- | gnu/services/web.scm | 112 | ||||
| -rw-r--r-- | gnu/services/xorg.scm | 37 |
16 files changed, 1421 insertions, 290 deletions
diff --git a/gnu/services/authentication.scm b/gnu/services/authentication.scm index 73969a5a6d..d7efc48cd0 100644 --- a/gnu/services/authentication.scm +++ b/gnu/services/authentication.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Danny Milosavljevic <dannym@scratchpost.org> ;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; @@ -31,6 +32,7 @@ #:use-module (guix gexp) #:use-module (guix records) #:use-module (guix packages) + #:use-module (guix modules) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -521,6 +523,16 @@ password.") (define (pam-ldap-pam-services config) (list (pam-ldap-pam-service config))) +(define %nslcd-activation + (with-imported-modules (source-module-closure '((gnu build activation))) + #~(begin + (use-modules (gnu build activation)) + (let ((rundir "/var/run/nslcd") + (user (getpwnam "nslcd"))) + (mkdir-p/perms rundir user #o755) + (when (file-exists? "/etc/nslcd.conf") + (chmod "/etc/nslcd.conf" #o400)))))) + (define nslcd-service-type (service-type (name 'nslcd) @@ -531,15 +543,7 @@ password.") (service-extension etc-service-type nslcd-etc-service) (service-extension activation-service-type - (const #~(begin - (use-modules (guix build utils)) - (let ((rundir "/var/run/nslcd") - (user (getpwnam "nslcd"))) - (mkdir-p rundir) - (chown rundir (passwd:uid user) (passwd:gid user)) - (chmod rundir #o755) - (when (file-exists? "/etc/nslcd.conf") - (chmod "/etc/nslcd.conf" #o400)))))) + (const %nslcd-activation)) (service-extension pam-root-service-type pam-ldap-pam-services) (service-extension nscd-service-type diff --git a/gnu/services/base.scm b/gnu/services/base.scm index f6a490f712..f50bcfdcb4 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -35,6 +35,7 @@ #:use-module (gnu services) #:use-module (gnu services admin) #:use-module (gnu services shepherd) + #:use-module (gnu services sysctl) #:use-module (gnu system pam) #:use-module (gnu system shadow) ; 'user-account', etc. #:use-module (gnu system uuid) @@ -2532,6 +2533,8 @@ to handle." (udev-configuration (rules (list lvm2 fuse alsa-utils crda)))) + (service sysctl-service-type) + (service special-files-service-type `(("/bin/sh" ,(file-append bash "/bin/sh")) ("/usr/bin/env" ,(file-append coreutils "/bin/env")))))) diff --git a/gnu/services/cuirass.scm b/gnu/services/cuirass.scm index d291d494fc..317d877459 100644 --- a/gnu/services/cuirass.scm +++ b/gnu/services/cuirass.scm @@ -22,11 +22,13 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (gnu services cuirass) + #:use-module (guix channels) #:use-module (guix gexp) #:use-module (guix records) #:use-module (guix utils) #:use-module (gnu packages admin) #:use-module (gnu packages ci) + #:use-module (gnu packages databases) #:use-module (gnu packages version-control) #:use-module (gnu services) #:use-module (gnu services base) @@ -34,6 +36,8 @@ #:use-module (gnu services shepherd) #:use-module (gnu services admin) #:use-module (gnu system shadow) + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) #:export (<cuirass-remote-server-configuration> cuirass-remote-server-configuration cuirass-remote-server-configuration? @@ -93,6 +97,8 @@ (default "cuirass")) (interval cuirass-configuration-interval ;integer (seconds) (default 60)) + (parameters cuirass-configuration-parameters ;string + (default #f)) (remote-server cuirass-configuration-remote-server (default #f)) (database cuirass-configuration-database ;string @@ -109,8 +115,6 @@ (default #f)) (fallback? cuirass-configuration-fallback? ;boolean (default #f)) - (zabbix-uri cuirass-configuration-zabbix-uri ;string - (default #f)) (extra-options cuirass-configuration-extra-options (default '()))) @@ -123,6 +127,7 @@ (user (cuirass-configuration-user config)) (group (cuirass-configuration-group config)) (interval (cuirass-configuration-interval config)) + (parameters (cuirass-configuration-parameters config)) (remote-server (cuirass-configuration-remote-server config)) (database (cuirass-configuration-database config)) (port (cuirass-configuration-port config)) @@ -131,12 +136,11 @@ (use-substitutes? (cuirass-configuration-use-substitutes? config)) (one-shot? (cuirass-configuration-one-shot? config)) (fallback? (cuirass-configuration-fallback? config)) - (zabbix-uri (cuirass-configuration-zabbix-uri config)) (extra-options (cuirass-configuration-extra-options config))) `(,(shepherd-service (documentation "Run Cuirass.") (provision '(cuirass)) - (requirement '(guix-daemon postgres networking)) + (requirement '(guix-daemon postgres postgres-roles networking)) (start #~(make-forkexec-constructor (list (string-append #$cuirass "/bin/cuirass") "--cache-directory" #$cache-directory @@ -144,15 +148,15 @@ #$(scheme-file "cuirass-specs.scm" specs) "--database" #$database "--interval" #$(number->string interval) + #$@(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") '()) - #$@(if zabbix-uri - (list (string-append - "--zabbix-uri=" - zabbix-uri)) - '()) #$@extra-options) #:environment-variables @@ -167,7 +171,7 @@ ,(shepherd-service (documentation "Run Cuirass web interface.") (provision '(cuirass-web)) - (requirement '(guix-daemon postgres networking)) + (requirement '(cuirass)) (start #~(make-forkexec-constructor (list (string-append #$cuirass "/bin/cuirass") "--cache-directory" #$cache-directory @@ -176,6 +180,11 @@ "--port" #$(number->string port) "--listen" #$host "--interval" #$(number->string interval) + #$@(if parameters + (list (string-append + "--parameters=" + parameters)) + '()) #$@(if use-substitutes? '("--use-substitutes") '()) #$@(if fallback? '("--fallback") '()) #$@extra-options) @@ -192,7 +201,7 @@ (shepherd-service (documentation "Run Cuirass remote build server.") (provision '(cuirass-remote-server)) - (requirement '(avahi-daemon cuirass guix-daemon networking)) + (requirement '(avahi-daemon cuirass)) (start #~(make-forkexec-constructor (list (string-append #$cuirass "/bin/remote-server") (string-append "--database=" #$database) @@ -208,6 +217,11 @@ "--publish-port=" (number->string publish-port))) '()) + #$@(if parameters + (list (string-append + "--parameters=" + parameters)) + '()) #$@(if trigger-url (list (string-append @@ -256,8 +270,6 @@ (remote-cache (and remote-server (cuirass-remote-server-configuration-cache remote-server))) - (db (dirname - (cuirass-configuration-database config))) (user (cuirass-configuration-user config)) (log "/var/log/cuirass") (group (cuirass-configuration-group config))) @@ -266,7 +278,6 @@ (use-modules (guix build utils)) (mkdir-p #$cache) - (mkdir-p #$db) (mkdir-p #$log) (when #$remote-cache @@ -275,7 +286,6 @@ (let ((uid (passwd:uid (getpw #$user))) (gid (group:gid (getgr #$group)))) (chown #$cache uid gid) - (chown #$db uid gid) (chown #$log uid gid) (when #$remote-cache @@ -299,6 +309,8 @@ (service-extension activation-service-type cuirass-activation) (service-extension shepherd-root-service-type cuirass-shepherd-service) (service-extension account-service-type cuirass-account) + ;; Make sure postgresql and postgresql-role are instantiated. + (service-extension postgresql-service-type (const #t)) (service-extension postgresql-role-service-type cuirass-postgresql-role))) (description @@ -311,6 +323,8 @@ (default cuirass)) (workers cuirass-remote-worker-workers ;int (default 1)) + (server cuirass-remote-worker-server ;string + (default #f)) (systems cuirass-remote-worker-systems ;list (default (list (%current-system)))) (log-file cuirass-remote-worker-log-file ;string @@ -326,7 +340,8 @@ "Return a <shepherd-service> for the Cuirass remote worker service with CONFIG." (match-record config <cuirass-remote-worker-configuration> - (cuirass workers systems log-file publish-port public-key private-key) + (cuirass workers server systems log-file publish-port + public-key private-key) (list (shepherd-service (documentation "Run Cuirass remote build worker.") (provision '(cuirass-remote-worker)) @@ -335,6 +350,9 @@ CONFIG." (list (string-append #$cuirass "/bin/remote-worker") (string-append "--workers=" #$(number->string workers)) + #$@(if server + (list (string-append "--server=" server)) + '()) #$@(if systems (list (string-append "--systems=" diff --git a/gnu/services/cups.scm b/gnu/services/cups.scm index 17ed04e58b..20e3917b93 100644 --- a/gnu/services/cups.scm +++ b/gnu/services/cups.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2019 Alex Griffin <a@ajgrf.com> ;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr> +;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; @@ -31,6 +32,7 @@ #:use-module (guix packages) #:use-module (guix records) #:use-module (guix gexp) + #:use-module (guix modules) #:use-module (ice-9 match) #:use-module ((srfi srfi-1) #:select (append-map find)) #:export (cups-service-type @@ -871,13 +873,11 @@ IPP specifications.") (define %cups-activation ;; Activation gexp. - (with-imported-modules '((guix build utils)) + (with-imported-modules (source-module-closure '((gnu build activation) + (guix build utils))) #~(begin - (use-modules (guix build utils)) - (define (mkdir-p/perms directory owner perms) - (mkdir-p directory) - (chown directory (passwd:uid owner) (passwd:gid owner)) - (chmod directory perms)) + (use-modules (gnu build activation) + (guix build utils)) (define (build-subject parameters) (string-concatenate (map (lambda (pair) diff --git a/gnu/services/databases.scm b/gnu/services/databases.scm index d908b86af8..a841e7a50e 100644 --- a/gnu/services/databases.scm +++ b/gnu/services/databases.scm @@ -79,13 +79,6 @@ memcached-configuration-udp-port memcached-configuration-additional-options - mongodb-configuration - mongodb-configuration? - mongodb-configuration-mongodb - mongodb-configuration-config-file - mongodb-configuration-data-directory - mongodb-service-type - mysql-service mysql-service-type mysql-configuration @@ -331,7 +324,9 @@ host all all ::1/128 md5")) (const %postgresql-accounts)) (service-extension profile-service-type - (compose list postgresql-configuration-postgresql)))))) + (compose list postgresql-configuration-postgresql)))) + (default-value (postgresql-configuration + (postgresql postgresql-10))))) (define-deprecated (postgresql-service #:key (postgresql postgresql) (port 5432) @@ -408,13 +403,8 @@ rolname = '" ,name "')) as not_exists;\n" (let ((host (postgresql-role-configuration-host config)) (roles (postgresql-role-configuration-roles config))) - (program-file - "postgresql-create-roles" - #~(begin - (let ((psql #$(file-append postgresql "/bin/psql"))) - (execl psql psql "-a" - "-h" #$host - "-f" #$(roles->queries roles))))))) + #~(let ((psql #$(file-append postgresql "/bin/psql"))) + (list psql "-a" "-h" #$host "-f" #$(roles->queries roles))))) (define (postgresql-role-shepherd-service config) (match-record config <postgresql-role-configuration> @@ -423,10 +413,14 @@ rolname = '" ,name "')) as not_exists;\n" (requirement '(postgres)) (provision '(postgres-roles)) (one-shot? #t) - (start #~(make-forkexec-constructor - (list #$(postgresql-create-roles config)) - #:user "postgres" #:group "postgres" - #:log-file #$log)) + (start + #~(lambda args + (let ((pid (fork+exec-command + #$(postgresql-create-roles config) + #:user "postgres" + #:group "postgres" + #:log-file #$log))) + (zero? (cdr (waitpid pid)))))) (documentation "Create PostgreSQL roles."))))) (define postgresql-role-service-type @@ -522,87 +516,6 @@ created after the PostgreSQL database is started."))) ;;; -;;; MongoDB -;;; - -(define %default-mongodb-configuration-file - (plain-file - "mongodb.yaml" - "# GNU Guix: MongoDB default configuration file -processManagement: - pidFilePath: /var/run/mongodb/pid -storage: - dbPath: /var/lib/mongodb -")) - - -(define-record-type* <mongodb-configuration> - mongodb-configuration make-mongodb-configuration - mongodb-configuration? - (mongodb mongodb-configuration-mongodb - (default mongodb)) - (config-file mongodb-configuration-config-file - (default %default-mongodb-configuration-file)) - (data-directory mongodb-configuration-data-directory - (default "/var/lib/mongodb"))) - -(define %mongodb-accounts - (list (user-group (name "mongodb") (system? #t)) - (user-account - (name "mongodb") - (group "mongodb") - (system? #t) - (comment "Mongodb server user") - (home-directory "/var/lib/mongodb") - (shell (file-append shadow "/sbin/nologin"))))) - -(define mongodb-activation - (match-lambda - (($ <mongodb-configuration> mongodb config-file data-directory) - #~(begin - (use-modules (guix build utils)) - (let ((user (getpwnam "mongodb"))) - (for-each - (lambda (directory) - (mkdir-p directory) - (chown directory - (passwd:uid user) (passwd:gid user))) - '("/var/run/mongodb" #$data-directory))))))) - -(define mongodb-shepherd-service - (match-lambda - (($ <mongodb-configuration> mongodb config-file data-directory) - (shepherd-service - (provision '(mongodb)) - (documentation "Run the Mongodb daemon.") - (requirement '(user-processes loopback)) - (start #~(make-forkexec-constructor - `(,(string-append #$mongodb "/bin/mongod") - "--config" - ,#$config-file) - #:user "mongodb" - #:group "mongodb" - #:pid-file "/var/run/mongodb/pid" - #:log-file "/var/log/mongodb.log")) - (stop #~(make-kill-destructor)))))) - -(define mongodb-service-type - (service-type - (name 'mongodb) - (description "Run the MongoDB document database server.") - (extensions - (list (service-extension shepherd-root-service-type - (compose list - mongodb-shepherd-service)) - (service-extension activation-service-type - mongodb-activation) - (service-extension account-service-type - (const %mongodb-accounts)))) - (default-value - (mongodb-configuration)))) - - -;;; ;;; MySQL. ;;; diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm index e015d3f68d..af1a1e4c3a 100644 --- a/gnu/services/dbus.scm +++ b/gnu/services/dbus.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com> +;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; @@ -28,6 +29,7 @@ #:use-module (guix gexp) #:use-module ((guix packages) #:select (package-name)) #:use-module (guix records) + #:use-module (guix modules) #:use-module (srfi srfi-1) #:use-module (ice-9 match) #:export (dbus-configuration @@ -161,24 +163,23 @@ includes the @code{etc/dbus-1/system.d} directories of each package listed in (define (dbus-activation config) "Return an activation gexp for D-Bus using @var{config}." - #~(begin - (use-modules (guix build utils)) - - (mkdir-p "/var/run/dbus") - - (let ((user (getpwnam "messagebus"))) - (chown "/var/run/dbus" - (passwd:uid user) (passwd:gid user)) - - ;; This directory contains the daemon's socket so it must be - ;; world-readable. - (chmod "/var/run/dbus" #o755)) - - (unless (file-exists? "/etc/machine-id") - (format #t "creating /etc/machine-id...~%") - (invoke (string-append #$(dbus-configuration-dbus config) - "/bin/dbus-uuidgen") - "--ensure=/etc/machine-id")))) + (with-imported-modules (source-module-closure + '((gnu build activation) + (guix build utils))) + #~(begin + (use-modules (gnu build activation) + (guix build utils)) + + (let ((user (getpwnam "messagebus"))) + ;; This directory contains the daemon's socket so it must be + ;; world-readable. + (mkdir-p/perms "/var/run/dbus" user #o755)) + + (unless (file-exists? "/etc/machine-id") + (format #t "creating /etc/machine-id...~%") + (invoke (string-append #$(dbus-configuration-dbus config) + "/bin/dbus-uuidgen") + "--ensure=/etc/machine-id"))))) (define dbus-shepherd-service (match-lambda diff --git a/gnu/services/dns.scm b/gnu/services/dns.scm index b339eb0619..55211cb08f 100644 --- a/gnu/services/dns.scm +++ b/gnu/services/dns.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2017 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> ;;; Copyright © 2020 Pierre Langlois <pierre.langlois@gmx.com> +;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. ;;; @@ -28,6 +29,7 @@ #:use-module (guix packages) #:use-module (guix records) #:use-module (guix gexp) + #:use-module (guix modules) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) @@ -256,9 +258,9 @@ (let ((id (knot-key-configuration-id key))) (unless (and (string? id) (not (equal? id ""))) (error-out "key id must be a non empty string."))) - (unless (memq '(#f hmac-md5 hmac-sha1 hmac-sha224 hmac-sha256 hmac-sha384 hmac-sha512) - (knot-key-configuration-algorithm key)) - (error-out "algorithm must be one of: #f, 'hmac-md5, 'hmac-sha1, + (unless (memq (knot-key-configuration-algorithm key) + '(#f hmac-md5 hmac-sha1 hmac-sha224 hmac-sha256 hmac-sha384 hmac-sha512)) + (error-out "algorithm must be one of: #f, 'hmac-md5, 'hmac-sha1, 'hmac-sha224, 'hmac-sha256, 'hmac-sha384 or 'hmac-sha512"))) (define (verify-knot-keystore-configuration keystore) @@ -267,9 +269,9 @@ (let ((id (knot-keystore-configuration-id keystore))) (unless (and (string? id) (not (equal? id ""))) (error-out "keystore id must be a non empty string."))) - (unless (memq '(pem pkcs11) - (knot-keystore-configuration-backend keystore)) - (error-out "backend must be one of: 'pem or 'pkcs11"))) + (unless (memq (knot-keystore-configuration-backend keystore) + '(pem pkcs11)) + (error-out "backend must be one of: 'pem or 'pkcs11"))) (define (verify-knot-policy-configuration policy) (unless (knot-policy-configuration? policy) @@ -288,7 +290,7 @@ (unless (and (string? id) (not (equal? id ""))) (error-out "acl id must be a non empty string.")) (unless (and (list? address) - (fold (lambda (x1 x2) (and (string? x1) (string? x2))) "" address)) + (every string? address)) (error-out "acl address must be a list of strings."))) (unless (boolean? (knot-acl-configuration-deny? acl)) (error-out "deny? must be #t or #f."))) @@ -607,17 +609,14 @@ (shell (file-append shadow "/sbin/nologin"))))) (define (knot-activation config) - #~(begin - (use-modules (guix build utils)) - (define (mkdir-p/perms directory owner perms) - (mkdir-p directory) - (chown directory (passwd:uid owner) (passwd:gid owner)) - (chmod directory perms)) - (mkdir-p/perms #$(knot-configuration-run-directory config) - (getpwnam "knot") #o755) - (mkdir-p/perms "/var/lib/knot" (getpwnam "knot") #o755) - (mkdir-p/perms "/var/lib/knot/keys" (getpwnam "knot") #o755) - (mkdir-p/perms "/var/lib/knot/keys/keys" (getpwnam "knot") #o755))) + (with-imported-modules (source-module-closure '((gnu build activation))) + #~(begin + (use-modules (gnu build activation)) + (mkdir-p/perms #$(knot-configuration-run-directory config) + (getpwnam "knot") #o755) + (mkdir-p/perms "/var/lib/knot" (getpwnam "knot") #o755) + (mkdir-p/perms "/var/lib/knot/keys" (getpwnam "knot") #o755) + (mkdir-p/perms "/var/lib/knot/keys/keys" (getpwnam "knot") #o755)))) (define (knot-shepherd-service config) (let* ((config-file (knot-config-file config)) diff --git a/gnu/services/file-sharing.scm b/gnu/services/file-sharing.scm new file mode 100644 index 0000000000..72cd6478d6 --- /dev/null +++ b/gnu/services/file-sharing.scm @@ -0,0 +1,804 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2020 Simon South <simon@simonsouth.net> +;;; +;;; 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 file-sharing) + #:use-module (gcrypt base16) + #:use-module (gcrypt hash) + #:use-module (gcrypt random) + #:use-module (gnu services) + #:use-module (gnu services admin) + #:use-module (gnu services configuration) + #:use-module (gnu services shepherd) + #:use-module (gnu packages admin) + #:use-module (gnu packages bittorrent) + #:use-module (gnu packages gnupg) + #:use-module (gnu packages guile) + #:use-module (gnu system shadow) + #:use-module (guix diagnostics) + #:use-module (guix gexp) + #:use-module (guix i18n) + #:use-module (guix modules) + #:use-module (guix packages) + #:use-module (guix records) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:export (transmission-daemon-configuration + transmission-daemon-service-type + transmission-password-hash + transmission-random-salt)) + +;;; +;;; Transmission Daemon. +;;; + +(define %transmission-daemon-user "transmission") +(define %transmission-daemon-group "transmission") + +(define %transmission-daemon-configuration-directory + "/var/lib/transmission-daemon") +(define %transmission-daemon-log-file + "/var/log/transmission.log") + +(define %transmission-salt-length 8) + +(define (transmission-password-hash password salt) + "Returns a string containing the result of hashing @var{password} together +with @var{salt}, in the format recognized by Transmission clients for their +@code{rpc-password} configuration setting. + +@var{salt} must be an eight-character string. The +@code{transmission-random-salt} procedure can be used to generate a suitable +salt value at random." + (if (not (and (string? salt) + (eq? (string-length salt) %transmission-salt-length))) + (raise (formatted-message + (G_ "salt value must be a string of ~d characters") + %transmission-salt-length)) + (string-append "{" + (bytevector->base16-string + (sha1 (string->utf8 (string-append password salt)))) + salt))) + +(define (transmission-random-salt) + "Returns a string containing a random, eight-character salt value of the +type generated and used by Transmission clients, suitable for passing to the +@code{transmission-password-hash} procedure." + ;; This implementation matches a portion of Transmission's tr_ssha1 + ;; function. See libtransmission/crypto-utils.c in the Transmission source + ;; distribution. + (let ((salter (string-append "0123456789" + "abcdefghijklmnopqrstuvwxyz" + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "./"))) + (list->string + (map (lambda (u8) + (string-ref salter (modulo u8 (string-length salter)))) + (bytevector->u8-list + (gen-random-bv %transmission-salt-length %gcry-strong-random)))))) + +(define (uglify-field-name field-name) + (string-delete #\? (symbol->string field-name))) + +(define (serialize-field field-name val) + ;; "Serialize" each configuration field as a G-expression containing a + ;; name-value pair, the collection of which will subsequently be serialized + ;; to disk as a JSON object. + #~(#$(uglify-field-name field-name) . #$val)) + +(define serialize-boolean serialize-field) +(define serialize-integer serialize-field) +(define serialize-rational serialize-field) + +(define serialize-string serialize-field) +(define-maybe string) +;; Override the definition of "serialize-maybe-string", as we need to output a +;; name-value pair for the JSON builder. +(set! serialize-maybe-string + (lambda (field-name val) + (serialize-string field-name + (if (and (symbol? val) + (eq? val 'disabled)) + "" + val)))) + +(define (string-list? val) + (and (list? val) + (and-map (lambda (x) + (and (string? x) + (not (string-index x #\,)))) + val))) +(define (serialize-string-list field-name val) + (serialize-field field-name (string-join val ","))) + +(define days + '((sunday . #b0000001) + (monday . #b0000010) + (tuesday . #b0000100) + (wednesday . #b0001000) + (thursday . #b0010000) + (friday . #b0100000) + (saturday . #b1000000))) +(define day-lists + (list (cons 'weekdays '(monday tuesday wednesday thursday friday)) + (cons 'weekends '(saturday sunday)) + (cons 'all (map car days)))) +(define (day-list? val) + (or (and (symbol? val) + (assq val day-lists)) + (and (list? val) + (and-map (lambda (x) + (and (symbol? x) + (assq x days))) + val)))) +(define (serialize-day-list field-name val) + (serialize-integer field-name + (reduce logior + #b0000000 + (map (lambda (day) + (assq-ref days day)) + (if (symbol? val) + (assq-ref day-lists val) + val))))) + +(define encryption-modes + '((prefer-unencrypted-connections . 0) + (prefer-encrypted-connections . 1) + (require-encrypted-connections . 2))) +(define (encryption-mode? val) + (and (symbol? val) + (assq val encryption-modes))) +(define (serialize-encryption-mode field-name val) + (serialize-integer field-name (assq-ref encryption-modes val))) + +(define serialize-file-like serialize-field) + +(define (file-object? val) + (or (string? val) + (file-like? val))) +(define (serialize-file-object field-name val) + (if (file-like? val) + (serialize-file-like field-name val) + (serialize-string field-name val))) +(define-maybe file-object) +(set! serialize-maybe-file-object + (lambda (field-name val) + (if (and (symbol? val) + (eq? val 'disabled)) + (serialize-string field-name "") + (serialize-file-object field-name val)))) + +(define (file-object-list? val) + (and (list? val) + (and-map file-object? val))) +(define serialize-file-object-list serialize-field) + +(define message-levels + '((none . 0) + (error . 1) + (info . 2) + (debug . 3))) +(define (message-level? val) + (and (symbol? val) + (assq val message-levels))) +(define (serialize-message-level field-name val) + (serialize-integer field-name (assq-ref message-levels val))) + +(define (non-negative-integer? val) + (and (integer? val) + (not (negative? val)))) +(define serialize-non-negative-integer serialize-integer) + +(define (non-negative-rational? val) + (and (rational? val) + (not (negative? val)))) +(define serialize-non-negative-rational serialize-rational) + +(define (port-number? val) + (and (integer? val) + (>= val 1) + (<= val 65535))) +(define serialize-port-number serialize-integer) + +(define preallocation-modes + '((none . 0) + (fast . 1) + (sparse . 1) + (full . 2))) +(define (preallocation-mode? val) + (and (symbol? val) + (assq val preallocation-modes))) +(define (serialize-preallocation-mode field-name val) + (serialize-integer field-name (assq-ref preallocation-modes val))) + +(define tcp-types-of-service + '((default . "default") + (low-cost . "lowcost") + (throughput . "throughput") + (low-delay . "lowdelay") + (reliability . "reliability"))) +(define (tcp-type-of-service? val) + (and (symbol? val) + (assq val tcp-types-of-service))) +(define (serialize-tcp-type-of-service field-name val) + (serialize-string field-name (assq-ref tcp-types-of-service val))) + +(define (transmission-password-hash? val) + (and (string? val) + (= (string-length val) 49) + (eqv? (string-ref val 0) #\{) + (string-every char-set:hex-digit val 1 41))) +(define serialize-transmission-password-hash serialize-string) +(define-maybe transmission-password-hash) +(set! serialize-maybe-transmission-password-hash serialize-maybe-string) + +(define (umask? val) + (and (integer? val) + (>= val #o000) + (<= val #o777))) +(define serialize-umask serialize-integer) ; must use decimal representation + +(define-configuration transmission-daemon-configuration + ;; Settings internal to this service definition. + (transmission + (package transmission) + "The Transmission package to use.") + (stop-wait-period + (non-negative-integer 10) + "The period, in seconds, to wait when stopping the service for +@command{transmission-daemon} to exit before killing its process. This allows +the daemon time to complete its housekeeping and send a final update to +trackers as it shuts down. On slow hosts, or hosts with a slow network +connection, this value may need to be increased.") + + ;; Files and directories. + (download-dir + (string (string-append %transmission-daemon-configuration-directory + "/downloads")) + "The directory to which torrent files are downloaded.") + (incomplete-dir-enabled? + (boolean #f) + "If @code{#t}, files will be held in @code{incomplete-dir} while their +torrent is being downloaded, then moved to @code{download-dir} once the +torrent is complete. Otherwise, files for all torrents (including those still +being downloaded) will be placed in @code{download-dir}.") + (incomplete-dir + (maybe-string 'disabled) + "The directory in which files from incompletely downloaded torrents will be +held when @code{incomplete-dir-enabled?} is @code{#t}.") + (umask + (umask #o022) + "The file mode creation mask used for downloaded files. (See the +@command{umask} man page for more information.)") + (rename-partial-files? + (boolean #t) + "When @code{#t}, ``.part'' is appended to the name of partially downloaded +files.") + (preallocation + (preallocation-mode 'fast) + "The mode by which space should be preallocated for downloaded files, one +of @code{none}, @code{fast} (or @code{sparse}) and @code{full}. Specifying +@code{full} will minimize disk fragmentation at a cost to file-creation +speed.") + (watch-dir-enabled? + (boolean #f) + "If @code{#t}, the directory specified by @code{watch-dir} will be watched +for new @file{.torrent} files and the torrents they describe added +automatically (and the original files removed, if +@code{trash-original-torrent-files?} is @code{#t}).") + (watch-dir + (maybe-string 'disabled) + "The directory to be watched for @file{.torrent} files indicating new +torrents to be added, when @code{watch-dir-enabled} is @code{#t}.") + (trash-original-torrent-files? + (boolean #f) + "When @code{#t}, @file{.torrent} files will be deleted from the watch +directory once their torrent has been added (see +@code{watch-directory-enabled?}).") + + ;; Bandwidth limits. + (speed-limit-down-enabled? + (boolean #f) + "When @code{#t}, the daemon's download speed will be limited to the rate +specified by @code{speed-limit-down}.") + (speed-limit-down + (non-negative-integer 100) + "The default global-maximum download speed, in kilobytes per second.") + (speed-limit-up-enabled? + (boolean #f) + "When @code{#t}, the daemon's upload speed will be limited to the rate +specified by @code{speed-limit-up}.") + (speed-limit-up + (non-negative-integer 100) + "The default global-maximum upload speed, in kilobytes per second.") + (alt-speed-enabled? + (boolean #f) + "When @code{#t}, the alternate speed limits @code{alt-speed-down} and +@code{alt-speed-up} are used (in place of @code{speed-limit-down} and +@code{speed-limit-up}, if they are enabled) to constrain the daemon's +bandwidth usage. This can be scheduled to occur automatically at certain +times during the week; see @code{alt-speed-time-enabled?}.") + (alt-speed-down + (non-negative-integer 50) + "The alternate global-maximum download speed, in kilobytes per second.") + (alt-speed-up + (non-negative-integer 50) + "The alternate global-maximum upload speed, in kilobytes per second.") + + ;; Bandwidth-limit scheduling. + (alt-speed-time-enabled? + (boolean #f) + "When @code{#t}, the alternate speed limits @code{alt-speed-down} and +@code{alt-speed-up} will be enabled automatically during the periods specified +by @code{alt-speed-time-day}, @code{alt-speed-time-begin} and +@code{alt-time-speed-end}.") + (alt-speed-time-day + (day-list 'all) + "The days of the week on which the alternate-speed schedule should be used, +specified either as a list of days (@code{sunday}, @code{monday}, and so on) +or using one of the symbols @code{weekdays}, @code{weekends} or @code{all}.") + (alt-speed-time-begin + (non-negative-integer 540) + "The time of day at which to enable the alternate speed limits, +expressed as a number of minutes since midnight.") + (alt-speed-time-end + (non-negative-integer 1020) + "The time of day at which to disable the alternate speed limits, +expressed as a number of minutes since midnight.") + + ;; Peer networking. + (bind-address-ipv4 + (string "0.0.0.0") + "The IP address at which to listen for peer connections, or ``0.0.0.0'' to +listen at all available IP addresses.") + (bind-address-ipv6 + (string "::") + "The IPv6 address at which to listen for peer connections, or ``::'' to +listen at all available IPv6 addresses.") + (peer-port-random-on-start? + (boolean #f) + "If @code{#t}, when the daemon starts it will select a port at random on +which to listen for peer connections, from the range specified (inclusively) +by @code{peer-port-random-low} and @code{peer-port-random-high}. Otherwise, +it listens on the port specified by @code{peer-port}.") + (peer-port-random-low + (port-number 49152) + "The lowest selectable port number when @code{peer-port-random-on-start?} +is @code{#t}.") + (peer-port-random-high + (port-number 65535) + "The highest selectable port number when @code{peer-port-random-on-start} +is @code{#t}.") + (peer-port + (port-number 51413) + "The port on which to listen for peer connections when +@code{peer-port-random-on-start?} is @code{#f}.") + (port-forwarding-enabled? + (boolean #t) + "If @code{#t}, the daemon will attempt to configure port-forwarding on an +upstream gateway automatically using @acronym{UPnP} and @acronym{NAT-PMP}.") + (encryption + (encryption-mode 'prefer-encrypted-connections) + "The encryption preference for peer connections, one of +@code{prefer-unencrypted-connections}, @code{prefer-encrypted-connections} or +@code{require-encrypted-connections}.") + (peer-congestion-algorithm + (maybe-string 'disabled) + "The TCP congestion-control algorithm to use for peer connections, +specified using a string recognized by the operating system in calls to +@code{setsockopt} (or set to @code{disabled}, in which case the +operating-system default is used). + +Note that on GNU/Linux systems, the kernel must be configured to allow +processes to use a congestion-control algorithm not in the default set; +otherwise, it will deny these requests with ``Operation not permitted''. To +see which algorithms are available on your system and which are currently +permitted for use, look at the contents of the files +@file{tcp_available_congestion_control} and +@file{tcp_allowed_congestion_control} in the @file{/proc/sys/net/ipv4} +directory. + +As an example, to have Transmission Daemon use +@uref{http://www-ece.rice.edu/networks/TCP-LP/, the TCP Low Priority +congestion-control algorithm}, you'll need to modify your kernel configuration +to build in support for the algorithm, then update your operating-system +configuration to allow its use by adding a @code{sysctl-service-type} +service (or updating the existing one's configuration) with lines like the +following: + +@lisp +(service sysctl-service-type + (sysctl-configuration + (settings + (\"net.ipv4.tcp_allowed_congestion_control\" . + \"reno cubic lp\")))) +@end lisp + +The Transmission Daemon configuration can then be updated with + +@lisp +(peer-congestion-algorithm \"lp\") +@end lisp + +and the system reconfigured to have the changes take effect.") + (peer-socket-tos + (tcp-type-of-service 'default) + "The type of service to request in outgoing @acronym{TCP} packets, +one of @code{default}, @code{low-cost}, @code{throughput}, @code{low-delay} +and @code{reliability}.") + (peer-limit-global + (non-negative-integer 200) + "The global limit on the number of connected peers.") + (peer-limit-per-torrent + (non-negative-integer 50) + "The per-torrent limit on the number of connected peers.") + (upload-slots-per-torrent + (non-negative-integer 14) + "The maximum number of peers to which the daemon will upload data +simultaneously for each torrent.") + (peer-id-ttl-hours + (non-negative-integer 6) + "The maximum lifespan, in hours, of the peer ID associated with each public +torrent before it is regenerated.") + + ;; Peer blocklists. + (blocklist-enabled? + (boolean #f) + "When @code{#t}, the daemon will ignore peers mentioned in the blocklist it +has most recently downloaded from @code{blocklist-url}.") + (blocklist-url + (maybe-string 'disabled) + "The URL of a peer blocklist (in @acronym{P2P}-plaintext or eMule +@file{.dat} format) to be periodically downloaded and applied when +@code{blocklist-enabled?} is @code{#t}.") + + ;; Queueing. + (download-queue-enabled? + (boolean #t) + "If @code{#t}, the daemon will be limited to downloading at most +@code{download-queue-size} non-stalled torrents simultaneously.") + (download-queue-size + (non-negative-integer 5) + "The size of the daemon's download queue, which limits the number of +non-stalled torrents it will download at any one time when +@code{download-queue-enabled?} is @code{#t}.") + (seed-queue-enabled? + (boolean #f) + "If @code{#t}, the daemon will be limited to seeding at most +@code{seed-queue-size} non-stalled torrents simultaneously.") + (seed-queue-size + (non-negative-integer 10) + "The size of the daemon's seed queue, which limits the number of +non-stalled torrents it will seed at any one time when +@code{seed-queue-enabled?} is @code{#t}.") + (queue-stalled-enabled? + (boolean #t) + "When @code{#t}, the daemon will consider torrents for which it has not +shared data in the past @code{queue-stalled-minutes} minutes to be stalled and +not count them against its @code{download-queue-size} and +@code{seed-queue-size} limits.") + (queue-stalled-minutes + (non-negative-integer 30) + "The maximum period, in minutes, a torrent may be idle before it is +considered to be stalled, when @code{queue-stalled-enabled?} is @code{#t}.") + + ;; Seeding limits. + (ratio-limit-enabled? + (boolean #f) + "When @code{#t}, a torrent being seeded will automatically be paused once +it reaches the ratio specified by @code{ratio-limit}.") + (ratio-limit + (non-negative-rational 2.0) + "The ratio at which a torrent being seeded will be paused, when +@code{ratio-limit-enabled?} is @code{#t}.") + (idle-seeding-limit-enabled? + (boolean #f) + "When @code{#t}, a torrent being seeded will automatically be paused once +it has been idle for @code{idle-seeding-limit} minutes.") + (idle-seeding-limit + (non-negative-integer 30) + "The maximum period, in minutes, a torrent being seeded may be idle before +it is paused, when @code{idle-seeding-limit-enabled?} is @code{#t}.") + + ;; BitTorrent extensions. + (dht-enabled? + (boolean #t) + "Enable @uref{http://bittorrent.org/beps/bep_0005.html, the distributed +hash table (@acronym{DHT}) protocol}, which supports the use of trackerless +torrents.") + (lpd-enabled? + (boolean #f) + "Enable @url{https://en.wikipedia.org/wiki/Local_Peer_Discovery, local peer +discovery} (@acronym{LPD}), which allows the discovery of peers on the local +network and may reduce the amount of data sent over the public Internet.") + (pex-enabled? + (boolean #t) + "Enable @url{https://en.wikipedia.org/wiki/Peer_exchange, peer +exchange} (@acronym{PEX}), which reduces the daemon's reliance on external +trackers and may improve its performance.") + (utp-enabled? + (boolean #t) + "Enable @url{http://bittorrent.org/beps/bep_0029.html, the micro transport +protocol} (@acronym{uTP}), which aims to reduce the impact of BitTorrent +traffic on other users of the local network while maintaining full utilization +of the available bandwidth.") + + ;; Remote procedure call (RPC) interface. + (rpc-enabled? + (boolean #t) + "If @code{#t}, enable the remote procedure call (@acronym{RPC}) interface, +which allows remote control of the daemon via its Web interface, the +@command{transmission-remote} command-line client, and similar tools.") + (rpc-bind-address + (string "0.0.0.0") + "The IP address at which to listen for @acronym{RPC} connections, or +``0.0.0.0'' to listen at all available IP addresses.") + (rpc-port + (port-number 9091) + "The port on which to listen for @acronym{RPC} connections.") + (rpc-url + (string "/transmission/") + "The path prefix to use in the @acronym{RPC}-endpoint @acronym{URL}.") + (rpc-authentication-required? + (boolean #f) + "When @code{#t}, clients must authenticate (see @code{rpc-username} and +@code{rpc-password}) when using the @acronym{RPC} interface. Note this has +the side effect of disabling host-name whitelisting (see +@code{rpc-host-whitelist-enabled?}.") + (rpc-username + (maybe-string 'disabled) + "The username required by clients to access the @acronym{RPC} interface +when @code{rpc-authentication-required?} is @code{#t}.") + (rpc-password + (maybe-transmission-password-hash 'disabled) + "The password required by clients to access the @acronym{RPC} interface +when @code{rpc-authentication-required?} is @code{#t}. This must be specified +using a password hash in the format recognized by Transmission clients, either +copied from an existing @file{settings.json} file or generated using the +@code{transmission-password-hash} procedure.") + (rpc-whitelist-enabled? + (boolean #t) + "When @code{#t}, @acronym{RPC} requests will be accepted only when they +originate from an address specified in @code{rpc-whitelist}.") + (rpc-whitelist + (string-list '("127.0.0.1" "::1")) + "The list of IP and IPv6 addresses from which @acronym{RPC} requests will +be accepted when @code{rpc-whitelist-enabled?} is @code{#t}. Wildcards may be +specified using @samp{*}.") + (rpc-host-whitelist-enabled? + (boolean #t) + "When @code{#t}, @acronym{RPC} requests will be accepted only when they are +addressed to a host named in @code{rpc-host-whitelist}. Note that requests to +``localhost'' or ``localhost.'', or to a numeric address, are always accepted +regardless of these settings. + +Note also this functionality is disabled when +@code{rpc-authentication-required?} is @code{#t}.") + (rpc-host-whitelist + (string-list '()) + "The list of host names recognized by the @acronym{RPC} server when +@code{rpc-host-whitelist-enabled?} is @code{#t}.") + + ;; Miscellaneous. + (message-level + (message-level 'info) + "The minimum severity level of messages to be logged (to +@file{/var/log/transmission.log}) by the daemon, one of @code{none} (no +logging), @code{error}, @code{info} and @code{debug}.") + (start-added-torrents? + (boolean #t) + "When @code{#t}, torrents are started as soon as they are added; otherwise, +they are added in ``paused'' state.") + (script-torrent-done-enabled? + (boolean #f) + "When @code{#t}, the script specified by +@code{script-torrent-done-filename} will be invoked each time a torrent +completes.") + (script-torrent-done-filename + (maybe-file-object 'disabled) + "A file name or file-like object specifying a script to run each time a +torrent completes, when @code{script-torrent-done-enabled?} is @code{#t}.") + (scrape-paused-torrents-enabled? + (boolean #t) + "When @code{#t}, the daemon will scrape trackers for a torrent even when +the torrent is paused.") + (cache-size-mb + (non-negative-integer 4) + "The amount of memory, in megabytes, to allocate for the daemon's in-memory +cache. A larger value may increase performance by reducing the frequency of +disk I/O.") + (prefetch-enabled? + (boolean #t) + "When @code{#t}, the daemon will try to improve I/O performance by hinting +to the operating system which data is likely to be read next from disk to +satisfy requests from peers.")) + +(define (transmission-daemon-shepherd-service config) + "Return a <shepherd-service> for Transmission Daemon with CONFIG." + (let ((transmission + (transmission-daemon-configuration-transmission config)) + (stop-wait-period + (transmission-daemon-configuration-stop-wait-period config))) + (list + (shepherd-service + (provision '(transmission-daemon transmission bittorrent)) + (requirement '(networking)) + (documentation "Share files using the BitTorrent protocol.") + (start #~(make-forkexec-constructor + '(#$(file-append transmission "/bin/transmission-daemon") + "--config-dir" + #$%transmission-daemon-configuration-directory + "--foreground") + #:user #$%transmission-daemon-user + #:group #$%transmission-daemon-group + #:directory #$%transmission-daemon-configuration-directory + #:log-file #$%transmission-daemon-log-file + #:environment-variables + '("CURL_CA_BUNDLE=/etc/ssl/certs/ca-certificates.crt"))) + (stop #~(lambda (pid) + (kill pid SIGTERM) + + ;; Transmission Daemon normally needs some time to shut down, + ;; as it will complete some housekeeping and send a final + ;; update to trackers before it exits. + ;; + ;; Wait a reasonable period for it to stop before continuing. + ;; If we don't do this, restarting the service can fail as the + ;; new daemon process finds the old one still running and + ;; attached to the port used for peer connections. + (let wait-before-killing ((period #$stop-wait-period)) + (if (zero? (car (waitpid pid WNOHANG))) + (if (positive? period) + (begin + (sleep 1) + (wait-before-killing (- period 1))) + (begin + (format #t + #$(G_ "Wait period expired; killing \ +transmission-daemon (pid ~a).~%") + pid) + (display #$(G_ "(If you see this message \ +regularly, you may need to increase the value +of 'stop-wait-period' in the service configuration.)\n")) + (kill pid SIGKILL))))) + #f)) + (actions + (list + (shepherd-action + (name 'reload) + (documentation "Reload the settings file from disk.") + (procedure #~(lambda (pid) + (if pid + (begin + (kill pid SIGHUP) + (display #$(G_ "Service transmission-daemon has \ +been asked to reload its settings file."))) + (display #$(G_ "Service transmission-daemon is not \ +running.")))))))))))) + +(define %transmission-daemon-accounts + (list (user-group + (name %transmission-daemon-group) + (system? #t)) + (user-account + (name %transmission-daemon-user) + (group %transmission-daemon-group) + (comment "Transmission Daemon service account") + (home-directory %transmission-daemon-configuration-directory) + (shell (file-append shadow "/sbin/nologin")) + (system? #t)))) + +(define %transmission-daemon-log-rotations + (list (log-rotation + (files (list %transmission-daemon-log-file))))) + +(define (transmission-daemon-computed-settings-file config) + "Return a @code{computed-file} object that, when unquoted in a G-expression, +produces a Transmission settings file (@file{settings.json}) matching CONFIG." + (let ((settings + ;; "Serialize" the configuration settings as a list of G-expressions + ;; containing a name-value pair, which will ultimately be sorted and + ;; serialized to the settings file as a JSON object. + (map + (lambda (field) + ((configuration-field-serializer field) + (configuration-field-name field) + ((configuration-field-getter field) config))) + (filter + (lambda (field) + ;; Omit configuration fields that are used only internally by + ;; this service definition. + (not (memq (configuration-field-name field) + '(transmission stop-wait-period)))) + transmission-daemon-configuration-fields)))) + (computed-file + "settings.json" + (with-extensions (list guile-gcrypt guile-json-4) + (with-imported-modules (source-module-closure '((json builder))) + #~(begin + (use-modules (json builder)) + + (with-output-to-file #$output + (lambda () + (scm->json (sort-list '(#$@settings) + (lambda (x y) + (string<=? (car x) (car y)))) + #:pretty #t))))))))) + +(define (transmission-daemon-activation config) + "Return the Transmission Daemon activation GEXP for CONFIG." + (let ((config-dir %transmission-daemon-configuration-directory) + (incomplete-dir-enabled + (transmission-daemon-configuration-incomplete-dir-enabled? config)) + (incomplete-dir + (transmission-daemon-configuration-incomplete-dir config)) + (watch-dir-enabled + (transmission-daemon-configuration-watch-dir-enabled? config)) + (watch-dir + (transmission-daemon-configuration-watch-dir config))) + (with-imported-modules (source-module-closure '((guix build utils))) + #~(begin + (use-modules (guix build utils)) + + (let ((owner (getpwnam #$%transmission-daemon-user))) + (define (mkdir-p/perms directory perms) + (mkdir-p directory) + (chown directory (passwd:uid owner) (passwd:gid owner)) + (chmod directory perms)) + + ;; Create the directories Transmission Daemon is configured to use + ;; and assign them suitable permissions. + (for-each (lambda (directory-specification) + (apply mkdir-p/perms directory-specification)) + '(#$@(append + `((,config-dir #o750)) + (if incomplete-dir-enabled + `((,incomplete-dir #o750)) + '()) + (if watch-dir-enabled + `((,watch-dir #o770)) + '()))))) + + ;; Generate and activate the daemon's settings file, settings.json. + (activate-special-files + '((#$(string-append config-dir "/settings.json") + #$(transmission-daemon-computed-settings-file config)))))))) + +(define transmission-daemon-service-type + (service-type + (name 'transmission) + (extensions + (list (service-extension shepherd-root-service-type + transmission-daemon-shepherd-service) + (service-extension account-service-type + (const %transmission-daemon-accounts)) + (service-extension rottlog-service-type + (const %transmission-daemon-log-rotations)) + (service-extension activation-service-type + transmission-daemon-activation))) + (default-value (transmission-daemon-configuration)) + (description "Share files using the BitTorrent protocol."))) + +(define (generate-transmission-daemon-documentation) + (generate-documentation + `((transmission-daemon-configuration + ,transmission-daemon-configuration-fields)) + 'transmission-daemon-configuration)) diff --git a/gnu/services/guix.scm b/gnu/services/guix.scm index 88d23f746a..d1d31febdc 100644 --- a/gnu/services/guix.scm +++ b/gnu/services/guix.scm @@ -55,14 +55,32 @@ guix-build-coordinator-agent-configuration-package guix-build-coordinator-agent-configuration-user guix-build-coordinator-agent-configuration-coordinator - guix-build-coordinator-agent-configuration-uuid - guix-build-coordinator-agent-configuration-password - guix-build-coordinator-agent-configuration-password-file + guix-build-coordinator-agent-configuration-authentication guix-build-coordinator-agent-configuration-systems guix-build-coordinator-agent-configuration-max-parallel-builds guix-build-coordinator-agent-configuration-derivation-substitute-urls guix-build-coordinator-agent-configuration-non-derivation-substitute-urls + guix-build-coordinator-agent-password-auth + guix-build-coordinator-agent-password-auth? + guix-build-coordinator-agent-password-auth-uuid + guix-build-coordinator-agent-password-auth-password + + guix-build-coordinator-agent-password-file-auth + guix-build-coordinator-agent-password-file-auth? + guix-build-coordinator-agent-password-file-auth-uuid + guix-build-coordinator-agent-password-file-auth-password-file + + guix-build-coordinator-agent-dynamic-auth + guix-build-coordinator-agent-dynamic-auth? + guix-build-coordinator-agent-dynamic-auth-agent-name + guix-build-coordinator-agent-dynamic-auth-token + + guix-build-coordinator-agent-dynamic-auth-with-file + guix-build-coordinator-agent-dynamic-auth-with-file? + guix-build-coordinator-agent-dynamic-auth-with-file-agent-name + guix-build-coordinator-agent-dynamic-auth-with-file-token-file + guix-build-coordinator-agent-service-type guix-build-coordinator-queue-builds-configuration @@ -132,11 +150,7 @@ (default "guix-build-coordinator-agent")) (coordinator guix-build-coordinator-agent-configuration-coordinator (default "http://localhost:8745")) - (uuid guix-build-coordinator-agent-configuration-uuid) - (password guix-build-coordinator-agent-configuration-password - (default #f)) - (password-file guix-build-coordinator-agent-configuration-password-file - (default #f)) + (authentication guix-build-coordinator-agent-configuration-authentication) (systems guix-build-coordinator-agent-configuration-systems (default #f)) (max-parallel-builds @@ -149,6 +163,35 @@ guix-build-coordinator-agent-configuration-non-derivation-substitute-urls (default #f))) +(define-record-type* <guix-build-coordinator-agent-password-auth> + guix-build-coordinator-agent-password-auth + make-guix-build-coordinator-agent-password-auth + guix-build-coordinator-agent-password-auth? + (uuid guix-build-coordinator-agent-password-auth-uuid) + (password guix-build-coordinator-agent-password-auth-password)) + +(define-record-type* <guix-build-coordinator-agent-password-file-auth> + guix-build-coordinator-agent-password-file-auth + make-guix-build-coordinator-agent-password-file-auth + guix-build-coordinator-agent-password-file-auth? + (uuid guix-build-coordinator-agent-password-file-auth-uuid) + (password-file + guix-build-coordinator-agent-password-file-auth-password-file)) + +(define-record-type* <guix-build-coordinator-agent-dynamic-auth> + guix-build-coordinator-agent-dynamic-auth + make-guix-build-coordinator-agent-dynamic-auth + guix-build-coordinator-agent-dynamic-auth? + (agent-name guix-build-coordinator-agent-dynamic-auth-agent-name) + (token guix-build-coordinator-agent-dynamic-auth-token)) + +(define-record-type* <guix-build-coordinator-agent-dynamic-auth-with-file> + guix-build-coordinator-agent-dynamic-auth-with-file + make-guix-build-coordinator-agent-dynamic-auth-with-file + guix-build-coordinator-agent-dynamic-auth-with-file? + (agent-name guix-build-coordinator-agent-dynamic-auth-with-file-agent-name) + (token-file guix-build-coordinator-agent-dynamic-auth-with-file-token-file)) + (define-record-type* <guix-build-coordinator-queue-builds-configuration> guix-build-coordinator-queue-builds-configuration make-guix-build-coordinator-queue-builds-configuration @@ -326,7 +369,7 @@ (define (guix-build-coordinator-agent-shepherd-services config) (match-record config <guix-build-coordinator-agent-configuration> - (package user coordinator uuid password password-file max-parallel-builds + (package user coordinator authentication max-parallel-builds derivation-substitute-urls non-derivation-substitute-urls systems) (list @@ -337,13 +380,26 @@ (start #~(make-forkexec-constructor (list #$(file-append package "/bin/guix-build-coordinator-agent") #$(string-append "--coordinator=" coordinator) - #$(string-append "--uuid=" uuid) - #$@(if password - #~(#$(string-append "--password=" password)) - #~()) - #$@(if password-file - #~(#$(string-append "--password-file=" password-file)) - #~()) + #$@(match authentication + (($ <guix-build-coordinator-agent-password-auth> + uuid password) + #~(#$(string-append "--uuid=" uuid) + #$(string-append "--password=" password))) + (($ <guix-build-coordinator-agent-password-file-auth> + uuid password-file) + #~(#$(string-append "--uuid=" uuid) + #$(string-append "--password-file=" + password-file))) + (($ <guix-build-coordinator-agent-dynamic-auth> + agent-name token) + #~(#$(string-append "--name=" agent-name) + #$(string-append "--dynamic-auth-token=" token))) + (($ + <guix-build-coordinator-agent-dynamic-auth-with-file> + agent-name token-file) + #~(#$(string-append "--name=" agent-name) + #$(string-append "--dynamic-auth-token-file=" + token-file)))) #$(simple-format #f "--max-parallel-builds=~A" max-parallel-builds) #$@(if derivation-substitute-urls diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm index a4d4ac0646..231a9f66c7 100644 --- a/gnu/services/networking.scm +++ b/gnu/services/networking.scm @@ -15,6 +15,7 @@ ;;; Copyright © 2019 Alex Griffin <a@ajgrf.com> ;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re> ;;; Copyright © 2021 Oleg Pykhalov <go.wigust@gmail.com> +;;; Copyright © 2021 Christopher Lemmer Webber <cwebber@dustycloud.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -744,7 +745,9 @@ demand."))) (hidden-services tor-configuration-hidden-services (default '())) (socks-socket-type tor-configuration-socks-socket-type ; 'tcp or 'unix - (default 'tcp))) + (default 'tcp)) + (control-socket? tor-control-socket-path + (default #f))) (define %tor-accounts ;; User account and groups for Tor. @@ -766,7 +769,8 @@ demand."))) (define (tor-configuration->torrc config) "Return a 'torrc' file for CONFIG." (match config - (($ <tor-configuration> tor config-file services socks-socket-type) + (($ <tor-configuration> tor config-file services + socks-socket-type control-socket?) (computed-file "torrc" (with-imported-modules '((guix build utils)) @@ -786,6 +790,11 @@ Log notice syslog\n" port) (display "\ SocksPort unix:/var/run/tor/socks-sock UnixSocksGroupWritable 1\n" port)) + (when #$control-socket? + (display "\ +ControlSocket unix:/var/run/tor/control-sock GroupWritable RelaxDirModeCheck +ControlSocketsGroupWritable 1\n" + port)) (for-each (match-lambda ((service (ports hosts) ...) diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm index e2ec59f5aa..7277273686 100644 --- a/gnu/services/shepherd.scm +++ b/gnu/services/shepherd.scm @@ -73,7 +73,9 @@ shepherd-service-back-edges shepherd-service-upgrade - user-processes-service-type)) + user-processes-service-type + + assert-valid-graph)) ;;; Commentary: ;;; @@ -97,7 +99,11 @@ #~(begin ;; Keep track of the booted system. (false-if-exception (delete-file "/run/booted-system")) - (symlink (readlink "/run/current-system") + + ;; Make /run/booted-system, an indirect GC root, point to the store item + ;; /run/current-system points to. Use 'canonicalize-path' rather than + ;; 'readlink' to make sure we get the store item. + (symlink (canonicalize-path "/run/current-system") "/run/booted-system") ;; Close any remaining open file descriptors to be on the safe diff --git a/gnu/services/sysctl.scm b/gnu/services/sysctl.scm index eb7a61b2a9..aaea7cc30d 100644 --- a/gnu/services/sysctl.scm +++ b/gnu/services/sysctl.scm @@ -25,20 +25,26 @@ #:use-module (srfi srfi-1) #:use-module (ice-9 match) #:export (sysctl-configuration - sysctl-service-type)) + sysctl-service-type + %default-sysctl-settings)) ;;; ;;; System Control Service. ;;; +(define %default-sysctl-settings + ;; Default kernel parameters enabled with sysctl. + '(("fs.protected_hardlinks" . "1") + ("fs.protected_symlinks" . "1"))) + (define-record-type* <sysctl-configuration> sysctl-configuration make-sysctl-configuration sysctl-configuration? (sysctl sysctl-configuration-sysctl ; path of the 'sysctl' command (default (file-append procps "/sbin/sysctl"))) (settings sysctl-configuration-settings ; alist of string pairs - (default '()))) + (default %default-sysctl-settings))) (define (sysctl-configuration-settings->sysctl.conf settings) "Return a file for @command{sysctl} to set kernel parameters as specified by diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm index a45da14a80..36e9feb05c 100644 --- a/gnu/services/virtualization.scm +++ b/gnu/services/virtualization.scm @@ -554,13 +554,14 @@ potential infinite waits blocking libvirt.")) ;;; ;; Platforms that QEMU can emulate. -(define-record-type <qemu-platform> - (qemu-platform name family magic mask) +(define-record-type* <qemu-platform> + qemu-platform make-qemu-platform qemu-platform? (name qemu-platform-name) ;string (family qemu-platform-family) ;string (magic qemu-platform-magic) ;bytevector - (mask qemu-platform-mask)) ;bytevector + (mask qemu-platform-mask) ;bytevector + (flags qemu-platform-flags (default "F"))) ;string (define-syntax bv (lambda (s) @@ -577,125 +578,173 @@ potential infinite waits blocking libvirt.")) ;;; 'scripts/qemu-binfmt-conf.sh' in QEMU. (define %i386 - (qemu-platform "i386" "i386" - (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x03\x00") - (bv "\xff\xff\xff\xff\xff\xfe\xfe\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))) + (qemu-platform + (name "i386") + (family "i386") + (magic (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x03\x00")) + (mask (bv "\xff\xff\xff\xff\xff\xfe\xfe\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))) (define %i486 - (qemu-platform "i486" "i386" - (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x06\x00") - (bv "\xff\xff\xff\xff\xff\xfe\xfe\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))) + (qemu-platform + (name "i486") + (family "i386") + (magic (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x06\x00")) + (mask (bv "\xff\xff\xff\xff\xff\xfe\xfe\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))) (define %alpha - (qemu-platform "alpha" "alpha" - (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x26\x90") - (bv "\xff\xff\xff\xff\xff\xfe\xfe\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))) + (qemu-platform + (name "alpha") + (family "alpha") + (magic (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x26\x90")) + (mask (bv "\xff\xff\xff\xff\xff\xfe\xfe\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))) (define %arm - (qemu-platform "arm" "arm" - (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x28\x00") - (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))) + (qemu-platform + (name "arm") + (family "arm") + (magic (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x28\x00")) + (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))) (define %armeb - (qemu-platform "armeb" "arm" - (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x28") - (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))) + (qemu-platform + (name "armeb") + (family "arm") + (magic (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x28")) + (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))) (define %sparc - (qemu-platform "sparc" "sparc" - (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x02") - (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))) + (qemu-platform + (name "sparc") + (family "sparc") + (magic (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x02")) + (mask (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))) (define %sparc32plus - (qemu-platform "sparc32plus" "sparc" - (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x12") - (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))) + (qemu-platform + (name "sparc32plus") + (family "sparc") + (magic (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x12")) + (mask (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))) (define %ppc - (qemu-platform "ppc" "ppc" - (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x14") - (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))) + (qemu-platform + (name "ppc") + (family "ppc") + (magic (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x14")) + (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))) (define %ppc64 - (qemu-platform "ppc64" "ppc" - (bv "\x7fELF\x02\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x15") - (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))) + (qemu-platform + (name "ppc64") + (family "ppc") + (magic (bv "\x7fELF\x02\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x15")) + (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))) (define %ppc64le - (qemu-platform "ppc64le" "ppcle" - (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x15\x00") - (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\x00"))) + (qemu-platform + (name "ppc64le") + (family "ppcle") + (magic (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x15\x00")) + (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\x00")))) (define %m68k - (qemu-platform "m68k" "m68k" - (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x04") - (bv "\xff\xff\xff\xff\xff\xff\xfe\xfe\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))) + (qemu-platform + (name "m68k") + (family "m68k") + (magic (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x04")) + (mask (bv "\xff\xff\xff\xff\xff\xff\xfe\xfe\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))) ;; XXX: We could use the other endianness on a MIPS host. (define %mips - (qemu-platform "mips" "mips" - (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08") - (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))) + (qemu-platform + (name "mips") + (family "mips") + (magic (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08")) + (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))) (define %mipsel - (qemu-platform "mipsel" "mips" - (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08\x00") - (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))) + (qemu-platform + (name "mipsel") + (family "mips") + (magic (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08\x00")) + (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))) (define %mipsn32 - (qemu-platform "mipsn32" "mips" - (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08") - (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))) + (qemu-platform + (name "mipsn32") + (family "mips") + (magic (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08")) + (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))) (define %mipsn32el - (qemu-platform "mipsn32el" "mips" - (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08\x00") - (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))) + (qemu-platform + (name "mipsn32el") + (family "mips") + (magic (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08\x00")) + (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))) (define %mips64 - (qemu-platform "mips64" "mips" - (bv "\x7fELF\x02\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08") - (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))) + (qemu-platform + (name "mips64") + (family "mips") + (magic (bv "\x7fELF\x02\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08")) + (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))) (define %mips64el - (qemu-platform "mips64el" "mips" - (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08\x00") - (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))) + (qemu-platform + (name "mips64el") + (family "mips") + (magic (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08\x00")) + (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))) (define %riscv32 - (qemu-platform "riscv32" "riscv" - (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\xf3\x00") - (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))) + (qemu-platform + (name "riscv32") + (family "riscv") + (magic (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\xf3\x00")) + (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))) (define %riscv64 - (qemu-platform "riscv64" "riscv" - (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\xf3\x00") - (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))) + (qemu-platform + (name "riscv64") + (family "riscv") + (magic (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\xf3\x00")) + (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))) (define %sh4 - (qemu-platform "sh4" "sh4" - (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x2a\x00") - (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))) + (qemu-platform + (name "sh4") + (family "sh4") + (magic (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x2a\x00")) + (mask (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))) (define %sh4eb - (qemu-platform "sh4eb" "sh4" - (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x2a") - (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))) + (qemu-platform + (name "sh4eb") + (family "sh4") + (magic (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x2a")) + (mask (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))) (define %s390x - (qemu-platform "s390x" "s390x" - (bv "\x7fELF\x02\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x16") - (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))) + (qemu-platform + (name "s390x") + (family "s390x") + (magic (bv "\x7fELF\x02\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x16")) + (mask (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))) (define %aarch64 - (qemu-platform "aarch64" "arm" - (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\xb7\x00") - (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))) + (qemu-platform + (name "aarch64") + (family "arm") + (magic (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\xb7\x00")) + (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff")))) (define %hppa - (qemu-platform "hppa" "hppa" - (bv "\x7f\x45\x4c\x46\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x0f") - (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))) + (qemu-platform + (name "hppa") + (family "hppa") + (magic (bv "\x7f\x45\x4c\x46\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x0f")) + (mask (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff")))) (define %qemu-platforms (list %i386 %i486 %alpha %arm %sparc32plus %ppc %ppc64 %ppc64le %m68k @@ -715,9 +764,7 @@ potential infinite waits blocking libvirt.")) (qemu qemu-binfmt-configuration-qemu (default qemu)) (platforms qemu-binfmt-configuration-platforms - (default '())) ;safest default - (guix-support? qemu-binfmt-configuration-guix-support? - (default #t))) + (default '()))) ;safest default (define (qemu-platform->binfmt qemu platform) "Return a gexp that evaluates to a binfmt string for PLATFORM, using the @@ -733,14 +780,13 @@ given QEMU package." (bytevector->u8-list bv)))) (match platform - (($ <qemu-platform> name family magic mask) + (($ <qemu-platform> name family magic mask flags) ;; See 'Documentation/binfmt_misc.txt' in the kernel. #~(string-append ":qemu-" #$name ":M::" #$(bytevector->binfmt-string magic) ":" #$(bytevector->binfmt-string mask) - ":" #$(file-append qemu "/bin/qemu-" name) - ":" ;FLAGS go here - )))) + ":" #$qemu:static "/bin/qemu-" #$name + ":" #$flags)))) (define %binfmt-mount-point (file-system-mount-point %binary-format-file-system)) @@ -779,19 +825,6 @@ given QEMU package." '#$(map qemu-platform-name platforms)) #f))))))) -(define qemu-binfmt-guix-chroot - (match-lambda - ;; Add QEMU and its dependencies to the guix-daemon chroot so that our - ;; binfmt_misc handlers work in the chroot (otherwise 'execve' would fail - ;; with ENOENT.) - ;; - ;; The 'F' flag of binfmt_misc is meant to address this problem by loading - ;; the interpreter upfront rather than lazily, but apparently that is - ;; insufficient (perhaps it loads the 'qemu-ARCH' binary upfront but looks - ;; up its dependencies lazily?). - (($ <qemu-binfmt-configuration> qemu platforms guix?) - (if guix? (list qemu) '())))) - (define qemu-binfmt-service-type ;; TODO: Make a separate binfmt_misc service out of this? (service-type (name 'qemu-binfmt) @@ -800,9 +833,7 @@ given QEMU package." (const (list %binary-format-file-system))) (service-extension shepherd-root-service-type - qemu-binfmt-shepherd-services) - (service-extension guix-service-type - qemu-binfmt-guix-chroot))) + qemu-binfmt-shepherd-services))) (default-value (qemu-binfmt-configuration)) (description "This service supports transparent emulation of binaries diff --git a/gnu/services/vpn.scm b/gnu/services/vpn.scm index 70f2617c7e..3e315a6df2 100644 --- a/gnu/services/vpn.scm +++ b/gnu/services/vpn.scm @@ -40,7 +40,24 @@ openvpn-remote-configuration openvpn-ccd-configuration generate-openvpn-client-documentation - generate-openvpn-server-documentation)) + generate-openvpn-server-documentation + + wireguard-peer + wireguard-peer? + wireguard-peer-name + wireguard-peer-endpoint + wireguard-peer-allowed-ips + + wireguard-configuration + wireguard-configuration? + wireguard-configuration-wireguard + wireguard-configuration-interface + wireguard-configuration-addresses + wireguard-configuration-port + wireguard-configuration-private-key + wireguard-configuration-peers + + wireguard-service-type)) ;;; ;;; OpenVPN. @@ -507,3 +524,122 @@ is truncated and rewritten every minute.") (remote openvpn-remote-configuration)) (openvpn-remote-configuration ,openvpn-remote-configuration-fields)) 'openvpn-client-configuration)) + + +;;; +;;; Wireguard. +;;; + +(define-record-type* <wireguard-peer> + wireguard-peer make-wireguard-peer + wireguard-peer? + (name wireguard-peer-name) + (endpoint wireguard-peer-endpoint + (default #f)) ;string + (public-key wireguard-peer-public-key) ;string + (allowed-ips wireguard-peer-allowed-ips)) ;list of strings + +(define-record-type* <wireguard-configuration> + wireguard-configuration make-wireguard-configuration + wireguard-configuration? + (wireguard wireguard-configuration-wireguard ;<package> + (default wireguard-tools)) + (interface wireguard-configuration-interface ;string + (default "wg0")) + (addresses wireguard-configuration-addresses ;string + (default '("10.0.0.1/32"))) + (port wireguard-configuration-port ;integer + (default 51820)) + (private-key wireguard-configuration-private-key ;string + (default "/etc/wireguard/private.key")) + (peers wireguard-configuration-peers ;list of <wiregard-peer> + (default '()))) + +(define (wireguard-configuration-file config) + (define (peer->config peer) + (let ((name (wireguard-peer-name peer)) + (public-key (wireguard-peer-public-key peer)) + (endpoint (wireguard-peer-endpoint peer)) + (allowed-ips (wireguard-peer-allowed-ips peer))) + (format #f "[Peer] #~a +PublicKey = ~a +AllowedIPs = ~a +~a" + name + public-key + (string-join allowed-ips ",") + (if endpoint + (format #f "Endpoint = ~a\n" endpoint) + "\n")))) + + (match-record config <wireguard-configuration> + (wireguard interface addresses port private-key peers) + (let* ((config-file (string-append interface ".conf")) + (peers (map peer->config peers)) + (config + (computed-file + "wireguard-config" + #~(begin + (mkdir #$output) + (chdir #$output) + (call-with-output-file #$config-file + (lambda (port) + (let ((format (@ (ice-9 format) format))) + (format port "[Interface] +Address = ~a +PostUp = ~a set %i private-key ~a +~a +~{~a~^~%~}" + #$(string-join addresses ",") + #$(file-append wireguard "/bin/wg") + #$private-key + #$(if port + (format #f "ListenPort = ~a" port) + "") + (list #$@peers))))))))) + (file-append config "/" config-file)))) + +(define (wireguard-activation config) + (match-record config <wireguard-configuration> + (private-key) + #~(begin + (use-modules (guix build utils) + (ice-9 popen) + (ice-9 rdelim)) + (mkdir-p (dirname #$private-key)) + (unless (file-exists? #$private-key) + (let* ((pipe + (open-input-pipe (string-append + #$(file-append wireguard-tools "/bin/wg") + " genkey"))) + (key (read-line pipe))) + (call-with-output-file #$private-key + (lambda (port) + (display key port))) + (chmod #$private-key #o400) + (close-pipe pipe)))))) + +(define (wireguard-shepherd-service config) + (match-record config <wireguard-configuration> + (wireguard interface) + (let ((wg-quick (file-append wireguard "/bin/wg-quick")) + (config (wireguard-configuration-file config))) + (list (shepherd-service + (requirement '(networking)) + (provision (list + (symbol-append 'wireguard- + (string->symbol interface)))) + (start #~(lambda _ + (invoke #$wg-quick "up" #$config))) + (stop #~(lambda _ + (invoke #$wg-quick "down" #$config))) + (documentation "Run the Wireguard VPN tunnel")))))) + +(define wireguard-service-type + (service-type + (name 'wireguard) + (extensions + (list (service-extension shepherd-root-service-type + wireguard-shepherd-service) + (service-extension activation-service-type + wireguard-activation))))) diff --git a/gnu/services/web.scm b/gnu/services/web.scm index ff7b262b6a..aa688a4328 100644 --- a/gnu/services/web.scm +++ b/gnu/services/web.scm @@ -14,7 +14,7 @@ ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> ;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net> ;;; Copyright © 2020 Oleg Pykhalov <go.wigust@gmail.com> -;;; Copyright © 2020 Alexandru-Sergiu Marton <brown121407@posteo.ro> +;;; Copyright © 2020, 2021 Alexandru-Sergiu Marton <brown121407@posteo.ro> ;;; ;;; This file is part of GNU Guix. ;;; @@ -50,6 +50,7 @@ #:use-module (gnu packages guile) #:use-module (gnu packages logging) #:use-module (gnu packages mail) + #:use-module (gnu packages rust-apps) #:use-module (guix packages) #:use-module (guix records) #:use-module (guix modules) @@ -263,7 +264,25 @@ gmnisrv-configuration-package gmnisrv-configuration-config-file - gmnisrv-service-type)) + gmnisrv-service-type + + agate-configuration + agate-configuration? + agate-configuration-package + agate-configuration-content + agate-configuration-cert + agate-configuration-key + agate-configuration-addr + agate-configuration-hostname + agate-configuration-lang + agate-configuration-silent + agate-configuration-serve-secret + agate-configuration-log-ip + agate-configuration-user + agate-configuration-group + agate-configuration-log-file + + agate-service-type)) ;;; Commentary: ;;; @@ -1885,3 +1904,92 @@ root=/srv/gemini "Run the gmnisrv Gemini server.") (default-value (gmnisrv-configuration)))) + +(define-record-type* <agate-configuration> + agate-configuration make-agate-configuration + agate-configuration? + (package agate-configuration-package + (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)) + (serve-secret? agate-configuration-serve-secret + (default #f)) + (log-ip? agate-configuration-log-ip + (default #t)) + (user agate-configuration-user + (default "agate")) + (group agate-configuration-group + (default "agate")) + (log-file agate-configuration-log + (default "/var/log/agate.log"))) + +(define agate-shepherd-service + (match-lambda + (($ <agate-configuration> package content cert key addr + hostname lang silent? serve-secret? + log-ip? user group log-file) + (list (shepherd-service + (provision '(agate)) + (requirement '(networking)) + (documentation "Run the agate Gemini server.") + (start (let ((agate (file-append package "/bin/agate"))) + #~(make-forkexec-constructor + (list #$agate + "--content" #$content + "--cert" #$cert + "--key" #$key + "--addr" #$@addr + #$@(if lang + (list "--lang" lang) + '()) + #$@(if hostname + (list "--hostname" hostname) + '()) + #$@(if silent? '("--silent") '()) + #$@(if serve-secret? '("--serve-secret") '()) + #$@(if log-ip? '("--log-ip") '())) + #:user #$user #:group #$group + #:log-file #$log-file))) + (stop #~(make-kill-destructor))))))) + +(define agate-accounts + (match-lambda + (($ <agate-configuration> _ _ _ _ _ + _ _ _ _ + _ user group _) + `(,@(if (equal? group "agate") + '() + (list (user-group (name "agate") (system? #t)))) + ,(user-group + (name group) + (system? #t)) + ,(user-account + (name user) + (group group) + (supplementary-groups '("agate")) + (system? #t) + (comment "agate server user") + (home-directory "/var/empty") + (shell (file-append shadow "/sbin/nologin"))))))) + +(define agate-service-type + (service-type + (name 'guix) + (extensions + (list (service-extension account-service-type + agate-accounts) + (service-extension shepherd-root-service-type + agate-shepherd-service))) + (default-value (agate-configuration)))) diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm index 4590709187..60611dc77d 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.scm @@ -45,6 +45,7 @@ #:use-module (gnu packages admin) #:use-module (gnu packages bash) #:use-module (gnu system shadow) + #:use-module (guix build-system trivial) #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix packages) @@ -70,6 +71,7 @@ xorg-wrapper xorg-start-command xinitrc + xorg-server-service-type %default-slim-theme %default-slim-theme-name @@ -483,6 +485,41 @@ a `service-extension', as used by `set-xorg-configuration'." (xorg-configuration xorg-configuration)) config))))))) +(define (xorg-server-profile-service config) + ;; XXX: profile-service-type only accepts <package> objects. + (list + (package + (name "xorg-wrapper") + (version (package-version xorg-server)) + (source (xorg-wrapper config)) + (build-system trivial-build-system) + (arguments + '(#:modules ((guix build utils)) + #:builder + (begin + (use-modules (guix build utils)) + (let* ((source (assoc-ref %build-inputs "source")) + (out (assoc-ref %outputs "out")) + (bin (string-append out "/bin"))) + (mkdir-p bin) + (symlink source (string-append bin "/X")) + (symlink source (string-append bin "/Xorg")) + #t)))) + (home-page (package-home-page xorg-server)) + (synopsis (package-synopsis xorg-server)) + (description (package-description xorg-server)) + (license (package-license xorg-server))))) + +(define xorg-server-service-type + (service-type + (name 'xorg-server) + (extensions + (list (service-extension profile-service-type + xorg-server-profile-service))) + (default-value (xorg-configuration)) + (description "Add @command{X} to the system profile, to be used with +@command{sx} or @command{xinit}."))) + ;;; ;;; SLiM log-in manager. |