;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018, 2019 Mathieu Othacehe ;;; Copyright © 2020 Ludovic Courtès ;;; ;;; 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 (gnu installer steps) #:use-module (guix records) #:use-module (guix build utils) #:use-module (gnu installer utils)
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)