diff options
Diffstat (limited to 'gnu/services')
| -rw-r--r-- | gnu/services/admin.scm | 171 | ||||
| -rw-r--r-- | gnu/services/audio.scm | 86 | ||||
| -rw-r--r-- | gnu/services/base.scm | 15 | ||||
| -rw-r--r-- | gnu/services/cuirass.scm | 11 | ||||
| -rw-r--r-- | gnu/services/databases.scm | 86 | ||||
| -rw-r--r-- | gnu/services/desktop.scm | 31 | ||||
| -rw-r--r-- | gnu/services/herd.scm | 42 | ||||
| -rw-r--r-- | gnu/services/networking.scm | 11 | ||||
| -rw-r--r-- | gnu/services/ssh.scm | 96 | ||||
| -rw-r--r-- | gnu/services/sysctl.scm | 2 | ||||
| -rw-r--r-- | gnu/services/virtualization.scm | 492 | ||||
| -rw-r--r-- | gnu/services/web.scm | 274 | ||||
| -rw-r--r-- | gnu/services/xorg.scm | 202 |
13 files changed, 1358 insertions, 161 deletions
diff --git a/gnu/services/admin.scm b/gnu/services/admin.scm index b9e3fa70a4..14452a86c7 100644 --- a/gnu/services/admin.scm +++ b/gnu/services/admin.scm @@ -20,14 +20,19 @@ (define-module (gnu services admin) #:use-module (gnu packages admin) #:use-module (gnu packages base) + #:use-module (gnu packages logging) #:use-module (gnu services) #:use-module (gnu services mcron) #:use-module (gnu services shepherd) + #:use-module (gnu services web) + #:use-module (gnu system shadow) #:use-module (guix gexp) + #:use-module (guix store) #:use-module (guix packages) #:use-module (guix records) #:use-module (srfi srfi-1) #:use-module (ice-9 vlist) + #:use-module (ice-9 match) #:export (%default-rotations %rotated-files @@ -41,7 +46,29 @@ rottlog-configuration rottlog-configuration? rottlog-service - rottlog-service-type)) + rottlog-service-type + + <tailon-configuration-file> + tailon-configuration-file + tailon-configuration-file? + tailon-configuration-file-files + tailon-configuration-file-bind + tailon-configuration-file-relative-root + tailon-configuration-file-allow-transfers? + tailon-configuration-file-follow-names? + tailon-configuration-file-tail-lines + tailon-configuration-file-allowed-commands + tailon-configuration-file-debug? + tailon-configuration-file-http-auth + tailon-configuration-file-users + + <tailon-configuration> + tailon-configuration + tailon-configuration? + tailon-configuration-config-file + tailon-configuration-package + + tailon-service-type)) ;;; Commentary: ;;; @@ -172,4 +199,146 @@ for ROTATION." rotations))))) (default-value (rottlog-configuration)))) + +;;; +;;; Tailon +;;; + +(define-record-type* <tailon-configuration-file> + tailon-configuration-file make-tailon-configuration-file + tailon-configuration-file? + (files tailon-configuration-file-files + (default '("/var/log"))) + (bind tailon-configuration-file-bind + (default "localhost:8080")) + (relative-root tailon-configuration-file-relative-root + (default #f)) + (allow-transfers? tailon-configuration-file-allow-transfers? + (default #t)) + (follow-names? tailon-configuration-file-follow-names? + (default #t)) + (tail-lines tailon-configuration-file-tail-lines + (default 200)) + (allowed-commands tailon-configuration-file-allowed-commands + (default '("tail" "grep" "awk"))) + (debug? tailon-configuration-file-debug? + (default #f)) + (wrap-lines tailon-configuration-file-wrap-lines + (default #t)) + (http-auth tailon-configuration-file-http-auth + (default #f)) + (users tailon-configuration-file-users + (default #f))) + +(define (tailon-configuration-files-string files) + (string-append + "\n" + (string-join + (map + (lambda (x) + (string-append + " - " + (cond + ((string? x) + (simple-format #f "'~A'" x)) + ((list? x) + (string-join + (cons (simple-format #f "'~A':" (car x)) + (map + (lambda (x) (simple-format #f " - '~A'" x)) + (cdr x))) + "\n")) + (else (error x))))) + files) + "\n"))) + +(define-gexp-compiler (tailon-configuration-file-compiler + (file <tailon-configuration-file>) system target) + (match file + (($ <tailon-configuration-file> files bind relative-root + allow-transfers? follow-names? + tail-lines allowed-commands debug? + wrap-lines http-auth users) + (text-file + "tailon-config.yaml" + (string-concatenate + (filter-map + (match-lambda + ((key . #f) #f) + ((key . value) (string-append key ": " value "\n"))) + + `(("files" . ,(tailon-configuration-files-string files)) + ("bind" . ,bind) + ("relative-root" . ,relative-root) + ("allow-transfers" . ,(if allow-transfers? "true" "false")) + ("follow-names" . ,(if follow-names? "true" "false")) + ("tail-lines" . ,(number->string tail-lines)) + ("commands" . ,(string-append "[" + (string-join allowed-commands ", ") + "]")) + ("debug" . ,(if debug? "true" #f)) + ("wrap-lines" . ,(if wrap-lines "true" "false")) + ("http-auth" . ,http-auth) + ("users" . ,(if users + (string-concatenate + (cons "\n" + (map (match-lambda + ((user . pass) + (string-append + " " user ":" pass))) + users))) + #f))))))))) + +(define-record-type* <tailon-configuration> + tailon-configuration make-tailon-configuration + tailon-configuration? + (config-file tailon-configuration-config-file + (default (tailon-configuration-file))) + (package tailon-configuration-package + (default tailon))) + +(define tailon-shepherd-service + (match-lambda + (($ <tailon-configuration> config-file package) + (list (shepherd-service + (provision '(tailon)) + (documentation "Run the tailon daemon.") + (start #~(make-forkexec-constructor + `(,(string-append #$package "/bin/tailon") + "-c" ,#$config-file) + #:user "tailon" + #:group "tailon")) + (stop #~(make-kill-destructor))))))) + +(define %tailon-accounts + (list (user-group (name "tailon") (system? #t)) + (user-account + (name "tailon") + (group "tailon") + (system? #t) + (comment "tailon") + (home-directory "/var/empty") + (shell (file-append shadow "/sbin/nologin"))))) + +(define tailon-service-type + (service-type + (name 'tailon) + (extensions + (list (service-extension shepherd-root-service-type + tailon-shepherd-service) + (service-extension account-service-type + (const %tailon-accounts)))) + (compose concatenate) + (extend (lambda (parameter files) + (tailon-configuration + (inherit parameter) + (config-file + (let ((old-config-file + (tailon-configuration-config-file parameter))) + (tailon-configuration-file + (inherit old-config-file) + (files (append (tailon-configuration-file-files old-config-file) + files)))))))) + (default-value (tailon-configuration)))) + ;;; admin.scm ends here diff --git a/gnu/services/audio.scm b/gnu/services/audio.scm new file mode 100644 index 0000000000..22814a6c09 --- /dev/null +++ b/gnu/services/audio.scm @@ -0,0 +1,86 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Peter Mikkelsen <petermikkelsen10@gmail.com> +;;; +;;; 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 audio) + #:use-module (guix gexp) + #:use-module (gnu services) + #:use-module (gnu services shepherd) + #:use-module (gnu packages mpd) + #:use-module (guix records) + #:use-module (ice-9 match) + #:export (mpd-configuration + mpd-configuration? + mpd-service-type)) + +;;; Commentary: +;;; +;;; Audio related services +;;; +;;; Code: + +(define-record-type* <mpd-configuration> + mpd-configuration make-mpd-configuration + mpd-configuration? + (user mpd-configuration-user + (default "mpd")) + (music-dir mpd-configuration-music-dir + (default "~/Music")) + (playlist-dir mpd-configuration-playlist-dir + (default "~/.mpd/playlists")) + (port mpd-configuration-port + (default "6600")) + (address mpd-configuration-address + (default "any")) + (pid-file mpd-configuration-pid-file + (default "/var/run/mpd.pid"))) + +(define (mpd-config->file config) + (apply + mixed-text-file "mpd.conf" + "audio_output {\n" + " type \"pulse\"\n" + " name \"MPD\"\n" + "}\n" + (map (match-lambda + ((config-name config-val) + (string-append config-name " \"" (config-val config) "\"\n"))) + `(("user" ,mpd-configuration-user) + ("music_directory" ,mpd-configuration-music-dir) + ("playlist_directory" ,mpd-configuration-playlist-dir) + ("port" ,mpd-configuration-port) + ("bind_to_address" ,mpd-configuration-address) + ("pid_file" ,mpd-configuration-pid-file))))) + +(define (mpd-service config) + (shepherd-service + (documentation "Run the MPD (Music Player Daemon)") + (provision '(mpd)) + (start #~(make-forkexec-constructor + (list #$(file-append mpd "/bin/mpd") + "--no-daemon" + #$(mpd-config->file config)) + #:pid-file #$(mpd-configuration-pid-file config))) + (stop #~(make-kill-destructor)))) + +(define mpd-service-type + (service-type + (name 'mpd) + (extensions + (list (service-extension shepherd-root-service-type + (compose list mpd-service)))) + (default-value (mpd-configuration)))) diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 813535ed65..54bd9ca2fb 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -37,7 +37,7 @@ #:use-module ((gnu packages linux) #:select (alsa-utils crda eudev e2fsprogs fuse gpm kbd lvm2 rng-tools)) #:use-module ((gnu packages base) - #:select (canonical-package glibc)) + #:select (canonical-package glibc glibc-utf8-locales)) #:use-module (gnu packages bash) #:use-module (gnu packages package-management) #:use-module (gnu packages linux) @@ -1220,6 +1220,9 @@ Service Switch}, for an example." # Don't log private authentication messages! *.info;mail.none;authpriv.none /var/log/messages + # Like /var/log/messages, but also including \"debug\"-level logs. + *.debug;mail.none;authpriv.none /var/log/debug + # Same, in a different place. *.info;mail.none;authpriv.none /dev/tty12 @@ -1499,7 +1502,15 @@ failed to register hydra.gnu.org public key: ~a~%" status)))))))) #~()) #$@(if cache #~((string-append "--cache=" #$cache)) - #~())))) + #~())) + + ;; Make sure we run in a UTF-8 locale so we can produce + ;; nars for packages that contain UTF-8 file names such + ;; as 'nss-certs'. See <https://bugs.gnu.org/26948>. + #:environment-variables + (list (string-append "GUIX_LOCPATH=" + #$glibc-utf8-locales "/lib/locale") + "LC_ALL=en_US.utf8"))) (stop #~(make-kill-destructor))))))) (define %guix-publish-accounts diff --git a/gnu/services/cuirass.scm b/gnu/services/cuirass.scm index 88a9a86111..73a30b2402 100644 --- a/gnu/services/cuirass.scm +++ b/gnu/services/cuirass.scm @@ -23,6 +23,7 @@ #:use-module (guix records) #:use-module (gnu packages admin) #:autoload (gnu packages ci) (cuirass) + #:autoload (gnu packages version-control) (git) #:use-module (gnu services) #:use-module (gnu services base) #:use-module (gnu services shepherd) @@ -66,6 +67,8 @@ (default #f)) (one-shot? cuirass-configuration-one-shot? ;boolean (default #f)) + (fallback? cuirass-configuration-fallback? ;boolean + (default #f)) (load-path cuirass-configuration-load-path (default '()))) @@ -84,6 +87,7 @@ (specs (cuirass-configuration-specifications config)) (use-substitutes? (cuirass-configuration-use-substitutes? config)) (one-shot? (cuirass-configuration-one-shot? config)) + (fallback? (cuirass-configuration-fallback? config)) (load-path (cuirass-configuration-load-path config))) (list (shepherd-service (documentation "Run Cuirass.") @@ -99,8 +103,15 @@ "--interval" #$(number->string interval) #$@(if use-substitutes? '("--use-substitutes") '()) #$@(if one-shot? '("--one-shot") '()) + #$@(if fallback? '("--fallback") '()) #$@(if (null? load-path) '() `("--load-path" ,(string-join load-path ":")))) + + #:environment-variables + (list "GIT_SSL_CAINFO=/etc/ssl/certs/ca-certificates.crt" + (string-append "GIT_EXEC_PATH=" #$git + "/libexec/git-core")) + #:user #$user #:group #$group #:log-file #$log-file)) diff --git a/gnu/services/databases.scm b/gnu/services/databases.scm index 3ecc8aff78..de1f6b8411 100644 --- a/gnu/services/databases.scm +++ b/gnu/services/databases.scm @@ -25,6 +25,7 @@ #:use-module (gnu system shadow) #:use-module (gnu packages admin) #:use-module (gnu packages databases) + #:use-module (guix modules) #:use-module (guix records) #:use-module (guix gexp) #:use-module (ice-9 match) @@ -33,6 +34,16 @@ postgresql-service postgresql-service-type + memcached-service-type + <memcached-configuration> + memcached-configuration + memcached-configuration? + memcached-configuration-memecached + memcached-configuration-interfaces + memcached-configuration-tcp-port + memcached-configuration-udp-port + memcached-configuration-additional-options + mysql-service mysql-service-type mysql-configuration @@ -178,6 +189,81 @@ and stores the database cluster in @var{data-directory}." ;;; +;;; Memcached +;;; + +(define-record-type* <memcached-configuration> + memcached-configuration make-memcached-configuration + memcached-configuration? + (memcached memcached-configuration-memcached ;<package> + (default memcached)) + (interfaces memcached-configuration-interfaces + (default '("0.0.0.0"))) + (tcp-port memcached-configuration-tcp-port + (default 11211)) + (udp-port memcached-configuration-udp-port + (default 11211)) + (additional-options memcached-configuration-additional-options + (default '()))) + +(define %memcached-accounts + (list (user-group (name "memcached") (system? #t)) + (user-account + (name "memcached") + (group "memcached") + (system? #t) + (comment "Memcached server user") + (home-directory "/var/empty") + (shell (file-append shadow "/sbin/nologin"))))) + +(define memcached-activation + #~(begin + (use-modules (guix build utils)) + (let ((user (getpwnam "memcached"))) + (mkdir-p "/var/run/memcached") + (chown "/var/run/memcached" + (passwd:uid user) (passwd:gid user))))) + +(define memcached-shepherd-service + (match-lambda + (($ <memcached-configuration> memcached interfaces tcp-port udp-port + additional-options) + (with-imported-modules (source-module-closure + '((gnu build shepherd))) + (list (shepherd-service + (provision '(memcached)) + (documentation "Run the Memcached daemon.") + (requirement '(user-processes loopback)) + (modules '((gnu build shepherd))) + (start #~(make-forkexec-constructor + `(#$(file-append memcached "/bin/memcached") + "-l" #$(string-join interfaces ",") + "-p" #$(number->string tcp-port) + "-U" #$(number->string udp-port) + "--daemon" + ;; Memcached changes to the memcached user prior to + ;; writing the pid file, so write it to a directory + ;; that memcached owns. + "-P" "/var/run/memcached/pid" + "-u" "memcached" + ,#$@additional-options) + #:log-file "/var/log/memcached" + #:pid-file "/var/run/memcached/pid")) + (stop #~(make-kill-destructor)))))))) + +(define memcached-service-type + (service-type (name 'memcached) + (extensions + (list (service-extension shepherd-root-service-type + memcached-shepherd-service) + (service-extension activation-service-type + (const memcached-activation)) + (service-extension account-service-type + (const %memcached-accounts)))) + (default-value (memcached-configuration)))) + + +;;; ;;; MySQL. ;;; diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm index 50a561bf51..0509bd8a44 100644 --- a/gnu/services/desktop.scm +++ b/gnu/services/desktop.scm @@ -73,6 +73,9 @@ elogind-service elogind-service-type + accountsservice-service-type + accountsservice-service + gnome-desktop-configuration gnome-desktop-configuration? gnome-desktop-service @@ -705,6 +708,33 @@ when they log out." ;;; +;;; AccountsService service. +;;; + +(define %accountsservice-activation + #~(begin + (use-modules (guix build utils)) + (mkdir-p "/var/lib/AccountsService"))) + +(define accountsservice-service-type + (service-type (name 'accountsservice) + (extensions + (list (service-extension activation-service-type + (const %accountsservice-activation)) + (service-extension dbus-root-service-type list) + (service-extension polkit-service-type list))))) + +(define* (accountsservice-service #:key (accountsservice accountsservice)) + "Return a service that runs AccountsService, a system service that +can list available accounts, change their passwords, and so on. +AccountsService integrates with PolicyKit to enable unprivileged users to +acquire the capability to modify their system configuration. +@uref{https://www.freedesktop.org/wiki/Software/AccountsService/, the +accountsservice web site} for more information." + (service accountsservice-service-type accountsservice)) + + +;;; ;;; GNOME desktop service. ;;; @@ -783,6 +813,7 @@ with the administrator's password." (wicd-service) (udisks-service) (upower-service) + (accountsservice-service) (colord-service) (geoclue-service) (polkit-service) diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm index f8d60a4802..5c894af6fd 100644 --- a/gnu/services/herd.scm +++ b/gnu/services/herd.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -49,7 +49,8 @@ unload-services unload-service load-services - start-service)) + start-service + stop-service)) ;;; Commentary: ;;; @@ -135,7 +136,8 @@ does not denote an error." (define* (invoke-action service action arguments cont) "Invoke ACTION on SERVICE with ARGUMENTS. On success, call CONT with the -result. Otherwise return #f." +list of results (one result per instance with the name SERVICE). Otherwise +return #f." (with-shepherd sock (write `(shepherd-command (version 0) (action ,action) @@ -146,7 +148,7 @@ result. Otherwise return #f." (force-output sock) (match (read sock) - (('reply ('version 0 _ ...) ('result (result)) ('error #f) + (('reply ('version 0 _ ...) ('result result) ('error #f) ('messages messages)) (for-each display-message messages) (cont result)) @@ -185,30 +187,34 @@ of pairs." "Return the list of currently defined Shepherd services, represented as <live-service> objects. Return #f if the list of services could not be obtained." - (with-shepherd-action 'root ('status) services - (match services - ((('service ('version 0 _ ...) _ ...) ...) - (map (lambda (service) - (alist-let* service (provides requires running) - (live-service provides requires running))) - services)) - (x - #f)))) + (with-shepherd-action 'root ('status) results + ;; We get a list of results, one for each service with the name 'root'. + ;; In practice there's only one such service though. + (match results + ((services _ ...) + (match services + ((('service ('version 0 _ ...) _ ...) ...) + (map (lambda (service) + (alist-let* service (provides requires running) + (live-service provides requires running))) + services)) + (x + #f)))))) (define (unload-service service) "Unload SERVICE, a symbol name; return #t on success." (with-shepherd-action 'root ('unload (symbol->string service)) result - result)) + (first result))) (define (%load-file file) "Load FILE in the Shepherd." (with-shepherd-action 'root ('load file) result - result)) + (first result))) (define (eval-there exp) "Eval EXP in the Shepherd." (with-shepherd-action 'root ('eval (object->string exp)) result - result)) + (first result))) (define (load-services files) "Load and register the services from FILES, where FILES contain code that @@ -222,6 +228,10 @@ returns a shepherd <service> object." (with-shepherd-action name ('start) result result)) +(define (stop-service name) + (with-shepherd-action name ('stop) result + result)) + ;; Local Variables: ;; eval: (put 'alist-let* 'scheme-indent-function 2) ;; eval: (put 'with-shepherd 'scheme-indent-function 1) diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm index c381581896..b45008de64 100644 --- a/gnu/services/networking.scm +++ b/gnu/services/networking.scm @@ -334,10 +334,13 @@ Protocol (DHCP) client, on all the non-loopback network interfaces." (service dhcp-client-service-type dhcp)) (define %ntp-servers - ;; Default set of NTP servers. - '("0.pool.ntp.org" - "1.pool.ntp.org" - "2.pool.ntp.org")) + ;; Default set of NTP servers. These URLs are managed by the NTP Pool project. + ;; Within Guix, Leo Famulari <leo@famulari.name> is the administrative contact + ;; for this NTP pool "zone". + '("0.guix.pool.ntp.org" + "1.guix.pool.ntp.org" + "2.guix.pool.ntp.org" + "3.guix.pool.ntp.org")) ;;; diff --git a/gnu/services/ssh.scm b/gnu/services/ssh.scm index 2a6c8d45c2..697bb1b82e 100644 --- a/gnu/services/ssh.scm +++ b/gnu/services/ssh.scm @@ -28,6 +28,8 @@ #:use-module (gnu system shadow) #:use-module (guix gexp) #:use-module (guix records) + #:use-module (guix modules) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:export (lsh-configuration @@ -295,7 +297,11 @@ The other options should be self-descriptive." (default #t)) ;; list of two-element lists (subsystems openssh-configuration-subsystems - (default '(("sftp" "internal-sftp"))))) + (default '(("sftp" "internal-sftp")))) + + ;; list of user-name/file-like tuples + (authorized-keys openssh-authorized-keys + (default '()))) (define %openssh-accounts (list (user-group (name "sshd") (system? #t)) @@ -309,22 +315,64 @@ The other options should be self-descriptive." (define (openssh-activation config) "Return the activation GEXP for CONFIG." - #~(begin - (use-modules (guix build utils)) - (mkdir-p "/etc/ssh") - (mkdir-p (dirname #$(openssh-configuration-pid-file config))) - - (define (touch file-name) - (call-with-output-file file-name (const #t))) - - (let ((lastlog "/var/log/lastlog")) - (when #$(openssh-configuration-print-last-log? config) - (unless (file-exists? lastlog) - (touch lastlog)))) - - ;; Generate missing host keys. - (system* (string-append #$(openssh-configuration-openssh config) - "/bin/ssh-keygen") "-A"))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + + (define (touch file-name) + (call-with-output-file file-name (const #t))) + + ;; Make sure /etc/ssh can be read by the 'sshd' user. + (mkdir-p "/etc/ssh") + (chmod "/etc/ssh" #o755) + (mkdir-p (dirname #$(openssh-configuration-pid-file config))) + + ;; 'sshd' complains if the authorized-key directory and its parents + ;; are group-writable, which rules out /gnu/store. Thus we copy the + ;; authorized-key directory to /etc. + (catch 'system-error + (lambda () + (delete-file-recursively "/etc/authorized_keys.d")) + (lambda args + (unless (= ENOENT (system-error-errno args)) + (apply throw args)))) + (copy-recursively #$(authorized-key-directory + (openssh-authorized-keys config)) + "/etc/ssh/authorized_keys.d") + + (chmod "/etc/ssh/authorized_keys.d" #o555) + + (let ((lastlog "/var/log/lastlog")) + (when #$(openssh-configuration-print-last-log? config) + (unless (file-exists? lastlog) + (touch lastlog)))) + + ;; Generate missing host keys. + (system* (string-append #$(openssh-configuration-openssh config) + "/bin/ssh-keygen") "-A")))) + +(define (authorized-key-directory keys) + "Return a directory containing the authorized keys specified in KEYS, a list +of user-name/file-like tuples." + (define build + (with-imported-modules (source-module-closure '((guix build utils))) + #~(begin + (use-modules (ice-9 match) (srfi srfi-26) + (guix build utils)) + + (mkdir #$output) + (for-each (match-lambda + ((user keys ...) + (let ((file (string-append #$output "/" user))) + (call-with-output-file file + (lambda (port) + (for-each (lambda (key) + (call-with-input-file key + (cut dump-port <> port))) + keys)))))) + '#$keys)))) + + (computed-file "openssh-authorized-keys" build)) (define (openssh-config-file config) "Return the sshd configuration file corresponding to CONFIG." @@ -367,6 +415,11 @@ The other options should be self-descriptive." (format port "PrintLastLog ~a\n" #$(if (openssh-configuration-print-last-log? config) "yes" "no")) + + ;; Add '/etc/authorized_keys.d/%u', which we populate. + (format port "AuthorizedKeysFile \ + .ssh/authorized_keys .ssh/authorized_keys2 /etc/ssh/authorized_keys.d/%u\n") + (for-each (match-lambda ((name command) (format port "Subsystem\t~a\t~a\n" name command))) @@ -398,6 +451,13 @@ The other options should be self-descriptive." #:allow-empty-passwords? (openssh-configuration-allow-empty-passwords? config)))) +(define (extend-openssh-authorized-keys config keys) + "Extend CONFIG with the extra authorized keys listed in KEYS." + (openssh-configuration + (inherit config) + (authorized-keys + (append (openssh-authorized-keys config) keys)))) + (define openssh-service-type (service-type (name 'openssh) (extensions @@ -409,6 +469,8 @@ The other options should be self-descriptive." openssh-activation) (service-extension account-service-type (const %openssh-accounts)))) + (compose concatenate) + (extend extend-openssh-authorized-keys) (default-value (openssh-configuration)))) diff --git a/gnu/services/sysctl.scm b/gnu/services/sysctl.scm index be5be59a05..5e9e6f0661 100644 --- a/gnu/services/sysctl.scm +++ b/gnu/services/sysctl.scm @@ -33,7 +33,7 @@ ;;; (define-record-type* <sysctl-configuration> - sysctl-configuration make-sysctl-configuration? + sysctl-configuration make-sysctl-configuration sysctl-configuration? (sysctl sysctl-configuration-sysctl ; path of the 'sysctl' command (default (file-append procps "/sbin/sysctl"))) diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm new file mode 100644 index 0000000000..845cdb07ba --- /dev/null +++ b/gnu/services/virtualization.scm @@ -0,0 +1,492 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ryan Moe <ryan.moe@gmail.com> +;;; +;;; 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 virtualization) + #:use-module (gnu services) + #:use-module (gnu services configuration) + #:use-module (gnu services base) + #:use-module (gnu services dbus) + #:use-module (gnu services shepherd) + #:use-module (gnu system shadow) + #:use-module (gnu packages admin) + #:use-module (gnu packages virtualization) + #:use-module (guix records) + #:use-module (guix gexp) + #:use-module (guix packages) + #:use-module (ice-9 match) + + #:export (libvirt-configuration + libvirt-service-type + virtlog-service-type)) + +(define (uglify-field-name field-name) + (let ((str (symbol->string field-name))) + (string-join + (string-split (string-delete #\? str) #\-) + "_"))) + +(define (quote-val val) + (string-append "\"" val "\"")) + +(define (serialize-field field-name val) + (format #t "~a = ~a\n" (uglify-field-name field-name) val)) + +(define (serialize-string field-name val) + (serialize-field field-name (quote-val val))) + +(define (serialize-boolean field-name val) + (serialize-field field-name (if val 1 0))) + +(define (serialize-integer field-name val) + (serialize-field field-name val)) + +(define (build-opt-list val) + (string-append + "[" + (string-join (map quote-val val) ",") + "]")) + +(define optional-list? list?) +(define optional-string? string?) + +(define (serialize-list field-name val) + (serialize-field field-name (build-opt-list val))) + +(define (serialize-optional-list field-name val) + (if (null? val) + (format #t "# ~a = []\n" (uglify-field-name field-name)) + (serialize-list field-name val))) + +(define (serialize-optional-string field-name val) + (if (string-null? val) + (format #t "# ~a = \"\"\n" (uglify-field-name field-name)) + (serialize-string field-name val))) + +(define-configuration libvirt-configuration + (libvirt + (package libvirt) + "Libvirt package.") + (listen-tls? + (boolean #t) + "Flag listening for secure TLS connections on the public TCP/IP port. +must set @code{listen} for this to have any effect. + +It is necessary to setup a CA and issue server certificates before +using this capability.") + (listen-tcp? + (boolean #f) + "Listen for unencrypted TCP connections on the public TCP/IP port. +must set @code{listen} for this to have any effect. + +Using the TCP socket requires SASL authentication by default. Only +SASL mechanisms which support data encryption are allowed. This is +DIGEST_MD5 and GSSAPI (Kerberos5)") + (tls-port + (string "16514") + "Port for accepting secure TLS connections This can be a port number, +or service name") + (tcp-port + (string "16509") + "Port for accepting insecure TCP connections This can be a port number, +or service name") + (listen-addr + (string "0.0.0.0") + "IP address or hostname used for client connections.") + (mdns-adv? + (boolean #f) + "Flag toggling mDNS advertisement of the libvirt service. + +Alternatively can disable for all services on a host by +stopping the Avahi daemon.") + (mdns-name + (string (string-append "Virtualization Host " (gethostname))) + "Default mDNS advertisement name. This must be unique on the +immediate broadcast network.") + (unix-sock-group + (string "root") + "UNIX domain socket group ownership. This can be used to +allow a 'trusted' set of users access to management capabilities +without becoming root.") + (unix-sock-ro-perms + (string "0777") + "UNIX socket permissions for the R/O socket. This is used +for monitoring VM status only.") + (unix-sock-rw-perms + (string "0770") + "UNIX socket permissions for the R/W socket. Default allows +only root. If PolicyKit is enabled on the socket, the default +will change to allow everyone (eg, 0777)") + (unix-sock-admin-perms + (string "0777") + "UNIX socket permissions for the admin socket. Default allows +only owner (root), do not change it unless you are sure to whom +you are exposing the access to.") + (unix-sock-dir + (string "/var/run/libvirt") + "The directory in which sockets will be found/created.") + (auth-unix-ro + (string "polkit") + "Authentication scheme for UNIX read-only sockets. By default +socket permissions allow anyone to connect") + (auth-unix-rw + (string "polkit") + "Authentication scheme for UNIX read-write sockets. By default +socket permissions only allow root. If PolicyKit support was compiled +into libvirt, the default will be to use 'polkit' auth.") + (auth-tcp + (string "sasl") + "Authentication scheme for TCP sockets. If you don't enable SASL, +then all TCP traffic is cleartext. Don't do this outside of a dev/test +scenario.") + (auth-tls + (string "none") + "Authentication scheme for TLS sockets. TLS sockets already have +encryption provided by the TLS layer, and limited authentication is +done by certificates. + +It is possible to make use of any SASL authentication mechanism as +well, by using 'sasl' for this option") + (access-drivers + (optional-list '()) + "API access control scheme. + +By default an authenticated user is allowed access to all APIs. Access +drivers can place restrictions on this.") + (key-file + (string "") + "Server key file path. If set to an empty string, then no private key +is loaded.") + (cert-file + (string "") + "Server key file path. If set to an empty string, then no certificate +is loaded.") + (ca-file + (string "") + "Server key file path. If set to an empty string, then no CA certificate +is loaded.") + (crl-file + (string "") + "Certificate revocation list path. If set to an empty string, then no +CRL is loaded.") + (tls-no-sanity-cert + (boolean #f) + "Disable verification of our own server certificates. + +When libvirtd starts it performs some sanity checks against its own +certificates.") + (tls-no-verify-cert + (boolean #f) + "Disable verification of client certificates. + +Client certificate verification is the primary authentication mechanism. +Any client which does not present a certificate signed by the CA +will be rejected.") + (tls-allowed-dn-list + (optional-list '()) + "Whitelist of allowed x509 Distinguished Name.") + (sasl-allowed-usernames + (optional-list '()) + "Whitelist of allowed SASL usernames. The format for username +depends on the SASL authentication mechanism.") + (tls-priority + (string "NORMAL") + "Override the compile time default TLS priority string. The +default is usually \"NORMAL\" unless overridden at build time. +Only set this is it is desired for libvirt to deviate from +the global default settings.") + (max-clients + (integer 5000) + "Maximum number of concurrent client connections to allow +over all sockets combined.") + (max-queued-clients + (integer 1000) + "Maximum length of queue of connections waiting to be +accepted by the daemon. Note, that some protocols supporting +retransmission may obey this so that a later reattempt at +connection succeeds.") + (max-anonymous-clients + (integer 20) + "Maximum length of queue of accepted but not yet authenticated +clients. Set this to zero to turn this feature off") + (min-workers + (integer 5) + "Number of workers to start up initially.") + (max-workers + (integer 20) + "Maximum number of worker threads. + +If the number of active clients exceeds @code{min-workers}, +then more threads are spawned, up to max_workers limit. +Typically you'd want max_workers to equal maximum number +of clients allowed.") + (prio-workers + (integer 5) + "Number of priority workers. If all workers from above +pool are stuck, some calls marked as high priority +(notably domainDestroy) can be executed in this pool.") + (max-requests + (integer 20) + "Total global limit on concurrent RPC calls.") + (max-client-requests + (integer 5) + "Limit on concurrent requests from a single client +connection. To avoid one client monopolizing the server +this should be a small fraction of the global max_requests +and max_workers parameter.") + (admin-min-workers + (integer 1) + "Same as @code{min-workers} but for the admin interface.") + (admin-max-workers + (integer 5) + "Same as @code{max-workers} but for the admin interface.") + (admin-max-clients + (integer 5) + "Same as @code{max-clients} but for the admin interface.") + (admin-max-queued-clients + (integer 5) + "Same as @code{max-queued-clients} but for the admin interface.") + (admin-max-client-requests + (integer 5) + "Same as @code{max-client-requests} but for the admin interface.") + (log-level + (integer 3) + "Logging level. 4 errors, 3 warnings, 2 information, 1 debug.") + (log-filters + (string "3:remote 4:event") + "Logging filters. + +A filter allows to select a different logging level for a given category +of logs +The format for a filter is one of: +@itemize +@item x:name + +@item x:+name +@end itemize + +where @code{name} is a string which is matched against the category +given in the @code{VIR_LOG_INIT()} at the top of each libvirt source +file, e.g., \"remote\", \"qemu\", or \"util.json\" (the name in the +filter can be a substring of the full category name, in order +to match multiple similar categories), the optional \"+\" prefix +tells libvirt to log stack trace for each message matching +name, and @code{x} is the minimal level where matching messages should +be logged: + +@itemize +@item 1: DEBUG +@item 2: INFO +@item 3: WARNING +@item 4: ERROR +@end itemize + +Multiple filters can be defined in a single filters statement, they just +need to be separated by spaces.") + (log-outputs + (string "3:stderr") + "Logging outputs. + +An output is one of the places to save logging information +The format for an output can be: + +@table @code +@item x:stderr +output goes to stderr + +@item x:syslog:name +use syslog for the output and use the given name as the ident + +@item x:file:file_path +output to a file, with the given filepath + +@item x:journald +output to journald logging system +@end table + +In all case the x prefix is the minimal level, acting as a filter + +@itemize +@item 1: DEBUG +@item 2: INFO +@item 3: WARNING +@item 4: ERROR +@end itemize + +Multiple outputs can be defined, they just need to be separated by spaces.") + (audit-level + (integer 1) + "Allows usage of the auditing subsystem to be altered + +@itemize +@item 0: disable all auditing +@item 1: enable auditing, only if enabled on host +@item 2: enable auditing, and exit if disabled on host. +@end itemize +") + (audit-logging + (boolean #f) + "Send audit messages via libvirt logging infrastructure.") + (host-uuid + (optional-string "") + "Host UUID. UUID must not have all digits be the same.") + (host-uuid-source + (string "smbios") + "Source to read host UUID. + +@itemize + +@item @code{smbios}: fetch the UUID from @code{dmidecode -s system-uuid} + +@item @code{machine-id}: fetch the UUID from @code{/etc/machine-id} + +@end itemize + +If @code{dmidecode} does not provide a valid UUID a temporary UUID +will be generated.") + (keepalive-interval + (integer 5) + "A keepalive message is sent to a client after +@code{keepalive_interval} seconds of inactivity to check if +the client is still responding. If set to -1, libvirtd will +never send keepalive requests; however clients can still send +them and the daemon will send responses.") + (keepalive-count + (integer 5) + "Maximum number of keepalive messages that are allowed to be sent +to the client without getting any response before the connection is +considered broken. + +In other words, the connection is automatically +closed approximately after +@code{keepalive_interval * (keepalive_count + 1)} seconds since the last +message received from the client. When @code{keepalive-count} is +set to 0, connections will be automatically closed after +@code{keepalive-interval} seconds of inactivity without sending any +keepalive messages.") + (admin-keepalive-interval + (integer 5) + "Same as above but for admin interface.") + (admin-keepalive-count + (integer 5) + "Same as above but for admin interface.") + (ovs-timeout + (integer 5) + "Timeout for Open vSwitch calls. + +The @code{ovs-vsctl} utility is used for the configuration and +its timeout option is set by default to 5 seconds to avoid +potential infinite waits blocking libvirt.")) + +(define* (libvirt-conf-file config) + "Return a libvirtd config file." + (plain-file "libvirtd.conf" + (with-output-to-string + (lambda () + (serialize-configuration config libvirt-configuration-fields))))) + +(define %libvirt-accounts + (list (user-group (name "libvirt") (system? #t)))) + +(define (%libvirt-activation config) + (let ((sock-dir (libvirt-configuration-unix-sock-dir config))) + #~(begin + (use-modules (guix build utils)) + (mkdir-p #$sock-dir)))) + + +(define (libvirt-shepherd-service config) + (let* ((config-file (libvirt-conf-file config)) + (libvirt (libvirt-configuration-libvirt config))) + (list (shepherd-service + (documentation "Run the libvirt daemon.") + (provision '(libvirtd)) + (start #~(make-forkexec-constructor + (list (string-append #$libvirt "/sbin/libvirtd") + "-f" #$config-file))) + (stop #~(make-kill-destructor)))))) + +(define libvirt-service-type + (service-type (name 'libvirt) + (extensions + (list + (service-extension polkit-service-type + (compose list libvirt-configuration-libvirt)) + (service-extension profile-service-type + (compose list + libvirt-configuration-libvirt)) + (service-extension activation-service-type + %libvirt-activation) + (service-extension shepherd-root-service-type + libvirt-shepherd-service) + (service-extension account-service-type + (const %libvirt-accounts)))) + (default-value (libvirt-configuration)))) + + +(define-record-type* <virtlog-configuration> + virtlog-configuration make-virtlog-configuration + virtlog-configuration? + (libvirt virtlog-configuration-libvirt + (default libvirt)) + (log-level virtlog-configuration-log-level + (default 3)) + (log-filters virtlog-configuration-log-filters + (default "3:remote 4:event")) + (log-outputs virtlog-configuration-log-outputs + (default "3:syslog:virtlogd")) + (max-clients virtlog-configuration-max-clients + (default 1024)) + (max-size virtlog-configuration-max-size + (default 2097152)) ;; 2MB + (max-backups virtlog-configuration-max-backups + (default 3))) + +(define* (virtlogd-conf-file config) + "Return a virtlogd config file." + (plain-file "virtlogd.conf" + (string-append + "log_level = " (number->string (virtlog-configuration-log-level config)) "\n" + "log_filters = \"" (virtlog-configuration-log-filters config) "\"\n" + "log_outputs = \"" (virtlog-configuration-log-outputs config) "\"\n" + "max_clients = " (number->string (virtlog-configuration-max-clients config)) "\n" + "max_size = " (number->string (virtlog-configuration-max-size config)) "\n" + "max_backups = " (number->string (virtlog-configuration-max-backups config)) "\n"))) + +(define (virtlogd-shepherd-service config) + (let* ((config-file (virtlogd-conf-file config)) + (libvirt (virtlog-configuration-libvirt config))) + (list (shepherd-service + (documentation "Run the virtlog daemon.") + (provision '(virtlogd)) + (start #~(make-forkexec-constructor + (list (string-append #$libvirt "/sbin/virtlogd") + "-f" #$config-file))) + (stop #~(make-kill-destructor)))))) + +(define virtlog-service-type + (service-type (name 'virtlogd) + (extensions + (list + (service-extension shepherd-root-service-type + virtlogd-shepherd-service))) + (default-value (virtlog-configuration)))) + +(define (generate-libvirt-documentation) + (generate-documentation + `((libvirt-configuration ,libvirt-configuration-fields)) + 'libvirt-configuration)) diff --git a/gnu/services/web.scm b/gnu/services/web.scm index f85b412159..18278502e4 100644 --- a/gnu/services/web.scm +++ b/gnu/services/web.scm @@ -30,18 +30,53 @@ #:use-module (guix gexp) #:use-module (srfi srfi-1) #:use-module (ice-9 match) - #:export (nginx-configuration + #:export (<nginx-configuration> + nginx-configuration nginx-configuration? + nginx-configuartion-nginx + nginx-configuration-log-directory + nginx-configuration-run-directory + nginx-configuration-server-blocks + nginx-configuration-upstream-blocks + nginx-configuration-file + + <nginx-server-configuration> nginx-server-configuration nginx-server-configuration? + nginx-server-configuration-http-port + nginx-server-configuartion-https-port + nginx-server-configuration-server-name + nginx-server-configuration-root + nginx-server-configuration-locations + nginx-server-configuration-index + nginx-server-configuration-ssl-certificate + nginx-server-configuration-ssl-certificate-key + nginx-server-configuration-server-tokens? + + <nginx-upstream-configuration> nginx-upstream-configuration nginx-upstream-configuration? + nginx-upstream-configuration-name + nginx-upstream-configuration-servers + + <nginx-location-configuration> nginx-location-configuration nginx-location-configuration? + nginx-location-configuration-uri + nginx-location-configuration-body + + <nginx-named-location-configuration> nginx-named-location-configuration nginx-named-location-configuration? + nginx-named-location-configuration-name + nginx-named-location-configuration-body + nginx-service - nginx-service-type)) + nginx-service-type + + fcgiwrap-configuration + fcgiwrap-configuration? + fcgiwrap-service-type)) ;;; Commentary: ;;; @@ -110,105 +145,109 @@ (define (config-domain-strings names) "Return a string denoting the nginx config representation of NAMES, a list of domain names." - (string-join - (map (match-lambda + (map (match-lambda ('default "_ ") - ((? string? str) (string-append str " "))) - names))) + ((? string? str) (list str " "))) + names)) (define (config-index-strings names) "Return a string denoting the nginx config representation of NAMES, a list of index files." - (string-join - (map (match-lambda - ((? string? str) (string-append str " "))) - names))) + (map (match-lambda + ((? string? str) (list str " "))) + names)) -(define nginx-location-config +(define emit-nginx-location-config (match-lambda (($ <nginx-location-configuration> uri body) - (string-append + (list " location " uri " {\n" - " " (string-join body "\n ") "\n" + (map (lambda (x) (list " " x "\n")) body) " }\n")) (($ <nginx-named-location-configuration> name body) - (string-append + (list " location @" name " {\n" - " " (string-join body "\n ") "\n" + (map (lambda (x) (list " " x "\n")) body) " }\n")))) -(define (default-nginx-server-config server) - (string-append - " server {\n" - (if (nginx-server-configuration-http-port server) - (string-append " listen " - (number->string (nginx-server-configuration-http-port server)) - ";\n") - "") - (if (nginx-server-configuration-https-port server) - (string-append " listen " - (number->string (nginx-server-configuration-https-port server)) - " ssl;\n") - "") - " server_name " (config-domain-strings - (nginx-server-configuration-server-name server)) - ";\n" - (if (nginx-server-configuration-ssl-certificate server) - (let ((certificate (nginx-server-configuration-ssl-certificate server))) - ;; lstat fails when the certificate file does not exist: it aborts - ;; and lets the user fix their configuration. - (lstat certificate) - (string-append " ssl_certificate " certificate ";\n")) - "") - (if (nginx-server-configuration-ssl-certificate-key server) - (let ((key (nginx-server-configuration-ssl-certificate-key server))) - (lstat key) - (string-append " ssl_certificate_key " key ";\n")) - "") - " 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" - (string-join - (map nginx-location-config (nginx-server-configuration-locations server)) - "\n") - " }\n")) +(define (emit-nginx-server-config server) + (let ((http-port (nginx-server-configuration-http-port server)) + (https-port (nginx-server-configuration-https-port server)) + (server-name (nginx-server-configuration-server-name server)) + (ssl-certificate (nginx-server-configuration-ssl-certificate server)) + (ssl-certificate-key + (nginx-server-configuration-ssl-certificate-key server)) + (root (nginx-server-configuration-root server)) + (index (nginx-server-configuration-index server)) + (server-tokens? (nginx-server-configuration-server-tokens? server)) + (locations (nginx-server-configuration-locations server))) + (define-syntax-parameter <> (syntax-rules ())) + (define-syntax-rule (and/l x tail ...) + (let ((x* x)) + (if x* + (syntax-parameterize ((<> (identifier-syntax x*))) + (list tail ...)) + '()))) + (for-each + (match-lambda + ((record-key . file) + (if (and file (not (file-exists? file))) + (error + (simple-format + #f + "~A in the nginx configuration for the server with name \"~A\" does not exist" record-key server-name))))) + `(("ssl-certificate" . ,ssl-certificate) + ("ssl-certificate-key" . ,ssl-certificate-key))) + (list + " server {\n" + (and/l http-port " listen " (number->string <>) ";\n") + (and/l https-port " listen " (number->string <>) " ssl;\n") + " server_name " (config-domain-strings server-name) ";\n" + (and/l ssl-certificate " ssl_certificate " <> ";\n") + (and/l ssl-certificate-key " ssl_certificate_key " <> ";\n") + " root " root ";\n" + " index " (config-index-strings index) ";\n" + " server_tokens " (if server-tokens? "on" "off") ";\n" + "\n" + (map emit-nginx-location-config locations) + "\n" + " }\n"))) -(define (nginx-upstream-config upstream) - (string-append +(define (emit-nginx-upstream-config upstream) + (list " upstream " (nginx-upstream-configuration-name upstream) " {\n" - (string-concatenate - (map (lambda (server) - (simple-format #f " server ~A;\n" server)) - (nginx-upstream-configuration-servers upstream))) + (map (lambda (server) + (simple-format #f " server ~A;\n" server)) + (nginx-upstream-configuration-servers upstream)) " }\n")) +(define (flatten . lst) + "Return a list that recursively concatenates all sub-lists of LST." + (define (flatten1 head out) + (if (list? head) + (fold-right flatten1 out head) + (cons head out))) + (fold-right flatten1 '() lst)) + (define (default-nginx-config nginx log-directory run-directory server-list upstream-list) - (mixed-text-file "nginx.conf" - "user nginx nginx;\n" - "pid " run-directory "/pid;\n" - "error_log " log-directory "/error.log info;\n" - "http {\n" - " client_body_temp_path " run-directory "/client_body_temp;\n" - " proxy_temp_path " run-directory "/proxy_temp;\n" - " fastcgi_temp_path " run-directory "/fastcgi_temp;\n" - " uwsgi_temp_path " run-directory "/uwsgi_temp;\n" - " scgi_temp_path " run-directory "/scgi_temp;\n" - " access_log " log-directory "/access.log;\n" - " include " nginx "/share/nginx/conf/mime.types;\n" - "\n" - (string-join - (filter (lambda (section) (not (null? section))) - (map nginx-upstream-config upstream-list)) - "\n") - "\n" - (let ((http (map default-nginx-server-config server-list))) - (do ((http http (cdr http)) - (block "" (string-append (car http) "\n" block ))) - ((null? http) block))) - "}\n" - "events {}\n")) + (apply mixed-text-file "nginx.conf" + (flatten + "user nginx nginx;\n" + "pid " run-directory "/pid;\n" + "error_log " log-directory "/error.log info;\n" + "http {\n" + " client_body_temp_path " run-directory "/client_body_temp;\n" + " proxy_temp_path " run-directory "/proxy_temp;\n" + " fastcgi_temp_path " run-directory "/fastcgi_temp;\n" + " uwsgi_temp_path " run-directory "/uwsgi_temp;\n" + " scgi_temp_path " run-directory "/scgi_temp;\n" + " access_log " log-directory "/access.log;\n" + " include " nginx "/share/nginx/conf/mime.types;\n" + "\n" + (map emit-nginx-upstream-config upstream-list) + (map emit-nginx-server-config server-list) + "}\n" + "events {}\n"))) (define %nginx-accounts (list (user-group (name "nginx") (system? #t)) @@ -285,23 +324,58 @@ of index files." (inherit config) (server-blocks (append (nginx-configuration-server-blocks config) - servers))))))) + servers))))) + (default-value + (nginx-configuration)))) + +(define-record-type* <fcgiwrap-configuration> fcgiwrap-configuration + make-fcgiwrap-configuration + fcgiwrap-configuration? + (package fcgiwrap-configuration-package ;<package> + (default fcgiwrap)) + (socket fcgiwrap-configuration-socket + (default "tcp:127.0.0.1:9000")) + (user fcgiwrap-configuration-user + (default "fcgiwrap")) + (group fcgiwrap-configuration-group + (default "fcgiwrap"))) -(define* (nginx-service #:key (nginx nginx) - (log-directory "/var/log/nginx") - (run-directory "/var/run/nginx") - (server-list '()) - (upstream-list '()) - (config-file #f)) - "Return a service that runs NGINX, the nginx web server. +(define fcgiwrap-accounts + (match-lambda + (($ <fcgiwrap-configuration> package socket user group) + (filter identity + (list + (and (equal? group "fcgiwrap") + (user-group + (name "fcgiwrap") + (system? #t))) + (and (equal? user "fcgiwrap") + (user-account + (name "fcgiwrap") + (group group) + (system? #t) + (comment "Fcgiwrap Daemon") + (home-directory "/var/empty") + (shell (file-append shadow "/sbin/nologin"))))))))) -The nginx daemon loads its runtime configuration from CONFIG-FILE, stores log -files in LOG-DIRECTORY, and stores temporary runtime files in RUN-DIRECTORY." - (service nginx-service-type - (nginx-configuration - (nginx nginx) - (log-directory log-directory) - (run-directory run-directory) - (server-blocks server-list) - (upstream-blocks upstream-list) - (file config-file)))) +(define fcgiwrap-shepherd-service + (match-lambda + (($ <fcgiwrap-configuration> package socket user group) + (list (shepherd-service + (provision '(fcgiwrap)) + (documentation "Run the fcgiwrap daemon.") + (requirement '(networking)) + (start #~(make-forkexec-constructor + '(#$(file-append package "/sbin/fcgiwrap") + "-s" #$socket) + #:user #$user #:group #$group)) + (stop #~(make-kill-destructor))))))) + +(define fcgiwrap-service-type + (service-type (name 'fcgiwrap) + (extensions + (list (service-extension shepherd-root-service-type + fcgiwrap-shepherd-service) + (service-extension account-service-type + fcgiwrap-accounts))) + (default-value (fcgiwrap-configuration)))) diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm index 5bae8c18e1..5a8ee6cd40 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.scm @@ -1,4 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Andy Wingo <wingo@igalia.com> ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com> ;;; @@ -22,14 +23,17 @@ #:use-module (gnu services) #:use-module (gnu services shepherd) #:use-module (gnu system pam) + #:use-module (gnu services dbus) #:use-module ((gnu packages base) #:select (canonical-package)) #:use-module (gnu packages guile) #:use-module (gnu packages xorg) #:use-module (gnu packages gl) #:use-module (gnu packages display-managers) #:use-module (gnu packages gnustep) + #:use-module (gnu packages gnome) #:use-module (gnu packages admin) #:use-module (gnu packages bash) + #:use-module (gnu system shadow) #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix packages) @@ -41,6 +45,7 @@ #:use-module (ice-9 match) #:export (xorg-configuration-file %default-xorg-modules + xorg-wrapper xorg-start-command xinitrc @@ -53,7 +58,11 @@ screen-locker screen-locker? screen-locker-service-type - screen-locker-service)) + screen-locker-service + + gdm-configuration + gdm-service-type + gdm-service)) ;;; Commentary: ;;; @@ -184,36 +193,51 @@ in @var{modules}." files) #t)))) -(define* (xorg-start-command #:key - (guile (canonical-package guile-2.0)) - (configuration-file (xorg-configuration-file)) - (modules %default-xorg-modules) - (xorg-server xorg-server)) +(define* (xorg-wrapper #:key + (guile (canonical-package guile-2.0)) + (configuration-file (xorg-configuration-file)) + (modules %default-xorg-modules) + (xorg-server xorg-server)) "Return a derivation that builds a @var{guile} script to start the X server from @var{xorg-server}. @var{configuration-file} is the server configuration file or a derivation that builds it; when omitted, the result of -@code{xorg-configuration-file} is used. - -Usually the X server is started by a login manager." +@code{xorg-configuration-file} is used. The resulting script should be used +in place of @code{/usr/bin/X}." (define exp ;; Write a small wrapper around the X server. #~(begin (setenv "XORG_DRI_DRIVER_PATH" (string-append #$mesa "/lib/dri")) (setenv "XKB_BINDIR" (string-append #$xkbcomp "/bin")) - (apply execl (string-append #$xorg-server "/bin/X") - (string-append #$xorg-server "/bin/X") ;argv[0] - "-logverbose" "-verbose" - "-xkbdir" (string-append #$xkeyboard-config "/share/X11/xkb") - "-config" #$configuration-file - "-configdir" #$(xorg-configuration-directory modules) - "-nolisten" "tcp" "-terminate" + (let ((X (string-append #$xorg-server "/bin/X"))) + (apply execl X X + "-xkbdir" (string-append #$xkeyboard-config "/share/X11/xkb") + "-config" #$configuration-file + "-configdir" #$(xorg-configuration-directory modules) + (cdr (command-line)))))) + + (program-file "X-wrapper" exp)) - ;; Note: SLiM and other display managers add the - ;; '-auth' flag by themselves. - (cdr (command-line))))) +(define* (xorg-start-command #:key + (guile (canonical-package guile-2.0)) + (configuration-file (xorg-configuration-file)) + (modules %default-xorg-modules) + (xorg-server xorg-server)) + "Return a derivation that builds a @code{startx} script in which a number of +X modules are available. See @code{xorg-wrapper} for more details on the +arguments. The result should be used in place of @code{startx}." + (define X + (xorg-wrapper #:guile guile + #:configuration-file configuration-file + #:modules modules + #:xorg-server xorg-server)) + (define exp + ;; Write a small wrapper around the X server. + #~(apply execl #$X #$X ;; Second #$X is for argv[0]. + "-logverbose" "-verbose" "-nolisten" "tcp" "-terminate" + (cdr (command-line)))) - (program-file "start-xorg" exp)) + (program-file "startx" exp)) (define* (xinitrc #:key (guile (canonical-package guile-2.0)) @@ -459,4 +483,142 @@ makes the good ol' XlockMore usable." (file-append package "/bin/" program) allow-empty-passwords?))) +(define %gdm-accounts + (list (user-group (name "gdm") (system? #t)) + (user-account + (name "gdm") + (group "gdm") + (system? #t) + (comment "GNOME Display Manager user") + (home-directory "/var/lib/gdm") + (shell (file-append shadow "/sbin/nologin"))))) + +(define-record-type* <gdm-configuration> + gdm-configuration make-gdm-configuration + gdm-configuration? + (gdm gdm-configuration-gdm (default gdm)) + (allow-empty-passwords? gdm-configuration-allow-empty-passwords? (default #t)) + (allow-root? gdm-configuration-allow-root? (default #t)) + (auto-login? gdm-configuration-auto-login? (default #f)) + (default-user gdm-configuration-default-user (default #f)) + (x-server gdm-configuration-x-server)) + +(define (gdm-etc-service config) + (define gdm-configuration-file + (mixed-text-file "gdm-custom.conf" + "[daemon]\n" + "#User=gdm\n" + "#Group=gdm\n" + (if (gdm-configuration-auto-login? config) + (string-append + "AutomaticLoginEnable=true\n" + "AutomaticLogin=" + (or (gdm-configuration-default-user config) + (error "missing default user for auto-login")) + "\n") + (string-append + "AutomaticLoginEnable=false\n" + "#AutomaticLogin=\n")) + "#TimedLoginEnable=false\n" + "#TimedLogin=\n" + "#TimedLoginDelay=0\n" + "#InitialSetupEnable=true\n" + ;; Enable me once X is working. + "WaylandEnable=false\n" + "\n" + "[debug]\n" + "Enable=true\n" + "\n" + "[security]\n" + "#DisallowTCP=true\n" + "#AllowRemoteAutoLogin=false\n")) + `(("gdm" ,(file-union + "gdm" + `(("custom.conf" ,gdm-configuration-file)))))) + +(define (gdm-pam-service config) + "Return a PAM service for @command{gdm}." + (list + (pam-service + (inherit (unix-pam-service "gdm-autologin")) + (auth (list (pam-entry + (control "[success=ok default=1]") + (module (file-append (gdm-configuration-gdm config) + "/lib/security/pam_gdm.so"))) + (pam-entry + (control "sufficient") + (module "pam_permit.so"))))) + (pam-service + (inherit (unix-pam-service "gdm-launch-environment")) + (auth (list (pam-entry + (control "required") + (module "pam_permit.so"))))) + (unix-pam-service + "gdm-password" + #:allow-empty-passwords? (gdm-configuration-allow-empty-passwords? config) + #:allow-root? (gdm-configuration-allow-root? config)))) + +(define (gdm-shepherd-service config) + (list (shepherd-service + (documentation "Xorg display server (GDM)") + (provision '(xorg-server)) + (requirement '(dbus-system user-processes host-name udev)) + ;; While this service isn't working properly, turn off auto-start. + (auto-start? #f) + (start #~(lambda () + (fork+exec-command + (list #$(file-append (gdm-configuration-gdm config) + "/bin/gdm")) + #:environment-variables + (list (string-append + "GDM_X_SERVER=" + #$(gdm-configuration-x-server config)))))) + (stop #~(make-kill-destructor)) + (respawn? #t)))) + +(define gdm-service-type + (service-type (name 'gdm) + (extensions + (list (service-extension shepherd-root-service-type + gdm-shepherd-service) + (service-extension account-service-type + (const %gdm-accounts)) + (service-extension pam-root-service-type + gdm-pam-service) + (service-extension etc-service-type + gdm-etc-service) + (service-extension dbus-root-service-type + (compose list gdm-configuration-gdm)))))) + +;; This service isn't working yet; it gets as far as starting to run the +;; greeter from gnome-shell but doesn't get any further. It is here because +;; it doesn't hurt anyone and perhaps it inspires someone to fix it :) +(define* (gdm-service #:key (gdm gdm) + (allow-empty-passwords? #t) + (x-server (xorg-wrapper))) + "Return a service that spawns the GDM graphical login manager, which in turn +starts the X display server with @var{X}, a command as returned by +@code{xorg-wrapper}. + +@cindex X session + +GDM automatically looks for session types described by the @file{.desktop} +files in @file{/run/current-system/profile/share/xsessions} and allows users +to choose a session from the log-in screen using @kbd{F1}. Packages such as +@var{xfce}, @var{sawfish}, and @var{ratpoison} provide @file{.desktop} files; +adding them to the system-wide set of packages automatically makes them +available at the log-in screen. + +In addition, @file{~/.xsession} files are honored. When available, +@file{~/.xsession} must be an executable that starts a window manager +and/or other X clients. + +When @var{allow-empty-passwords?} is true, allow logins with an empty +password." + (service gdm-service-type + (gdm-configuration + (gdm gdm) + (allow-empty-passwords? allow-empty-passwords?) + (x-server x-server)))) + ;;; xorg.scm ends here |