and 'jami-provisioning' system tests to pass again.
In version 0.9.0, Shepherd constructors are now run concurrently, via
cooperative scheduling (Guile Fibers). The Jami service previously relied on
blocking sleeps while polling for D-Bus services to become ready after forking
a process; this wouldn't work anymore since while blocking the service process
wouldn't be given the chance to finish starting. The new reliance on Fibers
in Shepherd's fork+exec-command in the helper 'send-dbus' procedure also meant
that it wouldn't work outside of Shepherd anymore. Finally, the
'start-service' Shepherd procedure used in the test suite would cause the Jami
daemon to be spawned multiple times (a bug introduced in Shepherd 0.9.0).
To fix/simplify these problems, this change does the following:
1. Use the Guile AC/D-Bus library for D-Bus communication, which simplify
things, such as avoiding the need to fork 'dbus-send' processes.
2. The non-blocking 'sleep' version of Fiber is used for the 'with-retries'
waiting syntax.
3. A 'dbus' package variant is used to adjust the session bus configuration,
tailoring it for the use case at hand.
4. Avoid start-service in the tests, preferring 'jami-service-available?' for
now.
* gnu/build/jami-service.scm (parse-dbus-reply, strip-quotes)
(deserialize-item, serialize-boolean, dbus-dict->alist)
(dbus-array->list, parse-account-ids, parse-account-details)
(parse-contacts): Delete procedures.
(%send-dbus-binary, %send-dbus-bus, %send-dbus-user, %send-dbus-group)
(%send-dbus-debug): Delete parameters.
(jami-service-running?): New procedure.
(send-dbus/configuration-manager): Rename to...
(call-configuration-manager-method): ... this. Turn METHOD into a positional
argument. Turn ARGUMENTS into an optional argument. Invoke
`call-dbus-method' instead of `send-dbus', adjusting callers accordingly.
(get-account-ids, id->account-details, id->account-details)
(id->volatile-account-details, username->id, add-account remove-account)
(username->contacts, remove-contact, add-contact, set-account-details)
(set-all-moderators, username->all-moderators?, username->moderators)
(set-moderator): Adjust accordingly.
(with-retries, send-dbus, dbus-available-services)
(dbus-service-available?): Move to ...
* gnu/build/dbus-service.scm: ... this new module.
(send-dbus): Rewrite to use the Guile AC/D-Bus library.
(%dbus-query-timeout, sleep*): New variables.
(%current-dbus-connection): New parameter.
(initialize-dbus-connection!, argument->signature-type)
(call-dbus-method): New procedures.
(dbus-available-services): Adjust accordingly.
* gnu/local.mk (GNU_SYSTEM_MODULES): Register new module.
* gnu/packages/glib.scm (dbus-for-jami): New variable.
* gnu/services/telephony.scm: (jami-configuration)[dbus]: Default to
dbus-for-jami.
(jami-dbus-session-activation): Write a D-Bus daemon configuration file at
'/var/run/jami/session-local.conf'.
(jami-shepherd-services): Add the closure of guile-ac-d-bus and guile-fibers
as extensions. Adjust imported modules. Remove no longer used parameters.
<jami-dbus-session>: Use a PID file, avoiding the need for the manual
synchronization.
<jami>: Set DBUS_SESSION_BUS_ADDRESS environment variable. Poll using
'jami-service-available?' instead of 'dbus-service-available?'.
* gnu/tests/telephony.scm (run-jami-test): Add needed Guile extensions. Set
DBUS_SESSION_BUS_ADDRESS environment variable. Adjust all tests to use
'jami-service-available?' to determine if the service is started rather than
the now problematic Shepherd's 'start-service'.
---
gnu/build/dbus-service.scm | 212 ++++++++++++++++
gnu/build/jami-service.scm | 390 +++++------------------------
gnu/local.mk | 1 +
gnu/packages/glib.scm | 19 +-
gnu/services/telephony.scm | 500 +++++++++++++++++--------------------
gnu/tests/telephony.scm | 412 +++++++++++++++---------------
6 files changed, 726 insertions(+), 808 deletions(-)
create mode 100644 gnu/build/dbus-service.scm
Toggle diff (414 lines)
diff --git a/gnu/build/dbus-service.scm b/gnu/build/dbus-service.scm
new file mode 100644
index 0000000000..d3d8c9f716
--- /dev/null
+++ b/gnu/build/dbus-service.scm
@@ -0,0 +1,212 @@
+;;; 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/>.
+
+;;; Commentary:
+;;;
+;;; This module contains procedures to interact with D-Bus via the 'dbus-send'
+;;; command line utility. Before using any public procedure
+;;;
+;;; Code:
+
+(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-conn-flush
+ d-bus-connect
+ d-bus-disconnect
+ d-bus-session-bus-address
+ d-bus-system-bus-address)
+ #:autoload (d-bus protocol messages) (MESSAGE_TYPE_METHOD_CALL
+ d-bus-headers-ref
+ d-bus-message-body
+ d-bus-message-headers
+ d-bus-read-message
+ d-bus-write-message
+ header-PATH
+ header-DESTINATION
+ header-INTERFACE
+ header-MEMBER
+ header-SIGNATURE
+ make-d-bus-message)
+ #:export (%dbus-query-timeout
+
+ initialize-dbus-connection!
+ %current-dbus-connection
+ send-dbus
+ call-dbus-method
+
+ dbus-available-services
+ dbus-service-available?
+
+ sleep*
+ with-retries))
+
+(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)
+ (begin
+ (format #f "fibers not available -- blocking 'sleep' in use")
+ sleep)))
+
+;;;
+;;; Utilities.
+;;;
+
+(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
+each retry."
+ (let loop ((attempts 0))
+ (catch #t
+ (lambda ()
+ (let ((result (begin body ...)))
+ (if (not result)
+ (error "failed attempt" attempts)
+ result)))
+ (lambda args
+ (if (< attempts n)
+ (begin
+ (sleep* delay) ;else wait and retry
+ (loop (+ 1 attempts)))
+ (error "maximum number of retry attempts reached"
+ body ... args))))))
+
+
+;;;
+;;; 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))
+ timeout)
+ "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)
+ (let retry ()
+ (when (> (time-second (time-difference (current-time time-monotonic)
+ start-time))
+ timeout*)
+ (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.
+ (when error-name
+ (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))
+ (match body
+ ((x x* ..1) ;contains 2 ore more elements
+ body)
+ ((x)
+ x) ;single element; return it directly
+ (#f #f))
+ (retry))))))
+
+(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).
+ (match argument
+ ((? boolean?) "b")
+ ((? string?) "s")
+ (#((? string?) (? string?) ...) "as")
+ (#(((? string?) . (? string?))
+ ((? string?) . (? string?)) ...) "a{ss}")
+ (_ (error 'dbus "no rule to infer type from argument" argument))))
+
+(define* (call-dbus-method method
+ #:key
+ (path "/org/freedesktop/DBus")
+ (destination "org.freedesktop.DBus")
+ (interface "org.freedesktop.DBus")
+ (connection (%current-dbus-connection))
+ arguments
+ timeout)
+ "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
+reply."
+ (let ((message (make-d-bus-message
+ MESSAGE_TYPE_METHOD_CALL 0 #f '()
+ `#(,(header-PATH path)
+ ,(header-DESTINATION destination)
+ ,(header-INTERFACE interface)
+ ,(header-MEMBER method)
+ ,@(if arguments
+ (list (header-SIGNATURE
+ (string-join
+ (map argument->signature-type arguments)
+ "")))
+ '()))
+ 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)))
+
+;; Local Variables:
+;; eval: (put 'with-retries 'scheme-indent-function 2)
+;; End:
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
@@ -1,5 +1,5 @@
;;; 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.
;;;
@@ -24,16 +24,16 @@
;;; Code:
(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?
+
+ account-fingerprint?
account-details->recutil
get-accounts
get-usernames
@@ -51,43 +51,12 @@ (define-module (gnu build jami-service)
set-all-moderators
set-moderator
username->all-moderators?
- username->moderators
-
- dbus-available-services
- dbus-service-available?
-
- %send-dbus-binary
- %send-dbus-bus
- %send-dbus-user
- %send-dbus-group
- %send-dbus-debug
- send-dbus
-
- with-retries))
+ username->moderators))
;;;
;;; Utilities.
;;;
-(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 each retry."
- (let loop ((attempts 0))
- (catch #t
- (lambda ()
- (let ((result (begin body ...)))
- (if (not result)
- (error "failed attempt" attempts)
- result)))
- (lambda args
- (if (< attempts n)
- (begin
- (sleep delay) ;else wait and retry
- (loop (+ 1 attempts)))
- (error "maximum number of retry attempts reached"
- body ... args))))))
-
(define (alist->list alist)
"Flatten ALIST into a list."
(append-map (match-lambda
@@ -104,212 +73,34 @@ (define (account-fingerprint? val)
(and (string? val)
(regexp-exec account-fingerprint-rx val)))
-
-;;;
-;;; D-Bus reply parser.
-;;;
-
-(define (parse-dbus-reply reply)
- "Return the parse tree of REPLY, a string returned by the 'dbus-send'
-command."
- ;; 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'
- value <-- (!NL .)* NL
- header < (!NL .)* NL
- variant-start < WS 'variant'
- array-start < WS 'array [' NL
- array-end < WS ']' NL
- dict-entry-start < WS 'dict entry(' NL
- dict-entry-end < WS ')' NL
- DQ < '\"'
- WS < ' '*
- NL < '\n'*")
-
- (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)
- (string-drop text 1)
- text))
- (text** (if (string-suffix? "\"" text*)
- (string-drop-right text* 1)
- text*)))
- text**))
-
-(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).
- (match item
- (('item ('type "string") ('value value))
- (strip-quotes value))
- (('item ('type "boolean") ('value value))
- (if (string=? "true" value)
- #t
- #f))
- (('item _ ('value 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))
-
- (match dict-parse-tree
- ('dict
- '())
- (('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
- ('array
- '())
- (('array items ...)
- (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
- bus
- dbus-send
- user group
- timeout
- arguments)
- "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
