;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 nee  <nee-git@hidamari.blue>
;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; 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 telephony)
  #:use-module ((gnu services) #:hide (delete))
  #:use-module (gnu services configuration)
  #:use-module (gnu services shepherd)
  #:use-module (gnu system shadow)
  #:use-module (gnu packages admin)
  #:use-module (gnu packages glib)
  #:use-module (gnu packages jami)
  #:use-module (gnu packages telephony)
  #:use-module (guix records)
  #:use-module (guix modules)
  #:use-module (guix packages)
  #:use-module (guix gexp)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:export (jami-daemon-configuration
            jami-daemon-configuration-jami-daemon
            jami-daemon-configuration-dbus
            jami-daemon-configuration-enable-logging?
            jami-daemon-configuration-debug?
            jami-daemon-configuration-auto-answer?
            jami-daemon-configuration-account-archives

            jami-daemon-service-type

            murmur-configuration
            make-murmur-configuration
            murmur-configuration?
            murmur-configuration-package
            murmur-configuration-user
            murmur-configuration-group
            murmur-configuration-port
            murmur-configuration-welcome-text
            murmur-configuration-server-password
            murmur-configuration-max-users
            murmur-configuration-max-user-bandwidth
            murmur-configuration-database-file
            murmur-configuration-log-file
            murmur-configuration-pid-file
            murmur-configuration-autoban-attempts
            murmur-configuration-autoban-timeframe
            murmur-configuration-autoban-time
            murmur-configuration-opus-threshold
            murmur-configuration-channel-nesting-limit
            murmur-configuration-channelname-regex
            murmur-configuration-username-regex
            murmur-configuration-text-message-length
            murmur-configuration-image-message-length
            murmur-configuration-cert-required?
            murmur-configuration-remember-channel?
            murmur-configuration-allow-html?
            murmur-configuration-allow-ping?
            murmur-configuration-bonjour?
            murmur-configuration-send-version?
            murmur-configuration-log-days
            murmur-configuration-obfuscate-ips?
            murmur-configuration-ssl-cert
            murmur-configuration-ssl-key
            murmur-configuration-ssl-dh-params
            murmur-configuration-ssl-ciphers
            murmur-configuration-public-registration
            murmur-configuration-file

            murmur-public-registration-configuration
            make-murmur-public-registration-configuration
            murmur-public-registration-configuration?
            murmur-public-registration-configuration-name
            murmur-public-registration-configuration-url
            murmur-public-registration-configuration-password
            murmur-public-registration-configuration-hostname

            murmur-service-type))


\f
;;;
;;; Jami daemon.
;;;

;;; Copied from (gnu services messaging).
(define (string-list? val)
  (and (list? val)
       (and-map (lambda (x)
                  (or (computed-file? x) ;XXX: for tests
                      (and (string? x) (not (string-index x #\,)))))
                val)))

(define-maybe/no-serialization string-list)

(define-configuration/no-serialization jami-daemon-configuration
  (jami-daemon
   (package libring)
   "The Jami daemon package to use.")
  (dbus
   (package dbus)
   "The D-Bus package to use to start the required D-Bus session.")
  (enable-logging?
   (boolean #t)
   "Whether to enable logging to syslog.")
  (debug?
   (boolean #f)
   "Whether to enable debug level messages.")
  (auto-answer?
   (boolean #f)
   "Whether to force automatic answer to incoming calls.")
  (account-archives
   (maybe-string-list 'disabled)
   "A list of Jami account archive (backup) file names to be (re-)provisioned
every time the Jami daemon service starts.  These Jami account backups should
@emph{not} be encrypted and should be made readable only to the @samp{jami}
user (i.e., not in the store), to guard against leaking the secret key
material of the Jami accounts they contain.  When providing this field, the
account directories under @file{/var/lib/jami/} are recreated every time the
service starts, ensuring a consistent state."))

(define %jami-daemon-accounts
  (list (user-group (name "jami") (system? #t))
        (user-account
         (name "jami")
         (group "jami")
         (system? #t)
         (comment "Jami daemon user")
         (home-directory "/var/lib/jami"))))

(define (jami-daemon-configuration->command-line-arguments config)
  "Derive the command line arguments to used to launch the Jami daemon from
CONFIG, a <jami-daemon-configuration> object."
  (match-record config <jami-daemon-configuration>
    (jami-daemon dbus enable-logging? debug? auto-answer?)
    `(,(file-append jami-daemon "/lib/ring/dring")
      "--persistent"                    ;stay alive after client quits
      ,@(if enable-logging?
            '()                         ;logs go to syslog by default
            (list "--console"))         ;else stdout/stderr
      ,@(if debug?
            (list "--debug")
            '())
      ,@(if auto-answer?
            (list "--auto-answer")
            '()))))

(define (jami-dbus-session-activation config)
  "Create a directory to hold the Jami D-Bus session socket."
  (with-imported-modules (source-module-closure '((gnu build activation)))
    #~(begin
        (use-modules (gnu build activation))
        (let ((user (getpwnam "jami")))
          (mkdir-p/perms "/var/run/jami" user #o700)))))

;; Local definitions to expand in source form in G-exps.
(define define-with-retries
  '(define-syntax-rule (with-retries n delay body ...)
     "Retry the code in BODY up to N times until it returns #t,
else #f.  A delay of DELAY seconds is inserted before each retry."
     (let loop ((attempts 0))
       (if (< attempts n)
           (or (catch #t
                 (lambda ()
                   body ...)
                 (lambda args
                   #f))
               (begin
                 (sleep delay)          ;else wait and retry
                 (loop (+ 1 attempts))))
           (error "maximum number of retry attempts reached")))))

(define define-send-dbus
  '(define (send-dbus dbus-send service path interface method . arguments)
     "Return the response of dbus-send, else #f."
     (let* ((command `(,dbus-send
                       "--bus=unix:path=/var/run/jami/bus"
                       "--print-reply"
                       ,(string-append "--dest=" service) ;e.g., cx.ring.Ring
                       ,path         ;e.g., /cx/ring/Ring/ConfigurationManager
                       ,(string-append interface "." method)
                       ,@arguments))
            (temporary-log-file "/var/run/jami/.temporary-dbus-output.log")
            (clear-temp-file (lambda () (false-if-exception
                                         (delete-file temporary-log-file)))))
       (catch #t
         (lambda ()
           (dynamic-wind
             clear-temp-file
             (lambda ()
               (let ((pid (fork+exec-command command
                                             #:user "jami" #:group "jami"
                                             #:log-file temporary-log-file)))
                 (match (waitpid pid)
                   ((_ . status)
                    (let ((exit-status (status:exit-val status)))
                      (unless (= 0 exit-status)
                        (error "the send-dbus command exited with"
                               exit-status))
                      #t))))
               (call-with-input-file temporary-log-file get-string-all))
             clear-temp-file))
         (lambda args
           (format (current-error-port) "command ~s failed with ~a~%"
                   command args)
           #f)))))

(define (jami-daemon-shepherd-services config)
  "Return a <shepherd-service> running the Jami daemon."
  (let* ((jami-daemon (jami-daemon-configuration-jami-daemon config))
         (dbus (jami-daemon-configuration-dbus config))
         (dbus-daemon (file-append dbus "/bin/dbus-daemon"))
         (dbus-send (file-append dbus "/bin/dbus-send"))
         (accounts (jami-daemon-configuration-account-archives config))
         (declarative-mode? (not (eq? 'disabled accounts))))

    (with-imported-modules (source-module-closure
                            '((gnu build shepherd)
                              (gnu system file-systems)))
      (list (shepherd-service
             (documentation "Run a D-Bus session for the Jami daemon.")
             (provision '(jami-daemon-dbus-session))
             (modules `((gnu build shepherd)
                        (gnu system file-systems)
                        ,@%default-modules))
             ;; The requirement on dbus-system is to ensure other required
             ;; activation for D-Bus, such as a /etc/machine-id file.
             (requirement '(dbus-system syslogd))
             (start
              #~(lambda args
                  #$define-with-retries

                  (define pid
                    ((make-forkexec-constructor/container
                      (list #$dbus-daemon "--session"
                            "--address=unix:path=/var/run/jami/bus"
                            "--nofork" "--syslog-only" "--nopidfile")
                      #:mappings (list (file-system-mapping
                                        (source "/dev/log") ;for syslog
                                        (target source))
                                       (file-system-mapping
                                        (source "/var/run/jami")
                                        (target source)
                                        (writable? #t)))
                      #:user "jami"
                      #:group "jami"
                      #:environment-variables
                      ;; This is so that the cx.ring.Ring service D-Bus
                      ;; definition is found by dbus-send.
                      (list (string-append "XDG_DATA_DIRS="
                                           #$jami-daemon "/share")))))

                  ;; XXX: This manual synchronization probably wouldn't be
                  ;; needed if we were using a PID file, but providing it via a
                  ;; customized config file with <pidfile> would not override
                  ;; the one inherited from the base config of D-Bus.
                  (let ((sock (socket PF_UNIX SOCK_STREAM 0)))
                    (with-retries 20 1 (catch 'system-error
                                         (lambda ()
                                           (connect sock AF_UNIX
                                                    "/var/run/jami/bus")
                                           (close-port sock)
                                           #t)
                                         (lambda args
                                           #f))))

                  pid))
             (stop #~(make-kill-destructor)))

            (shepherd-service
             (documentation "Run the Jami daemon.")
             (provision '(jami-daemon dring))
             (requirement '(jami-daemon-dbus-session))
             (modules `((ice-9 ftw)
                        (ice-9 match)
                        (rnrs io ports)
                        (srfi srfi-1)
                        (srfi srfi-26)
                        (gnu build shepherd)
                        (gnu system file-systems)
                        ,@%default-modules))
             (start
              #~(lambda args
                  #$define-with-retries
                  #$define-send-dbus

                  (define (delete-file-recursively/safe file)
                    ;; Ensure we're not deleting things outside of
                    ;; /var/lib/jami.  This prevents a possible attack in case
                    ;; the daemon is compromised and an attacker gains write
                    ;; access to /var/lib/jami.
                    (let ((parent-directory (dirname file)))
                      (if (eq? 'symlink (stat:type (stat parent-directory)))
                          (error "abnormality detected; unexpected symlink found at"
                                 parent-directory)
                          (delete-file-recursively file))))

                  (when #$declarative-mode?
                    ;; Clear the Jami configuration and accounts, to enforce the
                    ;; declared state.
                    (catch #t
                      (lambda ()
                        (for-each (cut delete-file-recursively/safe <>)
                                  '("/var/lib/jami/.cache/jami"
                                    "/var/lib/jami/.config/jami"
                                    "/var/lib/jami/.local/share/jami"
                                    "/var/lib/jami/accounts")))
                      (lambda args
                        #t))
                    ;; Copy the Jami accounts from somewhere readable by root to
                    ;; a place only the jami user can read.
                    (let* ((accounts-dir "/var/lib/jami/accounts/")
                           (pwd (getpwnam "jami"))
                           (user (passwd:uid pwd))
                           (group (passwd:gid pwd)))
                      (mkdir-p accounts-dir)
                      (chown accounts-dir user group)
                      (for-each (lambda (f)
                                  (let ((dest (string-append accounts-dir
                                                             (basename f))))
                                    (copy-file f dest)
                                    (chown dest user group)))
                                '#$accounts)))

                  ;; Start the daemon.
                  (define daemon-pid
                    ((make-forkexec-constructor/container
                      '#$(jami-daemon-configuration->command-line-arguments config)
                      #:mappings (list (file-system-mapping
                                        (source "/dev/log") ;for syslog
                                        (target source))
                                       (file-system-mapping
                                        (source "/var/lib/jami")
                                        (target source)
                                        (writable? #t))
                                       (file-system-mapping
                                        (source "/var/run/jami")
                                        (target source)
                                        (writable? #t)))
                      #:user "jami"
                      #:group "jami"
                      #:environment-variables
                      (list (string-append "DBUS_SESSION_BUS_ADDRESS="
                                           "unix:path=/var/run/jami/bus")))))

                  ;; Wait until the service name has been acquired by D-Bus
                  ;; (this does *not* trigger automatic D-Bus service
                  ;; activation, which is what we want).
                  (with-retries 20 1
                    (let ((output (send-dbus #$dbus-send "org.freedesktop.DBus"
                                             "/org/freedesktop/DBus"
                                             "org.freedesktop.DBus"
                                             "ListNames")))
                      (string-contains output "cx.ring.Ring")))

                  ;; Provision the accounts, by means of D-Bus commands sent to
                  ;; the daemon.
                  (when #$declarative-mode?
                    (or (every
                         identity
                         (map (lambda (archive)
                                (send-dbus
                                 #$dbus-send
                                 "cx.ring.Ring"
                                 "/cx/ring/Ring/ConfigurationManager"
                                 "cx.ring.Ring.ConfigurationManager"
                                 "addAccount"
                                 (string-append
                                  "dict:string:string:Account.archivePath,"
                                  archive
                                  ",Account.type,RING")))
                              (map (cut string-append
                                        "/var/lib/jami/accounts/" <>)
                                   (scandir "/var/lib/jami/accounts/"
                                            (lambda (f)
                                              (not (member f '("." ".."))))))))
                        (error "failed provisioning the jami accounts")))

                  ;; Finally, return the PID of the dring process.
                  daemon-pid))
             (stop
              #~(lambda (pid . args)
                  (kill pid SIGTERM)
                  ;; Wait for the process to exit; this prevents overlapping
                  ;; processes when issuing 'herd restart'.
                  (waitpid pid)
                  #f)))))))

(define jami-daemon-service-type
  (service-type
   (name 'jami-daemon)
   (default-value (jami-daemon-configuration))
   (extensions
    (list (service-extension shepherd-root-service-type
                             jami-daemon-shepherd-services)
          (service-extension account-service-type
                             (const %jami-daemon-accounts))
          (service-extension activation-service-type
                             jami-dbus-session-activation)))
   (description "Run the Jami daemon (@command{dring}).  This service is
geared toward the use case of hosting Jami rendezvous points over a headless
server.  If you use Jami on your local machine, you may prefer to setup a user
Shepherd service for it instead; this way, the daemon will be shared via your
normal user D-Bus session bus.")))

\f
;;;
;;; Murmur.
;;;

;; https://github.com/mumble-voip/mumble/blob/master/scripts/murmur.ini

(define-record-type* <murmur-configuration> murmur-configuration
  make-murmur-configuration
  murmur-configuration?
  (package               murmur-configuration-package ;<package>
                         (default mumble))
  (user                  murmur-configuration-user
                         (default "murmur"))
  (group                 murmur-configuration-group
                         (default "murmur"))
  (port                  murmur-configuration-port
                         (default 64738))
  (welcome-text          murmur-configuration-welcome-text
                         (default ""))
  (server-password       murmur-configuration-server-password
                         (default ""))
  (max-users             murmur-configuration-max-users
                         (default 100))
  (max-user-bandwidth    murmur-configuration-max-user-bandwidth
                         (default #f))
  (database-file         murmur-configuration-database-file
                         (default "/var/lib/murmur/db.sqlite"))
  (log-file              murmur-configuration-log-file
                         (default "/var/log/murmur/murmur.log"))
  (pid-file              murmur-configuration-pid-file
                         (default "/var/run/murmur/murmur.pid"))
  (autoban-attempts      murmur-configuration-autoban-attempts
                         (default 10))
  (autoban-timeframe     murmur-configuration-autoban-timeframe
                         (default 120))
  (autoban-time          murmur-configuration-autoban-time
                         (default 300))
  (opus-threshold        murmur-configuration-opus-threshold
                         (default 100)) ; integer percent
  (channel-nesting-limit murmur-configuration-channel-nesting-limit
                         (default 10))
  (channelname-regex     murmur-configuration-channelname-regex
                         (default #f))
  (username-regex        murmur-configuration-username-regex
                         (default #f))
  (text-message-length   murmur-configuration-text-message-length
                         (default 5000))
  (image-message-length  murmur-configuration-image-message-length
                         (default (* 128 1024))) ; 128 Kilobytes
  (cert-required?         murmur-configuration-cert-required?
                          (default #f))
  (remember-channel?     murmur-configuration-remember-channel?
                         (default #f))
  (allow-html?           murmur-configuration-allow-html?
                         (default #f))
  (allow-ping?           murmur-configuration-allow-ping?
                         (default #f))
  (bonjour?              murmur-configuration-bonjour?
                         (default #f))
  (send-version?         murmur-configuration-send-version?
                         (default #f))
  (log-days              murmur-configuration-log-days
                         (default 31))
  (obfuscate-ips?        murmur-obfuscate-ips?
                         (default #t))
  (ssl-cert              murmur-configuration-ssl-cert
                         (default #f))
  (ssl-key               murmur-configuration-ssl-key
                         (default #f))
  (ssl-dh-params         murmur-configuration-ssl-dh-params
                         (default #f))
  (ssl-ciphers           murmur-configuration-ssl-ciphers
                         (default #f))
  (public-registration   murmur-configuration-public-registration
                         (default #f))  ; <murmur-public-registration-configuration>
  (file                  murmur-configuration-file
                         (default #f)))

(define-record-type* <murmur-public-registration-configuration>
  murmur-public-registration-configuration
  make-murmur-public-registration-configuration
  murmur-public-registration-configuration?
  (name         murmur-public-registration-configuration-name)
  (password     murmur-public-registration-configuration-password)
  (url          murmur-public-registration-configuration-url)
  (hostname     murmur-public-registration-configuration-hostname
                (default #f)))

(define (flatten . lst)
  "Return a list that recursively concatenates all sub-lists of LST."
  (define (flatten1 head out)
    (if (list? head)
        (fold-right flatten1 out head)
        (cons head out)))
  (fold-right flatten1 '() lst))

(define (default-murmur-config config)
  (match-record
   config
   <murmur-configuration>
   (user port welcome-text server-password max-users max-user-bandwidth
    database-file log-file pid-file autoban-attempts autoban-timeframe
    autoban-time opus-threshold channel-nesting-limit channelname-regex
    username-regex text-message-length image-message-length cert-required?
    remember-channel? allow-html? allow-ping? bonjour? send-version?
    log-days obfuscate-ips? ssl-cert ssl-key ssl-dh-params ssl-ciphers
    public-registration)
   (apply mixed-text-file "murmur.ini"
          (flatten
           "welcometext=" welcome-text "\n"
           "port=" (number->string port) "\n"
           (if server-password (list "serverpassword=" server-password "\n") '())
           (if max-user-bandwidth (list "bandwidth="
                                        (number->string max-user-bandwidth) "\n")
               '())
           "users=" (number->string max-users) "\n"
           "uname=" user "\n"
           "database=" database-file "\n"
           "logfile=" log-file "\n"
           "pidfile=" pid-file "\n"
           (if autoban-attempts (list "autobanAttempts=" (number->string autoban-attempts) "\n") '())
           (if autoban-timeframe (list "autobanTimeframe=" (number->string autoban-timeframe) "\n") '())
           (if autoban-time (list "autobanTime=" (number->string autoban-time) "\n") '())
           (if opus-threshold (list "opusthreshold=" (number->string opus-threshold) "\n") '())
           (if channel-nesting-limit (list "channelnestinglimit=" (number->string channel-nesting-limit) "\n") '())
           (if channelname-regex (list "channelname=" channelname-regex "\n") '())
           (if username-regex (list "username=" username-regex "\n") '())
           (if text-message-length (list "textmessagelength=" (number->string text-message-length) "\n") '())
           (if image-message-length (list "imagemessagelength=" (number->string image-message-length) "\n") '())
           (if log-days (list "logdays=" (number->string log-days) "\n") '())
           "obfuscate=" (if obfuscate-ips? "true" "false") "\n"
           "certrequired=" (if cert-required? "true" "false") "\n"
           "rememberchannel=" (if remember-channel? "true" "false") "\n"
           "allowhtml=" (if allow-html? "true" "false") "\n"
           "allowping=" (if allow-ping? "true" "false") "\n"
           "bonjour=" (if bonjour? "true" "false") "\n"
           "sendversion=" (if send-version? "true" "false") "\n"
           (cond ((and ssl-cert ssl-key)
                  (list
                   "sslCert=" ssl-cert "\n"
                   "sslKey=" ssl-key "\n"))
                 ((or ssl-cert ssl-key)
                  (error "ssl-cert and ssl-key must both be set"
                         ssl-cert ssl-key))
                 (else '()))
           (if ssl-dh-params (list "sslDHParams=" ssl-dh-params) '())
           (if ssl-ciphers (list "sslCiphers=" ssl-ciphers) '())

           (match public-registration
             (#f '())
             (($ <murmur-public-registration-configuration>
                 name password url hostname)
              (if (and (or (not server-password) (string-null? server-password))
                       allow-ping?)
                  (list
                   "registerName=" name "\n"
                   "registerPassword=" password "\n"
                   "registerUrl=" url "\n"
                   (if hostname
                       (string-append "registerHostname=" hostname "\n")
                       ""))
                  (error "To publicly register your murmur server your server must be publicy visible
and users must be able to join without a password. To fix this set:
(allow-ping? #t)
(server-password \"\")
Or set public-registration to #f"))))))))

(define (murmur-activation config)
  #~(begin
      (use-modules (guix build utils))
      (let* ((log-dir (dirname #$(murmur-configuration-log-file config)))
             (pid-dir (dirname #$(murmur-configuration-pid-file config)))
             (db-dir (dirname #$(murmur-configuration-database-file config)))
             (user (getpwnam #$(murmur-configuration-user config)))
             (init-dir
              (lambda (name dir)
                (format #t "creating murmur ~a directory '~a'\n" name dir)
                (mkdir-p dir)
                (chown dir (passwd:uid user) (passwd:gid user))
                (chmod dir #o700)))
             (ini #$(or (murmur-configuration-file config)
                        (default-murmur-config config))))
        (init-dir "log" log-dir)
        (init-dir "pid" pid-dir)
        (init-dir "database" db-dir)

        (format #t "murmur: use config file: ~a~%\n" ini)
        (format #t "murmur: to set the SuperUser password run:
    `~a -ini ~a -readsupw`\n"
                #$(file-append (murmur-configuration-package config)
                               "/bin/murmurd") ini)
        #t)))

(define murmur-accounts
  (match-lambda
    (($ <murmur-configuration> _ user group)
     (list
      (user-group
       (name group)
       (system? #t))
      (user-account
       (name user)
       (group group)
       (system? #t)
       (comment "Murmur Daemon")
       (home-directory "/var/empty")
       (shell (file-append shadow "/sbin/nologin")))))))

(define (murmur-shepherd-service config)
  (list (shepherd-service
         (provision '(murmur))
         (documentation "Run the Murmur Mumble server.")
         (requirement '(networking))
         (start #~(make-forkexec-constructor
                   '(#$(file-append (murmur-configuration-package config)
                                    "/bin/murmurd")
                     "-ini"
                     #$(or (murmur-configuration-file config)
                           (default-murmur-config config)))
                   #:pid-file #$(murmur-configuration-pid-file config)))
         (stop #~(make-kill-destructor)))))

(define murmur-service-type
  (service-type (name 'murmur)
                (description
                 "Run the Murmur voice-over-IP (VoIP) server of the Mumble
suite.")
                (extensions
                 (list (service-extension shepherd-root-service-type
                                          murmur-shepherd-service)
                       (service-extension activation-service-type
                                          murmur-activation)
                       (service-extension account-service-type
                                          murmur-accounts)))
                (default-value (murmur-configuration))))

;; Local Variables:
;; eval: (put 'with-retries 'scheme-indent-function 2)
;; End: