;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Danny Milosavljevic ;;; Copyright © 2016, 2017 Theodoros Foradis ;;; Copyright © 2018 Tobias Geerinckx-Rice ;;; Copyright © 2019 Amin Bandali ;;; ;;; 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 . (define-module
aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2015, 2017-2020, 2022-2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Pierre-Antoine Rouby <contact@parouby.fr>
;;;
;;; 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 admin)
  #:use-module (gnu packages base)
  #:use-module (gnu packages irc)
  #:use-module (gnu packages messaging)
  #:use-module (gnu packages tls)
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module (gnu services configuration)
  #:use-module (gnu system shadow)
  #:autoload   (gnu build linux-container) (%namespaces)
  #:use-module ((gnu system file-systems) #:select (file-system-mapping))
  #:use-module (guix gexp)
  #:use-module (guix modules)
  #:use-module (guix records)
  #:use-module (guix packages)
  #:use-module (guix deprecation)
  #:use-module (guix least-authority)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-35)
  #:use-module (ice-9 match)
  #:export (prosody-service-type
            prosody-configuration
            opaque-prosody-configuration

            virtualhost-configuration
            int-component-configuration
            ext-component-configuration

            mod-muc-configuration
            ssl-configuration

            %default-modules-enabled
            prosody-configuration-pidfile

            bitlbee-configuration
            bitlbee-configuration?
            bitlbee-service-type

            quassel-configuration
            quassel-service-type))

;;; Commentary:
;;;
;;; Messaging services.
;;;
;;; Code:

(define-syntax define-all-configurations
  (lambda (stx)
    (define-syntax-rule (id ctx parts ...)
      "Assemble PARTS into a raw (unhygienic) identifier."
      (datum->syntax ctx (symbol-append (syntax->datum parts) ...)))
    (define (make-pred arg)
      (lambda (field target)
        (and (memq (syntax->datum target) `(common ,arg)) field)))
    (syntax-case stx ()
      ;; TODO Also handle (field-type) form, without a default.
      ((_ stem (field (field-type def) doc target) ...)
       (with-syntax (((new-field-type ...)
                      (map (lambda (field-type target)
                             (if (and (eq? 'common (syntax->datum target))
                                      (not (string-prefix?
                                            "maybe-"
                                            (symbol->string
                                             (syntax->datum field-type)))))
                                 (id #'stem #'maybe- field-type) field-type))
                           #'(field-type ...) #'(target ...)))
                     ((new-def ...)
                      (map (lambda (def target)
                             (if (eq? 'common (syntax->datum target))
                                 ;; TODO Use the %unset-value variable, or
                                 ;; even better just simplify this so that it
                                 ;; doesn't interfere with
                                 ;; define-configuration and define-maybe
                                 ;; internals.
                                 #''%unset-marker% def))
                           #'(def ...) #'(target ...)))
                     ((new-doc ...)
                      (map (lambda (doc target)
                             (if (eq? 'common (syntax->datum target))
                                 "" doc))
                           #'(doc ...) #'(target ...))))
         #`(begin
             (define #,(id #'stem #'common-fields)
               '(#,@(filter-map (make-pred #f) #'(field ...) #'(target ...))))
             (define-configuration #,(id #'stem #'prosody-configuration)
               #,@(filter-map (make-pred 'global)
                              #'((field (field-type def) doc) ...)
                              #'(target ...)))
             (define-configuration #,(id #'stem #'virtualhost-configuration)
               #,@(filter-map (make-pred 'virtualhost)
                              #'((field (new-field-type new-def) new-doc) ...)
                              #'(target ...)))
             (define-configuration #,(id #'stem #'int-component-configuration)
               #,@(filter-map (make-pred 'int-component)
                              #'((field (new-field-type new-def) new-doc) ...)
                              #'(target ...)))
             (define-configuration #,(id #'stem #'ext-component-configuration)
               #,@(filter-map (make-pred 'ext-component)
                              #'((field (new-field-type new-def) new-doc) ...)
                              #'(target ...)))))))))

(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-field 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 #~(format #f "{\n~@{~a;\n~}}" #$@val)))

(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 (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 (map number->string val)))
(define-maybe non-negative-integer-list)

(define (enclose-quotes s)
  #~(string-append "\"" #$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 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-list)

(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-list)

(define (raw-content? val)
  (maybe-value-set? val))
(define (serialize-raw-content field-name val)
  val)
(define-maybe raw-content)

(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.")

  (max-history-messages
   (non-negative-integer 20)
   "Maximum number of history messages that will be sent to the member that has
just joined the room."))
(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
   "This determines what handshake to use.")

  (key
   maybe-file-name
   "Path to your private key file.")

  (certificate
   maybe-file-name
   "Path to your certificate file.")

  (capath
   (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-object
   "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
   "A list of verification options (these mostly map to OpenSSL's
@code{set_verify()} flags).")

  (options
   maybe-string-list
   "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
   "How long a chain of certificate authorities to check when looking for a
trusted root certificate.")

  (ciphers
   maybe-string
   "An OpenSSL cipher string.  This selects what ciphers Prosody will offer to
clients, and in what order.")

  (dhparam
   maybe-file-name
   "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
   "Curve for Elliptic curve Diffie-Hellman. Prosody's default is
@samp{\"secp384r1\"}.")

  (verifyext
   maybe-string-list
   "A list of \"extra\" verification options.")

  (password
   maybe-string
   "Password for encrypted private keys."))
(define (serialize-ssl-configuration field-name val)
  #~(format #f "ssl = {\n~a};\n"
            #$(serialize-configuration val ssl-configuration-fields)))
(define-maybe ssl-configuration)

(define %default-module