;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Pierre-Antoine Rouby <contact@parouby.fr>
;;;
;;; This file is part of GNU Guix.
;;;
(define-module (gnu services messaging)
#:use-module (gnu packages messaging)
#:use-module (gnu packages admin)
+ #:use-module (gnu packages irc)
+ #:use-module (gnu packages tls)
#:use-module (gnu services)
#:use-module (gnu services shepherd)
#:use-module (gnu services configuration)
#:use-module (guix modules)
#:use-module (guix records)
#:use-module (guix packages)
+ #:use-module (guix deprecation)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-35)
#:use-module (ice-9 match)
bitlbee-configuration
bitlbee-configuration?
bitlbee-service
- bitlbee-service-type))
+ bitlbee-service-type
+
+ quassel-configuration
+ quassel-service-type))
;;; Commentary:
;;;
"_")))
(define (serialize-field field-name val)
- (format #t "~a = ~a;\n" (uglify-field-name field-name) val))
+ #~(format #f "~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 "}")))))
+ (serialize-field field-name #~(format #f "{\n~@{~a;\n~}}" #$@val)))
(define (serialize-boolean field-name val)
(serialize-field field-name (if val "true" "false")))
(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))
+ (serialize-field field-name (number->string 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))
+ (serialize-field-list field-name (map number->string val)))
(define-maybe non-negative-integer-list)
(define (enclose-quotes s)
- (format #f "\"~a\"" s))
+ #~(string-append "\"" #$s "\""))
(define (serialize-string field-name val)
(serialize-field field-name (enclose-quotes val)))
(define-maybe string)
(serialize-string-list field-name val))
(define-maybe file-name)
+(define (file-object? val)
+ (or (file-like? val) (file-name? val)))
+(define (serialize-file-object field-name val)
+ (serialize-string field-name val))
+(define-maybe file-object)
+
+(define (file-object-list? val)
+ (and (list? val) (and-map file-object? val)))
+(define (serialize-file-object-list field-name val)
+ (serialize-string-list field-name val))
+(define-maybe file-object)
+
(define (raw-content? val)
(not (eq? val 'disabled)))
(define (serialize-raw-content field-name val)
- (format #t "~a" val))
+ val)
(define-maybe raw-content)
(define-configuration mod-muc-configuration
"Path to your certificate file.")
(capath
- (file-name "/etc/ssl/certs")
+ (file-object "/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)
+ (maybe-file-object 'disabled)
"Path to a file containing root certificates that you wish Prosody to trust.
Similar to @code{capath} but with all certificates concatenated together.")
(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"))
+ #~(format #f "ssl = {\n~a};\n"
+ #$(serialize-configuration val ssl-configuration-fields)))
(define-maybe ssl-configuration)
(define %default-modules-enabled
(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))
+ #~(string-append
+ #$@(map (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))
+ #~(string-append
+ #$@(map (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))
+ #~(string-append
+ #$@(map (lambda (val)
+ (serialize-ext-component-configuration val)) l)))
(define-all-configurations prosody-configuration
(prosody
global)
(plugin-paths
- (file-name-list '())
+ (file-object-list '())
"Additional plugin directories. They are searched in all the specified
paths in order. See @url{https://prosody.im/doc/plugins_directory}."
global)
common)
(groups-file
- (file-name "/var/lib/prosody/sharedgroups.txt")
+ (file-object "/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{https://prosody.im/doc/modules/mod_groups}."
(log
(maybe-string "*syslog")
"Set logging options. Advanced logging configuration is not yet supported
-by the GuixSD Prosody Service. See @url{https://prosody.im/doc/logging}."
+by the Prosody service. See @url{https://prosody.im/doc/logging}."
common)
(pidfile
'(domain))))
(let ((domain (virtualhost-configuration-domain config))
(rest (filter rest? virtualhost-configuration-fields)))
- (format #t "VirtualHost \"~a\"\n" domain)
- (serialize-configuration config rest)))
+ #~(string-append
+ #$(format #f "VirtualHost \"~a\"\n" domain)
+ #$(serialize-configuration config rest))))
;; Serialize Component line first.
(define (serialize-int-component-configuration config)
(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)))
+ #~(string-append
+ #$(format #f "Component \"~a\" \"~a\"\n" hostname plugin)
+ #$(serialize-configuration config rest))))
;; Serialize Component line first.
(define (serialize-ext-component-configuration config)
'(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)))
+ #~(string-append
+ #$(format #f "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)))
+ #~(string-append
+ #$(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
(opaque-prosody-configuration-prosody config)
(prosody-configuration-prosody config)))
(prosodyctl-bin (file-append prosody "/bin/prosodyctl"))
+ (pid-file (prosody-configuration-pidfile config))
(prosodyctl-action (lambda args
#~(lambda _
- (zero? (system* #$prosodyctl-bin #$@args))))))
+ (invoke #$prosodyctl-bin #$@args)
+ (match '#$args
+ (("start")
+ (call-with-input-file #$pid-file read))
+ (_ #t))))))
(list (shepherd-service
(documentation "Run the Prosody XMPP server")
(provision '(prosody xmpp-daemon))
(requirement '(networking syslogd user-processes))
+ (modules `((ice-9 match)
+ ,@%default-modules))
(start (prosodyctl-action "start"))
(stop (prosodyctl-action "stop"))))))
(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)))
+ (config-str (if (opaque-prosody-configuration? config)
+ (opaque-prosody-configuration-prosody.cfg.lua config)
+ #~(begin
+ (use-modules (ice-9 format))
+ #$(serialize-prosody-configuration config))))
+ (config-file (mixed-text-file "prosody.cfg.lua" config-str)))
#~(begin
(use-modules (guix build utils))
(define %user (getpw "prosody"))
(service-extension account-service-type
(const %prosody-accounts))
(service-extension activation-service-type
- prosody-activation)))))
+ prosody-activation)))
+ (default-value (prosody-configuration
+ (virtualhosts
+ (list
+ (virtualhost-configuration
+ (domain "localhost"))))))
+ (description
+ "Run Prosody, a modern XMPP communication server.")))
;; A little helper to make it easier to document all those fields.
(define (generate-documentation)
(default "127.0.0.1"))
(port bitlbee-configuration-port
(default 6667))
+ (plugins bitlbee-plugins
+ (default '()))
(extra-settings bitlbee-configuration-extra-settings
(default "")))
(define bitlbee-shepherd-service
(match-lambda
- (($ <bitlbee-configuration> bitlbee interface port extra-settings)
- (let ((conf (plain-file "bitlbee.conf"
- (string-append "
+ (($ <bitlbee-configuration> bitlbee interface port
+ plugins extra-settings)
+ (let* ((plugins (directory-union "bitlbee-plugins" plugins))
+ (conf (mixed-text-file "bitlbee.conf"
+ "
[settings]
User = bitlbee
ConfigDir = /var/lib/bitlbee
DaemonInterface = " interface "
DaemonPort = " (number->string port) "
-" extra-settings))))
+ PluginDir = " plugins "/lib/bitlbee
+" extra-settings)))
(with-imported-modules (source-module-closure
'((gnu build shepherd)
(list #$(file-append bitlbee "/sbin/bitlbee")
"-n" "-F" "-u" "bitlbee" "-c" #$conf)
+ ;; Allow 'bitlbee-purple' to use libpurple plugins.
+ #:environment-variables
+ (list (string-append "PURPLE_PLUGIN_PATH="
+ #$plugins "/lib/purple-2"))
+
#:pid-file "/var/run/bitlbee.pid"
#:mappings (list (file-system-mapping
(source "/var/lib/bitlbee")
"Run @url{http://bitlbee.org,BitlBee}, a daemon that acts as
a gateway between IRC and chat networks.")))
-(define* (bitlbee-service #:key (bitlbee bitlbee) ;deprecated
- (interface "127.0.0.1") (port 6667)
- (extra-settings ""))
+(define-deprecated (bitlbee-service #:key (bitlbee bitlbee)
+ (interface "127.0.0.1") (port 6667)
+ (extra-settings ""))
+ bitlbee-service-type
"Return a service that runs @url{http://bitlbee.org,BitlBee}, a daemon that
acts as a gateway between IRC and chat networks.
(bitlbee bitlbee)
(interface interface) (port port)
(extra-settings extra-settings))))
+
+\f
+;;;
+;;; Quassel.
+;;;
+
+(define-record-type* <quassel-configuration>
+ quassel-configuration make-quassel-configuration
+ quassel-configuration?
+ (quassel quassel-configuration-quassel
+ (default quassel))
+ (interface quassel-configuration-interface
+ (default "::,0.0.0.0"))
+ (port quassel-configuration-port
+ (default 4242))
+ (loglevel quassel-configuration-loglevel
+ (default "Info")))
+
+(define quassel-shepherd-service
+ (match-lambda
+ (($ <quassel-configuration> quassel interface port loglevel)
+ (with-imported-modules (source-module-closure
+ '((gnu build shepherd)
+ (gnu system file-systems)))
+ (list (shepherd-service
+ (provision '(quassel))
+ (requirement '(user-processes networking))
+ (modules '((gnu build shepherd)
+ (gnu system file-systems)))
+ (start #~(make-forkexec-constructor/container
+ (list #$(file-append quassel "/bin/quasselcore")
+ "--configdir=/var/lib/quassel"
+ "--logfile=/var/log/quassel/core.log"
+ (string-append "--loglevel=" #$loglevel)
+ (string-append "--port=" (number->string #$port))
+ (string-append "--listen=" #$interface))
+ #:mappings (list (file-system-mapping
+ (source "/var/lib/quassel")
+ (target source)
+ (writable? #t))
+ (file-system-mapping
+ (source "/var/log/quassel")
+ (target source)
+ (writable? #t)))))
+ (stop #~(make-kill-destructor))))))))
+
+(define %quassel-account
+ (list (user-group (name "quassel") (system? #t))
+ (user-account
+ (name "quasselcore")
+ (group "quassel")
+ (system? #t)
+ (comment "Quassel daemon user")
+ (home-directory "/var/lib/quassel")
+ (shell (file-append shadow "/sbin/nologin")))))
+
+(define %quassel-activation
+ #~(begin
+ (use-modules (guix build utils))
+ (mkdir-p "/var/lib/quassel")
+ (mkdir-p "/var/log/quassel")
+ (let ((cert "/var/lib/quassel/quasselCert.pem"))
+ (unless (file-exists? cert)
+ (invoke #$(file-append openssl "/bin/openssl")
+ "req" "-x509" "-nodes" "-batch" "-days" "680" "-newkey"
+ "rsa" "-keyout" cert "-out" cert)))))
+
+(define quassel-service-type
+ (service-type (name 'quassel)
+ (extensions
+ (list (service-extension shepherd-root-service-type
+ quassel-shepherd-service)
+ (service-extension profile-service-type
+ (compose list quassel-configuration-quassel))
+ (service-extension account-service-type
+ (const %quassel-account))
+ (service-extension activation-service-type
+ (const %quassel-activation))))
+ (default-value (quassel-configuration))
+ (description
+ "Run @url{https://quassel-irc.org/,quasselcore}, the backend
+for the distributed IRC client quassel, which allows you to connect from
+multiple machines simultaneously.")))
HCoop / jackhill / guix / guix.git / blobdiff