From 31da8e84df7cdeb2084d4bf17c51208d7ad171db Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Wed, 8 Dec 2021 16:19:27 -0500 Subject: [PATCH 3/5] build: Move D-Bus parser to its own build module. * gnu/build/jami-service.scm (with-retries, parse-dbus-reply) (strip-quotes, deserialize-item, serialize-boolean, dict->alist) (array->list, %send-dbus-binary, %send-dbus-bus, %send-dbus-user) (%send-dbus-group, %send-dbus-debug, send-dbus, dbus-available-services) (dbus-service-available?): Move to ... * gnu/build/dbus-service.scm: ... this new module, prefixing 'dbus-' to dict->alist and array->list in the process. * gnu/local.mk (GNU_SYSTEM_MODULES): Register new module. * gnu/services/telephony.scm: Adjust. * gnu/tests/telephony.scm: Likewise. --- gnu/build/dbus-service.scm | 248 +++++++++++++++++++++++++++++++++++++ gnu/build/jami-service.scm | 209 +------------------------------ gnu/local.mk | 1 + gnu/services/telephony.scm | 5 +- gnu/tests/telephony.scm | 2 + 5 files changed, 261 insertions(+), 204 deletions(-) create mode 100644 gnu/build/dbus-service.scm diff --git a/gnu/build/dbus-service.scm b/gnu/build/dbus-service.scm new file mode 100644 index 0000000000..fd56c8dae7 --- /dev/null +++ b/gnu/build/dbus-service.scm @@ -0,0 +1,248 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Maxim Cournoyer +;;; +;;; 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 . + +;;; Commentary: +;;; +;;; This module contains procedures to interact with D-Bus via the 'dbus-send' +;;; command line utility. +;;; +;;; Code: + +(define-module (gnu build dbus-service) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 peg) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:autoload (shepherd service) (fork+exec-command) + #:export (%send-dbus-binary + %send-dbus-bus + %send-dbus-user + %send-dbus-group + %send-dbus-debug + send-dbus + + parse-dbus-reply + deserialize-item + serialize-boolean + dbus-dict->alist + dbus-array->list + + dbus-available-services + dbus-service-available? + + with-retries)) + +;;; +;;; 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)))))) + + +;;; +;;; 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 (dbus-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 (dbus-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)))))) + + +;;; +;;; Higher-level, D-Bus-related procedures. +;;; + +(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? ":" <>) + (dbus-array->list reply)))) + +(define (dbus-service-available? service) + "Predicate to check for the D-Bus SERVICE availability." + (member service (dbus-available-services))) diff --git a/gnu/build/jami-service.scm b/gnu/build/jami-service.scm index ddfc8cf937..f8c392d3e5 100644 --- a/gnu/build/jami-service.scm +++ b/gnu/build/jami-service.scm @@ -24,13 +24,11 @@ ;;; 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? @@ -51,43 +49,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,169 +71,20 @@ (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))) + (dbus-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))) + (dbus-dict->alist (parse-dbus-reply reply))) (define (parse-contacts reply) "Parse REPLY, which is assumed to be the output of the Jamid D-Bus @@ -275,7 +93,7 @@ (define (parse-contacts reply) ('array '()) (('array dicts ...) - (map dict->alist dicts)))) + (map dbus-dict->alist dicts)))) ;;; @@ -287,21 +105,6 @@ (define (validate-fingerprint fingerprint) (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 (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" @@ -522,7 +325,7 @@ (define (username->moderators username) #:method "getDefaultModerators" #:arguments (list (string-append "string:" id))))) - (array->list (parse-dbus-reply reply)))) + (dbus-array->list (parse-dbus-reply reply)))) (define (set-moderator contact enabled? username) "Set the moderator flag to ENABLED? for CONTACT, the 40 characters public diff --git a/gnu/local.mk b/gnu/local.mk index 5c19919f2e..55c5536450 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -706,6 +706,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 \ diff --git a/gnu/services/telephony.scm b/gnu/services/telephony.scm index 7c83f13b2a..f6501b6423 100644 --- a/gnu/services/telephony.scm +++ b/gnu/services/telephony.scm @@ -296,7 +296,8 @@ (define (jami-shepherd-services config) (declarative-mode? (not (eq? 'disabled accounts)))) (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))) @@ -515,6 +516,7 @@ (define disable-account-action (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)) @@ -579,6 +581,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) diff --git a/gnu/tests/telephony.scm b/gnu/tests/telephony.scm index 998bdbccf9..3b0a458c75 100644 --- a/gnu/tests/telephony.scm +++ b/gnu/tests/telephony.scm @@ -127,12 +127,14 @@ (define username (assoc-ref %jami-account-content-sexp (define test (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)) (define marionette -- 2.34.0