guix/gnu/build/dbus-service.scm

214 lines
8.6 KiB
Scheme
Raw Normal View History

services: jami: Modernize to adjust to Shepherd 0.9+ changes. This partially fixes <https://issues.guix.gnu.org/54786>, allowing the 'jami' 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'.
2022-05-30 03:46:35 +00:00
;;; 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?
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*
(lambda () ;delay execution
(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: