Toggle diff (1857 lines)
diff --git a/gnu/build/dbus-service.scm b/gnu/build/dbus-service.scm
index 0000000000..d3d8c9f716
+++ b/gnu/build/dbus-service.scm
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021, 2022 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/>.
+;;; This module contains procedures to interact with D-Bus via the 'dbus-send'
+;;; command line utility. Before using any public procedure
+(define-module (gnu build dbus-service)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-26)
+ #:autoload (d-bus protocol connections) (d-bus-conn?
+ d-bus-session-bus-address
+ d-bus-system-bus-address)
+ #:autoload (d-bus protocol messages) (MESSAGE_TYPE_METHOD_CALL
+ #:export (%dbus-query-timeout
+ initialize-dbus-connection!
+ %current-dbus-connection
+ dbus-available-services
+ dbus-service-available?
+(define %dbus-query-timeout 2) ;in seconds
+;;; Use Fibers' sleep to enable cooperative scheduling in Shepherd >= 0.9.0,
+;;; which is required at least for the Jami service.
+(define sleep* (if (resolve-module '(fibers) #f)
+ (module-ref (resolve-interface '(fibers)) 'sleep)
+ (format #f "fibers not available -- blocking 'sleep' in use")
+(define-syntax-rule (with-retries n delay body ...)
+ "Retry the code in BODY up to N times until it doesn't raise an exception nor
+return #f, else raise an error. A delay of DELAY seconds is inserted before
+ (let loop ((attempts 0))
+ (let ((result (begin body ...)))
+ (error "failed attempt" attempts)
+ (sleep* delay) ;else wait and retry
+ (error "maximum number of retry attempts reached"
+;;; Low level wrappers above AC/D-Bus.
+;; The active D-Bus connection (a parameter) used by the other procedures.
+(define %current-dbus-connection (make-parameter #f))
+(define* (initialize-dbus-connection!
+ #:key (address (or (d-bus-session-bus-address)
+ (d-bus-system-bus-address))))
+ "Initialize the D-Bus connection. ADDRESS should be the address of the D-Bus
+session, e.g. \"unix:path=/var/run/dbus/system_bus_socket\", the default value
+if ADDRESS is not provided and DBUS_SESSION_BUS_ADDRESS is not set. Return
+the initialized D-Bus connection."
+ ;; Clear current correction if already active.
+ (when (d-bus-conn? (%current-dbus-connection))
+ (d-bus-disconnect (%current-dbus-connection)))
+ (let ((connection (d-bus-connect address)))
+ (%current-dbus-connection connection) ;update connection parameter
+ (call-dbus-method "Hello")) ;initial handshake
+ (%current-dbus-connection))
+(define* (send-dbus message #:key
+ (connection (%current-dbus-connection))
+ "Send a D-Bus MESSAGE to CONNECTION and return the body of its reply. Up to
+READ-RETRIES replies are read until a matching reply is found, else an error
+is raised. MESSAGE is to be constructed with `make-d-bus-message'. When the
+body contains a single element, it is returned directly, else the body
+elements are returned as a list. TIMEOUT is a timeout value in seconds."
+ (let ((serial (d-bus-write-message connection message))
+ (start-time (current-time time-monotonic))
+ (timeout* (or timeout %dbus-query-timeout)))
+ (d-bus-conn-flush connection)
+ (when (> (time-second (time-difference (current-time time-monotonic)
+ (error 'dbus "fail to get reply in timeout" timeout*))
+ (let* ((reply (d-bus-read-message connection))
+ (reply-headers (d-bus-message-headers reply))
+ (reply-serial (d-bus-headers-ref reply-headers 'REPLY_SERIAL))
+ (error-name (d-bus-headers-ref reply-headers 'ERROR_NAME))
+ (body (d-bus-message-body reply)))
+ ;; Validate the reply matches the message.
+ (error 'dbus "method failed with error" error-name body))
+ ;; Some replies do not include a serial header, such as the for the
+ ;; org.freedesktop.DBus NameAcquired one.
+ (if (and reply-serial (= serial reply-serial))
+ ((x x* ..1) ;contains 2 ore more elements
+ x) ;single element; return it directly
+(define (argument->signature-type argument)
+ "Infer the D-Bus signature type from ARGUMENT."
+ ;; XXX: avoid ..1 when using vectors due to a bug (?) in (ice-9 match).
+ (#((? string?) (? string?) ...) "as")
+ (#(((? string?) . (? string?))
+ ((? string?) . (? string?)) ...) "a{ss}")+ (_ (error 'dbus "no rule to infer type from argument" argument))))
+(define* (call-dbus-method method
+ (path "/org/freedesktop/DBus")
+ (destination "org.freedesktop.DBus")
+ (interface "org.freedesktop.DBus")
+ (connection (%current-dbus-connection))
+ "Call the D-Bus method specified by METHOD, PATH, DESTINATION and INTERFACE.
+The currently active D-Bus CONNECTION is used unless explicitly provided.
+Method arguments may be provided via ARGUMENTS sent as the message body.
+TIMEOUT limit the maximum time to allow for the reply. Return the body of the
+ (let ((message (make-d-bus-message
+ MESSAGE_TYPE_METHOD_CALL 0 #f '()
+ ,(header-DESTINATION destination)
+ ,(header-INTERFACE interface)
+ ,(header-MEMBER method)
+ (list (header-SIGNATURE
+ (map argument->signature-type arguments)
+ (send-dbus message #:connection connection #:timeout timeout)))
+;;; Higher-level, D-Bus procedures.
+(define (dbus-available-services)
+ "Return the list of available (acquired) D-Bus services."
+ (let ((names (vector->list (call-dbus-method "ListNames"))))
+ ;; Remove entries such as ":1.7".
+ (remove (cut string-prefix? ":" <>) names)))
+(define (dbus-service-available? service)
+ "Predicate to check for the D-Bus SERVICE availability."
+ (member service (dbus-available-services)))
+;; eval: (put 'with-retries 'scheme-indent-function 2)
diff --git a/gnu/build/jami-service.scm b/gnu/build/jami-service.scm
index ddfc8cf937..0ceb03eb02 100644
--- a/gnu/build/jami-service.scm
+++ b/gnu/build/jami-service.scm
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; This file is part of GNU Guix.
(define-module (gnu build jami-service)
+ #:use-module (gnu build dbus-service)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
- #:use-module (ice-9 peg)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 regex)
- #:use-module (rnrs io ports)
- #:autoload (shepherd service) (fork+exec-command)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
- #:export (account-fingerprint?
+ #:export (jami-service-available?
@@ -51,43 +51,12 @@ (define-module (gnu build jami-service)
username->all-moderators?
- dbus-available-services
- dbus-service-available?
-(define-syntax-rule (with-retries n delay body ...)
- "Retry the code in BODY up to N times until it doesn't raise an exception
-nor return #f, else raise an error. A delay of DELAY seconds is inserted
- (let loop ((attempts 0))
- (let ((result (begin body ...)))
- (error "failed attempt" attempts)
- (sleep delay) ;else wait and retry
- (error "maximum number of retry attempts reached"
(define (alist->list alist)
"Flatten ALIST into a list."
(append-map (match-lambda
@@ -104,212 +73,34 @@ (define (account-fingerprint? val)
(regexp-exec account-fingerprint-rx val)))
-(define (parse-dbus-reply reply)
- "Return the parse tree of REPLY, a string returned by the 'dbus-send'
- ;; Refer to 'man 1 dbus-send' for the grammar reference. Note that the
- ;; format of the replies doesn't match the format of the input, which is the
- ;; one documented, but it gives an idea. For an even better reference, see
- ;; the `print_iter' procedure of the 'dbus-print-message.c' file from the
- ;; 'dbus' package sources.
- (define-peg-string-patterns
- "contents <- header (item / container (item / container*)?)
- item <-- WS type WS value NL
- container <- array / dict / variant
- array <-- array-start (item / container)* array-end
- dict <-- array-start dict-entry* array-end
- dict-entry <-- dict-entry-start item item dict-entry-end
- variant <-- variant-start item
- type <-- 'string' / 'int16' / 'uint16' / 'int32' / 'uint32' / 'int64' /
- 'uint64' / 'double' / 'byte' / 'boolean' / 'objpath'
- variant-start < WS 'variant'
- array-start < WS 'array [' NL
- dict-entry-start < WS 'dict entry(' NL- dict-entry-end < WS ')' NL
- (peg:tree (match-pattern contents reply)))
-(define (strip-quotes text)
- "Strip the leading and trailing double quotes (\") characters from TEXT."
- (let* ((text* (if (string-prefix? "\"" text)
- (text** (if (string-suffix? "\"" text*)
- (string-drop-right text* 1)
-(define (deserialize-item item)
- "Return the value described by the ITEM parse tree as a Guile object."
- ;; Strings are printed wrapped in double quotes (see the print_iter
- ;; procedure in dbus-print-message.c).
- (('item ('type "string") ('value value))- (('item ('type "boolean") ('value value))- (if (string=? "true" value)
- (('item _ ('value value))-(define (serialize-boolean bool)
- "Return the serialized format expected by dbus-send for BOOL."
- (format #f "boolean:~:[false~;true~]" bool))
-(define (dict->alist dict-parse-tree)
- "Translate a dict parse tree to an alist."
- (define (tuples->alist tuples)
- (map (lambda (x) (apply cons x)) tuples))
- (('dict ('dict-entry keys values) ...)- (let ((keys* (map deserialize-item keys))
- (values* (map deserialize-item values)))
- (tuples->alist (zip keys* values*))))))
-(define (array->list array-parse-tree)
- "Translate an array parse tree to a list."
- (match array-parse-tree
- (map deserialize-item items))))
-;;; Low-level, D-Bus-related procedures.
+(define (validate-fingerprint fingerprint)
+ "Validate that fingerprint is 40 characters long."
+ (unless (account-fingerprint? fingerprint)
+ (error "Account fingerprint is not valid:" fingerprint)))
-;;; The following parameters are used in the jami-service-type service
-;;; definition to conveniently customize the behavior of the send-dbus helper,
-;;; even when called indirectly.
-(define %send-dbus-binary (make-parameter "dbus-send"))
-(define %send-dbus-bus (make-parameter #f))
-(define %send-dbus-user (make-parameter #f))
-(define %send-dbus-group (make-parameter #f))
-(define %send-dbus-debug (make-parameter #f))
-(define* (send-dbus #:key service path interface method
- "Return the response of DBUS-SEND, else raise an error. Unless explicitly
-provided, DBUS-SEND takes the value of the %SEND-DBUS-BINARY parameter. BUS
-can be used to specify the bus address, such as 'unix:path=/var/run/jami/bus'.
-Alternatively, the %SEND-DBUS-BUS parameter can be used. ARGUMENTS can be
-used to pass input values to a D-Bus method call. TIMEOUT is the amount of
-time to wait for a reply in milliseconds before giving up with an error. USER
-and GROUP allow choosing under which user/group the DBUS-SEND command is
-executed. Alternatively, the %SEND-DBUS-USER and %SEND-DBUS-GROUP parameters
- (let* ((command `(,(if dbus-send
- ,@(if (or bus (%send-dbus-bus))
- (list (string-append "--bus="
- (or bus (%send-dbus-bus))))
- (list (format #f "--reply-timeout=~d" timeout))
- ,(string-append "--dest=" service) ;e.g., cx.ring.Ring
- ,path ;e.g., /cx/ring/Ring/ConfigurationManager
- ,(string-append interface "." method)
- (temp-port (mkstemp! (string-copy "/tmp/dbus-send-output-XXXXXXX")))
- (temp-file (port-filename temp-port)))
- (let* ((uid (or (and=> (or user (%send-dbus-user))
- (compose passwd:uid getpwnam)) -1))
- (gid (or (and=> (or group (%send-dbus-group))
- (compose group:gid getgrnam)) -1)))
- (chown temp-port uid gid)))
- (let ((pid (fork+exec-command command
- #:user (or user (%send-dbus-user))
- #:group (or group (%send-dbus-group))
- #:log-file temp-file)))
- (let ((exit-status (status:exit-val status))
- (output (call-with-port temp-port get-string-all)))
- (error "the send-dbus command exited with: "
- command exit-status output)))))))
- (false-if-exception (delete-file temp-file))))))
-(define (parse-account-ids reply)
- "Return the Jami account IDs from REPLY, which is assumed to be the output
-of the Jami D-Bus `getAccountList' method."
- (array->list (parse-dbus-reply reply)))
-(define (parse-account-details reply)
- "Parse REPLY, which is assumed to be the output of the Jami D-Bus
-`getAccountDetails' method, and return its content as an alist."
- (dict->alist (parse-dbus-reply reply)))
-(define (parse-contacts reply)
- "Parse REPLY, which is assumed to be the output of the Jamid D-Bus
-`getContacts' method, and return its content as an alist."
- (match (parse-dbus-reply reply)
- (map dict->alist dicts))))
+(define (jami-service-available?)
+ "Whether the Jami D-Bus service was acquired by the D-Bus daemon."
+ (unless (%current-dbus-connection)
+ (initialize-dbus-connection!))
+ (dbus-service-available? "cx.ring.Ring"))
-;;; Higher-level, D-Bus-related procedures.
+;;; Bindings for the Jami D-Bus API.
-(define (validate-fingerprint fingerprint)
- "Validate that fingerprint is 40 characters long."
- (unless (account-fingerprint? fingerprint)
- (error "Account fingerprint is not valid:" fingerprint)))
-(define (dbus-available-services)
- "Return the list of available (acquired) D-Bus services."
- (let ((reply (parse-dbus-reply
- (send-dbus #:service "org.freedesktop.DBus"
- #:path "/org/freedesktop/DBus"
- #:interface "org.freedesktop.DBus"
- #:method "ListNames"))))
- ;; Remove entries such as ":1.7".
- (remove (cut string-prefix? ":" <>)
-(define (dbus-service-available? service)
- "Predicate to check for the D-Bus SERVICE availability."
- (member service (dbus-available-services)))
-(define* (send-dbus/configuration-manager #:key method arguments timeout)
- "Query the Jami D-Bus ConfigurationManager service."
- (send-dbus #:service "cx.ring.Ring"
- #:path "/cx/ring/Ring/ConfigurationManager"
- #:interface "cx.ring.Ring.ConfigurationManager"
+(define* (call-configuration-manager-method method #:optional arguments
+ "Query the Jami D-Bus ConfigurationManager interface with METHOD applied to
+ARGUMENTS. TIMEOUT can optionally be provided as a value in seconds."
+ (unless (%current-dbus-connection)
+ (initialize-dbus-connection!))
+ (call-dbus-method method
+ #:path "/cx/ring/Ring/ConfigurationManager"
+ #:destination "cx.ring.Ring"
+ #:interface "cx.ring.Ring.ConfigurationManager"
;;; The following methods are for internal use; they make use of the account
;;; ID, an implementation detail of Jami the user should not need to be
@@ -317,22 +108,17 @@ (define* (send-dbus/configuration-manager #:key method arguments timeout)
(define (get-account-ids)
"Return the available Jami account identifiers (IDs). Account IDs are an
implementation detail used to identify the accounts in Jami."
- (send-dbus/configuration-manager #:method "getAccountList")))
+ (vector->list (call-configuration-manager-method "getAccountList")))
(define (id->account-details id)
"Retrieve the account data associated with the given account ID."
- (send-dbus/configuration-manager
- #:method "getAccountDetails"
- #:arguments (list (string-append "string:" id)))))
+ (vector->list (call-configuration-manager-method "getAccountDetails"
(define (id->volatile-account-details id)
"Retrieve the account data associated with the given account ID."
- (send-dbus/configuration-manager
- #:method "getVolatileAccountDetails"
- #:arguments (list (string-append "string:" id)))))
+ (vector->list (call-configuration-manager-method "getVolatileAccountDetails"
"Retrieve the complete account data associated with the given account ID."
@@ -362,8 +148,8 @@ (define (username->id username)
(or (assoc-ref %username-to-id-cache username)
- (let ((message (format #f "Could not retrieve a local account ID\
- for ~:[username~;fingerprint~]" (account-fingerprint? username))))
+ (let ((message (format #f "no account ID for ~:[username~;fingerprint~]"
+ (account-fingerprint? username))))
(error message username))))
(define (account->username account)
@@ -400,27 +186,21 @@ (define (add-account archive)
should *not* be encrypted with a password. Return the username associated
(invalidate-username-to-id-cache!)
- (let ((reply (send-dbus/configuration-manager
- #:arguments (list (string-append
- "dict:string:string:Account.archivePath,"
- ",Account.type,RING")))))
+ (let ((id (call-configuration-manager-method
+ "addAccount" (list `#(("Account.archivePath" . ,archive)+ ("Account.type" . "RING")))))) ;; The account information takes some time to be populated.
- (let ((id (deserialize-item (parse-dbus-reply reply))))
- (let ((username (id->username id)))
- (if (string-null? username)
+ (let ((username (id->username id)))
+ (if (and=> username (negate string-null?))
(define (remove-account username)
"Delete the Jami account associated with USERNAME, the account 40 characters
fingerprint or a registered username."
(let ((id (username->id username)))
- (send-dbus/configuration-manager
- #:method "removeAccount"
- #:arguments (list (string-append "string:" id))))
+ (call-configuration-manager-method "removeAccount" (list id)))
(invalidate-username-to-id-cache!))
(define* (username->contacts username)
@@ -430,15 +210,16 @@ (define* (username->contacts username)
fingerprint or a registered username. The contacts returned are represented
using their 40 characters fingerprint."
(let* ((id (username->id username))
- (reply (send-dbus/configuration-manager
- #:arguments (list (string-append "string:" id))))
- (all-contacts (parse-contacts reply))
+ ;; The contacts are returned as "aa{ss}", that is, an array of arrays+ ;; containing (string . string) pairs.
+ (contacts (map vector->list
+ (vector->list (call-configuration-manager-method
+ "getContacts" (list id)))))
(banned? (lambda (contact)
(and=> (assoc-ref contact "banned")
(cut string=? "true" <>))))
- (banned (filter banned? all-contacts))
- (not-banned (filter (negate banned?) all-contacts))
+ (banned (filter banned? contacts))
+ (not-banned (filter (negate banned?) contacts))
(fingerprint (cut assoc-ref <> "id")))
(values (map fingerprint not-banned)
(map fingerprint banned))))
@@ -449,27 +230,20 @@ (define* (remove-contact contact username #:key ban?)
username). When BAN? is true, also mark the contact as banned."
(validate-fingerprint contact)
(let ((id (username->id username)))
- (send-dbus/configuration-manager
- #:method "removeContact"
- #:arguments (list (string-append "string:" id)
- (string-append "string:" contact)
- (serialize-boolean ban?)))))
+ (call-configuration-manager-method "removeContact" (list id contact ban?))))
(define (add-contact contact username)
"Add CONTACT, the 40 characters public key fingerprint of a contact, to the
account of USERNAME (either a fingerprint or a registered username)."
(validate-fingerprint contact)
(let ((id (username->id username)))
- (send-dbus/configuration-manager
- #:arguments (list (string-append "string:" id)
- (string-append "string:" contact)))))
+ (call-configuration-manager-method "addContact" (list id contact))))
(define* (set-account-details details username #:key timeout)
"Set DETAILS, an alist containing the key value pairs to set for the account
of USERNAME, a registered username or account fingerprint. The value of the
parameters not provided are unchanged. TIMEOUT is a value in milliseconds to
-pass to the `send-dbus/configuration-manager' procedure."
+pass to the `call-configuration-manager-method' procedure."
(let* ((id (username->id username))
(current-details (id->account-details id))
(updated-details (map (match-lambda
@@ -477,52 +251,29 @@ (define* (set-account-details details username #:key timeout)
(or (and=> (assoc-ref details key)
- ;; dbus-send does not permit sending null strings (it throws a
- ;; "malformed dictionary" error). Luckily they seem to have the
- ;; semantic of "default account value" in Jami; so simply drop them.
- (updated-details* (remove (match-lambda
- (send-dbus/configuration-manager
- #:method "setAccountDetails"
- (list (string-append "string:" id)
- (string-append "dict:string:string:"
- (string-join (alist->list updated-details*)
+ (call-configuration-manager-method
+ "setAccountDetails" (list id (list->vector updated-details))
(define (set-all-moderators enabled? username)
"Set the 'AllModerators' property to enabled? for the account of USERNAME, a
registered username or account fingerprint."
(let ((id (username->id username)))
- (send-dbus/configuration-manager
- #:method "setAllModerators"
- (list (string-append "string:" id)
- (serialize-boolean enabled?)))))
+ (call-configuration-manager-method "setAllModerators" (list id enabled?))))
(define (username->all-moderators? username)
"Return the 'AllModerators' property for the account of USERNAME, a
registered username or account fingerprint."
- (let* ((id (username->id username))
- (reply (send-dbus/configuration-manager
- #:method "isAllModerators"
- (list (string-append "string:" id)))))
- (deserialize-item (parse-dbus-reply reply))))
+ (let ((id (username->id username)))
+ (call-configuration-manager-method "isAllModerators" (list id))))
(define (username->moderators username)
"Return the moderators for the account of USERNAME, a registered username or
- (let* ((id (username->id username))
- (reply (send-dbus/configuration-manager
- #:method "getDefaultModerators"
- (list (string-append "string:" id)))))
- (array->list (parse-dbus-reply reply))))
+ (let* ((id (username->id username)))
+ (vector->list (call-configuration-manager-method "getDefaultModerators"
(define (set-moderator contact enabled? username)
"Set the moderator flag to ENABLED? for CONTACT, the 40 characters public
@@ -530,11 +281,8 @@ (define (set-moderator contact enabled? username)
username or account fingerprint."
(validate-fingerprint contact)
(let* ((id (username->id username)))
- (send-dbus/configuration-manager #:method "setDefaultModerator"
- (list (string-append "string:" id)
- (string-append "string:" contact)
- (serialize-boolean enabled?)))))
+ (call-configuration-manager-method "setDefaultModerator"
+ (list id contact enabled?))))
(define (disable-account username)
"Disable the account known by USERNAME, a registered username or account
@@ -543,7 +291,7 @@ (define (disable-account username)
;; Waiting for the reply on this command takes a very
;; long time that trips the default D-Bus timeout value
;; (25 s), for some reason.
(define (enable-account username)
"Enable the account known by USERNAME, a registered username or account
@@ -581,7 +329,3 @@ (define sorted-account-details
(fold alist-delete account-details first-items))))
(string-join (map pair->recutil-property sorted-account-details) "\n"))
-;; eval: (put 'with-retries 'scheme-indent-function 2)
diff --git a/gnu/local.mk b/gnu/local.mk
index 93b4902151..7d5bef19c9 100644
@@ -716,6 +716,7 @@ GNU_SYSTEM_MODULES = \
%D%/build/bootloader.scm \
%D%/build/chromium-extension.scm \
%D%/build/cross-toolchain.scm \
+ %D%/build/dbus-service.scm \
%D%/build/jami-service.scm \
%D%/build/file-systems.scm \
diff --git a/gnu/packages/glib.scm b/gnu/packages/glib.scm
index 30e5433776..93526fa29f 100644
--- a/gnu/packages/glib.scm
+++ b/gnu/packages/glib.scm
;;; Copyright © 2017 Petter <petter@mykolab.ch>
;;; Copyright © 2018, 2019 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com>
-;;; Copyright © 2019, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2019, 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2019 Giacomo Leidi <goodoldpaul@autistici.org>
;;; Copyright © 2019, 2020, 2021 Marius Bakke <marius@gnu.org>
;;; Copyright © 2020 Nicolò Balzarotti <nicolo@nixo.xyz>
@@ -176,6 +176,23 @@ (define dbus
shared NFS home directories.")
(license license:gpl2+))) ; or Academic Free License 2.1
+;;; This variant is used for the Jami service: it provides an entry point to
+;;; further customize the configuration of the D-Bus instance run by the
+;;; jami-dbus-session service.
+(define-public dbus-for-jami
+ (substitute-keyword-arguments (package-arguments dbus)
+ `(modify-phases ,phases
+ (add-after 'unpack 'customize-config
+ (substitute* "bus/session.conf.in"
+ (("@SYSCONFDIR_FROM_PKGDATADIR@/dbus-1/session-local.conf")+ "/var/run/jami/session-local.conf")))))))))))
diff --git a/gnu/services/telephony.scm b/gnu/services/telephony.scm
index d8ebc7b39d..3b397054a8 100644
--- a/gnu/services/telephony.scm
+++ b/gnu/services/telephony.scm
@@ -26,6 +26,7 @@ (define-module (gnu services telephony)
#:use-module (gnu packages admin)
#:use-module (gnu packages certs)
#:use-module (gnu packages glib)
+ #:use-module (gnu packages guile-xyz)
#:use-module (gnu packages jami)
#:use-module (gnu packages telephony)
#:use-module (guix deprecation)
@@ -231,7 +232,7 @@ (define-configuration/no-serialization jami-configuration
"The Jami daemon package to use.")
+ (file-like dbus-for-jami)
"The D-Bus package to use to start the required D-Bus session.")
@@ -284,7 +285,20 @@ (define (jami-dbus-session-activation config)
(use-modules (gnu build activation))
(let ((user (getpwnam "jami")))
- (mkdir-p/perms "/var/run/jami" user #o700)))))
+ (mkdir-p/perms "/var/run/jami" user #o700)
+ ;; Customize the D-Bus policy to allow 'root' to access other users'
+ ;; session bus. Also modify the location of the written PID file,
+ ;; from the default '/var/run/dbus/pid' location. This file is only
+ ;; honored by the 'dbus-for-jami' package variant.
+ (call-with-output-file "/var/run/jami/session-local.conf"
+ <pidfile>/var/run/jami/pid</pidfile>
+ <policy context=\"mandatory\">
(define (jami-shepherd-services config)
"Return a <shepherd-service> running the Jami daemon."
@@ -292,26 +306,27 @@ (define (jami-shepherd-services config)
(nss-certs (jami-configuration-nss-certs config))
(dbus (jami-configuration-dbus config))
(dbus-daemon (file-append dbus "/bin/dbus-daemon"))
- (dbus-send (file-append dbus "/bin/dbus-send"))
(accounts (jami-configuration-accounts config))
(declarative-mode? (not (eq? 'disabled accounts))))
- (with-imported-modules (source-module-closure
- '((gnu build jami-service)
- (gnu system file-systems)))
- (define list-accounts-action
- (documentation "List the available Jami accounts. Return the account
+ (with-extensions (list guile-packrat ;used by guile-ac-d-bus
+ ;; Fibers is needed to provide the non-blocking
+ ;; variant of the 'sleep' procedure.
+ (with-imported-modules (source-module-closure
+ '((gnu build dbus-service)
+ (gnu build jami-service)
+ (gnu system file-systems)))
+ (define list-accounts-action
+ (documentation "List the available Jami accounts. Return the account
details alists keyed by their account username.")
- (parameterize ((%send-dbus-binary #$dbus-send)
- (%send-dbus-bus "unix:path=/var/run/jami/bus")
- (%send-dbus-user "jami")
- (%send-dbus-group "jami"))
;; Print the accounts summary or long listing, according to
(let* ((usernames (get-usernames))
@@ -341,39 +356,31 @@ (define disabled?
;; Return the account-details-list alist.
- (map cons usernames accounts)))))))
+ (map cons usernames accounts))))))
- (define list-account-details-action
- (name 'list-account-details)
- (documentation "Display the account details of the available Jami
+ (define list-account-details-action
+ (name 'list-account-details)
+ (documentation "Display the account details of the available Jami
accounts in the @code{recutils} format. Return the account details alists keyed by their account username.")
- (parameterize ((%send-dbus-binary #$dbus-send)
- (%send-dbus-bus "unix:path=/var/run/jami/bus")
- (%send-dbus-user "jami")
- (%send-dbus-group "jami"))
(let* ((usernames (get-usernames))
(accounts (map-in-order username->account usernames)))
(for-each (lambda (account)
(display (account-details->recutil account))
- (map cons usernames accounts)))))))
+ (map cons usernames accounts))))))
- (define list-contacts-action
- (documentation "Display the contacts for each Jami account. Return
+ (define list-contacts-action
+ (documentation "Display the contacts for each Jami account. Return
an alist containing the contacts keyed by the account usernames.")
- (parameterize ((%send-dbus-binary #$dbus-send)
- (%send-dbus-bus "unix:path=/var/run/jami/bus")
- (%send-dbus-user "jami")
- (%send-dbus-group "jami"))
(let* ((usernames (get-usernames))
(contacts (map-in-order username->contacts usernames)))
(for-each (lambda (username contacts)
@@ -381,19 +388,15 @@ (define list-contacts-action
(format #t "~{ - ~a~%~}~%" contacts))- (map cons usernames contacts)))))))
+ (map cons usernames contacts))))))
- (define list-moderators-action
- (name 'list-moderators)
- (documentation "Display the moderators for each Jami account. Return
+ (define list-moderators-action
+ (name 'list-moderators)
+ (documentation "Display the moderators for each Jami account. Return
an alist containing the moderators keyed by the account usernames.")
- (parameterize ((%send-dbus-binary #$dbus-send)
- (%send-dbus-bus "unix:path=/var/run/jami/bus")
- (%send-dbus-user "jami")
- (%send-dbus-group "jami"))
(let* ((usernames (get-usernames))
(moderators (map-in-order username->moderators
@@ -406,12 +409,12 @@ (define list-moderators-action
(format #t "Moderators for account ~a:~%" username)
(format #t "~{ - ~a~%~}~%" moderators))))- (map cons usernames moderators)))))))
+ (map cons usernames moderators))))))
- (define add-moderator-action
- (documentation "Add a moderator for a given Jami account. The
+ (define add-moderator-action
+ (documentation "Add a moderator for a given Jami account. The
MODERATOR contact must be given as its 40 characters fingerprint, while the
Jami account can be provided as its registered USERNAME or fingerprint.
@@ -420,21 +423,17 @@ (define add-moderator-action
Return the moderators for the account known by USERNAME.")
- #~(lambda (_ moderator username)
- (parameterize ((%send-dbus-binary #$dbus-send)
- (%send-dbus-bus "unix:path=/var/run/jami/bus")
- (%send-dbus-user "jami")
- (%send-dbus-group "jami"))
+ #~(lambda (_ moderator username)
(set-all-moderators #f username)
(add-contact moderator username)
(set-moderator moderator #t username)
- (username->moderators username))))))
+ (username->moderators username)))))
- (define ban-contact-action
- (documentation "Ban a contact for a given or all Jami accounts, and
+ (define ban-contact-action
+ (documentation "Ban a contact for a given or all Jami accounts, and
clear their moderator flag. The CONTACT must be given as its 40 characters
fingerprint, while the Jami account can be provided as its registered USERNAME
or fingerprint, or omitted. When the account is omitted, CONTACT is banned
@@ -443,31 +442,22 @@ (define ban-contact-action
herd ban-contact jami 1dbcb0f5f37324228235564b79f2b9737e9a008f [username]
- #~(lambda* (_ contact #:optional username)
- (parameterize ((%send-dbus-binary #$dbus-send)
- (%send-dbus-bus "unix:path=/var/run/jami/bus")
- (%send-dbus-user "jami")
- (%send-dbus-group "jami"))
+ #~(lambda* (_ contact #:optional username)
(let ((usernames (or (and=> username list)
(for-each (lambda (username)
(set-moderator contact #f username)
(remove-contact contact username #:ban? #t))
- (define list-banned-contacts-action
- (name 'list-banned-contacts)
- (documentation "List the banned contacts for each accounts. Return
+ (define list-banned-contacts-action
+ (name 'list-banned-contacts)
+ (documentation "List the banned contacts for each accounts. Return
an alist of the banned contacts, keyed by the account usernames.")
- (parameterize ((%send-dbus-binary #$dbus-send)
- (%send-dbus-bus "unix:path=/var/run/jami/bus")
- (%send-dbus-user "jami")
- (%send-dbus-group "jami"))
(let ((usernames (get-usernames)))
@@ -484,183 +474,157 @@ (define banned-contacts
(format #t "~{ - ~a~%~}~%" banned))))- (define enable-account-action
- (documentation "Enable an account. It takes USERNAME as an argument,
+ (define enable-account-action
+ (documentation "Enable an account. It takes USERNAME as an argument,
either a registered username or the fingerprint of the account.")
- (parameterize ((%send-dbus-binary #$dbus-send)
- (%send-dbus-bus "unix:path=/var/run/jami/bus")
- (%send-dbus-user "jami")
- (%send-dbus-group "jami"))
- (enable-account username))))))
- (define disable-account-action
- (name 'disable-account)
- (documentation "Disable an account. It takes USERNAME as an
+ (enable-account username)))))
+ (define disable-account-action
+ (name 'disable-account)
+ (documentation "Disable an account. It takes USERNAME as an
argument, either a registered username or the fingerprint of the account.")
- (parameterize ((%send-dbus-binary #$dbus-send)
- (%send-dbus-bus "unix:path=/var/run/jami/bus")
- (%send-dbus-user "jami")
- (%send-dbus-group "jami"))
- (disable-account username))))))
- (list (shepherd-service
- (documentation "Run a D-Bus session for the Jami daemon.")
- (provision '(jami-dbus-session))
- (modules `((gnu build shepherd)
- (gnu build jami-service)
- (gnu system file-systems)
- ;; 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))
- ((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
- (source "/var/run/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="
- ;; 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
- (stop #~(make-kill-destructor)))
- (documentation "Run the Jami daemon.")
- (actions (list list-accounts-action
- list-account-details-action
- list-banned-contacts-action
- disable-account-action))
- (requirement '(jami-dbus-session))
- (modules `((ice-9 format)
- (gnu build jami-service)
- (gnu system file-systems)
- (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"
- (delete-file-recursively file))))
- (when #$declarative-mode?
- ;; Clear the Jami configuration and accounts, to enforce the
- (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")))
- ;; Copy the Jami account archives 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)))
- (chown accounts-dir user group)
- (let ((dest (string-append accounts-dir
- (chown dest user group)))
- '#$(and declarative-mode?
- (map jami-account-archive accounts)))))
- ((make-forkexec-constructor/container
- '#$(jami-configuration->command-line-arguments config)
- (list (file-system-mapping
- (source "/dev/log") ;for syslog
- (source "/var/lib/jami")
- (source "/var/run/jami")
- ;; Expose TLS certificates for GnuTLS.
- (source #$(file-append nss-certs "/etc/ssl/certs"))
- (target "/etc/ssl/certs")))
- #:environment-variables
- (list (string-append "DBUS_SESSION_BUS_ADDRESS="
- "unix:path=/var/run/jami/bus")
- ;; Expose TLS certificates for OpenSSL.
- "SSL_CERT_DIR=/etc/ssl/certs"))))
- (parameterize ((%send-dbus-binary #$dbus-send)
- (%send-dbus-bus "unix:path=/var/run/jami/bus")
- (%send-dbus-user "jami")
- (%send-dbus-group "jami"))
+ (disable-account username)))))
+ (list (shepherd-service
+ (documentation "Run a D-Bus session for the Jami daemon.")
+ (provision '(jami-dbus-session))
+ (modules `((gnu build shepherd)
+ (gnu build dbus-service)
+ (gnu build jami-service)
+ (gnu system file-systems)
+ ;; 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))
+ #~(make-forkexec-constructor/container
+ (list #$dbus-daemon "--session"
+ "--address=unix:path=/var/run/jami/bus"
+ #:pid-file "/var/run/jami/pid"
+ (list (file-system-mapping
+ (source "/dev/log") ;for syslog
+ (source "/var/run/jami")
+ #:environment-variables
+ ;; This is so that the cx.ring.Ring service D-Bus
+ ;; definition is found by dbus-daemon.
+ (list (string-append "XDG_DATA_DIRS=" #$jamid "/share"))))
+ (stop #~(make-kill-destructor)))
+ (documentation "Run the Jami daemon.")
+ (actions (list list-accounts-action
+ list-account-details-action
+ list-banned-contacts-action
+ disable-account-action))
+ (requirement '(jami-dbus-session))
+ (modules `((ice-9 format)
+ (gnu build dbus-service)
+ (gnu build jami-service)
+ (gnu system file-systems)
+ (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"
+ (delete-file-recursively file))))
+ (when #$declarative-mode?
+ ;; Clear the Jami configuration and accounts, to enforce the
+ (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")))
+ ;; Copy the Jami account archives 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)))
+ (chown accounts-dir user group)
+ (let ((dest (string-append accounts-dir
+ (chown dest user group)))
+ '#$(and declarative-mode?
+ (map jami-account-archive accounts)))))
+ ((make-forkexec-constructor/container
+ '#$(jami-configuration->command-line-arguments config)
+ (list (file-system-mapping
+ (source "/dev/log") ;for syslog
+ (source "/var/lib/jami")
+ (source "/var/run/jami")
+ ;; Expose TLS certificates for GnuTLS.
+ (source #$(file-append nss-certs "/etc/ssl/certs"))
+ (target "/etc/ssl/certs")))
+ #:environment-variables
+ (list (string-append "DBUS_SESSION_BUS_ADDRESS="
+ "unix:path=/var/run/jami/bus")
+ ;; Expose TLS certificates for OpenSSL.
+ "SSL_CERT_DIR=/etc/ssl/certs"))))
+ (setenv "DBUS_SESSION_BUS_ADDRESS"
+ "unix:path=/var/run/jami/bus")
;; Wait until the service name has been acquired by D-Bus.
- (dbus-service-available? "cx.ring.Ring"))
+ (with-retries 20 1 (jami-service-available?))
(when #$declarative-mode?
;; Provision the accounts via the D-Bus API of the daemon.
@@ -717,17 +681,17 @@ (define (archive-name->username archive)
(map-in-order (cut jami-account-moderators <>)
'#$(and declarative-mode?
- (map-in-order jami-account->alist accounts))))))
- ;; Finally, return the PID of the daemon process.
- ;; Wait for the process to exit; this prevents overlapping
- ;; processes when issuing 'herd restart'.
+ (map-in-order jami-account->alist accounts)))))
+ ;; Finally, return the PID of the daemon process.
+ ;; Wait for the process to exit; this prevents overlapping
+ ;; processes when issuing 'herd restart'.
(define jami-service-type
diff --git a/gnu/tests/telephony.scm b/gnu/tests/telephony.scm
index bc464a431a..16ee313f69 100644
--- a/gnu/tests/telephony.scm
+++ b/gnu/tests/telephony.scm
@@ -20,6 +20,7 @@ (define-module (gnu tests telephony)
#:use-module (gnu packages)
#:use-module (gnu packages guile)
+ #:use-module (gnu packages guile-xyz)
#:use-module (gnu system vm)
#:use-module (gnu services)
@@ -125,221 +126,204 @@ (define username (assoc-ref %jami-account-content-sexp
- (with-imported-modules (source-module-closure
- '((gnu build marionette)
- (gnu build jami-service)))
- (use-modules (rnrs base)
- (gnu build jami-service))
- (make-marionette (list #$vm)))
- (test-runner-current (system-test-runner #$output))
- (test-assert "service is running"
- (use-modules (gnu services herd))
- (match (start-service 'jami)
- (('service response-parts ...)- (match (assq-ref response-parts 'running)
- ((pid) (number? pid))))))
- (test-assert "service can be stopped"
- (use-modules (gnu services herd)
- (setenv "PATH" "/run/current-system/profile/bin")
- (let ((pid (match (start-service 'jami)
- (('service response-parts ...)- (match (assq-ref response-parts 'running)
- (match (stop-service 'jami)
- (services ;a list of service symbols
- (member 'jami services)))
- ;; Sometimes, the process still appear in pgrep, even
- ;; though we are using waitpid after sending it SIGTERM
- ;; in the service; use retries.
+ (with-extensions (list guile-packrat ;used by guile-ac-d-bus
+ ;; Fibers is needed to provide the non-blocking
+ ;; variant of the 'sleep' procedure.
+ (with-imported-modules (source-module-closure
+ '((gnu build marionette)
+ (gnu build dbus-service)
+ (gnu build jami-service)))
+ (use-modules (rnrs base)
+ (gnu build dbus-service)
+ (gnu build jami-service))
+ (setenv "DBUS_SESSION_BUS_ADDRESS" "unix:path=/var/run/jami/bus")
+ (make-marionette (list #$vm)))
+ (test-runner-current (system-test-runner #$output))
+ (test-assert "service is running"
+ (use-modules (gnu build jami-service))
+ (jami-service-available?))
+ (test-assert "service can be stopped"
+ (use-modules (gnu build jami-service)
+ (assert (jami-service-available?))
+ (with-retries 20 1 (not (jami-service-available?))))
+ (test-assert "service can be restarted"
+ (use-modules (gnu build dbus-service)
+ (gnu build jami-service)
+ (with-retries 20 1 (jami-service-available?))
+ ;; Restart the service.
+ (restart-service 'jami)
+ (with-retries 20 1 (jami-service-available?)))
+ (unless #$provisioning? (test-skip 1))
+ (test-assert "jami accounts provisioning, account present"
+ (use-modules (gnu build dbus-service)
+ ;; Accounts take some time to appear after being added.
- (not (zero? (status:exit-val
- (system* "pgrep" "jamid")))))))
- (test-assert "service can be restarted"
- (use-modules (gnu services herd)
- ;; Start and retrieve the current PID.
- (define pid (match (start-service 'jami)
- (('service response-parts ...)- (match (assq-ref response-parts 'running)
- ;; Restart the service.
- (restart-service 'jami)
- (define new-pid (match (start-service 'jami)
- (('service response-parts ...)- (match (assq-ref response-parts 'running)
- (assert (number? new-pid))
- (not (eq? pid new-pid)))
- (unless #$provisioning? (test-skip 1))
- (test-assert "jami accounts provisioning, account present"
- (use-modules (gnu services herd)
- ;; Accounts take some time to appear after being added.
- (with-shepherd-action 'jami ('list-accounts) results+ (with-shepherd-action 'jami ('list-accounts) results+ (let ((account (assoc-ref (car results) #$username)))
+ (assert (string=? #$username
+ "Account.username")))))))
+ (unless #$provisioning? (test-skip 1))
+ (test-assert "jami accounts provisioning, allowed-contacts"
+ (use-modules (gnu services herd)
+ ;; Public mode is disabled.
+ (with-shepherd-action 'jami ('list-account-details) (let ((account (assoc-ref (car results) #$username)))
- (assert (string=? #$username
+ (assert (string=? "false"
- "Account.username")))))))
- (unless #$provisioning? (test-skip 1))
- (test-assert "jami accounts provisioning, allowed-contacts"
- (use-modules (gnu services herd)
- ;; Public mode is disabled.
- (with-shepherd-action 'jami ('list-account-details)- (let ((account (assoc-ref (car results) #$username)))
- (assert (string=? "false"
- "DHT.PublicInCalls")))))
- ;; Allowed contacts match those declared in the configuration.
- (with-shepherd-action 'jami ('list-contacts) results- (let ((contacts (assoc-ref (car results) #$username)))
- (assert (lset= string-ci=? contacts '#$%allowed-contacts)))))
- (unless #$provisioning? (test-skip 1))
- (test-assert "jami accounts provisioning, moderators"
- (use-modules (gnu services herd)
- ;; Moderators match those declared in the configuration.
- (with-shepherd-action 'jami ('list-moderators) results- (let ((moderators (assoc-ref (car results) #$username)))
- (assert (lset= string-ci=? moderators '#$%moderators))))
- ;; Moderators can be added via the Shepherd action.
- (with-shepherd-action 'jami
- ('add-moderator "cccccccccccccccccccccccccccccccccccccccc"- (let ((moderators (car results)))
- (assert (lset= string-ci=? moderators
- (cons "cccccccccccccccccccccccccccccccccccccccc"
- (unless #$provisioning? (test-skip 1))
- (test-assert "jami service actions, ban/unban contacts"
- (use-modules (gnu services herd)
- ;; Globally ban a contact.
- (with-shepherd-action 'jami
- ('ban-contact "1dbcb0f5f37324228235564b79f2b9737e9a008f") _- (with-shepherd-action 'jami ('list-banned-contacts) results- ((username . banned-contacts)
- (member "1dbcb0f5f37324228235564b79f2b9737e9a008f"
- ;; Ban a contact for a single account.
- (with-shepherd-action 'jami
- ('ban-contact "dddddddddddddddddddddddddddddddddddddddd"- (with-shepherd-action 'jami ('list-banned-contacts) results- ((username . banned-contacts)
- (let ((found? (member "dddddddddddddddddddddddddddddddddddddddd"
- (if (string=? #$username username)
- (unless #$provisioning? (test-skip 1))
- (test-assert "jami service actions, enable/disable accounts"
- (use-modules (gnu services herd)
- (with-shepherd-action 'jami
- ('disable-account #$username) _- (with-shepherd-action 'jami ('list-accounts) results- (let ((account (assoc-ref (car results) #$username)))
- (assert (string= "false"
- (assoc-ref account "Account.enable"))))))
- (with-shepherd-action 'jami
- ('enable-account #$username) _- (with-shepherd-action 'jami ('list-accounts) results- (let ((account (assoc-ref (car results) #$username)))
- (assert (string= "true"
- (assoc-ref account "Account.enable")))))))
- (unless #$provisioning? (test-skip 1))
- (test-assert "jami account parameters"
- (use-modules (gnu services herd)
- (with-shepherd-action 'jami ('list-account-details) results- (let ((account-details (assoc-ref (car results)
- '(("Account.hostname" .- "bootstrap.me;fallback.another.host")
- ("Account.peerDiscovery" . "false")- ("Account.rendezVous" . "true")- ("RingNS.uri" . "https://my.name.server"))+ "DHT.PublicInCalls")))))
+ ;; Allowed contacts match those declared in the configuration.
+ (with-shepherd-action 'jami ('list-contacts) results+ (let ((contacts (assoc-ref (car results) #$username)))
+ (assert (lset= string-ci=? contacts '#$%allowed-contacts)))))
+ (unless #$provisioning? (test-skip 1))
+ (test-assert "jami accounts provisioning, moderators"
+ (use-modules (gnu services herd)
+ ;; Moderators match those declared in the configuration.
+ (with-shepherd-action 'jami ('list-moderators) results+ (let ((moderators (assoc-ref (car results) #$username)))
+ (assert (lset= string-ci=? moderators '#$%moderators))))
+ ;; Moderators can be added via the Shepherd action.
+ (with-shepherd-action 'jami
+ ('add-moderator "cccccccccccccccccccccccccccccccccccccccc"+ (let ((moderators (car results)))
+ (assert (lset= string-ci=? moderators
+ (cons "cccccccccccccccccccccccccccccccccccccccc"
+ (unless #$provisioning? (test-skip 1))
+ (test-assert "jami service actions, ban/unban contacts"
+ (use-modules (gnu services herd)
+ ;; Globally ban a contact.
+ (with-shepherd-action 'jami
+ ('ban-contact "1dbcb0f5f37324228235564b79f2b9737e9a008f") _+ (with-shepherd-action 'jami ('list-banned-contacts) results+ ((username . banned-contacts)
+ (member "1dbcb0f5f37324228235564b79f2b9737e9a008f"
+ ;; Ban a contact for a single account.
+ (with-shepherd-action 'jami
+ ('ban-contact "dddddddddddddddddddddddddddddddddddddddd"+ (with-shepherd-action 'jami ('list-banned-contacts) results+ ((username . banned-contacts)
+ (let ((found? (member "dddddddddddddddddddddddddddddddddddddddd"
+ (if (string=? #$username username)
+ (unless #$provisioning? (test-skip 1))
+ (test-assert "jami service actions, enable/disable accounts"
+ (use-modules (gnu services herd)
+ (with-shepherd-action 'jami
+ ('disable-account #$username) _+ (with-shepherd-action 'jami ('list-accounts) results+ (let ((account (assoc-ref (car results) #$username)))
+ (assert (string= "false"
+ (assoc-ref account "Account.enable"))))))
+ (with-shepherd-action 'jami
+ ('enable-account #$username) _+ (with-shepherd-action 'jami ('list-accounts) results+ (let ((account (assoc-ref (car results) #$username)))
+ (assert (string= "true"
+ (assoc-ref account "Account.enable")))))))
+ (unless #$provisioning? (test-skip 1))
+ (test-assert "jami account parameters"
+ (use-modules (gnu services herd)
+ (with-shepherd-action 'jami ('list-account-details) results+ (let ((account-details (assoc-ref (car results)
+ '(("Account.hostname" .+ "bootstrap.me;fallback.another.host")
+ ("Account.peerDiscovery" . "false")+ ("Account.rendezVous" . "true")+ ("RingNS.uri" . "https://my.name.server")) (gexp->derivation (if provisioning?
@@ -357,7 +341,3 @@ (define %test-jami-provisioning
(name "jami-provisioning")
(description "Provisioning test for the jami service.")
(value (run-jami-test #:provisioning? #t))))
-;; eval: (put 'with-retries 'scheme-indent-function 2)
