From mboxrd@z Thu Jan 1 00:00:00 1970 From: =?UTF-8?q?Cl=C3=A9ment=20Lassieur?= Subject: [PATCH] gnu: Add prosody service Date: Sat, 26 Nov 2016 22:30:19 +0100 Message-ID: <20161126213019.22499-1-clement@lassieur.org> References: <874m2uxiuu.fsf@lassieur.org> Mime-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: quoted-printable Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:35110) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1cAkYG-00030G-QF for guix-devel@gnu.org; Sat, 26 Nov 2016 16:30:32 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1cAkYD-0002st-IK for guix-devel@gnu.org; Sat, 26 Nov 2016 16:30:28 -0500 Received: from mail.lassieur.org ([83.152.10.219]:47718) by eggs.gnu.org with esmtps (TLS1.0:DHE_RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1cAkYC-0002sd-My for guix-devel@gnu.org; Sat, 26 Nov 2016 16:30:25 -0500 Received: from localhost.localdomain (rke75-1-81-57-64-9.fbx.proxad.net [81.57.64.9]) by mail.lassieur.org (Postfix) with ESMTPSA id 78D8364015F for ; Sat, 26 Nov 2016 22:30:21 +0100 (CET) In-Reply-To: <874m2uxiuu.fsf@lassieur.org> List-Id: "Development of GNU Guix and the GNU System distribution." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org Sender: "Guix-devel" To: guix-devel@gnu.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 =3D \ %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 =3D.*") "INSTALLEDCONFIG =3D /etc/pro= sody\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 =C2=A9 2016 Cl=C3=A9ment Lassieur +;;; +;;; 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 (a= t +;;; 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 . + +(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 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-t= ype)) + #'(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 #'-fie= lds)) + 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 s= tr))) + str) + #\-) + "_"))) + +(define (serialize-package field-name val) + #f) + +(define (serialize-field field-name val) + (format #t "~a =3D ~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\"} restrict= s room +creation to users on the service's parent domain. E.g. @samp{user@@exam= ple.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, s= ee the +LuaSec source.") + + (depth + (maybe-non-negative-integer 'disabled) + "How long a chain of certificate authorities to check when looking fo= r a +trusted root certificate.") + + (ciphers + (maybe-string 'disabled) + "An OpenSSL cipher string. This selects what ciphers Prosody will of= fer to +clients, and in what order.") + + (dhparam + (maybe-file-name 'disabled) + "A path to a file containing parameters for Diffie-Hellman key exchan= ge. 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 =3D {\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-configur= ation +;; is assumed to be a function. See +;; https://www.gnu.org/software/guile/manual/html_node/R6RS-Incompatibil= ities.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 speci= fied +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 t= hat you +must create the accounts separately. See @url{http://prosody.im/doc/adm= ins} 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. Se= e +@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 look= s for +@code{mod_modulename.lua} in the plugins folder, so make sure that exist= s too. +Documentation on modules can be found at: @url{http://prosody.im/doc/mod= ules}. +Defaults to @samp{%default-modules-enabled}." + common) + + (modules-disabled + (string-list '()) + "@samp{\"offline\"}, @samp{\"c2s\"} and @samp{\"s2s\"} are auto-loa= ded, 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 optio= ns, do +not add them to your config, it is easy to lower the security of your se= rver +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. Thi= s +provides ideal security, but requires servers you communicate with to su= pport +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-sign= ed +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 st= ores +passwords in plaintext and uses Prosody's configured data storage to sto= re the +authentication data. If you do not trust your server please see +@url{http://prosody.im/doc/modules/mod_auth_internal_hashed} for informa= tion +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 u= sers. +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} - t= hey are +loaded automatically on-demand. + +Note that @samp{\"sql\"} storage is not yet supported by the GuixSD Pros= ody +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 su= pported +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 create= d. 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 thi= s host. + +Note: the name \"virtual\" host is used in configuration to avoid confus= ion 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 c= lients, +usually on a subdomain of the main server (such as +@samp{\"mycomponent.example.com\"}). Example components might be chatro= om +servers, user directories, or gateways to other protocols. + +Internal components are implemented with Prosody-specific plugins. To a= dd an +internal component, you simply fill the hostname field, and the plugin y= ou 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 fie= ld. 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 an= d/or +AAAA record for this address. Alternatively you can specify an IP addre= ss. " + global) + + (proxy65-acl + (string-list '()) + "Access Control List, when specified all users will be denied acces= s +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 'hostna= me)) + "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 crea= te +hosted chatrooms/conferences for XMPP users. + +General information on setting up and using MUC chatrooms can be found i= n our +\"Chatrooms\" documentation (@url{http://prosody.im/doc/chatrooms}), whi= ch 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 'hostna= me)) + "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-configur= ation + 'prosody.cfg.lua)) + "The contents of the @code{prosody.cfg.lua} to use.")) + +(define (prosody-shepherd-service config) + "Return a 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 #$@ar= gs)))))) + (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-f= ields) + ", "))) + (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-nam= e) '())) + (format #t "@end deftypevr\n\n"))) + (filter (lambda (f) + (not (string=3D? "" (configuration-field-documentation= f)))) + fields))))) + (generate 'prosody-configuration)) + +;;; messaging.scm ends here --=20 2.10.1