guix-devel
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[PATCH] gnu: Add prosody service


From: Clément Lassieur
Subject: [PATCH] gnu: Add prosody service
Date: Sat, 26 Nov 2016 18:20:12 +0100

From: Clément Lassieur <address@hidden>

---
 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 <address@hidden>
+;;;
+;;; 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
address@hidden()} flags).")
+
+  (options
+   (maybe-string-list 'disabled)
+   "A list of general options relating to SSL/TLS.  These map to OpenSSL's
address@hidden()}.  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:
address@hidden dhparam -out /etc/prosody/certs/dh-2048.pem 2048}")
+
+  (curve
+   (maybe-string 'disabled)
+   "Curve for Elliptic curve Diffie-Hellman. Prosody's default is
address@hidden"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
address@hidden://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
address@hidden://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
address@hidden 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
address@hidden://prosody.im/doc/modules/mod_groups}.")
+
+    (allow-registration?
+     (boolean #f)
+     "Disable account creation by default, for security.  See
address@hidden://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
address@hidden://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
address@hidden://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
address@hidden://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
address@hidden://prosody.im/doc/modules/mod_auth_internal_hashed} for 
information
+about using the hashed backend.  See also
address@hidden://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
address@hidden://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
address@hidden://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
address@hidden"john.smith@@example.com\"} then you need to add a host
address@hidden"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
address@hidden"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
address@hidden://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 
address@hidden))))))
+    (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 address@hidden 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




reply via email to

[Prev in Thread] Current Thread [Next in Thread]