From: "Clément Lassieur" <clement@lassieur.org>
To: guix-devel@gnu.org
Subject: [PATCH] gnu: Add prosody service
Date: Sat, 26 Nov 2016 22:28:26 +0100 [thread overview]
Message-ID: <20161126212826.22073-1-clement@lassieur.org> (raw)
In-Reply-To: <874m2uxiuu.fsf@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
next prev parent reply other threads:[~2016-11-26 21:28 UTC|newest]
Thread overview: 18+ messages / expand[flat|nested] mbox.gz Atom feed top
2016-11-26 17:15 RFH: Add prosody service Clément Lassieur
2016-11-26 17:20 ` [PATCH] gnu: " Clément Lassieur
2016-11-26 23:41 ` Leo Famulari
2016-11-27 10:04 ` Clément Lassieur
2016-11-26 17:20 ` Clément Lassieur
2016-11-26 21:28 ` Clément Lassieur [this message]
2016-11-26 21:30 ` Clément Lassieur
2016-11-28 19:54 ` RFH: " Hartmut Goebel
2016-11-28 21:01 ` Ludovic Courtès
2016-12-02 11:19 ` Clément Lassieur
2016-12-04 21:11 ` Ludovic Courtès
-- strict thread matches above, loose matches on Subject: below --
2017-01-04 21:55 [PATCH] gnu: Add Prosody service Clément Lassieur
2017-01-05 10:34 ` Hartmut Goebel
2017-01-05 10:50 ` ng0
2017-01-07 22:10 ` Clément Lassieur
2017-01-07 21:14 ` Clément Lassieur
2017-01-07 21:29 ` Ludovic Courtès
2017-01-08 19:06 ` Clément Lassieur
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://guix.gnu.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20161126212826.22073-1-clement@lassieur.org \
--to=clement@lassieur.org \
--cc=guix-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).