RFH: Add prosody service

RFH: Add prosody service

[Clément Lassieur]

Hello,

I'm actually working on the Prosody service, and I am struggling with a
few things.  What I did works, but some configurations are probably
missing.  I'm not sure I'm doing it the right way, so I would appreciate
a few comments before I go further.

Here is how a typical .lua Prosody configuration file looks like:

-- global section --

global-1 = ...
global-2 = ...
common-1 = ...
common-2 = ...
common-3 = ...

-- virtualhosts section --

Virtualhost domain1
  common-1 = ...
  common-2 = ...
  common-3 = ...

Virtualhost domain2
  common-1 = ...
  common-2 = ...
  common-3 = ...

Settings that are in the global section apply to all virtualhosts.
Settings under each Virtualhost entry apply only to that virtualhost.

So in Scheme, I implemented this as a prosody-configuration
(representing the whole file), containing:
  - global settings,
  - common settings,
  - a list of virtualhost-configuration.

Here are my problems.

A. A virtualhost-configuration has a lot in common with
   prosody-configuration, and I don't want to repeat stuff.

B. Common settings should have a default value in prosody-configuration,
   and be disabled by default in the list of virtualhost-configurations.

I found two ways to solve this:

1. One uses "eval" to transform the input of "define-configuration" into
   a list that I can build from other lists.

2. The other uses a macro that takes define-configuration's input, plus
   a tag (called target) describing whether it's a global, common, or
   virtualhost specific field.  Then the macro calls
   define-configuration many times, each time with a subset of the
   original input, filtered with a specific tag ("global",
   "virtualhost") plus the "common" tag.
   (Its name is define-all-configurations.)

I prefer the first one because it is more readable, but I have been said
in this thread:
http://lists.gnu.org/archive/html/guix-devel/2016-11/msg00993.html
that it is bad programming style.

So I will send two patches, one with the first way and the other with
the second way.  Maybe none of them will be good, don't hesitate to tell
me.  I'm willing to do any changes you'll want.

I did not talk about Components so to simplify things, but its quite
like a Virtualhost, in that it can have common settings too.

There's another issue: how to represent fields that we don't want to
serialize (see problem B).  I define a macro (define-maybe) that adds to
a field the possibility to have the value 'disabled.  But there are
plenty of other ways to do, I could do differently, just tell me.  There
is this thread talking about it:
http://lists.gnu.org/archive/html/guix-devel/2016-11/msg01024.html.

-- 
Clément Lassieur

[PATCH] gnu: Add prosody service

[Clément Lassieur]

From: Clément Lassieur <clement@lassieur.org>

---
 gnu/local.mk               |   1 +
 gnu/packages/messaging.scm |   3 +
 gnu/services/messaging.scm | 787 +++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 791 insertions(+)
 create mode 100644 gnu/services/messaging.scm

diff --git a/gnu/local.mk b/gnu/local.mk
index 466a9ff..bdb6d4f 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -408,6 +408,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/services/lirc.scm				\
   %D%/services/mail.scm				\
   %D%/services/mcron.scm			\
+  %D%/services/messaging.scm			\
   %D%/services/networking.scm			\
   %D%/services/nfs.scm			\
   %D%/services/shepherd.scm			\
diff --git a/gnu/packages/messaging.scm b/gnu/packages/messaging.scm
index 72b8906..5b7c01c 100644
--- a/gnu/packages/messaging.scm
+++ b/gnu/packages/messaging.scm
@@ -527,6 +527,9 @@ end-to-end encryption support; XML console.")
              ;; arguments.  Make it more tolerant.
              (substitute* "configure"
                (("exit 1") ""))
+             ;; Use /etc/prosody as CFG_CONFIGDIR so prosodyctl finds it.
+             (substitute* "Makefile"
+               (("^INSTALLEDCONFIG =.*") "INSTALLEDCONFIG = /etc/prosody\n"))
              #t))
          (add-after 'install 'wrap-programs
            (lambda* (#:key inputs outputs #:allow-other-keys)
diff --git a/gnu/services/messaging.scm b/gnu/services/messaging.scm
new file mode 100644
index 0000000..138b1ef
--- /dev/null
+++ b/gnu/services/messaging.scm
@@ -0,0 +1,787 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 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 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-configuration-error
+            prosody-configuration-error?
+
+            prosody-service
+            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-condition-type &prosody-configuration-error &error
+  prosody-configuration-error?)
+
+(define (prosody-error message)
+  (raise (condition (&message (message message))
+                    (&prosody-configuration-error))))
+(define (prosody-configuration-field-error field val)
+  (prosody-error
+   (format #f "Invalid value for field ~a: ~s" field val)))
+(define (prosody-configuration-missing-field kind field)
+  (prosody-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 (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-configuration
+  (lambda (stx)
+    (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 (list->configuration stem fields)
+  (eval `(define-configuration ,stem ,@fields) (current-module)))
+
+(define fields-names
+  (match-lambda (((field (field-type def) doc) ...) field)))
+
+(define (strip-common-fields fields)
+  (define (append-maybe field-type)
+    (let ((string-field-type (symbol->string field-type)))
+      (if (string-prefix? "maybe-" string-field-type)
+          field-type
+          (string->symbol (string-append "maybe-" string-field-type)))))
+  (map (match-lambda
+         ((field (field-type def) doc)
+          `(,field (,(append-maybe field-type) 'disabled) "")))
+       fields))
+
+(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)
+                  (prosody-configuration-field-error
+                   (configuration-field-name field) val))))
+            fields))
+
+(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-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 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"))
+
+(define common-fields
+  '((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\"))}")
+
+    (use-libevent?
+     (boolean #f)
+     "Enable use of libevent for better performance under high load.  See
+@url{http://prosody.im/doc/libevent}.")
+
+    (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}.")
+
+    (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.")
+
+    (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}.")
+
+    (allow-registration?
+     (boolean #f)
+     "Disable account creation by default, for security.  See
+@url{http://prosody.im/doc/creating_accounts}.")
+
+    (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}.")
+
+    (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}.")
+
+    (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}.")
+
+    (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}.")
+
+    (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}.")
+
+    (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}.")
+
+    (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}")
+
+    ;; TODO: Add "sql" storage.
+    (storage
+     (maybe-string 'disabled)
+     "Prosody needs to store a certain amount of data, primarily about users.
+For example account names/passwords, contact lists, profiles.  Starting with
+Prosody 0.8.0 the storage system became extensible via plugins.  We have two
+plugins that come with Prosody, @samp{\"internal\"} and @samp{\"sql\"}.
+
+It is not necessary to add storage plugins to @code{modules-enabled} - they are
+loaded automatically on-demand.
+
+Note that @samp{\"sql\"} storage is not yet supported by the GuixSD Prosody
+Service.
+
+See @url{http://prosody.im/doc/storage}.")
+
+    ;; 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}.")))
+
+(define global-fields
+  '((prosody
+     (package prosody)
+     "The Prosody package.")
+
+    (data-path
+     (file-name "/var/lib/prosody")
+     "Location of the Prosody data storage directory.  See
+@url{http://prosody.im/doc/configure}.")
+
+    (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}.")
+
+    (pidfile
+     (file-name "/var/run/prosody/prosody.pid")
+     "File to write pid in.  See
+@url{http://prosody.im/doc/modules/mod_posix}.")
+
+    (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}.")
+
+    (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}.")
+
+    (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}.")
+
+    (component-ports
+     (non-negative-integer-list '(5347))
+     "Port(s) Prosody listens on for component connections.")
+
+    (component-interface
+     (string "127.0.0.1")
+     "Interface Prosody listens on for component connections.")
+
+    (proxy65-address
+     (maybe-string 'disabled)
+     "The advertised address of the proxy, which clients use to connect to.  If
+not set the hostname of the component is used.  There must be a DNS A and/or
+AAAA record for this address.  Alternatively you can specify an IP address. ")
+
+    (proxy65-acl
+     (string-list '())
+     "Access Control List, when specified all users will be denied access
+unless in the list.  The list can contain domains, bare jids (normal) or full
+jids (including a resource).")
+
+    (proxy65-interfaces
+     (string-list '("*" "::"))
+     "A list of interfaces to listen on.  Defaults to all IPv4 and IPv6
+interfaces.")
+
+    (proxy65-port
+     (non-negative-integer-list '(5000))
+     "A list of ports to listen to")))
+
+(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."))
+(define (serialize-mod-muc-configuration field-name val)
+  (serialize-configuration val mod-muc-configuration-fields))
+(define-maybe mod-muc-configuration)
+
+(define ext-component-fields
+  '((component-secret
+     (string (prosody-configuration-missing-field 'ext-component
+                                                  'component-secret))
+     "Password which the component will use to log in.")
+
+    (hostname
+     (string (prosody-configuration-missing-field 'ext-component 'hostname))
+     "Hostname of the component.")))
+
+(define int-component-fields
+  '((hostname
+     (string (prosody-configuration-missing-field 'int-component 'hostname))
+     "Hostname of the component.")
+
+    (plugin
+     (string (prosody-configuration-missing-field 'int-component 'plugin))
+     "Plugin you wish to use for the 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 MUC chatrooms can be found in our
+\"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}.")))
+
+(define virtualhost-fields
+  '((domain
+     (string (prosody-configuration-missing-field 'virtualhost 'domain))
+     "Domain you wish Prosody to serve.")))
+
+(list->configuration 'virtualhost-configuration
+                     (append (strip-common-fields common-fields)
+                             virtualhost-fields))
+(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))
+
+(list->configuration 'int-component-configuration
+                     (append (strip-common-fields common-fields)
+                             int-component-fields))
+(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))
+
+
+(list->configuration 'ext-component-configuration
+                     (append (strip-common-fields common-fields)
+                             ext-component-fields))
+(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))
+
+(list->configuration 'prosody-configuration
+                     (append common-fields
+                             global-fields))
+
+;; 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 (prosody-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)))
+  (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:"
+                 (string-join (map (lambda (s)
+                                     (format #f "@code{~a}" s))
+                                   (fields-names 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))
+
+;;; messaging.scm ends here
-- 
2.10.1

Re: [PATCH] gnu: Add prosody service

[Leo Famulari]

On Sat, Nov 26, 2016 at 06:20:12PM +0100, Clément Lassieur wrote:
> From: Clément Lassieur <clement@lassieur.org>

Hi, thanks for working on this!

> 
> ---
>  gnu/local.mk               |   1 +
>  gnu/packages/messaging.scm |   3 +
>  gnu/services/messaging.scm | 787 +++++++++++++++++++++++++++++++++++++++++++++
>  3 files changed, 791 insertions(+)
>  create mode 100644 gnu/services/messaging.scm

Which version of the patch should we review? :)

If you are using `git format-patch` or `git send-email`, you can use
--subject-prefix to version your patches.

For example:

$ git send-email --cover-letter -n --thread=shallow --subject-prefix=v2 master

Re: [PATCH] gnu: Add prosody service

[Clément Lassieur]

> Which version of the patch should we review? :)

Oh...  I accidentally sent the patches with my professional address, but
it took a long time to get into the list, so I thought it did not work
and sent a second set of patches with my real address.

Please do not answer the mails sent with my professional address.

way1: http://lists.gnu.org/archive/html/guix-devel/2016-11/msg01074.html
way2: http://lists.gnu.org/archive/html/guix-devel/2016-11/msg01075.html

> If you are using `git format-patch` or `git send-email`, you can use
> --subject-prefix to version your patches.
>
> For example:
>
> $ git send-email --cover-letter -n --thread=shallow --subject-prefix=v2 master

Yes, next time I'll do this.  Sorry for the confusion.

[PATCH] gnu: Add prosody service

[Clément Lassieur]

From: Clément Lassieur <clement@lassieur.org>

---
 gnu/local.mk               |   1 +
 gnu/packages/messaging.scm |   3 +
 gnu/services/messaging.scm | 833 +++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 837 insertions(+)
 create mode 100644 gnu/services/messaging.scm

diff --git a/gnu/local.mk b/gnu/local.mk
index 466a9ff..bdb6d4f 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -408,6 +408,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/services/lirc.scm				\
   %D%/services/mail.scm				\
   %D%/services/mcron.scm			\
+  %D%/services/messaging.scm			\
   %D%/services/networking.scm			\
   %D%/services/nfs.scm			\
   %D%/services/shepherd.scm			\
diff --git a/gnu/packages/messaging.scm b/gnu/packages/messaging.scm
index 72b8906..5b7c01c 100644
--- a/gnu/packages/messaging.scm
+++ b/gnu/packages/messaging.scm
@@ -527,6 +527,9 @@ end-to-end encryption support; XML console.")
              ;; arguments.  Make it more tolerant.
              (substitute* "configure"
                (("exit 1") ""))
+             ;; Use /etc/prosody as CFG_CONFIGDIR so prosodyctl finds it.
+             (substitute* "Makefile"
+               (("^INSTALLEDCONFIG =.*") "INSTALLEDCONFIG = /etc/prosody\n"))
              #t))
          (add-after 'install 'wrap-programs
            (lambda* (#:key inputs outputs #:allow-other-keys)
diff --git a/gnu/services/messaging.scm b/gnu/services/messaging.scm
new file mode 100644
index 0000000..b10f3f4
--- /dev/null
+++ b/gnu/services/messaging.scm
@@ -0,0 +1,833 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 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 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-configuration-error
+            prosody-configuration-error?
+
+            prosody-service
+            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-condition-type &prosody-configuration-error &error
+  prosody-configuration-error?)
+
+(define (prosody-error message)
+  (raise (condition (&message (message message))
+                    (&prosody-configuration-error))))
+(define (prosody-configuration-field-error field val)
+  (prosody-error
+   (format #f "Invalid value for field ~a: ~s" field val)))
+(define (prosody-configuration-missing-field kind field)
+  (prosody-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 (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-syntax define-configuration
+  (lambda (stx)
+    (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 (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)
+                  (prosody-configuration-field-error
+                   (configuration-field-name field) val))))
+            fields))
+
+(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-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."))
+(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: Add "sql" storage.
+    (storage
+     (maybe-string 'disabled)
+     "Prosody needs to store a certain amount of data, primarily about users.
+For example account names/passwords, contact lists, profiles.  Starting with
+Prosody 0.8.0 the storage system became extensible via plugins.  We have two
+plugins that come with Prosody, @samp{\"internal\"} and @samp{\"sql\"}.
+
+It is not necessary to add storage plugins to @code{modules-enabled} - they are
+loaded automatically on-demand.
+
+Note that @samp{\"sql\"} storage is not yet supported by the GuixSD Prosody
+Service.
+
+See @url{http://prosody.im/doc/storage}."
+     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 (prosody-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)
+
+    (proxy65-address
+     (maybe-string 'disabled)
+     "The advertised address of the proxy, which clients use to connect to.  If
+not set the hostname of the component is used.  There must be a DNS A and/or
+AAAA record for this address.  Alternatively you can specify an IP address. "
+     global)
+
+    (proxy65-acl
+     (string-list '())
+     "Access Control List, when specified all users will be denied access
+unless in the list.  The list can contain domains, bare jids (normal) or full
+jids (including a resource)."
+     global)
+
+    (proxy65-interfaces
+     (string-list '("*" "::"))
+     "A list of interfaces to listen on.  Defaults to all IPv4 and IPv6
+interfaces."
+     global)
+
+    (proxy65-port
+     (non-negative-integer-list '(5000))
+     "A list of ports to listen to"
+     global)
+
+    (domain
+     (string (prosody-configuration-missing-field 'virtualhost 'domain))
+     "Domain you wish Prosody to serve."
+     virtualhost)
+
+    (hostname
+     (string (prosody-configuration-missing-field 'int-component 'hostname))
+     "Hostname of the component."
+     int-component)
+
+    (plugin
+     (string (prosody-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 MUC chatrooms can be found in our
+\"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 (prosody-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 (prosody-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)))
+  (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:"
+                 (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))
+
+;;; messaging.scm ends here
-- 
2.10.1

[PATCH] gnu: Add prosody service

[Clément Lassieur]

---
 gnu/local.mk               |   1 +
 gnu/packages/messaging.scm |   3 +
 gnu/services/messaging.scm | 787 +++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 791 insertions(+)
 create mode 100644 gnu/services/messaging.scm

diff --git a/gnu/local.mk b/gnu/local.mk
index 466a9ff..bdb6d4f 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -408,6 +408,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/services/lirc.scm				\
   %D%/services/mail.scm				\
   %D%/services/mcron.scm			\
+  %D%/services/messaging.scm			\
   %D%/services/networking.scm			\
   %D%/services/nfs.scm			\
   %D%/services/shepherd.scm			\
diff --git a/gnu/packages/messaging.scm b/gnu/packages/messaging.scm
index 72b8906..5b7c01c 100644
--- a/gnu/packages/messaging.scm
+++ b/gnu/packages/messaging.scm
@@ -527,6 +527,9 @@ end-to-end encryption support; XML console.")
              ;; arguments.  Make it more tolerant.
              (substitute* "configure"
                (("exit 1") ""))
+             ;; Use /etc/prosody as CFG_CONFIGDIR so prosodyctl finds it.
+             (substitute* "Makefile"
+               (("^INSTALLEDCONFIG =.*") "INSTALLEDCONFIG = /etc/prosody\n"))
              #t))
          (add-after 'install 'wrap-programs
            (lambda* (#:key inputs outputs #:allow-other-keys)
diff --git a/gnu/services/messaging.scm b/gnu/services/messaging.scm
new file mode 100644
index 0000000..138b1ef
--- /dev/null
+++ b/gnu/services/messaging.scm
@@ -0,0 +1,787 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 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 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-configuration-error
+            prosody-configuration-error?
+
+            prosody-service
+            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-condition-type &prosody-configuration-error &error
+  prosody-configuration-error?)
+
+(define (prosody-error message)
+  (raise (condition (&message (message message))
+                    (&prosody-configuration-error))))
+(define (prosody-configuration-field-error field val)
+  (prosody-error
+   (format #f "Invalid value for field ~a: ~s" field val)))
+(define (prosody-configuration-missing-field kind field)
+  (prosody-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 (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-configuration
+  (lambda (stx)
+    (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 (list->configuration stem fields)
+  (eval `(define-configuration ,stem ,@fields) (current-module)))
+
+(define fields-names
+  (match-lambda (((field (field-type def) doc) ...) field)))
+
+(define (strip-common-fields fields)
+  (define (append-maybe field-type)
+    (let ((string-field-type (symbol->string field-type)))
+      (if (string-prefix? "maybe-" string-field-type)
+          field-type
+          (string->symbol (string-append "maybe-" string-field-type)))))
+  (map (match-lambda
+         ((field (field-type def) doc)
+          `(,field (,(append-maybe field-type) 'disabled) "")))
+       fields))
+
+(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)
+                  (prosody-configuration-field-error
+                   (configuration-field-name field) val))))
+            fields))
+
+(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-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 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"))
+
+(define common-fields
+  '((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\"))}")
+
+    (use-libevent?
+     (boolean #f)
+     "Enable use of libevent for better performance under high load.  See
+@url{http://prosody.im/doc/libevent}.")
+
+    (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}.")
+
+    (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.")
+
+    (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}.")
+
+    (allow-registration?
+     (boolean #f)
+     "Disable account creation by default, for security.  See
+@url{http://prosody.im/doc/creating_accounts}.")
+
+    (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}.")
+
+    (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}.")
+
+    (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}.")
+
+    (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}.")
+
+    (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}.")
+
+    (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}.")
+
+    (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}")
+
+    ;; TODO: Add "sql" storage.
+    (storage
+     (maybe-string 'disabled)
+     "Prosody needs to store a certain amount of data, primarily about users.
+For example account names/passwords, contact lists, profiles.  Starting with
+Prosody 0.8.0 the storage system became extensible via plugins.  We have two
+plugins that come with Prosody, @samp{\"internal\"} and @samp{\"sql\"}.
+
+It is not necessary to add storage plugins to @code{modules-enabled} - they are
+loaded automatically on-demand.
+
+Note that @samp{\"sql\"} storage is not yet supported by the GuixSD Prosody
+Service.
+
+See @url{http://prosody.im/doc/storage}.")
+
+    ;; 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}.")))
+
+(define global-fields
+  '((prosody
+     (package prosody)
+     "The Prosody package.")
+
+    (data-path
+     (file-name "/var/lib/prosody")
+     "Location of the Prosody data storage directory.  See
+@url{http://prosody.im/doc/configure}.")
+
+    (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}.")
+
+    (pidfile
+     (file-name "/var/run/prosody/prosody.pid")
+     "File to write pid in.  See
+@url{http://prosody.im/doc/modules/mod_posix}.")
+
+    (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}.")
+
+    (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}.")
+
+    (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}.")
+
+    (component-ports
+     (non-negative-integer-list '(5347))
+     "Port(s) Prosody listens on for component connections.")
+
+    (component-interface
+     (string "127.0.0.1")
+     "Interface Prosody listens on for component connections.")
+
+    (proxy65-address
+     (maybe-string 'disabled)
+     "The advertised address of the proxy, which clients use to connect to.  If
+not set the hostname of the component is used.  There must be a DNS A and/or
+AAAA record for this address.  Alternatively you can specify an IP address. ")
+
+    (proxy65-acl
+     (string-list '())
+     "Access Control List, when specified all users will be denied access
+unless in the list.  The list can contain domains, bare jids (normal) or full
+jids (including a resource).")
+
+    (proxy65-interfaces
+     (string-list '("*" "::"))
+     "A list of interfaces to listen on.  Defaults to all IPv4 and IPv6
+interfaces.")
+
+    (proxy65-port
+     (non-negative-integer-list '(5000))
+     "A list of ports to listen to")))
+
+(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."))
+(define (serialize-mod-muc-configuration field-name val)
+  (serialize-configuration val mod-muc-configuration-fields))
+(define-maybe mod-muc-configuration)
+
+(define ext-component-fields
+  '((component-secret
+     (string (prosody-configuration-missing-field 'ext-component
+                                                  'component-secret))
+     "Password which the component will use to log in.")
+
+    (hostname
+     (string (prosody-configuration-missing-field 'ext-component 'hostname))
+     "Hostname of the component.")))
+
+(define int-component-fields
+  '((hostname
+     (string (prosody-configuration-missing-field 'int-component 'hostname))
+     "Hostname of the component.")
+
+    (plugin
+     (string (prosody-configuration-missing-field 'int-component 'plugin))
+     "Plugin you wish to use for the 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 MUC chatrooms can be found in our
+\"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}.")))
+
+(define virtualhost-fields
+  '((domain
+     (string (prosody-configuration-missing-field 'virtualhost 'domain))
+     "Domain you wish Prosody to serve.")))
+
+(list->configuration 'virtualhost-configuration
+                     (append (strip-common-fields common-fields)
+                             virtualhost-fields))
+(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))
+
+(list->configuration 'int-component-configuration
+                     (append (strip-common-fields common-fields)
+                             int-component-fields))
+(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))
+
+
+(list->configuration 'ext-component-configuration
+                     (append (strip-common-fields common-fields)
+                             ext-component-fields))
+(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))
+
+(list->configuration 'prosody-configuration
+                     (append common-fields
+                             global-fields))
+
+;; 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 (prosody-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)))
+  (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:"
+                 (string-join (map (lambda (s)
+                                     (format #f "@code{~a}" s))
+                                   (fields-names 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))
+
+;;; messaging.scm ends here
-- 
2.10.1

[PATCH] gnu: Add prosody service

[Clément Lassieur]

---
 gnu/local.mk               |   1 +
 gnu/packages/messaging.scm |   3 +
 gnu/services/messaging.scm | 833 +++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 837 insertions(+)
 create mode 100644 gnu/services/messaging.scm

diff --git a/gnu/local.mk b/gnu/local.mk
index 466a9ff..bdb6d4f 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -408,6 +408,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/services/lirc.scm				\
   %D%/services/mail.scm				\
   %D%/services/mcron.scm			\
+  %D%/services/messaging.scm			\
   %D%/services/networking.scm			\
   %D%/services/nfs.scm			\
   %D%/services/shepherd.scm			\
diff --git a/gnu/packages/messaging.scm b/gnu/packages/messaging.scm
index 72b8906..5b7c01c 100644
--- a/gnu/packages/messaging.scm
+++ b/gnu/packages/messaging.scm
@@ -527,6 +527,9 @@ end-to-end encryption support; XML console.")
              ;; arguments.  Make it more tolerant.
              (substitute* "configure"
                (("exit 1") ""))
+             ;; Use /etc/prosody as CFG_CONFIGDIR so prosodyctl finds it.
+             (substitute* "Makefile"
+               (("^INSTALLEDCONFIG =.*") "INSTALLEDCONFIG = /etc/prosody\n"))
              #t))
          (add-after 'install 'wrap-programs
            (lambda* (#:key inputs outputs #:allow-other-keys)
diff --git a/gnu/services/messaging.scm b/gnu/services/messaging.scm
new file mode 100644
index 0000000..b10f3f4
--- /dev/null
+++ b/gnu/services/messaging.scm
@@ -0,0 +1,833 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 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 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-configuration-error
+            prosody-configuration-error?
+
+            prosody-service
+            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-condition-type &prosody-configuration-error &error
+  prosody-configuration-error?)
+
+(define (prosody-error message)
+  (raise (condition (&message (message message))
+                    (&prosody-configuration-error))))
+(define (prosody-configuration-field-error field val)
+  (prosody-error
+   (format #f "Invalid value for field ~a: ~s" field val)))
+(define (prosody-configuration-missing-field kind field)
+  (prosody-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 (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-syntax define-configuration
+  (lambda (stx)
+    (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 (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)
+                  (prosody-configuration-field-error
+                   (configuration-field-name field) val))))
+            fields))
+
+(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-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."))
+(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: Add "sql" storage.
+    (storage
+     (maybe-string 'disabled)
+     "Prosody needs to store a certain amount of data, primarily about users.
+For example account names/passwords, contact lists, profiles.  Starting with
+Prosody 0.8.0 the storage system became extensible via plugins.  We have two
+plugins that come with Prosody, @samp{\"internal\"} and @samp{\"sql\"}.
+
+It is not necessary to add storage plugins to @code{modules-enabled} - they are
+loaded automatically on-demand.
+
+Note that @samp{\"sql\"} storage is not yet supported by the GuixSD Prosody
+Service.
+
+See @url{http://prosody.im/doc/storage}."
+     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 (prosody-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)
+
+    (proxy65-address
+     (maybe-string 'disabled)
+     "The advertised address of the proxy, which clients use to connect to.  If
+not set the hostname of the component is used.  There must be a DNS A and/or
+AAAA record for this address.  Alternatively you can specify an IP address. "
+     global)
+
+    (proxy65-acl
+     (string-list '())
+     "Access Control List, when specified all users will be denied access
+unless in the list.  The list can contain domains, bare jids (normal) or full
+jids (including a resource)."
+     global)
+
+    (proxy65-interfaces
+     (string-list '("*" "::"))
+     "A list of interfaces to listen on.  Defaults to all IPv4 and IPv6
+interfaces."
+     global)
+
+    (proxy65-port
+     (non-negative-integer-list '(5000))
+     "A list of ports to listen to"
+     global)
+
+    (domain
+     (string (prosody-configuration-missing-field 'virtualhost 'domain))
+     "Domain you wish Prosody to serve."
+     virtualhost)
+
+    (hostname
+     (string (prosody-configuration-missing-field 'int-component 'hostname))
+     "Hostname of the component."
+     int-component)
+
+    (plugin
+     (string (prosody-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 MUC chatrooms can be found in our
+\"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 (prosody-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 (prosody-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)))
+  (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:"
+                 (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))
+
+;;; messaging.scm ends here
-- 
2.10.1

Re: RFH: Add prosody service

[Hartmut Goebel]

Am 26.11.2016 um 18:15 schrieb Clément Lassieur:
> So in Scheme, I implemented this as a prosody-configuration
> (representing the whole file), containing:
>   - global settings,
>   - common settings,
>   - a list of virtualhost-configuration.

I'm interested in how to implement this, too.

Some examples we could use this:
- default security-settings for nginx servers (ak vhosts)
- config for all "pools" in php-fpm

debops (http://debops.org), a collection of recipes for Ansible which I
worked with last year for quite some time, add another features: If the
software does not support such config layers, debops implements them by
adding the "global" and "common" settings to the "vhost" config-file. I
really likes this feature :-)

-- 
Regards
Hartmut Goebel

| Hartmut Goebel          | h.goebel@crazy-compilers.com               |
| www.crazy-compilers.com | compilers which you thought are impossible |

Re: RFH: Add prosody service

[Ludovic Courtès]

Hi!

Clément Lassieur <clement@lassieur.org> skribis:

> I'm actually working on the Prosody service, and I am struggling with a
> few things.  What I did works, but some configurations are probably
> missing.  I'm not sure I'm doing it the right way, so I would appreciate
> a few comments before I go further.
>
> Here is how a typical .lua Prosody configuration file looks like:
>
> -- global section --
>
> global-1 = ...
> global-2 = ...
> common-1 = ...
> common-2 = ...
> common-3 = ...
>
> -- virtualhosts section --
>
> Virtualhost domain1
>   common-1 = ...
>   common-2 = ...
>   common-3 = ...
>
> Virtualhost domain2
>   common-1 = ...
>   common-2 = ...
>   common-3 = ...
>
> Settings that are in the global section apply to all virtualhosts.
> Settings under each Virtualhost entry apply only to that virtualhost.
>
> So in Scheme, I implemented this as a prosody-configuration
> (representing the whole file), containing:
>   - global settings,
>   - common settings,
>   - a list of virtualhost-configuration.
>
> Here are my problems.
>
> A. A virtualhost-configuration has a lot in common with
>    prosody-configuration, and I don't want to repeat stuff.

What about a <prosody-global-settings> record that would have
‘global-1’…‘global-N’ fields, plus a ‘virtual-host-settings’ that would
aggregate a <prosody-virtual-host>?

> B. Common settings should have a default value in prosody-configuration,
>    and be disabled by default in the list of virtualhost-configurations.

Oh, I see.

> I found two ways to solve this:
>
> 1. One uses "eval" to transform the input of "define-configuration" into
>    a list that I can build from other lists.
>
> 2. The other uses a macro that takes define-configuration's input, plus
>    a tag (called target) describing whether it's a global, common, or
>    virtualhost specific field.  Then the macro calls
>    define-configuration many times, each time with a subset of the
>    original input, filtered with a specific tag ("global",
>    "virtualhost") plus the "common" tag.
>    (Its name is define-all-configurations.)

I think you could always write a ‘define-common-configurations’ macro on
top of ‘define-configuration’ that would let you specify two default
values: one for the global context, and one for the virtual-host
contexts.  (Thus, no need for ‘eval’: the code is generated at macro
expansion time.)

Would that work?

It would allow you to avoid repeating field definitions, but you’d end
up with two almost identical record types that are completely disjoint
(no inheritance in particular.)  This may or may not be desirable.

For record type inheritance, we’d need SRFI-99 or something equivalent.

> There's another issue: how to represent fields that we don't want to
> serialize (see problem B).  I define a macro (define-maybe) that adds to
> a field the possibility to have the value 'disabled.  But there are
> plenty of other ways to do, I could do differently, just tell me.  There
> is this thread talking about it:
> http://lists.gnu.org/archive/html/guix-devel/2016-11/msg01024.html.

Looking at (gnu services mail), you can define custom field types with
associated serializers.

So you could define a ‘maybe-string’ type, say, with an associated
serializer.

How does that sound?

That said, I’m not familiar with (gnu services configuration) yet.

Ludo’.

Re: RFH: Add prosody service

[Clément Lassieur]

Hi Ludovic,

>> Here are my problems.
>>
>> A. A virtualhost-configuration has a lot in common with
>>    prosody-configuration, and I don't want to repeat stuff.
>
> What about a <prosody-global-settings> record that would have
> ‘global-1’…‘global-N’ fields, plus a ‘virtual-host-settings’ that would
> aggregate a <prosody-virtual-host>?

That wouldn't solve problem B.

>> B. Common settings should have a default value in prosody-configuration,
>>    and be disabled by default in the list of virtualhost-configurations.
>
> Oh, I see.
>
>> I found two ways to solve this:
>>
>> 1. One uses "eval" to transform the input of "define-configuration" into
>>    a list that I can build from other lists.
>>
>> 2. The other uses a macro that takes define-configuration's input, plus
>>    a tag (called target) describing whether it's a global, common, or
>>    virtualhost specific field.  Then the macro calls
>>    define-configuration many times, each time with a subset of the
>>    original input, filtered with a specific tag ("global",
>>    "virtualhost") plus the "common" tag.
>>    (Its name is define-all-configurations.)
>
> I think you could always write a ‘define-common-configurations’ macro on
> top of ‘define-configuration’ that would let you specify two default
> values: one for the global context, and one for the virtual-host
> contexts.  (Thus, no need for ‘eval’: the code is generated at macro
> expansion time.)
>
> Would that work?

That's kind of what I did here:
http://lists.gnu.org/archive/html/guix-devel/2016-11/msg01075.html

The macro 'define-all-configurations' defines two default values: one
for the global context (def) and one for the virtual-host context
('disabled).

(The macro I did also changes the doc and the type, depending on whether
it's a virtualhost or not.)

> It would allow you to avoid repeating field definitions, but you’d end
> up with two almost identical record types that are completely disjoint
> (no inheritance in particular.)  This may or may not be desirable.
>
> For record type inheritance, we’d need SRFI-99 or something equivalent.

Which is not implemented by Guile, is it?

So is what I did desirable?  Or maybe should we wait until we have
something similar to SRFI-99, and use opaque-prosody-configuration only?

>> There's another issue: how to represent fields that we don't want to
>> serialize (see problem B).  I define a macro (define-maybe) that adds to
>> a field the possibility to have the value 'disabled.  But there are
>> plenty of other ways to do, I could do differently, just tell me.  There
>> is this thread talking about it:
>> http://lists.gnu.org/archive/html/guix-devel/2016-11/msg01024.html.
>
> Looking at (gnu services mail), you can define custom field types with
> associated serializers.
>
> So you could define a ‘maybe-string’ type, say, with an associated
> serializer.
>
> How does that sound?

That's also what I did here:
http://lists.gnu.org/archive/html/guix-devel/2016-11/msg01075.html

-- 
Clément

Re: RFH: Add prosody service

[Ludovic Courtès]

Hello Clément,

Clément Lassieur <clement@lassieur.org> skribis:

>>> B. Common settings should have a default value in prosody-configuration,
>>>    and be disabled by default in the list of virtualhost-configurations.
>>
>> Oh, I see.
>>
>>> I found two ways to solve this:
>>>
>>> 1. One uses "eval" to transform the input of "define-configuration" into
>>>    a list that I can build from other lists.
>>>
>>> 2. The other uses a macro that takes define-configuration's input, plus
>>>    a tag (called target) describing whether it's a global, common, or
>>>    virtualhost specific field.  Then the macro calls
>>>    define-configuration many times, each time with a subset of the
>>>    original input, filtered with a specific tag ("global",
>>>    "virtualhost") plus the "common" tag.
>>>    (Its name is define-all-configurations.)
>>
>> I think you could always write a ‘define-common-configurations’ macro on
>> top of ‘define-configuration’ that would let you specify two default
>> values: one for the global context, and one for the virtual-host
>> contexts.  (Thus, no need for ‘eval’: the code is generated at macro
>> expansion time.)
>>
>> Would that work?
>
> That's kind of what I did here:
> http://lists.gnu.org/archive/html/guix-devel/2016-11/msg01075.html
>
> The macro 'define-all-configurations' defines two default values: one
> for the global context (def) and one for the virtual-host context
> ('disabled).
>
> (The macro I did also changes the doc and the type, depending on whether
> it's a virtualhost or not.)

Sounds good.

>> It would allow you to avoid repeating field definitions, but you’d end
>> up with two almost identical record types that are completely disjoint
>> (no inheritance in particular.)  This may or may not be desirable.
>>
>> For record type inheritance, we’d need SRFI-99 or something equivalent.
>
> Which is not implemented by Guile, is it?

No, though maybe the reference implementation just works.  Alternate,
SRFI-35 and (rnrs records), both available in Guile, support
inheritance.

> So is what I did desirable?  Or maybe should we wait until we have
> something similar to SRFI-99, and use opaque-prosody-configuration only?

What you did looks good.  Whether proper inheritance should be prefer
over the purely syntactic approach you took is something I can’t answer;
I guess it depends on the semantics and expected use of those data
structures.

So if it sounds good to you, we can certainly start with the patch you
have (minus duplication with (gnu services configuration).)

WDYT?

>> So you could define a ‘maybe-string’ type, say, with an associated
>> serializer.
>>
>> How does that sound?
>
> That's also what I did here:
> http://lists.gnu.org/archive/html/guix-devel/2016-11/msg01075.html

Perfect.  :-)

Sorry for the delay, I admit I got lost in the discussion, my bad!

Thanks,
Ludo’.