aboutsummaryrefslogtreecommitdiff
path: root/gnu/services
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/services')
-rw-r--r--gnu/services/admin.scm171
-rw-r--r--gnu/services/audio.scm86
-rw-r--r--gnu/services/base.scm15
-rw-r--r--gnu/services/cuirass.scm11
-rw-r--r--gnu/services/databases.scm86
-rw-r--r--gnu/services/desktop.scm31
-rw-r--r--gnu/services/herd.scm42
-rw-r--r--gnu/services/networking.scm11
-rw-r--r--gnu/services/ssh.scm96
-rw-r--r--gnu/services/sysctl.scm2
-rw-r--r--gnu/services/virtualization.scm492
-rw-r--r--gnu/services/web.scm274
-rw-r--r--gnu/services/xorg.scm202
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
generated by cgit v1.2.3 (git 2.45.0) at 2025-01-05 14:21:05 +0000