Merge branch 'master' into staging

9 files changed, 531 insertions, 438 deletions

diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm
new file mode 100644
index 0000000000..9f28aabc96
--- /dev/null
+++ b/gnu/services/configuration.scm
@@ -0,0 +1,205 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 Andy Wingo <wingo@igalia.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 configuration)
+  #:use-module (guix packages)
+  #:use-module (guix records)
+  #:use-module (guix gexp)
+  #:autoload   (texinfo) (texi-fragment->stexi)
+  #:autoload   (texinfo serialize) (stexi->texi)
+  #:use-module (ice-9 match)
+  #:use-module ((srfi srfi-1) #:select (append-map))
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:export (configuration-field
+            configuration-field-name
+            configuration-missing-field
+            configuration-field-error
+            serialize-configuration
+            define-configuration
+            validate-configuration
+            generate-documentation
+            serialize-field
+            serialize-string
+            serialize-name
+            serialize-space-separated-string-list
+            space-separated-string-list?
+            serialize-file-name
+            file-name?
+            serialize-boolean
+            serialize-package))
+
+;;; Commentary:
+;;;
+;;; Syntax for creating Scheme bindings to complex configuration files.
+;;;
+;;; Code:
+
+(define-condition-type &configuration-error &error
+  configuration-error?)
+
+(define (configuration-error message)
+  (raise (condition (&message (message message))
+                    (&configuration-error))))
+(define (configuration-field-error field val)
+  (configuration-error
+   (format #f "Invalid value for field ~a: ~s" field val)))
+(define (configuration-missing-field kind field)
+  (configuration-error
+   (format #f "~a configuration missing required field ~a" kind field)))
+
+(define-record-type* <configuration-field>
+  configuration-field make-configuration-field configuration-field?
+  (name configuration-field-name)
+  (type configuration-field-type)
+  (getter configuration-field-getter)
+  (predicate configuration-field-predicate)
+  (serializer configuration-field-serializer)
+  (default-value-thunk configuration-field-default-value-thunk)
+  (documentation configuration-field-documentation))
+
+(define (serialize-configuration config fields)
+  (for-each (lambda (field)
+              ((configuration-field-serializer field)
+               (configuration-field-name field)
+               ((configuration-field-getter field) config)))
+            fields))
+
+(define (validate-configuration config fields)
+  (for-each (lambda (field)
+              (let ((val ((configuration-field-getter field) config)))
+                (unless ((configuration-field-predicate field) val)
+                  (configuration-field-error
+                   (configuration-field-name field) val))))
+            fields))
+
+(define-syntax define-configuration
+  (lambda (stx)
+    (define (id ctx part . parts)
+      (let ((part (syntax->datum part)))
+        (datum->syntax
+         ctx
+         (match parts
+           (() part)
+           (parts (symbol-append part
+                                 (syntax->datum (apply id ctx parts))))))))
+    (syntax-case stx ()
+      ((_ stem (field (field-type def) doc) ...)
+       (with-syntax (((field-getter ...)
+                      (map (lambda (field)
+                             (id #'stem #'stem #'- field))
+                           #'(field ...)))
+                     ((field-predicate ...)
+                      (map (lambda (type)
+                             (id #'stem type #'?))
+                           #'(field-type ...)))
+                     ((field-serializer ...)
+                      (map (lambda (type)
+                             (id #'stem #'serialize- type))
+                           #'(field-type ...))))
+           #`(begin
+               (define-record-type* #,(id #'stem #'< #'stem #'>)
+                 #,(id #'stem #'% #'stem)
+                 #,(id #'stem #'make- #'stem)
+                 #,(id #'stem #'stem #'?)
+                 (field field-getter (default def))
+                 ...)
+               (define #,(id #'stem #'stem #'-fields)
+                 (list (configuration-field
+                        (name 'field)
+                        (type 'field-type)
+                        (getter field-getter)
+                        (predicate field-predicate)
+                        (serializer field-serializer)
+                        (default-value-thunk (lambda () def))
+                        (documentation doc))
+                       ...))
+               (define-syntax-rule (stem arg (... ...))
+                 (let ((conf (#,(id #'stem #'% #'stem) arg (... ...))))
+                   (validate-configuration conf
+                                           #,(id #'stem #'stem #'-fields))
+                   conf))))))))
+
+(define (uglify-field-name field-name)
+  (let ((str (symbol->string field-name)))
+    (string-concatenate
+     (map string-titlecase
+          (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-package field-name val)
+  #f)
+
+(define (serialize-string field-name val)
+  (serialize-field field-name val))
+
+(define (space-separated-string-list? val)
+  (and (list? val)
+       (and-map (lambda (x)
+                  (and (string? x) (not (string-index x #\space))))
+                val)))
+(define (serialize-space-separated-string-list field-name val)
+  (serialize-field field-name (string-join val " ")))
+
+(define (file-name? val)
+  (and (string? val)
+       (string-prefix? "/" val)))
+(define (serialize-file-name field-name val)
+  (serialize-string field-name val))
+
+(define (serialize-boolean field-name val)
+  (serialize-string field-name (if val "yes" "no")))
+
+;; A little helper to make it easier to document all those fields.
+(define (generate-documentation documentation documentation-name)
+  (define (str x) (object->string x))
+  (define (generate configuration-name)
+    (match (assq-ref documentation configuration-name)
+      ((fields . sub-documentation)
+       `((para "Available " (code ,(str configuration-name)) " fields are:")
+         ,@(map
+            (lambda (f)
+              (let ((field-name (configuration-field-name f))
+                    (field-type (configuration-field-type f))
+                    (field-docs (cdr (texi-fragment->stexi
+                                      (configuration-field-documentation f))))
+                    (default (catch #t
+                               (configuration-field-default-value-thunk f)
+                               (lambda _ '%invalid))))
+                (define (show-default? val)
+                  (or (string? default) (number? default) (boolean? default)
+                      (and (symbol? val) (not (eq? val '%invalid)))
+                      (and (list? val) (and-map show-default? val))))
+                `(deftypevr (% (category
+                                (code ,(str configuration-name)) " parameter")
+                               (data-type ,(str field-type))
+                               (name ,(str field-name)))
+                   ,@field-docs
+                   ,@(if (show-default? default)
+                         `((para "Defaults to " (samp ,(str default)) "."))
+                         '())
+                   ,@(append-map
+                      generate
+                      (or (assq-ref sub-documentation field-name) '())))))
+            fields)))))
+  (stexi->texi `(*fragment* . ,(generate documentation-name))))
diff --git a/gnu/services/cuirass.scm b/gnu/services/cuirass.scm
new file mode 100644
index 0000000000..d843c07335
--- /dev/null
+++ b/gnu/services/cuirass.scm
@@ -0,0 +1,115 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation, either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu services cuirass)
+  #:use-module (guix gexp)
+  #:use-module (guix records)
+  #:use-module (gnu packages admin)
+  #:autoload   (gnu packages ci) (cuirass)
+  #:use-module (gnu services)
+  #:use-module (gnu services base)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu system shadow)
+  #:export (<cuirass-configuration>
+            cuirass-configuration
+            cuirass-configuration?
+
+            cuirass-service-type
+            cuirass-service))
+
+;;;; Commentary:
+;;;
+;;; This module implements a service that to run instances of Cuirass, a
+;;; continuous integration tool.
+;;;
+;;;; Code:
+
+(define-record-type* <cuirass-configuration>
+  cuirass-configuration make-cuirass-configuration
+  cuirass-configuration?
+  (cache-directory  cuirass-configuration-cache-directory ;string (dir-name)
+                    (default ""))
+  (user             cuirass-configuration-user ;string
+                    (default "cuirass"))
+  (group            cuirass-configuration-group ;string
+                    (default "cuirass"))
+  (interval         cuirass-configuration-interval ;integer (seconds)
+                    (default 60))
+  (database         cuirass-configuration-database ;string (file-name)
+                    (default "/var/run/cuirass/cuirass.db"))
+  (specifications   cuirass-configuration-specifications ;string (file-name)
+                    (default ""))
+  (use-substitutes? cuirass-configuration-use-substitutes? ;boolean
+                    (default #f))
+  (one-shot?        cuirass-configuration-one-shot? ;boolean
+                    (default #f)))
+
+(define (cuirass-shepherd-service config)
+  "Return a <shepherd-service> for the Cuirass service with CONFIG."
+  (and
+   (cuirass-configuration? config)
+   (let ((cache-directory  (cuirass-configuration-cache-directory config))
+         (interval         (cuirass-configuration-interval config))
+         (database         (cuirass-configuration-database config))
+         (specifications   (cuirass-configuration-specifications config))
+         (use-substitutes? (cuirass-configuration-use-substitutes? config))
+         (one-shot?        (cuirass-configuration-one-shot? config)))
+     (list (shepherd-service
+            (documentation "Run Cuirass.")
+            (provision '(cuirass))
+            (requirement '(guix-daemon))
+            (start #~(make-forkexec-constructor
+                      (list (string-append #$cuirass "/bin/cuirass")
+                            #$@(if (string=? "" cache-directory)
+                                   '()
+                                   (list "--cache-directory" cache-directory))
+                            #$@(if (string=? "" specifications)
+                                   '()
+                                   (list "--specifications" specifications))
+                            "--database" #$database
+                            "--interval" #$(number->string interval)
+                            #$@(if use-substitutes? '("--use-substitutes") '())
+                            #$@(if one-shot? '("--one-shot") '()))))
+            (stop #~(make-kill-destructor)))))))
+
+(define (cuirass-account config)
+  "Return the user accounts and user groups for CONFIG."
+  (let ((cuirass-user  (cuirass-configuration-user config))
+        (cuirass-group (cuirass-configuration-group config)))
+    (list (user-group
+           (name cuirass-group)
+           (system? #t))
+          (user-account
+           (name cuirass-user)
+           (group cuirass-group)
+           (system? #t)
+           (comment "Cuirass privilege separation user")
+           (home-directory (string-append "/var/run/" cuirass-user))
+           (shell #~(string-append #$shadow "/sbin/nologin"))))))
+
+(define cuirass-service-type
+  (service-type
+   (name 'cuirass)
+   (extensions
+    (list
+     (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/cups.scm b/gnu/services/cups.scm
index 7542ee26c0..391046a75f 100644
--- a/gnu/services/cups.scm
+++ b/gnu/services/cups.scm
@@ -19,6 +19,7 @@
 (define-module (gnu services cups)
   #:use-module (gnu services)
   #:use-module (gnu services shepherd)
+  #:use-module (gnu services configuration)
   #:use-module (gnu system shadow)
   #:use-module (gnu packages admin)
   #:use-module (gnu packages cups)
@@ -26,16 +27,9 @@
   #:use-module (guix packages)
   #:use-module (guix records)
   #:use-module (guix gexp)
-  #:use-module (texinfo)
-  #:use-module (texinfo serialize)
   #:use-module (ice-9 match)
   #:use-module ((srfi srfi-1) #:select (append-map))
-  #:use-module (srfi srfi-34)
-  #:use-module (srfi srfi-35)
-  #:export (&cups-configuation-error
-            cups-configuration-error?
-
-            cups-service-type
+  #:export (cups-service-type
             cups-configuration
             opaque-cups-configuration
 
@@ -51,91 +45,6 @@
 ;;;
 ;;; Code:
 
-(define-condition-type &cups-configuration-error &error
-  cups-configuration-error?)
-
-(define (cups-error message)
-  (raise (condition (&message (message message))
-                    (&cups-configuration-error))))
-(define (cups-configuration-field-error field val)
-  (cups-error
-   (format #f "Invalid value for field ~a: ~s" field val)))
-(define (cups-configuration-missing-field kind field)
-  (cups-error
-   (format #f "~a configuration missing required field ~a" kind field)))
-
-(define-record-type* <configuration-field>
-  configuration-field make-configuration-field configuration-field?
-  (name configuration-field-name)
-  (type configuration-field-type)
-  (getter configuration-field-getter)
-  (predicate configuration-field-predicate)
-  (serializer configuration-field-serializer)
-  (default-value-thunk configuration-field-default-value-thunk)
-  (documentation configuration-field-documentation))
-
-(define (serialize-configuration config fields)
-  (for-each (lambda (field)
-              ((configuration-field-serializer field)
-               (configuration-field-name field)
-               ((configuration-field-getter field) config)))
-            fields))
-
-(define (validate-configuration config fields)
-  (for-each (lambda (field)
-              (let ((val ((configuration-field-getter field) config)))
-                (unless ((configuration-field-predicate field) val)
-                  (cups-configuration-field-error
-                   (configuration-field-name field) val))))
-            fields))
-
-(define-syntax define-configuration
-  (lambda (stx)
-    (define (id ctx part . parts)
-      (let ((part (syntax->datum part)))
-        (datum->syntax
-         ctx
-         (match parts
-           (() part)
-           (parts (symbol-append part
-                                 (syntax->datum (apply id ctx parts))))))))
-    (syntax-case stx ()
-      ((_ stem (field (field-type def) doc) ...)
-       (with-syntax (((field-getter ...)
-                      (map (lambda (field)
-                             (id #'stem #'stem #'- field))
-                           #'(field ...)))
-                     ((field-predicate ...)
-                      (map (lambda (type)
-                             (id #'stem type #'?))
-                           #'(field-type ...)))
-                     ((field-serializer ...)
-                      (map (lambda (type)
-                             (id #'stem #'serialize- type))
-                           #'(field-type ...))))
-           #`(begin
-               (define-record-type* #,(id #'stem #'< #'stem #'>)
-                 #,(id #'stem #'% #'stem)
-                 #,(id #'stem #'make- #'stem)
-                 #,(id #'stem #'stem #'?)
-                 (field field-getter (default def))
-                 ...)
-               (define #,(id #'stem #'stem #'-fields)
-                 (list (configuration-field
-                        (name 'field)
-                        (type 'field-type)
-                        (getter field-getter)
-                        (predicate field-predicate)
-                        (serializer field-serializer)
-                        (default-value-thunk (lambda () def))
-                        (documentation doc))
-                       ...))
-               (define-syntax-rule (stem arg (... ...))
-                 (let ((conf (#,(id #'stem #'% #'stem) arg (... ...))))
-                   (validate-configuration conf
-                                           #,(id #'stem #'stem #'-fields))
-                   conf))))))))
-
 (define %cups-accounts
   (list (user-group (name "lp") (system? #t))
         (user-group (name "lpadmin") (system? #t))
@@ -147,24 +56,6 @@
          (home-directory "/var/empty")
          (shell (file-append shadow "/sbin/nologin")))))
 
-(define (uglify-field-name field-name)
-  (let ((str (symbol->string field-name)))
-    (string-concatenate
-     (map string-titlecase
-          (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-package field-name val)
-  #f)
-
-(define (serialize-string field-name val)
-  (serialize-field field-name val))
-
 (define (multiline-string-list? val)
   (and (list? val)
        (and-map (lambda (x)
@@ -173,28 +64,11 @@
 (define (serialize-multiline-string-list field-name val)
   (for-each (lambda (str) (serialize-field field-name str)) val))
 
-(define (space-separated-string-list? val)
-  (and (list? val)
-       (and-map (lambda (x)
-                  (and (string? x) (not (string-index x #\space))))
-                val)))
-(define (serialize-space-separated-string-list field-name val)
-  (serialize-field field-name (string-join val " ")))
-
 (define (space-separated-symbol-list? val)
   (and (list? val) (and-map symbol? val)))
 (define (serialize-space-separated-symbol-list field-name val)
   (serialize-field field-name (string-join (map symbol->string val) " ")))
 
-(define (file-name? val)
-  (and (string? val)
-       (string-prefix? "/" val)))
-(define (serialize-file-name field-name val)
-  (serialize-string field-name val))
-
-(define (serialize-boolean field-name val)
-  (serialize-string field-name (if val "yes" "no")))
-
 (define (non-negative-integer? val)
   (and (exact-integer? val) (not (negative? val))))
 (define (serialize-non-negative-integer field-name val)
@@ -333,7 +207,7 @@ methods.  Otherwise apply to only the listed methods.")
 
 (define-configuration location-access-control
   (path
-   (file-name (cups-configuration-missing-field 'location-access-control 'path))
+   (file-name (configuration-missing-field 'location-access-control 'path))
    "Specifies the URI path to which the access control applies.")
   (access-controls
    (access-control-list '())
@@ -359,7 +233,7 @@ methods.  Otherwise apply to only the listed methods.")
 
 (define-configuration policy-configuration
   (name
-   (string (cups-configuration-missing-field 'policy-configuration 'name))
+   (string (configuration-missing-field 'policy-configuration 'name))
    "Name of the policy.")
   (job-private-access
    (string "@OWNER @SYSTEM")
@@ -925,12 +799,12 @@ IPP specifications.")
    (package-list '())
    "Drivers and other extensions to the CUPS package.")
   (cupsd.conf
-   (string (cups-configuration-missing-field 'opaque-cups-configuration
-                                             'cupsd.conf))
+   (string (configuration-missing-field 'opaque-cups-configuration
+                                        'cupsd.conf))
    "The contents of the @code{cupsd.conf} to use.")
   (cups-files.conf
-   (string (cups-configuration-missing-field 'opaque-cups-configuration
-                                             'cups-files.conf))
+   (string (configuration-missing-field 'opaque-cups-configuration
+                                        'cups-files.conf))
    "The contents of the @code{cups-files.conf} to use."))
 
 (define %cups-activation
@@ -1117,8 +991,8 @@ extensions that it uses."
                                extensions)))))))))
 
 ;; A little helper to make it easier to document all those fields.
-(define (generate-documentation)
-  (define documentation
+(define (generate-cups-documentation)
+  (generate-documentation
     `((cups-configuration
        ,cups-configuration-fields
        (files-configuration files-configuration)
@@ -1132,35 +1006,5 @@ extensions that it uses."
        ,location-access-control-fields
        (method-access-controls method-access-controls))
       (operation-access-controls ,operation-access-control-fields)
-      (method-access-controls ,method-access-control-fields)))
-  (define (str x) (object->string x))
-  (define (generate configuration-name)
-    (match (assq-ref documentation configuration-name)
-      ((fields . sub-documentation)
-       `((para "Available " (code ,(str configuration-name)) " fields are:")
-         ,@(map
-            (lambda (f)
-              (let ((field-name (configuration-field-name f))
-                    (field-type (configuration-field-type f))
-                    (field-docs (cdr (texi-fragment->stexi
-                                      (configuration-field-documentation f))))
-                    (default (catch #t
-                               (configuration-field-default-value-thunk f)
-                               (lambda _ '%invalid))))
-                (define (show-default? val)
-                  (or (string? default) (number? default) (boolean? default)
-                      (and (symbol? val) (not (eq? val '%invalid)))
-                      (and (list? val) (and-map show-default? val))))
-                `(deftypevr (% (category
-                                (code ,(str configuration-name)) " parameter")
-                               (data-type ,(str field-type))
-                               (name ,(str field-name)))
-                   ,@field-docs
-                   ,@(if (show-default? default)
-                         `((para "Defaults to " (samp ,(str default)) "."))
-                         '())
-                   ,@(append-map
-                      generate
-                      (or (assq-ref sub-documentation field-name) '())))))
-            fields)))))
-  (stexi->texi `(*fragment* . ,(generate 'cups-configuration))))
+      (method-access-controls ,method-access-control-fields))
+    'cups-configuration))
diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm
index 876f56d45f..26390a4acd 100644
--- a/gnu/services/dbus.scm
+++ b/gnu/services/dbus.scm
@@ -21,7 +21,9 @@
   #:use-module (gnu services)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system shadow)
+  #:use-module (gnu system pam)
   #:use-module ((gnu packages glib) #:select (dbus))
+  #:use-module (gnu packages polkit)
   #:use-module (gnu packages admin)
   #:use-module (guix gexp)
   #:use-module (guix records)
@@ -30,7 +32,10 @@
   #:export (dbus-configuration
             dbus-configuration?
             dbus-root-service-type
-            dbus-service))
+            dbus-service
+
+            polkit-service-type
+            polkit-service))
 
 ;;;
 ;;; D-Bus.
@@ -218,4 +223,91 @@ and policy files.  For example, to allow avahi-daemon to use the system bus,
            (dbus-configuration (dbus dbus)
                                (services services))))
 
+
+;;;
+;;; Polkit privilege management service.
+;;;
+
+(define-record-type* <polkit-configuration>
+  polkit-configuration make-polkit-configuration
+  polkit-configuration?
+  (polkit   polkit-configuration-polkit           ;<package>
+            (default polkit))
+  (actions  polkit-configuration-actions          ;list of <package>
+            (default '())))
+
+(define %polkit-accounts
+  (list (user-group (name "polkitd") (system? #t))
+        (user-account
+         (name "polkitd")
+         (group "polkitd")
+         (system? #t)
+         (comment "Polkit daemon user")
+         (home-directory "/var/empty")
+         (shell "/run/current-system/profile/sbin/nologin"))))
+
+(define %polkit-pam-services
+  (list (unix-pam-service "polkit-1")))
+
+(define (polkit-directory packages)
+  "Return a directory containing an @file{actions} and possibly a
+@file{rules.d} sub-directory, for use as @file{/etc/polkit-1}."
+  (with-imported-modules '((guix build union))
+    (computed-file "etc-polkit-1"
+                   #~(begin
+                       (use-modules (guix build union) (srfi srfi-26))
+
+                       (union-build #$output
+                                    (map (cut string-append <>
+                                              "/share/polkit-1")
+                                         (list #$@packages)))))))
+
+(define polkit-etc-files
+  (match-lambda
+    (($ <polkit-configuration> polkit packages)
+     `(("polkit-1" ,(polkit-directory (cons polkit packages)))))))
+
+(define polkit-setuid-programs
+  (match-lambda
+    (($ <polkit-configuration> polkit)
+     (list (file-append polkit "/lib/polkit-1/polkit-agent-helper-1")
+           (file-append polkit "/bin/pkexec")))))
+
+(define polkit-service-type
+  (service-type (name 'polkit)
+                (extensions
+                 (list (service-extension account-service-type
+                                          (const %polkit-accounts))
+                       (service-extension pam-root-service-type
+                                          (const %polkit-pam-services))
+                       (service-extension dbus-root-service-type
+                                          (compose
+                                           list
+                                           polkit-configuration-polkit))
+                       (service-extension etc-service-type
+                                          polkit-etc-files)
+                       (service-extension setuid-program-service-type
+                                          polkit-setuid-programs)))
+
+                ;; Extensions are lists of packages that provide polkit rules
+                ;; or actions under share/polkit-1/{actions,rules.d}.
+                (compose concatenate)
+                (extend (lambda (config actions)
+                          (polkit-configuration
+                           (inherit config)
+                           (actions
+                            (append (polkit-configuration-actions config)
+                                    actions)))))))
+
+(define* (polkit-service #:key (polkit polkit))
+  "Return a service that runs the
+@uref{http://www.freedesktop.org/wiki/Software/polkit/, Polkit privilege
+management service}, which allows system administrators to grant access to
+privileged operations in a structured way.  By querying the Polkit service, a
+privileged system component can know when it should grant additional
+capabilities to ordinary users.  For example, an ordinary user can be granted
+the capability to suspend the system if the user is logged in locally."
+  (service polkit-service-type
+           (polkit-configuration (polkit polkit))))
+
 ;;; dbus.scm ends here
diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm
index dfd1ea6e92..7555780ade 100644
--- a/gnu/services/desktop.scm
+++ b/gnu/services/desktop.scm
@@ -37,7 +37,6 @@
   #:use-module (gnu packages gnome)
   #:use-module (gnu packages xfce)
   #:use-module (gnu packages avahi)
-  #:use-module (gnu packages polkit)
   #:use-module (gnu packages xdisorg)
   #:use-module (gnu packages suckless)
   #:use-module (gnu packages linux)
@@ -68,11 +67,6 @@
 
             bluetooth-service
 
-            polkit-configuration
-            polkit-configuration?
-            polkit-service
-            polkit-service-type
-
             elogind-configuration
             elogind-configuration?
             elogind-service
@@ -415,93 +409,6 @@ Users need to be in the @code{lp} group to access the D-Bus service.
 
 
 ;;;
-;;; Polkit privilege management service.
-;;;
-
-(define-record-type* <polkit-configuration>
-  polkit-configuration make-polkit-configuration
-  polkit-configuration?
-  (polkit   polkit-configuration-polkit           ;<package>
-            (default polkit))
-  (actions  polkit-configuration-actions          ;list of <package>
-            (default '())))
-
-(define %polkit-accounts
-  (list (user-group (name "polkitd") (system? #t))
-        (user-account
-         (name "polkitd")
-         (group "polkitd")
-         (system? #t)
-         (comment "Polkit daemon user")
-         (home-directory "/var/empty")
-         (shell "/run/current-system/profile/sbin/nologin"))))
-
-(define %polkit-pam-services
-  (list (unix-pam-service "polkit-1")))
-
-(define (polkit-directory packages)
-  "Return a directory containing an @file{actions} and possibly a
-@file{rules.d} sub-directory, for use as @file{/etc/polkit-1}."
-  (with-imported-modules '((guix build union))
-    (computed-file "etc-polkit-1"
-                   #~(begin
-                       (use-modules (guix build union) (srfi srfi-26))
-
-                       (union-build #$output
-                                    (map (cut string-append <>
-                                              "/share/polkit-1")
-                                         (list #$@packages)))))))
-
-(define polkit-etc-files
-  (match-lambda
-    (($ <polkit-configuration> polkit packages)
-     `(("polkit-1" ,(polkit-directory (cons polkit packages)))))))
-
-(define polkit-setuid-programs
-  (match-lambda
-    (($ <polkit-configuration> polkit)
-     (list (file-append polkit "/lib/polkit-1/polkit-agent-helper-1")
-           (file-append polkit "/bin/pkexec")))))
-
-(define polkit-service-type
-  (service-type (name 'polkit)
-                (extensions
-                 (list (service-extension account-service-type
-                                          (const %polkit-accounts))
-                       (service-extension pam-root-service-type
-                                          (const %polkit-pam-services))
-                       (service-extension dbus-root-service-type
-                                          (compose
-                                           list
-                                           polkit-configuration-polkit))
-                       (service-extension etc-service-type
-                                          polkit-etc-files)
-                       (service-extension setuid-program-service-type
-                                          polkit-setuid-programs)))
-
-                ;; Extensions are lists of packages that provide polkit rules
-                ;; or actions under share/polkit-1/{actions,rules.d}.
-                (compose concatenate)
-                (extend (lambda (config actions)
-                          (polkit-configuration
-                           (inherit config)
-                           (actions
-                            (append (polkit-configuration-actions config)
-                                    actions)))))))
-
-(define* (polkit-service #:key (polkit polkit))
-  "Return a service that runs the
-@uref{http://www.freedesktop.org/wiki/Software/polkit/, Polkit privilege
-management service}, which allows system administrators to grant access to
-privileged operations in a structured way.  By querying the Polkit service, a
-privileged system component can know when it should grant additional
-capabilities to ordinary users.  For example, an ordinary user can be granted
-the capability to suspend the system if the user is logged in locally."
-  (service polkit-service-type
-           (polkit-configuration (polkit polkit))))
-
-
-;;;
 ;;; Colord D-Bus service.
 ;;;
 
diff --git a/gnu/services/kerberos.scm b/gnu/services/kerberos.scm
index 144c71bba0..a56f63082c 100644
--- a/gnu/services/kerberos.scm
+++ b/gnu/services/kerberos.scm
@@ -38,15 +38,17 @@
   "Return a PAM service for Kerberos authentication."
   (lambda (pam)
     (define pam-krb5-module
-      #~(string-append #$(pam-krb5-configuration-pam-krb5 config) "/lib/security/pam_krb5.so"))
+      #~(string-append #$(pam-krb5-configuration-pam-krb5 config)
+                       "/lib/security/pam_krb5.so"))
 
     (let ((pam-krb5-sufficient
            (pam-entry
             (control "sufficient")
             (module pam-krb5-module)
-            (arguments (list
-                        (format #f "minimum_uid=~a"
-                                (pam-krb5-configuration-minimum-uid config)))))))
+            (arguments
+             (list
+              (format #f "minimum_uid=~a"
+                      (pam-krb5-configuration-minimum-uid config)))))))
       (pam-service
        (inherit pam)
        (auth (cons* pam-krb5-sufficient
diff --git a/gnu/services/mail.scm b/gnu/services/mail.scm
index cb0f119f43..c1381405d8 100644
--- a/gnu/services/mail.scm
+++ b/gnu/services/mail.scm
@@ -21,6 +21,7 @@
 (define-module (gnu services mail)
   #:use-module (gnu services)
   #:use-module (gnu services base)
+  #:use-module (gnu services configuration)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system pam)
   #:use-module (gnu system shadow)
@@ -30,13 +31,8 @@
   #:use-module (guix records)
   #:use-module (guix packages)
   #:use-module (guix gexp)
-  #:use-module (srfi srfi-34)
-  #:use-module (srfi srfi-35)
   #:use-module (ice-9 match)
-  #:export (&dovecot-configuation-error
-            dovecot-configuration-error?
-
-            dovecot-service
+  #:export (dovecot-service
             dovecot-service-type
             dovecot-configuration
             opaque-dovecot-configuration
@@ -51,7 +47,12 @@
             protocol-configuration
             plugin-configuration
             mailbox-configuration
-            namespace-configuration))
+            namespace-configuration
+
+            opensmtpd-configuration
+            opensmtpd-configuration?
+            opensmtpd-service-type
+            %default-opensmtpd-config-file))
 
 ;;; Commentary:
 ;;;
@@ -60,112 +61,6 @@
 ;;;
 ;;; Code:
 
-(define-condition-type &dovecot-configuration-error &error
-  dovecot-configuration-error?)
-
-(define (dovecot-error message)
-  (raise (condition (&message (message message))
-                    (&dovecot-configuration-error))))
-(define (dovecot-configuration-field-error field val)
-  (dovecot-error
-   (format #f "Invalid value for field ~a: ~s" field val)))
-(define (dovecot-configuration-missing-field kind field)
-  (dovecot-error
-   (format #f "~a configuration missing required field ~a" kind field)))
-
-(define-record-type* <configuration-field>
-  configuration-field make-configuration-field configuration-field?
-  (name configuration-field-name)
-  (type configuration-field-type)
-  (getter configuration-field-getter)
-  (predicate configuration-field-predicate)
-  (serializer configuration-field-serializer)
-  (default-value-thunk configuration-field-default-value-thunk)
-  (documentation configuration-field-documentation))
-
-(define-syntax define-configuration
-  (lambda (stx)
-    (define (id ctx part . parts)
-      (let ((part (syntax->datum part)))
-        (datum->syntax
-         ctx
-         (match parts
-           (() part)
-           (parts (symbol-append part
-                                 (syntax->datum (apply id ctx parts))))))))
-    (syntax-case stx ()
-      ((_ stem (field (field-type def) doc) ...)
-       (with-syntax (((field-getter ...)
-                      (map (lambda (field)
-                             (id #'stem #'stem #'- field))
-                           #'(field ...)))
-                     ((field-predicate ...)
-                      (map (lambda (type)
-                             (id #'stem type #'?))
-                           #'(field-type ...)))
-                     ((field-serializer ...)
-                      (map (lambda (type)
-                             (id #'stem #'serialize- type))
-                           #'(field-type ...))))
-           #`(begin
-               (define-record-type* #,(id #'stem #'< #'stem #'>)
-                 stem #,(id #'stem #'make- #'stem) #,(id #'stem #'stem #'?)
-                 (field field-getter (default def))
-                 ...)
-               (define #,(id #'stem #'stem #'-fields)
-                 (list (configuration-field
-                        (name 'field)
-                        (type 'field-type)
-                        (getter field-getter)
-                        (predicate field-predicate)
-                        (serializer field-serializer)
-                        (default-value-thunk (lambda () def))
-                        (documentation doc))
-                       ...))))))))
-
-(define (serialize-configuration config fields)
-  (for-each (lambda (field)
-              ((configuration-field-serializer field)
-               (configuration-field-name field)
-               ((configuration-field-getter field) config)))
-            fields))
-
-(define (validate-configuration config fields)
-  (for-each (lambda (field)
-              (let ((val ((configuration-field-getter field) config)))
-                (unless ((configuration-field-predicate field) val)
-                  (dovecot-configuration-field-error
-                   (configuration-field-name field) val))))
-            fields))
-
-(define (validate-package field-name package)
-  (unless (package? package)
-    (dovecot-configuration-field-error field-name package)))
-
-(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-package field-name val)
-  #f)
-
-(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 val))
-
-(define (space-separated-string-list? val)
-  (and (list? val)
-       (and-map (lambda (x)
-                  (and (string? x) (not (string-index x #\space))))
-                val)))
-(define (serialize-space-separated-string-list field-name val)
-  (serialize-field field-name (string-join val " ")))
 
 (define (comma-separated-string-list? val)
   (and (list? val)
@@ -175,12 +70,6 @@
 (define (serialize-comma-separated-string-list field-name val)
   (serialize-field field-name (string-join val ",")))
 
-(define (file-name? val)
-  (and (string? val)
-       (string-prefix? "/" val)))
-(define (serialize-file-name field-name val)
-  (serialize-string field-name val))
-
 (define (colon-separated-file-name-list? val)
   (and (list? val)
        ;; Trailing slashes not needed and not
@@ -188,9 +77,6 @@
 (define (serialize-colon-separated-file-name-list field-name val)
   (serialize-field field-name (string-join val ":")))
 
-(define (serialize-boolean field-name val)
-  (serialize-string field-name (if val "yes" "no")))
-
 (define (non-negative-integer? val)
   (and (exact-integer? val) (not (negative? val))))
 (define (serialize-non-negative-integer field-name val)
@@ -271,7 +157,7 @@
 
 (define-configuration unix-listener-configuration
   (path
-   (file-name (dovecot-configuration-missing-field 'unix-listener 'path))
+   (file-name (configuration-missing-field 'unix-listener 'path))
    "The file name on which to listen.")
   (mode
    (string "0600")
@@ -290,7 +176,7 @@
 
 (define-configuration fifo-listener-configuration
   (path
-   (file-name (dovecot-configuration-missing-field 'fifo-listener 'path))
+   (file-name (configuration-missing-field 'fifo-listener 'path))
    "The file name on which to listen.")
   (mode
    (string "0600")
@@ -309,14 +195,14 @@
 
 (define-configuration inet-listener-configuration
   (protocol
-   (string (dovecot-configuration-missing-field 'inet-listener 'protocol))
+   (string (configuration-missing-field 'inet-listener 'protocol))
    "The protocol to listen for.")
   (address
    (string "")
    "The address on which to listen, or empty for all addresses.")
   (port
    (non-negative-integer
-    (dovecot-configuration-missing-field 'inet-listener 'port))
+    (configuration-missing-field 'inet-listener 'port))
    "The port on which to listen.")
   (ssl?
    (boolean #t)
@@ -340,7 +226,7 @@
     (serialize-fifo-listener-configuration field-name val))
    ((inet-listener-configuration? val)
     (serialize-inet-listener-configuration field-name val))
-   (else (dovecot-configuration-field-error field-name val))))
+   (else (configuration-field-error field-name val))))
 (define (listener-configuration-list? val)
   (and (list? val) (and-map listener-configuration? val)))
 (define (serialize-listener-configuration-list field-name val)
@@ -350,7 +236,7 @@
 
 (define-configuration service-configuration
   (kind
-   (string (dovecot-configuration-missing-field 'service 'kind))
+   (string (configuration-missing-field 'service 'kind))
    "The service kind.  Valid values include @code{director},
 @code{imap-login}, @code{pop3-login}, @code{lmtp}, @code{imap},
 @code{pop3}, @code{auth}, @code{auth-worker}, @code{dict},
@@ -388,7 +274,7 @@ this."))
 
 (define-configuration protocol-configuration
   (name
-   (string (dovecot-configuration-missing-field 'protocol 'name))
+   (string (configuration-missing-field 'protocol 'name))
    "The name of the protocol.")
   (auth-socket-path
    (string "/var/run/dovecot/auth-userdb")
@@ -1492,8 +1378,8 @@ greyed out, instead of only later giving \"not selectable\" popup error.
    "The dovecot package.")
 
   (string
-   (string (dovecot-configuration-missing-field 'opaque-dovecot-configuration
-                                                'string))
+   (string (configuration-missing-field 'opaque-dovecot-configuration
+                                        'string))
    "The contents of the @code{dovecot.conf} to use."))
 
 (define %dovecot-accounts
@@ -1629,8 +1515,8 @@ by @code{dovecot-configuration}.  @var{config} may also be created by
   (service dovecot-service-type config))
 
 ;; A little helper to make it easier to document all those fields.
-(define (generate-documentation)
-  (define documentation
+(define (generate-dovecot-documentation)
+  (generate-documentation
     `((dovecot-configuration
        ,dovecot-configuration-fields
        (dict dict-configuration)
@@ -1655,39 +1541,80 @@ by @code{dovecot-configuration}.  @var{config} may also be created by
        ,service-configuration-fields
        (listeners unix-listener-configuration fifo-listener-configuration
                   inet-listener-configuration))
-      (protocol-configuration ,protocol-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)
-       (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")))
-        fields))))
-  (generate 'dovecot-configuration))
+      (protocol-configuration ,protocol-configuration-fields))
+  'dovecot-configuration))
+
+
+;;;
+;;; OpenSMTPD.
+;;;
+
+(define-record-type* <opensmtpd-configuration>
+  opensmtpd-configuration make-opensmtpd-configuration
+  opensmtpd-configuration?
+  (package     opensmtpd-configuration-package
+               (default opensmtpd))
+  (config-file opensmtpd-configuration-config-file
+               (default %default-opensmtpd-config-file)))
+
+(define %default-opensmtpd-config-file
+  (plain-file "smtpd.conf" "
+listen on lo
+accept from any for local deliver to mbox
+accept from local for any relay
+"))
+
+(define opensmtpd-shepherd-service
+  (match-lambda
+    (($ <opensmtpd-configuration> package config-file)
+     (list (shepherd-service
+            (provision '(smtpd))
+            (requirement '(loopback))
+            (documentation "Run the OpenSMTPD daemon.")
+            (start (let ((smtpd (file-append package "/sbin/smtpd")))
+                     #~(make-forkexec-constructor
+                        (list #$smtpd "-f" #$config-file)
+                        #:pid-file "/var/run/smtpd.pid")))
+            (stop #~(make-kill-destructor)))))))
+
+(define %opensmtpd-accounts
+  (list (user-group
+         (name "smtpq")
+         (system? #t))
+        (user-account
+         (name "smtpd")
+         (group "nogroup")
+         (system? #t)
+         (comment "SMTP Daemon")
+         (home-directory "/var/empty")
+         (shell (file-append shadow "/sbin/nologin")))
+        (user-account
+         (name "smtpq")
+         (group "smtpq")
+         (system? #t)
+         (comment "SMTPD Queue")
+         (home-directory "/var/empty")
+         (shell (file-append shadow "/sbin/nologin")))))
+
+(define opensmtpd-activation
+  (match-lambda
+    (($ <opensmtpd-configuration> package config-file)
+     (let ((smtpd (file-append package "/sbin/smtpd")))
+       #~(begin
+           ;; Create mbox and spool directories.
+           (mkdir-p "/var/mail")
+           (mkdir-p "/var/spool/smtpd")
+           (chmod "/var/spool/smtpd" #o711))))))
+
+(define opensmtpd-service-type
+  (service-type
+   (name 'opensmtpd)
+   (extensions
+    (list (service-extension account-service-type
+                             (const %opensmtpd-accounts))
+          (service-extension activation-service-type
+                             opensmtpd-activation)
+          (service-extension profile-service-type
+                             (compose list opensmtpd-configuration-package))
+          (service-extension shepherd-root-service-type
+                             opensmtpd-shepherd-service)))))
diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm
index 5a83240d77..bbb9053008 100644
--- a/gnu/services/networking.scm
+++ b/gnu/services/networking.scm
@@ -682,7 +682,7 @@ and @command{wicd-curses} user interfaces."
   (list (shepherd-service
          (documentation "Run the NetworkManager.")
          (provision '(networking))
-         (requirement '(user-processes dbus-system loopback))
+         (requirement '(user-processes dbus-system wpa-supplicant loopback))
          (start #~(make-forkexec-constructor
                    (list (string-append #$network-manager
                                         "/sbin/NetworkManager")
@@ -695,6 +695,7 @@ and @command{wicd-curses} user interfaces."
                  (list (service-extension shepherd-root-service-type
                                           network-manager-shepherd-service)
                        (service-extension dbus-root-service-type list)
+                       (service-extension polkit-service-type list)
                        (service-extension activation-service-type
                                           (const %network-manager-activation))
                        ;; Add network-manager to the system profile.
diff --git a/gnu/services/web.scm b/gnu/services/web.scm
index 59e1e54e04..8f6e5bf6b7 100644
--- a/gnu/services/web.scm
+++ b/gnu/services/web.scm
@@ -72,7 +72,7 @@
 (define (config-domain-strings names)
  "Return a string denoting the nginx config representation of NAMES, a list
 of domain names."
- (string-concatenate
+ (string-join
   (map (match-lambda
         ('default "_")
         ((? string? str) str))
@@ -81,7 +81,7 @@ of domain names."
 (define (config-index-strings names)
  "Return a string denoting the nginx config representation of NAMES, a list
 of index files."
- (string-concatenate
+ (string-join
   (map (match-lambda
         ((? string? str) str))
        names)))