diff options
Diffstat (limited to 'gnu/build/jami-service.scm')
| -rw-r--r-- | gnu/build/jami-service.scm | 390 |
1 files changed, 67 insertions, 323 deletions
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 @@ 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 @@ hexadecimal characters." (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 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)))) +(define (jami-service-available?) + "Whether the Jami D-Bus service was acquired by the D-Bus daemon." + (unless (%current-dbus-connection) + (initialize-dbus-connection!)) + (dbus-service-available? "cx.ring.Ring")) ;;; -;;; Higher-level, D-Bus-related procedures. +;;; Bindings for the Jami D-Bus API. ;;; -(define (validate-fingerprint fingerprint) - "Validate that fingerprint is 40 characters long." - (unless (account-fingerprint? fingerprint) - (error "Account fingerprint is not valid:" fingerprint))) - -(define (dbus-available-services) - "Return the list of available (acquired) D-Bus services." - (let ((reply (parse-dbus-reply - (send-dbus #:service "org.freedesktop.DBus" - #:path "/org/freedesktop/DBus" - #:interface "org.freedesktop.DBus" - #:method "ListNames")))) - ;; Remove entries such as ":1.7". - (remove (cut string-prefix? ":" <>) - (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" - #:path "/cx/ring/Ring/ConfigurationManager" - #:interface "cx.ring.Ring.ConfigurationManager" - #:method method - #:arguments arguments - #:timeout timeout)) +(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" + #:arguments arguments + #:timeout timeout)) ;;; The following methods are for internal use; they make use of the account ;;; ID, an implementation detail of Jami the user should not need to be @@ -317,22 +108,17 @@ of the Jami D-Bus `getAccountList' method." (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 @@ implementation detail used to identify the accounts in Jami." '())))) (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 @@ registered username." 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)))))) + (with-retries 20 1 + (let ((username (id->username id))) + (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 @@ contacts. USERNAME can be either the account 40 characters public key 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 @@ the account associated with USERNAME (either a fingerprint or a registered 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 @@ pass to the `send-dbus/configuration-manager' procedure." (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 @@ key fingerprint of a contact for the account of USERNAME, a registered 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 @@ fingerprint." ;; 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 @@ requirements." (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: |