Merge branch 'master' into python-tests

12 files changed, 979 insertions, 95 deletions

diff --git a/gnu/services/admin.scm b/gnu/services/admin.scm
index d8086b78d4..deaf677bd9 100644
--- a/gnu/services/admin.scm
+++ b/gnu/services/admin.scm
@@ -58,8 +58,8 @@
 }
 "))
 
-(define (simple-rotation-config file)
-  (string-append file " {
+(define (simple-rotation-config files)
+  #~(string-append #$(string-join files ",") " {
         sharedscripts
 }
 "))
@@ -72,7 +72,8 @@
                            (display #$(syslog-rotation-config %rotated-files)
                                     port)
                            (display #$(simple-rotation-config
-                                       "/var/log/shepherd.log")
+                                       '("/var/log/shepherd.log"
+                                         "/var/log/guix-daemon.log"))
                                     port)))))))
 
 (define (default-jobs rottlog)
diff --git a/gnu/services/avahi.scm b/gnu/services/avahi.scm
index 60e9e61f94..29720415fc 100644
--- a/gnu/services/avahi.scm
+++ b/gnu/services/avahi.scm
@@ -107,7 +107,7 @@
            (requirement '(dbus-system networking))
 
            (start #~(make-forkexec-constructor
-                     (list (string-append #$avahi "/sbin/avahi-daemon")
+                     (list #$(file-append avahi "/sbin/avahi-daemon")
                            "--daemonize"
                            #$@(if debug? #~("--debug") #~())
                            "-f" #$config)
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index ea1ab63d1b..1b1ce0d5e8 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -37,7 +37,6 @@
   #:use-module ((gnu packages base)
                 #:select (canonical-package glibc))
   #:use-module (gnu packages package-management)
-  #:use-module (gnu packages ssh)
   #:use-module (gnu packages lsof)
   #:use-module (gnu packages terminals)
   #:use-module ((gnu build file-systems)
@@ -610,7 +609,7 @@ strings or string-valued gexps."
            (dup2 (open-fdes #$tty O_RDONLY) 0)
            (close-fdes 1)
            (dup2 (open-fdes #$tty O_WRONLY) 1)
-           (execl (string-append #$kbd "/bin/unicode_start")
+           (execl #$(file-append kbd "/bin/unicode_start")
                   "unicode_start"))
           (else
            (zero? (cdr (waitpid pid))))))))
@@ -623,7 +622,7 @@ strings or string-valued gexps."
       (documentation (string-append "Load console keymap (loadkeys)."))
       (provision '(console-keymap))
       (start #~(lambda _
-                 (zero? (system* (string-append #$kbd "/bin/loadkeys")
+                 (zero? (system* #$(file-append kbd "/bin/loadkeys")
                                  #$@files))))
       (respawn? #f)))))
 
@@ -655,7 +654,7 @@ strings or string-valued gexps."
              (start #~(lambda _
                         (and #$(unicode-start device)
                              (zero?
-                              (system* (string-append #$kbd "/bin/setfont")
+                              (system* #$(file-append kbd "/bin/setfont")
                                        "-C" #$device #$font)))))
              (stop #~(const #t))
              (respawn? #f)))))
@@ -737,7 +736,7 @@ the message of the day, among other things."
        (requirement '(user-processes host-name udev))
 
        (start  #~(make-forkexec-constructor
-                  (list (string-append #$mingetty "/sbin/mingetty")
+                  (list #$(file-append mingetty "/sbin/mingetty")
                         "--noclear" #$tty
                         #$@(if auto-login
                                #~("--autologin" #$auto-login)
@@ -872,7 +871,7 @@ the tty to run, among other things."
            (provision '(nscd))
            (requirement '(user-processes))
            (start #~(make-forkexec-constructor
-                     (list (string-append #$(nscd-configuration-glibc config)
+                     (list #$(file-append (nscd-configuration-glibc config)
                                           "/sbin/nscd")
                            "-f" #$nscd.conf "--foreground")
 
@@ -1058,7 +1057,7 @@ public key, with GUIX."
              (format #t "registering public key '~a'...~%" key)
              (close-port (current-input-port))
              (dup port 0)
-             (execl (string-append #$guix "/bin/guix")
+             (execl #$(file-append guix "/bin/guix")
                     "guix" "archive" "--authorize")
              (exit 1)))
           (else
@@ -1090,10 +1089,10 @@ failed to register hydra.gnu.org public key: ~a~%" status))))))))
                     (default %default-substitute-urls))
   (extra-options    guix-configuration-extra-options ;list of strings
                     (default '()))
+  (log-file         guix-configuration-log-file   ;string
+                    (default "/var/log/guix-daemon.log"))
   (lsof             guix-configuration-lsof       ;<package>
-                    (default lsof))
-  (lsh              guix-configuration-lsh        ;<package>
-                    (default lsh)))
+                    (default lsof)))
 
 (define %default-guix-configuration
   (guix-configuration))
@@ -1104,14 +1103,14 @@ failed to register hydra.gnu.org public key: ~a~%" status))))))))
     (($ <guix-configuration> guix build-group build-accounts
                              authorize-key? keys
                              use-substitutes? substitute-urls extra-options
-                             lsof lsh)
+                             log-file lsof)
      (list (shepherd-service
             (documentation "Run the Guix daemon.")
             (provision '(guix-daemon))
             (requirement '(user-processes))
             (start
              #~(make-forkexec-constructor
-                (list (string-append #$guix "/bin/guix-daemon")
+                (list #$(file-append guix "/bin/guix-daemon")
                       "--build-users-group" #$build-group
                       #$@(if use-substitutes?
                              '()
@@ -1119,10 +1118,11 @@ failed to register hydra.gnu.org public key: ~a~%" status))))))))
                       "--substitute-urls" #$(string-join substitute-urls)
                       #$@extra-options)
 
-                ;; Add 'lsof' (for the GC) and 'lsh' (for offloading) to the
-                ;; daemon's $PATH.
+                ;; Add 'lsof' (for the GC) to the daemon's $PATH.
                 #:environment-variables
-                (list (string-append "PATH=" #$lsof "/bin:" #$lsh "/bin"))))
+                (list (string-append "PATH=" #$lsof "/bin"))
+
+                #:log-file #$log-file))
             (stop #~(make-kill-destructor)))))))
 
 (define (guix-accounts config)
@@ -1186,7 +1186,7 @@ failed to register hydra.gnu.org public key: ~a~%" status))))))))
             (provision '(guix-publish))
             (requirement '(guix-daemon))
             (start #~(make-forkexec-constructor
-                      (list (string-append #$guix "/bin/guix")
+                      (list #$(file-append guix "/bin/guix")
                             "publish" "-u" "guix-publish"
                             "-p" #$(number->string port)
                             (string-append "--listen=" #$host))))
@@ -1340,7 +1340,7 @@ item of @var{packages}."
                     ;; The first one is for udev, the second one for eudev.
                     (setenv "UDEV_CONFIG_FILE" #$udev.conf)
                     (setenv "EUDEV_RULES_DIRECTORY"
-                            (string-append #$rules "/lib/udev/rules.d"))
+                            #$(file-append rules "/lib/udev/rules.d"))
 
                     (let ((pid (primitive-fork)))
                       (case pid
@@ -1353,11 +1353,11 @@ item of @var{packages}."
                          (wait-for-udevd)
 
                          ;; Trigger device node creation.
-                         (system* (string-append #$udev "/bin/udevadm")
+                         (system* #$(file-append udev "/bin/udevadm")
                                   "trigger" "--action=add")
 
                          ;; Wait for things to settle down.
-                         (system* (string-append #$udev "/bin/udevadm")
+                         (system* #$(file-append udev "/bin/udevadm")
                                   "settle")
                          pid)))))
          (stop #~(make-kill-destructor))
@@ -1428,7 +1428,7 @@ extra rules from the packages listed in @var{rules}."
                        ;; 'gpm' runs in the background and sets a PID file.
                        ;; Note that it requires running as "root".
                        (false-if-exception (delete-file "/var/run/gpm.pid"))
-                       (fork+exec-command (list (string-append #$gpm "/sbin/gpm")
+                       (fork+exec-command (list #$(file-append gpm "/sbin/gpm")
                                                 #$@options))
 
                        ;; Wait for the PID file to appear; declare failure if
@@ -1443,7 +1443,7 @@ extra rules from the packages listed in @var{rules}."
 
             (stop #~(lambda (_)
                       ;; Return #f if successfully stopped.
-                      (not (zero? (system* (string-append #$gpm "/sbin/gpm")
+                      (not (zero? (system* #$(file-append gpm "/sbin/gpm")
                                            "-k"))))))))))
 
 (define gpm-service-type
@@ -1472,7 +1472,7 @@ This service is not part of @var{%base-services}."
                            (default kmscon))
   (virtual-terminal        kmscon-configuration-virtual-terminal)
   (login-program           kmscon-configuration-login-program
-                           (default #~(string-append #$shadow "/bin/login")))
+                           (default (file-append shadow "/bin/login")))
   (login-arguments         kmscon-configuration-login-arguments
                            (default '("-p")))
   (hardware-acceleration?  kmscon-configuration-hardware-acceleration?
@@ -1490,7 +1490,7 @@ This service is not part of @var{%base-services}."
 
        (define kmscon-command
          #~(list
-            (string-append #$kmscon "/bin/kmscon") "--login"
+            #$(file-append kmscon "/bin/kmscon") "--login"
             "--vt" #$virtual-terminal
             #$@(if hardware-acceleration? '("--hwaccel") '())
             "--" #$login-program #$@login-arguments))
diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm
index 94c5f21557..a98db64fa5 100644
--- a/gnu/services/configuration.scm
+++ b/gnu/services/configuration.scm
@@ -28,10 +28,13 @@
   #:use-module (srfi srfi-35)
   #:export (configuration-field
             configuration-field-name
+            configuration-field-type
             configuration-missing-field
             configuration-field-error
             configuration-field-serializer
             configuration-field-getter
+            configuration-field-default-value-thunk
+            configuration-field-documentation
             serialize-configuration
             define-configuration
             validate-configuration
diff --git a/gnu/services/cuirass.scm b/gnu/services/cuirass.scm
index d843c07335..c15a846bad 100644
--- a/gnu/services/cuirass.scm
+++ b/gnu/services/cuirass.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -29,8 +30,7 @@
             cuirass-configuration
             cuirass-configuration?
 
-            cuirass-service-type
-            cuirass-service))
+            cuirass-service-type))
 
 ;;;; Commentary:
 ;;;
@@ -42,8 +42,12 @@
 (define-record-type* <cuirass-configuration>
   cuirass-configuration make-cuirass-configuration
   cuirass-configuration?
+  (cuirass          cuirass-configuration-cuirass ;package
+                    (default cuirass))
+  (log-file         cuirass-configuration-log-file ;string
+                    (default "/var/log/cuirass.log"))
   (cache-directory  cuirass-configuration-cache-directory ;string (dir-name)
-                    (default ""))
+                    (default "/var/cache/cuirass"))
   (user             cuirass-configuration-user ;string
                     (default "cuirass"))
   (group            cuirass-configuration-group ;string
@@ -52,8 +56,8 @@
                     (default 60))
   (database         cuirass-configuration-database ;string (file-name)
                     (default "/var/run/cuirass/cuirass.db"))
-  (specifications   cuirass-configuration-specifications ;string (file-name)
-                    (default ""))
+  (specifications   cuirass-configuration-specifications)
+                                  ;gexp that evaluates to specification-alist
   (use-substitutes? cuirass-configuration-use-substitutes? ;boolean
                     (default #f))
   (one-shot?        cuirass-configuration-one-shot? ;boolean
@@ -63,10 +67,14 @@
   "Return a <shepherd-service> for the Cuirass service with CONFIG."
   (and
    (cuirass-configuration? config)
-   (let ((cache-directory  (cuirass-configuration-cache-directory config))
+   (let ((cuirass          (cuirass-configuration-cuirass config))
+         (cache-directory  (cuirass-configuration-cache-directory config))
+         (log-file         (cuirass-configuration-log-file config))
+         (user             (cuirass-configuration-user config))
+         (group            (cuirass-configuration-group config))
          (interval         (cuirass-configuration-interval config))
          (database         (cuirass-configuration-database config))
-         (specifications   (cuirass-configuration-specifications config))
+         (specs            (cuirass-configuration-specifications config))
          (use-substitutes? (cuirass-configuration-use-substitutes? config))
          (one-shot?        (cuirass-configuration-one-shot? config)))
      (list (shepherd-service
@@ -75,16 +83,16 @@
             (requirement '(guix-daemon))
             (start #~(make-forkexec-constructor
                       (list (string-append #$cuirass "/bin/cuirass")
-                            #$@(if (string=? "" cache-directory)
-                                   '()
-                                   (list "--cache-directory" cache-directory))
-                            #$@(if (string=? "" specifications)
-                                   '()
-                                   (list "--specifications" specifications))
+                            "--cache-directory" #$cache-directory
+                            "--specifications"
+                            #$(scheme-file "cuirass-specs.scm" specs)
                             "--database" #$database
                             "--interval" #$(number->string interval)
                             #$@(if use-substitutes? '("--use-substitutes") '())
-                            #$@(if one-shot? '("--one-shot") '()))))
+                            #$@(if one-shot? '("--one-shot") '()))
+                      #:user #$user
+                      #:group #$group
+                      #:log-file #$log-file))
             (stop #~(make-kill-destructor)))))))
 
 (define (cuirass-account config)
@@ -102,14 +110,32 @@
            (home-directory (string-append "/var/run/" cuirass-user))
            (shell #~(string-append #$shadow "/sbin/nologin"))))))
 
+(define (cuirass-activation config)
+  "Return the activation code for CONFIG."
+  (let ((cache (cuirass-configuration-cache-directory config))
+        (db    (dirname (cuirass-configuration-database config)))
+        (user  (cuirass-configuration-user config))
+        (group (cuirass-configuration-group config)))
+    (with-imported-modules '((guix build utils))
+      #~(begin
+          (use-modules (guix build utils))
+
+          (mkdir-p #$cache)
+          (mkdir-p #$db)
+
+          (let ((uid (passwd:uid (getpw #$user)))
+                (gid (group:gid (getgr #$group))))
+            (chown #$cache uid gid)
+            (chown #$db uid gid))))))
+
 (define cuirass-service-type
   (service-type
    (name 'cuirass)
    (extensions
     (list
+     (service-extension profile-service-type      ;for 'info cuirass'
+                        (compose list cuirass-configuration-cuirass))
+     (service-extension activation-service-type cuirass-activation)
      (service-extension shepherd-root-service-type cuirass-shepherd-service)
      (service-extension account-service-type cuirass-account)))))
 
-(define* (cuirass-service #:key (config (cuirass-configuration)))
-  "Return a service that runs cuirass according to CONFIG."
-  (service cuirass-service-type config))
diff --git a/gnu/services/databases.scm b/gnu/services/databases.scm
index 1eed85542b..3ecc8aff78 100644
--- a/gnu/services/databases.scm
+++ b/gnu/services/databases.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
 ;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Leo Famulari <leo@famulari.name>
+;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -35,7 +36,11 @@
             mysql-service
             mysql-service-type
             mysql-configuration
-            mysql-configuration?))
+            mysql-configuration?
+
+            redis-configuration
+            redis-configuration?
+            redis-service-type))
 
 ;;; Commentary:
 ;;;
@@ -48,6 +53,10 @@
   postgresql-configuration?
   (postgresql     postgresql-configuration-postgresql ;<package>
                   (default postgresql))
+  (port           postgresql-configuration-port
+                  (default 5432))
+  (locale         postgresql-configuration-locale
+                  (default "en_US.utf8"))
   (config-file    postgresql-configuration-file)
   (data-directory postgresql-configuration-data-directory))
 
@@ -80,13 +89,18 @@ host	all	all	::1/128 	trust"))
 
 (define postgresql-activation
   (match-lambda
-    (($ <postgresql-configuration> postgresql config-file data-directory)
+    (($ <postgresql-configuration> postgresql port locale config-file data-directory)
      #~(begin
          (use-modules (guix build utils)
                       (ice-9 match))
 
          (let ((user (getpwnam "postgres"))
-               (initdb (string-append #$postgresql "/bin/initdb")))
+               (initdb (string-append #$postgresql "/bin/initdb"))
+               (initdb-args
+                (append
+                 (if #$locale
+                     (list (string-append "--locale=" #$locale))
+                     '()))))
            ;; Create db state directory.
            (mkdir-p #$data-directory)
            (chown #$data-directory (passwd:uid user) (passwd:gid user))
@@ -101,14 +115,19 @@ host	all	all	::1/128 	trust"))
                 (lambda ()
                   (setgid (passwd:gid user))
                   (setuid (passwd:uid user))
-                  (primitive-exit (system* initdb "-D" #$data-directory)))
+                  (primitive-exit
+                   (apply system*
+                          initdb
+                          "-D"
+                          #$data-directory
+                          initdb-args)))
                 (lambda ()
                   (primitive-exit 1))))
              (pid (waitpid pid))))))))
 
 (define postgresql-shepherd-service
   (match-lambda
-    (($ <postgresql-configuration> postgresql config-file data-directory)
+    (($ <postgresql-configuration> postgresql port locale config-file data-directory)
      (let ((start-script
             ;; Wrapper script that switches to the 'postgres' user before
             ;; launching daemon.
@@ -121,6 +140,7 @@ host	all	all	::1/128 	trust"))
                               (system* postgres
                                        (string-append "--config-file="
                                                       #$config-file)
+                                       "-p" (number->string #$port)
                                        "-D" #$data-directory)))))
        (list (shepherd-service
               (provision '(postgres))
@@ -140,6 +160,8 @@ host	all	all	::1/128 	trust"))
                                           (const %postgresql-accounts))))))
 
 (define* (postgresql-service #:key (postgresql postgresql)
+                             (port 5432)
+                             (locale "en_US.utf8")
                              (config-file %default-postgres-config)
                              (data-directory "/var/lib/postgresql/data"))
   "Return a service that runs @var{postgresql}, the PostgreSQL database server.
@@ -149,6 +171,8 @@ and stores the database cluster in @var{data-directory}."
   (service postgresql-service-type
            (postgresql-configuration
             (postgresql postgresql)
+            (port port)
+            (locale locale)
             (config-file config-file)
             (data-directory data-directory))))
 
@@ -160,7 +184,8 @@ and stores the database cluster in @var{data-directory}."
 (define-record-type* <mysql-configuration>
   mysql-configuration make-mysql-configuration
   mysql-configuration?
-  (mysql mysql-configuration-mysql (default mariadb)))
+  (mysql mysql-configuration-mysql (default mariadb))
+  (port mysql-configuration-port (default 3306)))
 
 (define %mysql-accounts
   (list (user-group
@@ -175,10 +200,11 @@ and stores the database cluster in @var{data-directory}."
 
 (define mysql-configuration-file
   (match-lambda
-    (($ <mysql-configuration> mysql)
-     (plain-file "my.cnf" "[mysqld]
+    (($ <mysql-configuration> mysql port)
+     (mixed-text-file "my.cnf" "[mysqld]
 datadir=/var/lib/mysql
 socket=/run/mysqld/mysqld.sock
+port=" (number->string port) "
 "))))
 
 (define (%mysql-activation config)
@@ -266,3 +292,77 @@ database server.
 The optional @var{config} argument specifies the configuration for
 @command{mysqld}, which should be a @code{<mysql-configuration>} object."
   (service mysql-service-type config))
+
+
+;;;
+;;; Redis
+;;;
+
+(define-record-type* <redis-configuration>
+  redis-configuration make-redis-configuration
+  redis-configuration?
+  (redis             redis-configuration-redis ;<package>
+                     (default redis))
+  (bind              redis-configuration-bind
+                     (default "127.0.0.1"))
+  (port              redis-configuration-port
+                     (default 6379))
+  (working-directory redis-configuration-working-directory
+                     (default "/var/lib/redis"))
+  (config-file       redis-configuration-config-file
+                     (default #f)))
+
+(define (default-redis.conf bind port working-directory)
+  (mixed-text-file "redis.conf"
+                   "bind " bind "\n"
+                   "port " (number->string port) "\n"
+                   "dir " working-directory "\n"
+                   "daemonize no\n"))
+
+(define %redis-accounts
+  (list (user-group (name "redis") (system? #t))
+        (user-account
+         (name "redis")
+         (group "redis")
+         (system? #t)
+         (comment "Redis server user")
+         (home-directory "/var/empty")
+         (shell (file-append shadow "/sbin/nologin")))))
+
+(define redis-activation
+  (match-lambda
+    (($ <redis-configuration> redis bind port working-directory config-file)
+     #~(begin
+         (use-modules (guix build utils)
+                      (ice-9 match))
+
+         (let ((user (getpwnam "redis")))
+           (mkdir-p #$working-directory)
+           (chown #$working-directory (passwd:uid user) (passwd:gid user)))))))
+
+(define redis-shepherd-service
+  (match-lambda
+    (($ <redis-configuration> redis bind port working-directory config-file)
+     (let ((config-file
+            (or config-file
+                (default-redis.conf bind port working-directory))))
+       (list (shepherd-service
+              (provision '(redis))
+              (documentation "Run the Redis daemon.")
+              (requirement '(user-processes syslogd))
+              (start #~(make-forkexec-constructor
+                        '(#$(file-append redis "/bin/redis-server")
+                          #$config-file)
+                        #:user "redis"
+                        #:group "redis"))
+              (stop #~(make-kill-destructor))))))))
+
+(define redis-service-type
+  (service-type (name 'redis)
+                (extensions
+                 (list (service-extension shepherd-root-service-type
+                                          redis-shepherd-service)
+                       (service-extension activation-service-type
+                                          redis-activation)
+                       (service-extension account-service-type
+                                          (const %redis-accounts))))))
diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm
index 7555780ade..36049587d3 100644
--- a/gnu/services/desktop.scm
+++ b/gnu/services/desktop.scm
@@ -40,6 +40,7 @@
   #:use-module (gnu packages xdisorg)
   #:use-module (gnu packages suckless)
   #:use-module (gnu packages linux)
+  #:use-module (gnu packages libusb)
   #:use-module (guix records)
   #:use-module (guix packages)
   #:use-module (guix store)
@@ -753,6 +754,10 @@ with the administrator's password."
          (screen-locker-service slock)
          (screen-locker-service xlockmore "xlock")
 
+         ;; Add udev rules for MTP devices so that non-root users can access
+         ;; them.
+         (simple-service 'mtp udev-service-type (list libmtp))
+
          ;; The D-Bus clique.
          (avahi-service)
          (wicd-service)
diff --git a/gnu/services/messaging.scm b/gnu/services/messaging.scm
new file mode 100644
index 0000000000..0b5aa1fae8
--- /dev/null
+++ b/gnu/services/messaging.scm
@@ -0,0 +1,726 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu services messaging)
+  #:use-module (gnu packages messaging)
+  #:use-module (gnu packages admin)
+  #:use-module (gnu services)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu services configuration)
+  #:use-module (gnu system shadow)
+  #:use-module (guix gexp)
+  #:use-module (guix records)
+  #:use-module (guix packages)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-35)
+  #:use-module (ice-9 match)
+  #:export (prosody-service-type
+            prosody-configuration
+            opaque-prosody-configuration
+
+            virtualhost-configuration
+            int-component-configuration
+            ext-component-configuration
+
+            mod-muc-configuration
+            ssl-configuration
+
+            %default-modules-enabled))
+
+;;; Commentary:
+;;;
+;;; Messaging services.
+;;;
+;;; Code:
+
+(define (id ctx . parts)
+  (datum->syntax ctx (apply symbol-append (map syntax->datum parts))))
+
+(define-syntax define-maybe
+  (lambda (x)
+    (syntax-case x ()
+      ((_ stem)
+       (with-syntax
+           ((stem?                (id #'stem #'stem #'?))
+            (maybe-stem?          (id #'stem #'maybe- #'stem #'?))
+            (serialize-stem       (id #'stem #'serialize- #'stem))
+            (serialize-maybe-stem (id #'stem #'serialize-maybe- #'stem)))
+         #'(begin
+             (define (maybe-stem? val)
+               (or (eq? val 'disabled) (stem? val)))
+             (define (serialize-maybe-stem field-name val)
+               (when (stem? val) (serialize-stem field-name val)))))))))
+
+(define-syntax define-all-configurations
+  (lambda (stx)
+    (define (make-pred arg)
+      (lambda (field target)
+        (and (memq (syntax->datum target) `(common ,arg)) field)))
+    (syntax-case stx ()
+      ((_ stem (field (field-type def) doc target) ...)
+       (with-syntax (((new-field-type ...)
+                      (map (lambda (field-type target)
+                             (if (and (eq? 'common (syntax->datum target))
+                                      (not (string-prefix?
+                                            "maybe-"
+                                            (symbol->string
+                                             (syntax->datum field-type)))))
+                                 (id #'stem #'maybe- field-type) field-type))
+                           #'(field-type ...) #'(target ...)))
+                     ((new-def ...)
+                      (map (lambda (def target)
+                             (if (eq? 'common (syntax->datum target))
+                                 #''disabled def))
+                           #'(def ...) #'(target ...)))
+                     ((new-doc ...)
+                      (map (lambda (doc target)
+                             (if (eq? 'common (syntax->datum target))
+                                 "" doc))
+                           #'(doc ...) #'(target ...))))
+         #`(begin
+             (define common-fields
+               '(#,@(filter-map (make-pred #f) #'(field ...) #'(target ...))))
+             (define-configuration prosody-configuration
+               #,@(filter-map (make-pred 'global)
+                              #'((field (field-type def) doc) ...)
+                              #'(target ...)))
+             (define-configuration virtualhost-configuration
+               #,@(filter-map (make-pred 'virtualhost)
+                              #'((field (new-field-type new-def) new-doc) ...)
+                              #'(target ...)))
+             (define-configuration int-component-configuration
+               #,@(filter-map (make-pred 'int-component)
+                              #'((field (new-field-type new-def) new-doc) ...)
+                              #'(target ...)))
+             (define-configuration ext-component-configuration
+               #,@(filter-map (make-pred 'ext-component)
+                              #'((field (new-field-type new-def) new-doc) ...)
+                              #'(target ...)))))))))
+
+(define (uglify-field-name field-name)
+  (let ((str (symbol->string field-name)))
+    (string-join (string-split (if (string-suffix? "?" str)
+                                   (substring str 0 (1- (string-length str)))
+                                   str)
+                               #\-)
+                 "_")))
+
+(define (serialize-field field-name val)
+  (format #t "~a = ~a;\n" (uglify-field-name field-name) val))
+(define (serialize-field-list field-name val)
+  (serialize-field field-name
+                   (with-output-to-string
+                     (lambda ()
+                       (format #t "{\n")
+                       (for-each (lambda (x)
+                                   (format #t "~a;\n" x))
+                                 val)
+                       (format #t "}")))))
+
+(define (serialize-boolean field-name val)
+  (serialize-field field-name (if val "true" "false")))
+(define-maybe boolean)
+
+(define (string-or-boolean? val)
+  (or (string? val) (boolean? val)))
+(define (serialize-string-or-boolean field-name val)
+  (if (string? val)
+      (serialize-string field-name val)
+      (serialize-boolean field-name val)))
+
+(define (non-negative-integer? val)
+  (and (exact-integer? val) (not (negative? val))))
+(define (serialize-non-negative-integer field-name val)
+  (serialize-field field-name val))
+(define-maybe non-negative-integer)
+
+(define (non-negative-integer-list? val)
+  (and (list? val) (and-map non-negative-integer? val)))
+(define (serialize-non-negative-integer-list field-name val)
+  (serialize-field-list field-name val))
+(define-maybe non-negative-integer-list)
+
+(define (enclose-quotes s)
+  (format #f "\"~a\"" s))
+(define (serialize-string field-name val)
+  (serialize-field field-name (enclose-quotes val)))
+(define-maybe string)
+
+(define (string-list? val)
+  (and (list? val)
+       (and-map (lambda (x)
+                  (and (string? x) (not (string-index x #\,))))
+                val)))
+(define (serialize-string-list field-name val)
+  (serialize-field-list field-name (map enclose-quotes val)))
+(define-maybe string-list)
+
+(define (module-list? val)
+  (string-list? val))
+(define (serialize-module-list field-name val)
+  (serialize-string-list field-name (cons "posix" val)))
+(define-maybe module-list)
+
+(define (file-name? val)
+  (and (string? val)
+       (string-prefix? "/" val)))
+(define (serialize-file-name field-name val)
+  (serialize-string field-name val))
+(define-maybe file-name)
+
+(define (file-name-list? val)
+  (and (list? val) (and-map file-name? val)))
+(define (serialize-file-name-list field-name val)
+  (serialize-string-list field-name val))
+(define-maybe file-name)
+
+(define-configuration mod-muc-configuration
+  (name
+   (string "Prosody Chatrooms")
+   "The name to return in service discovery responses.")
+
+  (restrict-room-creation
+   (string-or-boolean #f)
+   "If @samp{#t}, this will only allow admins to create new chatrooms.
+Otherwise anyone can create a room.  The value @samp{\"local\"} restricts room
+creation to users on the service's parent domain.  E.g. @samp{user@@example.com}
+can create rooms on @samp{rooms.example.com}.  The value @samp{\"admin\"}
+restricts to service administrators only.")
+
+  (max-history-messages
+   (non-negative-integer 20)
+   "Maximum number of history messages that will be sent to the member that has
+just joined the room."))
+(define (serialize-mod-muc-configuration field-name val)
+  (serialize-configuration val mod-muc-configuration-fields))
+(define-maybe mod-muc-configuration)
+
+(define-configuration ssl-configuration
+  (protocol
+   (maybe-string 'disabled)
+   "This determines what handshake to use.")
+
+  (key
+   (file-name "/etc/prosody/certs/key.pem")
+   "Path to your private key file, relative to @code{/etc/prosody}.")
+
+  (certificate
+   (file-name "/etc/prosody/certs/cert.pem")
+   "Path to your certificate file, relative to @code{/etc/prosody}.")
+
+  (capath
+   (file-name "/etc/ssl/certs")
+   "Path to directory containing root certificates that you wish Prosody to
+trust when verifying the certificates of remote servers.")
+
+  (cafile
+   (maybe-file-name 'disabled)
+   "Path to a file containing root certificates that you wish Prosody to trust.
+Similar to @code{capath} but with all certificates concatenated together.")
+
+  (verify
+   (maybe-string-list 'disabled)
+   "A list of verification options (these mostly map to OpenSSL's
+@code{set_verify()} flags).")
+
+  (options
+   (maybe-string-list 'disabled)
+   "A list of general options relating to SSL/TLS.  These map to OpenSSL's
+@code{set_options()}.  For a full list of options available in LuaSec, see the
+LuaSec source.")
+
+  (depth
+   (maybe-non-negative-integer 'disabled)
+   "How long a chain of certificate authorities to check when looking for a
+trusted root certificate.")
+
+  (ciphers
+   (maybe-string 'disabled)
+   "An OpenSSL cipher string.  This selects what ciphers Prosody will offer to
+clients, and in what order.")
+
+  (dhparam
+   (maybe-file-name 'disabled)
+   "A path to a file containing parameters for Diffie-Hellman key exchange.  You
+can create such a file with:
+@code{openssl dhparam -out /etc/prosody/certs/dh-2048.pem 2048}")
+
+  (curve
+   (maybe-string 'disabled)
+   "Curve for Elliptic curve Diffie-Hellman. Prosody's default is
+@samp{\"secp384r1\"}.")
+
+  (verifyext
+   (maybe-string-list 'disabled)
+   "A list of \"extra\" verification options.")
+
+  (password
+   (maybe-string 'disabled)
+   "Password for encrypted private keys."))
+(define (serialize-ssl-configuration field-name val)
+  (format #t "ssl = {\n")
+  (serialize-configuration val ssl-configuration-fields)
+  (format #t "};\n"))
+(define-maybe ssl-configuration)
+
+(define %default-modules-enabled
+  '("roster"
+    "saslauth"
+    "tls"
+    "dialback"
+    "disco"
+    "private"
+    "vcard"
+    "version"
+    "uptime"
+    "time"
+    "ping"
+    "pep"
+    "register"
+    "admin_adhoc"))
+
+;; Guile bug.  Use begin wrapper, because otherwise virtualhost-configuration
+;; is assumed to be a function.  See
+;; https://www.gnu.org/software/guile/manual/html_node/R6RS-Incompatibilities.html
+(begin
+  (define (virtualhost-configuration-list? val)
+    (and (list? val) (and-map virtualhost-configuration? val)))
+  (define (serialize-virtualhost-configuration-list l)
+    (for-each
+     (lambda (val) (serialize-virtualhost-configuration val)) l))
+
+  (define (int-component-configuration-list? val)
+    (and (list? val) (and-map int-component-configuration? val)))
+  (define (serialize-int-component-configuration-list l)
+    (for-each
+     (lambda (val) (serialize-int-component-configuration val)) l))
+
+  (define (ext-component-configuration-list? val)
+    (and (list? val) (and-map ext-component-configuration? val)))
+  (define (serialize-ext-component-configuration-list l)
+    (for-each
+     (lambda (val) (serialize-ext-component-configuration val)) l))
+
+  (define-all-configurations prosody-configuration
+    (prosody
+     (package prosody)
+     "The Prosody package."
+     global)
+
+    (data-path
+     (file-name "/var/lib/prosody")
+     "Location of the Prosody data storage directory.  See
+@url{http://prosody.im/doc/configure}."
+     global)
+
+    (plugin-paths
+     (file-name-list '())
+     "Additional plugin directories.  They are searched in all the specified
+paths in order.  See @url{http://prosody.im/doc/plugins_directory}."
+     global)
+
+    (admins
+     (string-list '())
+     "This is a list of accounts that are admins for the server.  Note that you
+must create the accounts separately.  See @url{http://prosody.im/doc/admins} and
+@url{http://prosody.im/doc/creating_accounts}.
+Example: @code{(admins '(\"user1@@example.com\" \"user2@@example.net\"))}"
+     common)
+
+    (use-libevent?
+     (boolean #f)
+     "Enable use of libevent for better performance under high load.  See
+@url{http://prosody.im/doc/libevent}."
+     common)
+
+    (modules-enabled
+     (module-list %default-modules-enabled)
+     "This is the list of modules Prosody will load on startup.  It looks for
+@code{mod_modulename.lua} in the plugins folder, so make sure that exists too.
+Documentation on modules can be found at: @url{http://prosody.im/doc/modules}.
+Defaults to @samp{%default-modules-enabled}."
+     common)
+
+    (modules-disabled
+     (string-list '())
+     "@samp{\"offline\"}, @samp{\"c2s\"} and @samp{\"s2s\"} are auto-loaded, but
+should you want to disable them then add them to this list."
+     common)
+
+    (groups-file
+     (file-name "/var/lib/prosody/sharedgroups.txt")
+     "Path to a text file where the shared groups are defined.  If this path is
+empty then @samp{mod_groups} does nothing.  See
+@url{http://prosody.im/doc/modules/mod_groups}."
+     common)
+
+    (allow-registration?
+     (boolean #f)
+     "Disable account creation by default, for security.  See
+@url{http://prosody.im/doc/creating_accounts}."
+     common)
+
+    (ssl
+     (maybe-ssl-configuration (ssl-configuration))
+     "These are the SSL/TLS-related settings.  Most of them are disabled so to
+use Prosody's defaults.  If you do not completely understand these options, do
+not add them to your config, it is easy to lower the security of your server
+using them.  See @url{http://prosody.im/doc/advanced_ssl_config}."
+     common)
+
+    (c2s-require-encryption?
+     (boolean #f)
+     "Whether to force all client-to-server connections to be encrypted or not.
+See @url{http://prosody.im/doc/modules/mod_tls}."
+     common)
+
+    (s2s-require-encryption?
+     (boolean #f)
+     "Whether to force all server-to-server connections to be encrypted or not.
+See @url{http://prosody.im/doc/modules/mod_tls}."
+     common)
+
+    (s2s-secure-auth?
+     (boolean #f)
+     "Whether to require encryption and certificate authentication.  This
+provides ideal security, but requires servers you communicate with to support
+encryption AND present valid, trusted certificates.  See
+@url{http://prosody.im/doc/s2s#security}."
+     common)
+
+    (s2s-insecure-domains
+     (string-list '())
+     "Many servers don't support encryption or have invalid or self-signed
+certificates.  You can list domains here that will not be required to
+authenticate using certificates.  They will be authenticated using DNS.  See
+@url{http://prosody.im/doc/s2s#security}."
+     common)
+
+    (s2s-secure-domains
+     (string-list '())
+     "Even if you leave @code{s2s-secure-auth?} disabled, you can still require
+valid certificates for some domains by specifying a list here.  See
+@url{http://prosody.im/doc/s2s#security}."
+     common)
+
+    (authentication
+     (string "internal_plain")
+     "Select the authentication backend to use.  The default provider stores
+passwords in plaintext and uses Prosody's configured data storage to store the
+authentication data.  If you do not trust your server please see
+@url{http://prosody.im/doc/modules/mod_auth_internal_hashed} for information
+about using the hashed backend.  See also
+@url{http://prosody.im/doc/authentication}"
+     common)
+
+    ;; TODO: Handle more complicated log structures.
+    (log
+     (maybe-string "*syslog")
+     "Set logging options.  Advanced logging configuration is not yet supported
+by the GuixSD Prosody Service.  See @url{http://prosody.im/doc/logging}."
+     common)
+
+    (pidfile
+     (file-name "/var/run/prosody/prosody.pid")
+     "File to write pid in.  See @url{http://prosody.im/doc/modules/mod_posix}."
+     global)
+
+    (virtualhosts
+     (virtualhost-configuration-list
+      (list (virtualhost-configuration
+             (domain "localhost"))))
+     "A host in Prosody is a domain on which user accounts can be created.  For
+example if you want your users to have addresses like
+@samp{\"john.smith@@example.com\"} then you need to add a host
+@samp{\"example.com\"}.  All options in this list will apply only to this host.
+
+Note: the name \"virtual\" host is used in configuration to avoid confusion with
+the actual physical host that Prosody is installed on.  A single Prosody
+instance can serve many domains, each one defined as a VirtualHost entry in
+Prosody's configuration.  Conversely a server that hosts a single domain would
+have just one VirtualHost entry.
+
+See @url{http://prosody.im/doc/configure#virtual_host_settings}."
+     global)
+
+    (int-components
+     (int-component-configuration-list '())
+     "Components are extra services on a server which are available to clients,
+usually on a subdomain of the main server (such as
+@samp{\"mycomponent.example.com\"}).  Example components might be chatroom
+servers, user directories, or gateways to other protocols.
+
+Internal components are implemented with Prosody-specific plugins.  To add an
+internal component, you simply fill the hostname field, and the plugin you wish
+to use for the component.
+
+See @url{http://prosody.im/doc/components}."
+     global)
+
+    (ext-components
+     (ext-component-configuration-list '())
+     "External components use XEP-0114, which most standalone components
+support.  To add an external component, you simply fill the hostname field.  See
+@url{http://prosody.im/doc/components}."
+     global)
+
+    (component-secret
+     (string (configuration-missing-field 'ext-component 'component-secret))
+     "Password which the component will use to log in."
+     ext-component)
+
+    (component-ports
+     (non-negative-integer-list '(5347))
+     "Port(s) Prosody listens on for component connections."
+     global)
+
+    (component-interface
+     (string "127.0.0.1")
+     "Interface Prosody listens on for component connections."
+     global)
+
+    (domain
+     (string (configuration-missing-field 'virtualhost 'domain))
+     "Domain you wish Prosody to serve."
+     virtualhost)
+
+    (hostname
+     (string (configuration-missing-field 'int-component 'hostname))
+     "Hostname of the component."
+     int-component)
+
+    (plugin
+     (string (configuration-missing-field 'int-component 'plugin))
+     "Plugin you wish to use for the component."
+     int-component)
+
+    (mod-muc
+     (maybe-mod-muc-configuration 'disabled)
+     "Multi-user chat (MUC) is Prosody's module for allowing you to create
+hosted chatrooms/conferences for XMPP users.
+
+General information on setting up and using multi-user chatrooms can be found
+in the \"Chatrooms\" documentation (@url{http://prosody.im/doc/chatrooms}),
+which you should read if you are new to XMPP chatrooms.
+
+See also @url{http://prosody.im/doc/modules/mod_muc}."
+     int-component)
+
+    (hostname
+     (string (configuration-missing-field 'ext-component 'hostname))
+     "Hostname of the component."
+     ext-component)))
+
+;; Serialize Virtualhost line first.
+(define (serialize-virtualhost-configuration config)
+  (define (rest? field)
+    (not (memq (configuration-field-name field)
+               '(domain))))
+  (let ((domain (virtualhost-configuration-domain config))
+        (rest (filter rest? virtualhost-configuration-fields)))
+    (format #t "VirtualHost \"~a\"\n" domain)
+    (serialize-configuration config rest)))
+
+;; Serialize Component line first.
+(define (serialize-int-component-configuration config)
+  (define (rest? field)
+    (not (memq (configuration-field-name field)
+               '(hostname plugin))))
+  (let ((hostname (int-component-configuration-hostname config))
+        (plugin (int-component-configuration-plugin config))
+        (rest (filter rest? int-component-configuration-fields)))
+    (format #t "Component \"~a\" \"~a\"\n" hostname plugin)
+    (serialize-configuration config rest)))
+
+;; Serialize Component line first.
+(define (serialize-ext-component-configuration config)
+  (define (rest? field)
+    (not (memq (configuration-field-name field)
+               '(hostname))))
+  (let ((hostname (ext-component-configuration-hostname config))
+        (rest (filter rest? ext-component-configuration-fields)))
+    (format #t "Component \"~a\"\n" hostname)
+    (serialize-configuration config rest)))
+
+;; Serialize virtualhosts and components last.
+(define (serialize-prosody-configuration config)
+  (define (rest? field)
+    (not (memq (configuration-field-name field)
+               '(virtualhosts int-components ext-components))))
+  (let ((rest (filter rest? prosody-configuration-fields)))
+    (serialize-configuration config rest))
+  (serialize-virtualhost-configuration-list
+   (prosody-configuration-virtualhosts config))
+  (serialize-int-component-configuration-list
+   (prosody-configuration-int-components config))
+  (serialize-ext-component-configuration-list
+   (prosody-configuration-ext-components config)))
+
+(define-configuration opaque-prosody-configuration
+  (prosody
+   (package prosody)
+   "The prosody package.")
+
+  (prosody.cfg.lua
+   (string (configuration-missing-field 'opaque-prosody-configuration
+                                        'prosody.cfg.lua))
+   "The contents of the @code{prosody.cfg.lua} to use."))
+
+(define (prosody-shepherd-service config)
+  "Return a <shepherd-service> for Prosody with CONFIG."
+  (let* ((prosody (if (opaque-prosody-configuration? config)
+                      (opaque-prosody-configuration-prosody config)
+                      (prosody-configuration-prosody config)))
+         (prosodyctl-bin (file-append prosody "/bin/prosodyctl"))
+         (prosodyctl-action (lambda args
+                              #~(lambda _
+                                  (zero? (system* #$prosodyctl-bin #$@args))))))
+    (list (shepherd-service
+           (documentation "Run the Prosody XMPP server")
+           (provision '(prosody))
+           (requirement '(networking syslogd user-processes))
+           (start (prosodyctl-action "start"))
+           (stop (prosodyctl-action "stop"))))))
+
+(define %prosody-accounts
+  (list (user-group (name "prosody") (system? #t))
+        (user-account
+         (name "prosody")
+         (group "prosody")
+         (system? #t)
+         (comment "Prosody daemon user")
+         (home-directory "/var/empty")
+         (shell (file-append shadow "/sbin/nologin")))))
+
+(define (prosody-activation config)
+  "Return the activation gexp for CONFIG."
+  (let* ((config-dir "/etc/prosody")
+         (default-certs-dir "/etc/prosody/certs")
+         (data-path (prosody-configuration-data-path config))
+         (pidfile-dir (dirname (prosody-configuration-pidfile config)))
+         (config-str
+          (if (opaque-prosody-configuration? config)
+              (opaque-prosody-configuration-prosody.cfg.lua config)
+              (with-output-to-string
+                (lambda ()
+                  (serialize-prosody-configuration config)))))
+         (config-file (plain-file "prosody.cfg.lua" config-str)))
+    #~(begin
+        (define %user (getpw "prosody"))
+
+        (mkdir-p #$config-dir)
+        (chown #$config-dir (passwd:uid %user) (passwd:gid %user))
+        (copy-file #$config-file (string-append #$config-dir
+                                                "/prosody.cfg.lua"))
+
+        (mkdir-p #$default-certs-dir)
+        (chown #$default-certs-dir (passwd:uid %user) (passwd:gid %user))
+        (chmod #$default-certs-dir #o750)
+
+        (mkdir-p #$data-path)
+        (chown #$data-path (passwd:uid %user) (passwd:gid %user))
+        (chmod #$data-path #o750)
+
+        (mkdir-p #$pidfile-dir)
+        (chown #$pidfile-dir (passwd:uid %user) (passwd:gid %user)))))
+
+(define prosody-service-type
+  (service-type (name 'prosody)
+                (extensions
+                 (list (service-extension shepherd-root-service-type
+                                          prosody-shepherd-service)
+                       (service-extension account-service-type
+                                          (const %prosody-accounts))
+                       (service-extension activation-service-type
+                                          prosody-activation)))))
+
+;; A little helper to make it easier to document all those fields.
+(define (generate-documentation)
+  (define documentation
+    `((prosody-configuration
+       ,prosody-configuration-fields
+       (ssl ssl-configuration)
+       (virtualhosts virtualhost-configuration)
+       (int-components int-component-configuration)
+       (ext-components ext-component-configuration))
+      (ssl-configuration ,ssl-configuration-fields)
+      (int-component-configuration ,int-component-configuration-fields
+                                   (mod-muc mod-muc-configuration))
+      (ext-component-configuration ,ext-component-configuration-fields)
+      (mod-muc-configuration ,mod-muc-configuration-fields)
+      (virtualhost-configuration ,virtualhost-configuration-fields)
+      (opaque-prosody-configuration ,opaque-prosody-configuration-fields)))
+  (define (generate configuration-name)
+    (match (assq-ref documentation configuration-name)
+      ((fields . sub-documentation)
+       (format #t "\nAvailable @code{~a} fields are:\n\n" configuration-name)
+       (when (memq configuration-name
+                   '(virtualhost-configuration
+                     int-component-configuration
+                     ext-component-configuration))
+         (format #t "all these @code{prosody-configuration} fields: ~a, plus:\n"
+                 (string-join (map (lambda (s)
+                                     (format #f "@code{~a}" s)) common-fields)
+                              ", ")))
+       (for-each
+        (lambda (f)
+          (let ((field-name (configuration-field-name f))
+                (field-type (configuration-field-type f))
+                (field-docs (string-trim-both
+                             (configuration-field-documentation f)))
+                (default (catch #t
+                           (configuration-field-default-value-thunk f)
+                           (lambda _ 'nope))))
+            (define (escape-chars str chars escape)
+              (with-output-to-string
+                (lambda ()
+                  (string-for-each (lambda (c)
+                                     (when (char-set-contains? chars c)
+                                       (display escape))
+                                     (display c))
+                                   str))))
+            (define (show-default? val)
+              (or (string? default) (number? default) (boolean? default)
+                  (and (list? val) (and-map show-default? val))))
+            (format #t "@deftypevr {@code{~a} parameter} ~a ~a\n~a\n"
+                    configuration-name field-type field-name field-docs)
+            (when (show-default? default)
+              (format #t "Defaults to @samp{~a}.\n"
+                      (escape-chars (format #f "~s" default)
+                                    (char-set #\@ #\{ #\})
+                                    #\@)))
+            (for-each generate (or (assq-ref sub-documentation field-name) '()))
+            (format #t "@end deftypevr\n\n")))
+        (filter (lambda (f)
+                  (not (string=? "" (configuration-field-documentation f))))
+                fields)))))
+  (generate 'prosody-configuration)
+  (format #t "It could be that you just want to get a @code{prosody.cfg.lua}
+up and running.  In that case, you can pass an
+@code{opaque-prosody-configuration} record as the value of
+@code{prosody-service-type}.  As its name indicates, an opaque configuration
+does not have easy reflective capabilities.")
+  (generate 'opaque-prosody-configuration)
+  (format #t "For example, if your @code{prosody.cfg.lua} is just the empty
+string, you could instantiate a prosody service like this:
+
+@example
+(service prosody-service-type
+         (opaque-prosody-configuration
+          (prosody.cfg.lua \"\")))
+@end example"))
diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm
index d672ecf687..ac011f1286 100644
--- a/gnu/services/networking.scm
+++ b/gnu/services/networking.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2016 John Darrington <jmd@gnu.org>
@@ -633,7 +633,12 @@ configuration file."
       (let ((file-name "/etc/wicd/dhclient.conf.template.default"))
         (unless (file-exists? file-name)
           (copy-file (string-append #$wicd file-name)
-                     file-name)))))
+                     file-name)))
+
+      ;; Wicd invokes 'wpa_supplicant', which needs this directory for its
+      ;; named socket files.
+      (mkdir-p "/var/run/wpa_supplicant")
+      (chmod "/var/run/wpa_supplicant" #o750)))
 
 (define (wicd-shepherd-service wicd)
   "Return a shepherd service for WICD."
diff --git a/gnu/services/sddm.scm b/gnu/services/sddm.scm
index 5bb58bd6f0..2ebfe22016 100644
--- a/gnu/services/sddm.scm
+++ b/gnu/services/sddm.scm
@@ -220,7 +220,7 @@ Relogin="              (if (sddm-configuration-relogin? config)
    (name "sddm-greeter")
    (auth
     (list
-     ;; Load environment form /etc/environment and ~/.pam_environment
+     ;; Load environment from /etc/environment and ~/.pam_environment
      (pam-entry
       (control "required")
       (module "pam_env.so"))
diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm
index 3273184b9a..d8d5006abf 100644
--- a/gnu/services/shepherd.scm
+++ b/gnu/services/shepherd.scm
@@ -82,7 +82,7 @@
                     (loop (+ 1 fd))))
 
                 ;; Start shepherd.
-                (execl (string-append #$shepherd "/bin/shepherd")
+                (execl #$(file-append shepherd "/bin/shepherd")
                        "shepherd" "--config" #$shepherd-conf)))))
 
 (define shepherd-root-service-type
diff --git a/gnu/services/web.scm b/gnu/services/web.scm
index 8f6e5bf6b7..db895405a2 100644
--- a/gnu/services/web.scm
+++ b/gnu/services/web.scm
@@ -27,11 +27,12 @@
   #:use-module (gnu packages web)
   #:use-module (guix records)
   #:use-module (guix gexp)
+  #:use-module (srfi srfi-1)
   #:use-module (ice-9 match)
   #:export (nginx-configuration
             nginx-configuration?
-            nginx-vhost-configuration
-            nginx-vhost-configuration?
+            nginx-server-configuration
+            nginx-server-configuration?
             nginx-service
             nginx-service-type))
 
@@ -41,24 +42,24 @@
 ;;;
 ;;; Code:
 
-(define-record-type* <nginx-vhost-configuration>
-  nginx-vhost-configuration make-nginx-vhost-configuration
-  nginx-vhost-configuration?
-  (http-port           nginx-vhost-configuration-http-port
+(define-record-type* <nginx-server-configuration>
+  nginx-server-configuration make-nginx-server-configuration
+  nginx-server-configuration?
+  (http-port           nginx-server-configuration-http-port
                        (default 80))
-  (https-port          nginx-vhost-configuration-https-port
+  (https-port          nginx-server-configuration-https-port
                        (default 443))
-  (server-name         nginx-vhost-configuration-server-name
+  (server-name         nginx-server-configuration-server-name
                        (default (list 'default)))
-  (root                nginx-vhost-configuration-root
+  (root                nginx-server-configuration-root
                        (default "/srv/http"))
-  (index               nginx-vhost-configuration-index
+  (index               nginx-server-configuration-index
                        (default (list "index.html")))
-  (ssl-certificate     nginx-vhost-configuration-ssl-certificate
+  (ssl-certificate     nginx-server-configuration-ssl-certificate
                        (default "/etc/nginx/cert.pem"))
-  (ssl-certificate-key nginx-vhost-configuration-ssl-certificate-key
+  (ssl-certificate-key nginx-server-configuration-ssl-certificate-key
                        (default "/etc/nginx/key.pem"))
-  (server-tokens?      nginx-vhost-configuration-server-tokens?
+  (server-tokens?      nginx-server-configuration-server-tokens?
                        (default #f)))
 
 (define-record-type* <nginx-configuration>
@@ -67,6 +68,7 @@
   (nginx         nginx-configuration-nginx)         ;<package>
   (log-directory nginx-configuration-log-directory) ;string
   (run-directory nginx-configuration-run-directory) ;string
+  (server-blocks nginx-configuration-server-blocks) ;list
   (file          nginx-configuration-file))         ;string | file-like
 
 (define (config-domain-strings names)
@@ -74,8 +76,8 @@
 of domain names."
  (string-join
   (map (match-lambda
-        ('default "_")
-        ((? string? str) str))
+        ('default "_ ")
+        ((? string? str) (string-append str " ")))
        names)))
 
 (define (config-index-strings names)
@@ -83,40 +85,40 @@ of domain names."
 of index files."
  (string-join
   (map (match-lambda
-        ((? string? str) str))
+        ((? string? str) (string-append str " ")))
        names)))
 
-(define (default-nginx-vhost-config vhost)
+(define (default-nginx-server-config server)
   (string-append
    "    server {\n"
-   (if (nginx-vhost-configuration-http-port vhost)
+   (if (nginx-server-configuration-http-port server)
        (string-append "      listen "
-                      (number->string (nginx-vhost-configuration-http-port vhost))
+                      (number->string (nginx-server-configuration-http-port server))
                       ";\n")
        "")
-   (if (nginx-vhost-configuration-https-port vhost)
+   (if (nginx-server-configuration-https-port server)
        (string-append "      listen "
-                      (number->string (nginx-vhost-configuration-https-port vhost))
+                      (number->string (nginx-server-configuration-https-port server))
                       " ssl;\n")
        "")
    "      server_name " (config-domain-strings
-                         (nginx-vhost-configuration-server-name vhost))
+                         (nginx-server-configuration-server-name server))
                         ";\n"
-   (if (nginx-vhost-configuration-ssl-certificate vhost)
+   (if (nginx-server-configuration-ssl-certificate server)
        (string-append "      ssl_certificate "
-                      (nginx-vhost-configuration-ssl-certificate vhost) ";\n")
+                      (nginx-server-configuration-ssl-certificate server) ";\n")
        "")
-   (if (nginx-vhost-configuration-ssl-certificate-key vhost)
+   (if (nginx-server-configuration-ssl-certificate-key server)
        (string-append "      ssl_certificate_key "
-                      (nginx-vhost-configuration-ssl-certificate-key vhost) ";\n")
+                      (nginx-server-configuration-ssl-certificate-key server) ";\n")
        "")
-   "      root " (nginx-vhost-configuration-root vhost) ";\n"
-   "      index " (config-index-strings (nginx-vhost-configuration-index vhost)) ";\n"
-   "      server_tokens " (if (nginx-vhost-configuration-server-tokens? vhost)
+   "      root " (nginx-server-configuration-root server) ";\n"
+   "      index " (config-index-strings (nginx-server-configuration-index server)) ";\n"
+   "      server_tokens " (if (nginx-server-configuration-server-tokens? server)
                               "on" "off") ";\n"
    "    }\n"))
 
-(define (default-nginx-config log-directory run-directory vhost-list)
+(define (default-nginx-config log-directory run-directory server-list)
   (plain-file "nginx.conf"
               (string-append
                "user nginx nginx;\n"
@@ -129,7 +131,7 @@ of index files."
                "    uwsgi_temp_path " run-directory "/uwsgi_temp;\n"
                "    scgi_temp_path " run-directory "/scgi_temp;\n"
                "    access_log " log-directory "/access.log;\n"
-               (let ((http (map default-nginx-vhost-config vhost-list)))
+               (let ((http (map default-nginx-server-config server-list)))
                  (do ((http http (cdr http))
                       (block "" (string-append (car http) "\n" block )))
                      ((null? http) block)))
@@ -148,7 +150,8 @@ of index files."
 
 (define nginx-activation
   (match-lambda
-    (($ <nginx-configuration> nginx log-directory run-directory config-file)
+    (($ <nginx-configuration> nginx log-directory run-directory server-blocks
+                              config-file)
      #~(begin
          (use-modules (guix build utils))
 
@@ -164,17 +167,25 @@ of index files."
          (mkdir-p (string-append #$run-directory "/scgi_temp"))
          ;; Check configuration file syntax.
          (system* (string-append #$nginx "/sbin/nginx")
-                  "-c" #$config-file "-t")))))
+                  "-c" #$(or config-file
+                             (default-nginx-config log-directory
+                               run-directory server-blocks))
+                  "-t")))))
 
 (define nginx-shepherd-service
   (match-lambda
-    (($ <nginx-configuration> nginx log-directory run-directory config-file)
+    (($ <nginx-configuration> nginx log-directory run-directory server-blocks
+                              config-file)
      (let* ((nginx-binary (file-append nginx "/sbin/nginx"))
             (nginx-action
              (lambda args
                #~(lambda _
                    (zero?
-                    (system* #$nginx-binary "-c" #$config-file #$@args))))))
+                    (system* #$nginx-binary "-c"
+                             #$(or config-file
+                                   (default-nginx-config log-directory
+                                     run-directory server-blocks))
+                             #$@args))))))
 
        ;; TODO: Add 'reload' action.
        (list (shepherd-service
@@ -192,14 +203,20 @@ of index files."
                        (service-extension activation-service-type
                                           nginx-activation)
                        (service-extension account-service-type
-                                          (const %nginx-accounts))))))
+                                          (const %nginx-accounts))))
+                (compose concatenate)
+                (extend (lambda (config servers)
+                          (nginx-configuration
+                            (inherit config)
+                            (server-blocks
+                              (append (nginx-configuration-server-blocks config)
+                              servers)))))))
 
 (define* (nginx-service #:key (nginx nginx)
                         (log-directory "/var/log/nginx")
                         (run-directory "/var/run/nginx")
-                        (vhost-list (list (nginx-vhost-configuration)))
-                        (config-file
-                         (default-nginx-config log-directory run-directory vhost-list)))
+                        (server-list '())
+                        (config-file #f))
   "Return a service that runs NGINX, the nginx web server.
 
 The nginx daemon loads its runtime configuration from CONFIG-FILE, stores log
@@ -209,4 +226,5 @@ files in LOG-DIRECTORY, and stores temporary runtime files in RUN-DIRECTORY."
             (nginx nginx)
             (log-directory log-directory)
             (run-directory run-directory)
+            (server-blocks server-list)
             (file config-file))))