mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
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'.
This commit is contained in:
parent
b8edfdb008
commit
85b4dabd94
7 changed files with 698 additions and 779 deletions
|
@ -25546,7 +25546,7 @@ Available @code{jami-configuration} fields are:
|
|||
@item @code{jamid} (default: @code{libjami}) (type: package)
|
||||
The Jami daemon package to use.
|
||||
|
||||
@item @code{dbus} (default: @code{dbus}) (type: package)
|
||||
@item @code{dbus} (default: @code{dbus-for-jami}) (type: package)
|
||||
The D-Bus package to use to start the required D-Bus session.
|
||||
|
||||
@item @code{nss-certs} (default: @code{nss-certs}) (type: package)
|
||||
|
|
213
gnu/build/dbus-service.scm
Normal file
213
gnu/build/dbus-service.scm
Normal file
|
@ -0,0 +1,213 @@
|
|||
;;; 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:
|
|
@ -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,210 +73,32 @@ (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.
|
||||
;;;
|
||||
|
||||
;;; 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 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
|
||||
can be used instead."
|
||||
(let* ((command `(,(if dbus-send
|
||||
dbus-send
|
||||
(%send-dbus-binary))
|
||||
,@(if (or bus (%send-dbus-bus))
|
||||
(list (string-append "--bus="
|
||||
(or bus (%send-dbus-bus))))
|
||||
'())
|
||||
"--print-reply"
|
||||
,@(if timeout
|
||||
(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)
|
||||
,@(or arguments '())))
|
||||
(temp-port (mkstemp! (string-copy "/tmp/dbus-send-output-XXXXXXX")))
|
||||
(temp-file (port-filename temp-port)))
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(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)))
|
||||
(lambda ()
|
||||
(let ((pid (fork+exec-command command
|
||||
#:user (or user (%send-dbus-user))
|
||||
#:group (or group (%send-dbus-group))
|
||||
#:log-file temp-file)))
|
||||
(match (waitpid pid)
|
||||
((_ . status)
|
||||
(let ((exit-status (status:exit-val status))
|
||||
(output (call-with-port temp-port get-string-all)))
|
||||
(if (= 0 exit-status)
|
||||
output
|
||||
(error "the send-dbus command exited with: "
|
||||
command exit-status output)))))))
|
||||
(lambda ()
|
||||
(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)
|
||||
('array
|
||||
'())
|
||||
(('array dicts ...)
|
||||
(map dict->alist dicts))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Higher-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)))
|
||||
|
||||
(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? ":" <>)
|
||||
(array->list reply))))
|
||||
(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"))
|
||||
|
||||
(define (dbus-service-available? service)
|
||||
"Predicate to check for the D-Bus SERVICE availability."
|
||||
(member service (dbus-available-services)))
|
||||
|
||||
;;;
|
||||
;;; Bindings for the Jami D-Bus API.
|
||||
;;;
|
||||
|
||||
(define* (send-dbus/configuration-manager #:key method arguments timeout)
|
||||
"Query the Jami D-Bus ConfigurationManager service."
|
||||
(send-dbus #:service "cx.ring.Ring"
|
||||
(define* (call-configuration-manager-method method #:optional arguments
|
||||
#:key timeout)
|
||||
"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"
|
||||
#:method method
|
||||
#:arguments arguments
|
||||
#:timeout timeout))
|
||||
|
||||
|
@ -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."
|
||||
(parse-account-ids
|
||||
(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."
|
||||
(parse-account-details
|
||||
(send-dbus/configuration-manager
|
||||
#:method "getAccountDetails"
|
||||
#:arguments (list (string-append "string:" id)))))
|
||||
(vector->list (call-configuration-manager-method "getAccountDetails"
|
||||
(list id))))
|
||||
|
||||
(define (id->volatile-account-details id)
|
||||
"Retrieve the account data associated with the given account ID."
|
||||
(parse-account-details
|
||||
(send-dbus/configuration-manager
|
||||
#:method "getVolatileAccountDetails"
|
||||
#:arguments (list (string-append "string:" id)))))
|
||||
(vector->list (call-configuration-manager-method "getVolatileAccountDetails"
|
||||
(list id))))
|
||||
|
||||
(define (id->account id)
|
||||
"Retrieve the complete account data associated with the given account ID."
|
||||
|
@ -362,8 +148,8 @@ (define (username->id username)
|
|||
'()))))
|
||||
(get-account-ids))))
|
||||
(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
|
||||
with the account."
|
||||
(invalidate-username-to-id-cache!)
|
||||
(let ((reply (send-dbus/configuration-manager
|
||||
#:method "addAccount"
|
||||
#:arguments (list (string-append
|
||||
"dict:string:string:Account.archivePath,"
|
||||
archive
|
||||
",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))))
|
||||
(with-retries 20 1
|
||||
(let ((username (id->username id)))
|
||||
(if (string-null? username)
|
||||
#f
|
||||
username))))))
|
||||
(if (and=> username (negate string-null?))
|
||||
username
|
||||
#f)))))
|
||||
|
||||
(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
|
||||
#:method "getContacts"
|
||||
#: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
|
||||
#:method "addContact"
|
||||
#: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)
|
||||
(cut cons key <>))
|
||||
(cons key value))))
|
||||
current-details))
|
||||
;; 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
|
||||
((_ . value)
|
||||
(string-null? value)))
|
||||
updated-details)))
|
||||
(send-dbus/configuration-manager
|
||||
#:timeout timeout
|
||||
#:method "setAccountDetails"
|
||||
#:arguments
|
||||
(list (string-append "string:" id)
|
||||
(string-append "dict:string:string:"
|
||||
(string-join (alist->list updated-details*)
|
||||
","))))))
|
||||
current-details)))
|
||||
(call-configuration-manager-method
|
||||
"setAccountDetails" (list id (list->vector updated-details))
|
||||
#:timeout timeout)))
|
||||
|
||||
(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"
|
||||
#:arguments
|
||||
(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"
|
||||
#:arguments
|
||||
(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
|
||||
account fingerprint."
|
||||
(let* ((id (username->id username))
|
||||
(reply (send-dbus/configuration-manager
|
||||
#:method "getDefaultModerators"
|
||||
#:arguments
|
||||
(list (string-append "string:" id)))))
|
||||
(array->list (parse-dbus-reply reply))))
|
||||
(let* ((id (username->id username)))
|
||||
(vector->list (call-configuration-manager-method "getDefaultModerators"
|
||||
(list id)))))
|
||||
|
||||
(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"
|
||||
#:arguments
|
||||
(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.
|
||||
#:timeout 60000))
|
||||
#:timeout 60))
|
||||
|
||||
(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"))
|
||||
|
||||
;; Local Variables:
|
||||
;; eval: (put 'with-retries 'scheme-indent-function 2)
|
||||
;; End:
|
||||
|
|
|
@ -715,6 +715,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/image.scm \
|
||||
%D%/build/jami-service.scm \
|
||||
%D%/build/file-systems.scm \
|
||||
|
|
|
@ -9,7 +9,7 @@
|
|||
;;; 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
|
||||
(hidden-package
|
||||
(package/inherit dbus
|
||||
(name "dbus-for-jami")
|
||||
(arguments
|
||||
(substitute-keyword-arguments (package-arguments dbus)
|
||||
((#:phases phases)
|
||||
`(modify-phases ,phases
|
||||
(add-after 'unpack 'customize-config
|
||||
(lambda _
|
||||
(substitute* "bus/session.conf.in"
|
||||
(("@SYSCONFDIR_FROM_PKGDATADIR@/dbus-1/session-local.conf")
|
||||
"/var/run/jami/session-local.conf")))))))))))
|
||||
|
||||
(define glib
|
||||
(package
|
||||
(name "glib")
|
||||
|
|
|
@ -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
|
|||
(file-like libjami)
|
||||
"The Jami daemon package to use.")
|
||||
(dbus
|
||||
(file-like dbus)
|
||||
(file-like dbus-for-jami)
|
||||
"The D-Bus package to use to start the required D-Bus session.")
|
||||
(nss-certs
|
||||
(file-like nss-certs)
|
||||
|
@ -284,7 +285,20 @@ (define (jami-dbus-session-activation config)
|
|||
#~(begin
|
||||
(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"
|
||||
(lambda (port)
|
||||
(format port "\
|
||||
<busconfig>
|
||||
<pidfile>/var/run/jami/pid</pidfile>
|
||||
<policy context=\"mandatory\">
|
||||
<allow user=\"root\"/>
|
||||
</policy>
|
||||
</busconfig>~%")))))))
|
||||
|
||||
(define (jami-shepherd-services config)
|
||||
"Return a <shepherd-service> running the Jami daemon."
|
||||
|
@ -292,12 +306,17 @@ (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-extensions (list guile-packrat ;used by guile-ac-d-bus
|
||||
guile-ac-d-bus
|
||||
;; Fibers is needed to provide the non-blocking
|
||||
;; variant of the 'sleep' procedure.
|
||||
guile-fibers)
|
||||
(with-imported-modules (source-module-closure
|
||||
'((gnu build jami-service)
|
||||
'((gnu build dbus-service)
|
||||
(gnu build jami-service)
|
||||
(gnu build shepherd)
|
||||
(gnu system file-systems)))
|
||||
|
||||
|
@ -308,10 +327,6 @@ (define list-accounts-action
|
|||
details alists keyed by their account username.")
|
||||
(procedure
|
||||
#~(lambda _
|
||||
(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
|
||||
;; user-provided option.
|
||||
(let* ((usernames (get-usernames))
|
||||
|
@ -341,7 +356,7 @@ (define disabled?
|
|||
accounts)
|
||||
(display "\n")))
|
||||
;; Return the account-details-list alist.
|
||||
(map cons usernames accounts)))))))
|
||||
(map cons usernames accounts))))))
|
||||
|
||||
(define list-account-details-action
|
||||
(shepherd-action
|
||||
|
@ -351,17 +366,13 @@ (define list-account-details-action
|
|||
keyed by their account username.")
|
||||
(procedure
|
||||
#~(lambda _
|
||||
(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))
|
||||
(display "\n\n"))
|
||||
accounts)
|
||||
(map cons usernames accounts)))))))
|
||||
(map cons usernames accounts))))))
|
||||
|
||||
(define list-contacts-action
|
||||
(shepherd-action
|
||||
|
@ -370,10 +381,6 @@ (define list-contacts-action
|
|||
an alist containing the contacts keyed by the account usernames.")
|
||||
(procedure
|
||||
#~(lambda _
|
||||
(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,7 +388,7 @@ (define list-contacts-action
|
|||
username)
|
||||
(format #t "~{ - ~a~%~}~%" contacts))
|
||||
usernames contacts)
|
||||
(map cons usernames contacts)))))))
|
||||
(map cons usernames contacts))))))
|
||||
|
||||
(define list-moderators-action
|
||||
(shepherd-action
|
||||
|
@ -390,10 +397,6 @@ (define list-moderators-action
|
|||
an alist containing the moderators keyed by the account usernames.")
|
||||
(procedure
|
||||
#~(lambda _
|
||||
(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
|
||||
usernames)))
|
||||
|
@ -406,7 +409,7 @@ (define list-moderators-action
|
|||
(format #t "Moderators for account ~a:~%" username)
|
||||
(format #t "~{ - ~a~%~}~%" moderators))))
|
||||
usernames moderators)
|
||||
(map cons usernames moderators)))))))
|
||||
(map cons usernames moderators))))))
|
||||
|
||||
(define add-moderator-action
|
||||
(shepherd-action
|
||||
|
@ -422,14 +425,10 @@ (define add-moderator-action
|
|||
Return the moderators for the account known by USERNAME.")
|
||||
(procedure
|
||||
#~(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"))
|
||||
(set-all-moderators #f username)
|
||||
(add-contact moderator username)
|
||||
(set-moderator moderator #t username)
|
||||
(username->moderators username))))))
|
||||
(username->moderators username)))))
|
||||
|
||||
(define ban-contact-action
|
||||
(shepherd-action
|
||||
|
@ -445,16 +444,12 @@ (define ban-contact-action
|
|||
@end example")
|
||||
(procedure
|
||||
#~(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"))
|
||||
(let ((usernames (or (and=> username list)
|
||||
(get-usernames))))
|
||||
(for-each (lambda (username)
|
||||
(set-moderator contact #f username)
|
||||
(remove-contact contact username #:ban? #t))
|
||||
usernames)))))))
|
||||
usernames))))))
|
||||
|
||||
(define list-banned-contacts-action
|
||||
(shepherd-action
|
||||
|
@ -463,11 +458,6 @@ (define list-banned-contacts-action
|
|||
an alist of the banned contacts, keyed by the account usernames.")
|
||||
(procedure
|
||||
#~(lambda _
|
||||
(parameterize ((%send-dbus-binary #$dbus-send)
|
||||
(%send-dbus-bus "unix:path=/var/run/jami/bus")
|
||||
(%send-dbus-user "jami")
|
||||
(%send-dbus-group "jami"))
|
||||
|
||||
(define banned-contacts
|
||||
(let ((usernames (get-usernames)))
|
||||
(map cons usernames
|
||||
|
@ -484,7 +474,7 @@ (define banned-contacts
|
|||
username)
|
||||
(format #t "~{ - ~a~%~}~%" banned))))
|
||||
banned-contacts)
|
||||
banned-contacts)))))
|
||||
banned-contacts))))
|
||||
|
||||
(define enable-account-action
|
||||
(shepherd-action
|
||||
|
@ -493,11 +483,7 @@ (define enable-account-action
|
|||
either a registered username or the fingerprint of the account.")
|
||||
(procedure
|
||||
#~(lambda (_ username)
|
||||
(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))))))
|
||||
(enable-account username)))))
|
||||
|
||||
(define disable-account-action
|
||||
(shepherd-action
|
||||
|
@ -506,16 +492,13 @@ (define disable-account-action
|
|||
argument, either a registered username or the fingerprint of the account.")
|
||||
(procedure
|
||||
#~(lambda (_ username)
|
||||
(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))))))
|
||||
(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)
|
||||
,@%default-modules))
|
||||
|
@ -523,13 +506,13 @@ (define disable-account-action
|
|||
;; activation for D-Bus, such as a /etc/machine-id file.
|
||||
(requirement '(dbus-system syslogd))
|
||||
(start
|
||||
#~(lambda args
|
||||
(define pid
|
||||
((make-forkexec-constructor/container
|
||||
#~(make-forkexec-constructor/container
|
||||
(list #$dbus-daemon "--session"
|
||||
"--address=unix:path=/var/run/jami/bus"
|
||||
"--nofork" "--syslog-only" "--nopidfile")
|
||||
#:mappings (list (file-system-mapping
|
||||
"--syslog-only")
|
||||
#:pid-file "/var/run/jami/pid"
|
||||
#:mappings
|
||||
(list (file-system-mapping
|
||||
(source "/dev/log") ;for syslog
|
||||
(target source))
|
||||
(file-system-mapping
|
||||
|
@ -540,25 +523,8 @@ (define pid
|
|||
#: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="
|
||||
#$jamid "/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))
|
||||
;; definition is found by dbus-daemon.
|
||||
(list (string-append "XDG_DATA_DIRS=" #$jamid "/share"))))
|
||||
(stop #~(make-kill-destructor)))
|
||||
|
||||
(shepherd-service
|
||||
|
@ -580,6 +546,7 @@ (define pid
|
|||
(ice-9 receive)
|
||||
(srfi srfi-1)
|
||||
(srfi srfi-26)
|
||||
(gnu build dbus-service)
|
||||
(gnu build jami-service)
|
||||
(gnu build shepherd)
|
||||
(gnu system file-systems)
|
||||
|
@ -653,14 +620,11 @@ (define daemon-pid
|
|||
;; 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"))
|
||||
(setenv "DBUS_SESSION_BUS_ADDRESS"
|
||||
"unix:path=/var/run/jami/bus")
|
||||
|
||||
;; Wait until the service name has been acquired by D-Bus.
|
||||
(with-retries 20 1
|
||||
(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,7 +681,7 @@ (define (archive-name->username archive)
|
|||
(map-in-order (cut jami-account-moderators <>)
|
||||
accounts))
|
||||
'#$(and declarative-mode?
|
||||
(map-in-order jami-account->alist accounts))))))
|
||||
(map-in-order jami-account->alist accounts)))))
|
||||
|
||||
;; Finally, return the PID of the daemon process.
|
||||
daemon-pid))
|
||||
|
@ -727,7 +691,7 @@ (define (archive-name->username archive)
|
|||
;; Wait for the process to exit; this prevents overlapping
|
||||
;; processes when issuing 'herd restart'.
|
||||
(waitpid pid)
|
||||
#f)))))))
|
||||
#f))))))))
|
||||
|
||||
(define jami-service-type
|
||||
(service-type
|
||||
|
|
|
@ -20,6 +20,7 @@ (define-module (gnu tests telephony)
|
|||
#:use-module (gnu)
|
||||
#:use-module (gnu packages)
|
||||
#:use-module (gnu packages guile)
|
||||
#:use-module (gnu packages guile-xyz)
|
||||
#:use-module (gnu tests)
|
||||
#:use-module (gnu system vm)
|
||||
#:use-module (gnu services)
|
||||
|
@ -125,16 +126,25 @@ (define username (assoc-ref %jami-account-content-sexp
|
|||
"Account.username"))
|
||||
|
||||
(define test
|
||||
(with-extensions (list guile-packrat ;used by guile-ac-d-bus
|
||||
guile-ac-d-bus
|
||||
;; Fibers is needed to provide the non-blocking
|
||||
;; variant of the 'sleep' procedure.
|
||||
guile-fibers)
|
||||
(with-imported-modules (source-module-closure
|
||||
'((gnu build marionette)
|
||||
(gnu build dbus-service)
|
||||
(gnu build jami-service)))
|
||||
#~(begin
|
||||
(use-modules (rnrs base)
|
||||
(srfi srfi-11)
|
||||
(srfi srfi-64)
|
||||
(gnu build marionette)
|
||||
(gnu build dbus-service)
|
||||
(gnu build jami-service))
|
||||
|
||||
(setenv "DBUS_SESSION_BUS_ADDRESS" "unix:path=/var/run/jami/bus")
|
||||
|
||||
(define marionette
|
||||
(make-marionette (list #$vm)))
|
||||
|
||||
|
@ -144,70 +154,44 @@ (define marionette
|
|||
(test-assert "service is running"
|
||||
(marionette-eval
|
||||
'(begin
|
||||
(use-modules (gnu services herd))
|
||||
(match (start-service 'jami)
|
||||
(#f #f)
|
||||
(('service response-parts ...)
|
||||
(match (assq-ref response-parts 'running)
|
||||
((pid) (number? pid))))))
|
||||
(use-modules (gnu build jami-service))
|
||||
(jami-service-available?))
|
||||
marionette))
|
||||
|
||||
(test-assert "service can be stopped"
|
||||
(marionette-eval
|
||||
'(begin
|
||||
(use-modules (gnu services herd)
|
||||
(use-modules (gnu build jami-service)
|
||||
(gnu services herd)
|
||||
(rnrs base))
|
||||
(setenv "PATH" "/run/current-system/profile/bin")
|
||||
(let ((pid (match (start-service 'jami)
|
||||
(#f #f)
|
||||
(('service response-parts ...)
|
||||
(match (assq-ref response-parts 'running)
|
||||
((pid) pid))))))
|
||||
(assert (jami-service-available?))
|
||||
|
||||
(assert (number? pid))
|
||||
(stop-service 'jami)
|
||||
|
||||
(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-retries 20 1
|
||||
(not (zero? (status:exit-val
|
||||
(system* "pgrep" "jamid")))))))
|
||||
(with-retries 20 1 (not (jami-service-available?))))
|
||||
marionette))
|
||||
|
||||
(test-assert "service can be restarted"
|
||||
(marionette-eval
|
||||
'(begin
|
||||
(use-modules (gnu services herd)
|
||||
(rnrs base))
|
||||
;; Start and retrieve the current PID.
|
||||
(define pid (match (start-service 'jami)
|
||||
(#f #f)
|
||||
(('service response-parts ...)
|
||||
(match (assq-ref response-parts 'running)
|
||||
((pid) pid)))))
|
||||
(assert (number? pid))
|
||||
|
||||
(use-modules (gnu build dbus-service)
|
||||
(gnu build jami-service)
|
||||
(gnu services herd)
|
||||
(rnrs base) )
|
||||
;; Start the service.
|
||||
(start-service 'jami)
|
||||
(with-retries 20 1 (jami-service-available?))
|
||||
;; Restart the service.
|
||||
(restart-service 'jami)
|
||||
|
||||
(define new-pid (match (start-service 'jami)
|
||||
(#f #f)
|
||||
(('service response-parts ...)
|
||||
(match (assq-ref response-parts 'running)
|
||||
((pid) pid)))))
|
||||
(assert (number? new-pid))
|
||||
|
||||
(not (eq? pid new-pid)))
|
||||
(with-retries 20 1 (jami-service-available?)))
|
||||
marionette))
|
||||
|
||||
(unless #$provisioning? (test-skip 1))
|
||||
(test-assert "jami accounts provisioning, account present"
|
||||
(marionette-eval
|
||||
'(begin
|
||||
(use-modules (gnu services herd)
|
||||
(use-modules (gnu build dbus-service)
|
||||
(gnu services herd)
|
||||
(rnrs base))
|
||||
;; Accounts take some time to appear after being added.
|
||||
(with-retries 20 1
|
||||
|
@ -339,7 +323,7 @@ (define new-pid (match (start-service 'jami)
|
|||
account-details)))))
|
||||
marionette))
|
||||
|
||||
(test-end))))
|
||||
(test-end)))))
|
||||
|
||||
(gexp->derivation (if provisioning?
|
||||
"jami-provisioning-test"
|
||||
|
@ -357,7 +341,3 @@ (define %test-jami-provisioning
|
|||
(name "jami-provisioning")
|
||||
(description "Provisioning test for the jami service.")
|
||||
(value (run-jami-test #:provisioning? #t))))
|
||||
|
||||
;; Local Variables:
|
||||
;; eval: (put 'with-retries 'scheme-indent-function 2)
|
||||
;; End:
|
||||
|
|
Loading…
Reference in a new issue